+++ /dev/null
-C*********************************************************************
-C*********************************************************************
-C* **
-C* November 2007 **
-C* **
-C* The Lund Monte Carlo **
-C* **
-C* PYTHIA version 6.4 **
-C* **
-C* Torbjorn Sjostrand **
-C* CERN/PH, CH-1211 Geneva, Switzerland **
-C* phone +41 - 22 - 767 82 27 **
-C* and **
-C* Department of Theoretical Physics **
-C* Lund University **
-C* Solvegatan 14A, S-223 62 Lund, Sweden **
-C* E-mail torbjorn@thep.lu.se **
-C* **
-C* SUSY and Technicolor parts by **
-C* Stephen Mrenna **
-C* Computing Division **
-C* Generators and Detector Simulation Group **
-C* Fermi National Accelerator Laboratory **
-C* MS 234, Batavia, IL 60510, USA **
-C* phone + 1 - 630 - 840 - 2556 **
-C* E-mail mrenna@fnal.gov **
-C* **
-C* New multiple interactions and more SUSY parts by **
-C* Peter Skands **
-C* Theoretical Physics Department **
-C* Fermi National Accelerator Laboratory **
-C* MS 106, Batavia, IL 60510, USA **
-C* and **
-C* CERN/PH, CH-1211 Geneva, Switzerland **
-C* phone +41 - 22 - 767 24 59 **
-C* E-mail skands@fnal.gov **
-C* **
-C* Several parts are written by Hans-Uno Bengtsson **
-C* PYSHOW is written together with Mats Bengtsson **
-C* PYMAEL is written by Emanuel Norrbin **
-C* advanced popcorn baryon production written by Patrik Eden **
-C* code for virtual photons mainly written by Christer Friberg **
-C* code for low-mass strings mainly written by Emanuel Norrbin **
-C* Bose-Einstein code mainly written by Leif Lonnblad **
-C* CTEQ parton distributions are by the CTEQ collaboration **
-C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
-C* SaS photon parton distributions together with Gerhard Schuler **
-C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
-C* MSSM Higgs mass calculation code by M. Carena, **
-C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
-C* PYGAUS adapted from CERN library (K.S. Kolbig) **
-C* NRQCD/colour octet production of onium by S. Wolf **
-C* **
-C* The latest program version and documentation is found on WWW **
-C* http://www.thep.lu.se/~torbjorn/Pythia.html **
-C* **
-C* Copyright Torbjorn Sjostrand, Lund (and CERN) 2007 **
-C* **
-C*********************************************************************
-C*********************************************************************
-C *
-C List of subprograms in order of appearance, with main purpose *
-C (S = subroutine, F = function, B = block data) *
-C *
-C B PYDATA to contain all default values *
-C S PYCKBD to check that BLOCK DATA has been correctly loaded *
-C S PYTEST to test the proper functioning of the package *
-C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
-C *
-C S PYINIT to administer the initialization procedure *
-C S PYEVNT to administer the generation of an event *
-C S PYEVNW ditto, for new multiple interactions scenario *
-C S PYSTAT to print cross-section and other information *
-C S PYUPEV to administer the generation of an LHA hard process *
-C S PYUPIN to provide initialization needed for LHA input *
-C S PYLHEF to produce a Les Houches Event File from run *
-C S PYINRE to initialize treatment of resonances *
-C S PYINBM to read in beam, target and frame choices *
-C S PYINKI to initialize kinematics of incoming particles *
-C S PYINPR to set up the selection of included processes *
-C S PYXTOT to give total, elastic and diffractive cross-sect. *
-C S PYMAXI to find differential cross-section maxima *
-C S PYPILE to select multiplicity of pileup events *
-C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
-C S PYGAGA to handle lepton -> lepton + gamma branchings *
-C S PYRAND to select subprocess and kinematics for event *
-C S PYSCAT to set up kinematics and colour flow of event *
-C S PYEVOL handler for pT-ordered ISR and multiple interactions *
-C S PYSSPA to simulate initial state spacelike showers *
-C S PYPTIS to do pT-ordered initial state spacelike showers *
-C S PYMEMX auxiliary to PYSSPA/PYPTIS for ME correction maximum *
-C S PYMEWT auxiliary to PYSSPA/.. for matrix element correction *
-C S PYPTMI to do pT-ordered multiple interactions *
-C F PYFCMP to give companion quark x*f distribution *
-C F PYPCMP to calculate momentum integral for companion quarks *
-C S PYUPRE to rearranges contents of the HEPEUP commonblock *
-C S PYADSH to administrate sequential final-state showers *
-C S PYVETO to allow the generation of an event to be aborted *
-C S PYRESD to perform resonance decays *
-C S PYMULT to generate multiple interactions - old scheme *
-C S PYREMN to add on target remnants - old scheme *
-C S PYMIGN to generate multiple interactions - new scheme *
-C S PYMIHK to connect colours in mult. int. - new scheme *
-C S PYCTTR to translate PYTHIA colour information to LHA1 tags *
-C S PYMIHG to collapse two pairs of LHA1 colour tags. *
-C S PYMIRM to add on target remnants in mult. int.- new scheme *
-C S PYFSCR to perform final state colour reconnections - -"- *
-C S PYDIFF to set up kinematics for diffractive events *
-C S PYDISG to set up kinematics, remnant and showers for DIS *
-C S PYDOCU to compute cross-sections and handle documentation *
-C S PYFRAM to perform boosts between different frames *
-C S PYWIDT to calculate full and partial widths of resonances *
-C S PYOFSH to calculate partial width into off-shell channels *
-C S PYRECO to handle colour reconnection in W+W- events *
-C S PYKLIM to calculate borders of allowed kinematical region *
-C S PYKMAP to construct value of kinematical variable *
-C S PYSIGH to calculate differential cross-sections *
-C S PYSGQC auxiliary to PYSIGH for QCD processes *
-C S PYSGHF auxiliary to PYSIGH for heavy flavour processes *
-C S PYSGWZ auxiliary to PYSIGH for W and Z processes *
-C S PYSGHG auxiliary to PYSIGH for Higgs processes *
-C S PYSGSU auxiliary to PYSIGH for supersymmetry processes *
-C S PYSGTC auxiliary to PYSIGH for technicolor processes *
-C S PYSGEX auxiliary to PYSIGH for various exotic processes *
-C S PYPDFU to evaluate parton distributions *
-C S PYPDFL to evaluate parton distributions at low x and Q^2 *
-C S PYPDEL to evaluate electron parton distributions *
-C S PYPDGA to evaluate photon parton distributions (generic) *
-C S PYGGAM to evaluate photon parton distributions (SaS sets) *
-C S PYGVMD to evaluate VMD part of photon parton distributions *
-C S PYGANO to evaluate anomalous part of photon PDFs *
-C S PYGBEH to evaluate Bethe-Heitler part of photon PDFs *
-C S PYGDIR to evaluate direct contribution to photon PDFs *
-C S PYPDPI to evaluate pion parton distributions *
-C S PYPDPR to evaluate proton parton distributions *
-C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
-C S PYGRVL to evaluate the GRV 94L proton parton distributions *
-C S PYGRVM to evaluate the GRV 94M proton parton distributions *
-C S PYGRVD to evaluate the GRV 94D proton parton distributions *
-C F PYGRVV auxiliary to the PYGRV* routines *
-C F PYGRVW auxiliary to the PYGRV* routines *
-C F PYGRVS auxiliary to the PYGRV* routines *
-C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
-C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
-C S PYPDPO to evaluate old proton parton distributions *
-C F PYHFTH to evaluate threshold factor for heavy flavour *
-C S PYSPLI to find flavours left in hadron when one removed *
-C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
-C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
-C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
-C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
-C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
-C S PYSTBH to evaluate matrix element for t + b + H processes *
-C S PYTBHB auxiliary to PYSTBH *
-C S PYTBHG auxiliary to PYSTBH *
-C S PYTBHQ auxiliary to PYSTBH *
-C F PYTBHS auxiliary to PYSTBH *
-C *
-C S PYMSIN to initialize the supersymmetry simulation *
-C S PYSLHA to interface to SUSY spectrum and decay calculators *
-C S PYAPPS to determine MSSM parameters from SUGRA input *
-C S PYSUGI to determine MSSM parameters using ISASUSY *
-C S PYFEYN to determine MSSM Higgs parameters using FEYNHIGGS *
-C F PYRNMQ to determine running squark masses *
-C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
-C S PYINOM to calculate neutralino/chargino mass eigenstates *
-C F PYRNM3 to determine running M3, gluino mass *
-C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
-C S PYHGGM to determine Higgs mass spectrum *
-C S PYSUBH to determine Higgs masses in the MSSM *
-C S PYPOLE to determine Higgs masses in the MSSM *
-C S PYRGHM auxiliary to PYPOLE *
-C S PYGFXX auxiliary to PYRGHM *
-C F PYFINT auxiliary to PYPOLE *
-C F PYFISB auxiliary to PYFINT *
-C S PYSFDC to calculate sfermion decay partial widths *
-C S PYGLUI to calculate gluino decay partial widths *
-C S PYTBBN to calculate 3-body decay of gluino to neutralino *
-C S PYTBBC to calculate 3-body decay of gluino to chargino *
-C S PYNJDC to calculate neutralino decay partial widths *
-C S PYCJDC to calculate chargino decay partial widths *
-C F PYXXZ6 auxiliary for ino 3-body decays *
-C F PYXXGA auxiliary for ino -> ino + gamma decay *
-C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
-C F PYX2XH auxiliary for ino -> ino + Higgs decay *
-C S PYHEXT to calculate non-SM Higgs decay partial widths *
-C F PYH2XX auxiliary for H -> ino + ino decay *
-C F PYGAUS to perform Gaussian integration *
-C F PYGAU2 copy of PYGAUS to allow two-dimensional integration *
-C F PYSIMP to perform Simpson integration *
-C F PYLAMF to evaluate the lambda kinematics function *
-C S PYTBDY to perform 3-body decay of gauginos *
-C S PYTECM to calculate techni_rho/omega masses *
-C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
-C S PYCMQR auxiliary to PYEICG *
-C S PYCMQ2 auxiliary to PYEICG *
-C S PYCDIV auxiliary to PYCMQR *
-C S PYCSRT auxiliary to PYCMQR *
-C S PYTHAG auxiliary to PYCMQR *
-C S PYCBAL auxiliary to PYEICG *
-C S PYCBA2 auxiliary to PYEICG *
-C S PYCRTH auxiliary to PYEICG *
-C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
-C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
-C S PYWIDX to calculate decay widths from within PYWIDT *
-C S PYRVSF to calculate R-violating sfermion decay widths *
-C S PYRVNE to calculate R-violating neutralino decay widths *
-C S PYRVCH to calculate R-violating chargino decay widths *
-C S PYRVGL to calculate R-violating gluino decay widths *
-C F PYRVSB auxiliary to PYRVSF *
-C S PYRVGW to calculate R-Violating 3-body widths *
-C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
-C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
-C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
-C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
-C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
-C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
-C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
-C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
-C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
-C *
-C S PY1ENT to fill one entry (= parton or particle) *
-C S PY2ENT to fill two entries *
-C S PY3ENT to fill three entries *
-C S PY4ENT to fill four entries *
-C S PY2FRM to interface to generic two-fermion generator *
-C S PY4FRM to interface to generic four-fermion generator *
-C S PY6FRM to interface to generic six-fermion generator *
-C S PY4JET to generate a shower from a given 4-parton config *
-C S PY4JTW to evaluate the weight od a shower history for above *
-C S PY4JTS to set up the parton configuration for above *
-C S PYJOIN to connect entries with colour flow information *
-C S PYGIVE to fill (or query) commonblock variables *
-C S PYONOF to allow easy control of particle decay modes *
-C S PYTUNE to select a predefined 'tune' for min-bias and UE *
-C S PYEXEC to administrate fragmentation and decay chain *
-C S PYPREP to rearrange showered partons along strings *
-C S PYSTRF to do string fragmentation of jet system *
-C S PYJURF to find boost to string junction rest frame *
-C S PYINDF to do independent fragmentation of one or many jets *
-C S PYDECY to do the decay of a particle *
-C S PYDCYK to select parton and hadron flavours in decays *
-C S PYKFDI to select parton and hadron flavours in fragm *
-C S PYNMES to select number of popcorn mesons *
-C S PYKFIN to calculate falvour prod. ratios from input params. *
-C S PYPTDI to select transverse momenta in fragm *
-C S PYZDIS to select longitudinal scaling variable in fragm *
-C S PYSHOW to do m-ordered timelike parton shower evolution *
-C S PYPTFS to do pT-ordered timelike parton shower evolution *
-C F PYMAEL auxiliary to PYSHOW & PYPTFS: gluon emission ME's *
-C S PYBOEI to include Bose-Einstein effects (crudely) *
-C S PYBESQ auxiliary to PYBOEI *
-C F PYMASS to give the mass of a particle or parton *
-C F PYMRUN to give the running MSbar mass of a quark *
-C S PYNAME to give the name of a particle or parton *
-C F PYCHGE to give three times the electric charge *
-C F PYCOMP to compress standard KF flavour code to internal KC *
-C S PYERRM to write error messages and abort faulty run *
-C F PYALEM to give the alpha_electromagnetic value *
-C F PYALPS to give the alpha_strong value *
-C F PYANGL to give the angle from known x and y components *
-C F PYR to provide a random number generator *
-C S PYRGET to save the state of the random number generator *
-C S PYRSET to set the state of the random number generator *
-C S PYROBO to rotate and/or boost an event *
-C S PYEDIT to remove unwanted entries from record *
-C S PYLIST to list event record or particle data *
-C S PYLOGO to write a logo *
-C S PYUPDA to update particle data *
-C F PYK to provide integer-valued event information *
-C F PYP to provide real-valued event information *
-C S PYSPHE to perform sphericity analysis *
-C S PYTHRU to perform thrust analysis *
-C S PYCLUS to perform three-dimensional cluster analysis *
-C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
-C S PYJMAS to give high and low jet mass of event *
-C S PYFOWO to give Fox-Wolfram moments *
-C S PYTABU to analyze events, with tabular output *
-C *
-C S PYEEVT to administrate the generation of an e+e- event *
-C S PYXTEE to give the total cross-section at given CM energy *
-C S PYRADK to generate initial state photon radiation *
-C S PYXKFL to select flavour of primary qqbar pair *
-C S PYXJET to select (matrix element) jet multiplicity *
-C S PYX3JT to select kinematics of three-jet event *
-C S PYX4JT to select kinematics of four-jet event *
-C S PYXDIF to select angular orientation of event *
-C S PYONIA to perform generation of onium decay to gluons *
-C *
-C S PYBOOK to book a histogram *
-C S PYFILL to fill an entry in a histogram *
-C S PYFACT to multiply histogram contents by a factor *
-C S PYOPER to perform operations between histograms *
-C S PYHIST to print and reset all histograms *
-C S PYPLOT to print a single histogram *
-C S PYNULL to reset contents of a single histogram *
-C S PYDUMP to dump histogram contents onto a file *
-C *
-C S PYSTOP routine to handle Fortran STOP condition *
-C *
-C S PYKCUT dummy routine for user kinematical cuts *
-C S PYEVWT dummy routine for weighting events *
-C S UPINIT dummy routine to initialize user processes *
-C S UPEVNT dummy routine to generate a user process event *
-C S UPVETO dummy routine to abort event at parton level *
-C S PDFSET dummy routine to be removed when using PDFLIB *
-C S STRUCTM dummy routine to be removed when using PDFLIB *
-C S STRUCTP dummy routine to be removed when using PDFLIB *
-C S SUGRA dummy routine to be removed when linking with ISAJET *
-C F VISAJE dummy functn. to be removed when linking with ISAJET *
-C S SSMSSM dummy routine to be removed when linking with ISAJET *
-C S FHSETFLAGS dummy routine -"- FEYNHIGGS *
-C S FHSETPARA dummy routine -"- FEYNHIGGS *
-C S FHHIGGSCORR dummy routine -"- FEYNHIGGS *
-C S PYTAUD dummy routine for interface to tau decay libraries *
-C S PYTIME dummy routine for giving date and time *
-C *
-C*********************************************************************
-
-C...PYDATA
-C...Default values for switches and parameters,
-C...and particle, decay and process data.
-
- BLOCK DATA PYDATA
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYDAT4/CHAF(500,2)
- CHARACTER CHAF*16
- COMMON/PYDATR/MRPY(6),RRPY(100)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- COMMON/PYINT6/PROC(0:500)
- CHARACTER PROC*28
- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
- COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
- COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
- COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
- & AU(3,3),AD(3,3),AE(3,3)
- COMMON/PYLH3C/CPRO(2),CVER(2)
- CHARACTER CPRO*12,CVER*12
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
- &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
- &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,
- &/PYBINS/,/PYLH3P/,/PYLH3C/
-
-C...PYDAT1, containing status codes and most parameters.
- DATA MSTU/
- & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
- 1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0,
- 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
- 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
- 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
- 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 7 30*0,
- 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
- & 80*0/
- DATA (PARU(I),I=1,100)/
- & 3.141592653589793D0, 6.283185307179586D0,
- & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
- 1 0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
- 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
- 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
- 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
- 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
- 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
- 6 40*0D0/
- DATA (PARU(I),I=101,200)/
- & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
- & 0D0, 0D0, 0D0, 0D0, 0D0,
- 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
- 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
- 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
- 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
- 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
- 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
- 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
- 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
- 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
- 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
- DATA MSTJ/
- & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
- 1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0,
- 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
- 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
- 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
- 6 40*0,
- & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
- 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
- 2 80*0/
- DATA PARJ/
- & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
- & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
- 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
- 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
- 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
- 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
- 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
- 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
- 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
- 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
- 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
- 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
- & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
- 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
- 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
- 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
- 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
- 4 10*0D0,
- 5 10*0D0,
- 6 10*0D0,
- 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
- 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
- 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
- 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
- 9 5*0D0/
-
-C...PYDAT2, with particle data and flavour treatment parameters.
- DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
- &-3,0,-3,6*0,3,9*0,3,2*0,3,4*0,-1,41*0,2,-1,20*0,3*3,7*0,3*3,3*0,
- &3*3,3*0,3*3,6*0,3*3,3*0,3*3,4*0,-2,-3,2*1,2*0,4,2*3,6,2*-2,2*-3,
- &0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,3,2*1,2*0,
- &2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,3,2*-2,
- &2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,-3,2*0,
- &2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,3*0,3,2*0,3,0,3,0,3,
- &2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,2,-1,
- &2,-1,2,-3,0,-3,0,-3,2*0,3,3*0,3,8*0,-1,2,-3,6*0,3,2*6,0,3,4*0,3,
- &7*0,3,131*0/
- DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
- &2*0,-1,3*0,2*-1,3*0,2*-1,4*0,-1,5*0,2*-1,4*0,2*-1,5*0,2*-1,6*0,
- &-1,7*0,2*-1,5*0,2*-1,6*0,2*-1,7*0,2*-1,8*0,-1,56*0,6*1,6*0,2,7*0,
- &6*1,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2,133*0/
- DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
- &2*1,39*0,1,0,2*1,20*0,3*1,4*0,6*1,3*0,9*1,3*0,12*1,4*0,100*1,2*0,
- &2*1,2*0,4*1,2*0,6*1,2*0,8*1,3*0,1,0,2*1,0,3*1,0,4*1,3*0,12*1,3*0,
- &1,2*0,1,0,12*1,0,1,3*0,1,8*0,4*1,5*0,3*1,0,1,3*0,2*1,7*0,1,131*0/
- DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
- &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
- &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
- &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
- &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
- &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
- &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
- &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
- &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
- &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
- &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
- &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
- &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
- &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
- &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
- &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
- &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
- &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
- &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
- &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
- DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
- &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
- &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
- &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
- &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
- &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
- &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
- &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
- &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
- &9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551,
- &3000115,3000215,131*0/
- DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
- &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
- &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
- &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
- &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
- &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
- &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
- &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
- &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
- &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
- &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
- &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
- &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
- &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
- &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
- &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
- &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
- &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
- &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
- &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
- DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
- &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
- &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
- &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
- &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
- &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
- &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
- &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
- &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
- &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
- &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
- &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
- &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,3*3.1D0,
- &3*9.5D0,2*250D0,131*0D0/
- DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
- &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
- &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
- &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
- &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
- &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
- &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
- &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
- &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
- &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
- &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
- &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
- &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
- &0.0208D0,0.01195D0,0.03705D0,0.09511D0,1.89978D0,1.60746D0,
- &0.13396D0,200.47294D0,0.02296D0,0.18886D0,94.66794D0,6.08718D0,
- &0D0,2.17482D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
- &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
- &7*0D0,6*0.01D0,0.25499D0,0.28446D0,131*0D0/
- DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
- &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
- &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
- &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
- &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
- &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
- &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
- &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
- &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
- &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
- &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
- &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
- &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
- &0.20797D0,0.11949D0,0.37048D0,0.95114D0,18.99785D0,16.07463D0,
- &1.33964D0,450D0,0.22959D0,1.88863D0,360D0,60.8718D0,0D0,
- &21.74824D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
- &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
- &8.80013D0,13*0D0,2.54987D0,2.84456D0,131*0D0/
- DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
- &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
- &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
- &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
- &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
- &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
- &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
- &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,120*0D0,131*0D0/
-
- DATA PARF/
- & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
- 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
- 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
- 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
- 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
- 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
- 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
- 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
- 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
- 9 0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0, 4*0D0,
- & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
- 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
- 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
- 3 60*0D0,
- 4 0.2D0, 0.5D0, 8*0D0,
- 5 1800*0D0/
- DATA ((VCKM(I,J),J=1,4),I=1,4)/
- & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
- & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
- & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
- & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
-
-C...PYDAT3, with particle decay parameters and data.
- DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
- &4*1,3*0,2*1,40*0,3*1,16*0,3*1,2*0,9*1,0,32*1,2*0,1,3*0,1,2*0,2*1,
- &2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,5*1,2*0,6*1,0,7*1,2*0,5*1,2*0,
- &6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,1,0,26*1,7*0,8*1,131*0/
- DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
- &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
- &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
- &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
- &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
- &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
- &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
- &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
- &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
- &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
- &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
- &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
- &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
- &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
- &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
- &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
- &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162,
- &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,
- &3924,0,3960,0,3996,4004,4012,4020,4217,4243,4270,4023,4029,4036,
- &4043,4050,4056,4062,4071,4075,4079,4082,4084,4104,4126,4148,4170/
- DATA (MDCY(I,2),I= 352, 500)/4185,4197,4204,7*0,4211,4212,4213,
- &4214,4215,4216,4296,4322,131*0/
- DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
- &2*0,9,12,16,20,79,6*0,22,0,23,86,83,27,3*0,9,1,40*0,1,4,9,16*0,2,
- &5,2*9,2*2,7,8,6,9,2*2,3,10,6,3,11,6,11,6,63,3,8,61,2,8,33,2,4,1,
- &3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,2*0,1,3*0,3,2*0,3,1,2*0,2,
- &3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,2*1,76,4,2*0,4*1,4,2*0,1,2,1,2,4,1,
- &0,7*4,2*0,2*1,17,2*9,2*0,4*1,2*9,2*0,4*1,9,1,9,2*0,8*9,0,9*9,4*1,
- &5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,9*2,11,14,45,24,45,24,
- &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,
- &28,49,28,36,0,36,0,36,0,3*8,3,26,27,26,6,3*7,2*6,9,2*4,3,2,20,
- &3*22,15,12,2*7,7*0,6*1,26,30,131*0/
- DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
- &7*1,-1,1,7*-1,8*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,5*1,0,2*-1,6*1,0,
- &2*-1,3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1,
- &2*-1,3*1,-1,5*1,62*1,6*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,
- &3*1,4*-1,6*1,2*-1,3*1,-1,12*1,62*1,6*1,2*-1,3*1,-1,9*1,62*1,
- &3*1,-1,3*1,-1,1,18*1,4*1,2*-1,2*1,-1,1249*1,2*-1,377*1,2*-1,
- &1921*1,2*-1,6*1,2*-1,133*1,2*-1,6*1,2*-1,10*1,-1,3*1,-1,3*1,5*-1,
- &3*1,-1,16*1,2*-1,6*1,2*-1,16*1,2*-1,6*1,2*-1,13*1,-1,3*1,-1,3*1,
- &5*-1,3*1,-1,3649*0/
- DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
- &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
- &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
- &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
- &18*53,6*32,4*0,12,2*42,2*11,9*42,0,2,3,15*0,4*42,5*0,3,12*0,2,
- &3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,3*0,1,11*0,22*42,41*0,
- &2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,6*0,12,2*0,12,0,12,
- &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
- &19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,4*32,2*4,0,32,45*0,
- &14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,2*42,2*11,0,2*42,
- &2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,
- &2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,9*42,0,162*42,50*0,2*12,
- &17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,4*32,2*4,5*0,2404*53,4*32,
- &3*0,6*32,3*0,4*32,3*0,50*32,3*53,12*0,8*32,12*0,66*51,6*32,9*0,
- &9*32,17*0,6*51,10*0,8*32,15*0,16*32,14*0,8*32,18*0,8*32,18*0,
- &16*32,3653*0/
- DATA (BRAT(I) ,I= 1, 348)/43*0D0,0.00003D0,0.001765D0,
- &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
- &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
- &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
- &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
- &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
- &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
- &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
- &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
- &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
- &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
- &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
- &0.108087D0,0D0,0.000001D0,0D0,0.000353D0,0.04359D0,0.795274D0,
- &4*0D0,0.000339D0,0.095746D0,0D0,0.060724D0,0.003054D0,0.000919D0,
- &64*0D0,0.145835D0,0.113276D0,0.145835D0,0.113271D0,0.145781D0,
- &0.049002D0,2*0D0,0.032025D0,0.063642D0,0.032025D0,0.063642D0,
- &0.032022D0,0.063642D0,8*0D0,0.251225D0,0.0129D0,0.000006D0,0D0,
- &0.0129D0,0.250764D0,0.00038D0,0D0,0.000008D0,0.000465D0,
- &0.215418D0,5*0D0,2*0.085312D0,0.08531D0,7*0D0,0.000029D0,
- &0.000536D0,5*0D0,0.000074D0,0D0,0.000417D0,0.000015D0,0.000061D0/
- DATA (BRAT(I) ,I= 349, 655)/0.306789D0,0.689189D0,0D0,0.00289D0,
- &69*0D0,0.000001D0,0.000072D0,0.001333D0,4*0D0,0.000001D0,
- &0.000184D0,0D0,0.003108D0,0.000015D0,0.000003D0,2*0D0,0.995284D0,
- &66*0D0,0.000014D0,0.082234D0,2*0D0,0.000013D0,0.003746D0,0D0,
- &0.913992D0,18*0D0,3*0.215119D0,0.214724D0,2*0D0,0.06996D0,
- &0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,
- &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,
- &0.998739D0,0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0,
- &0.144D0,0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,
- &0.1256D0,2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,
- &0.999877D0,0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,
- &0.104D0,0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,
- &0.0478D0,0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,
- &0.0221D0,0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,
- &0.023D0,2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,
- &0.665D0,0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,
- &0.043D0,0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,
- &0.0173D0,0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,
- &0.166D0,0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,
- &2*0.002D0,0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0/
- DATA (BRAT(I) ,I= 656, 831)/0.48947D0,0.34D0,3*0.043D0,0.027D0,
- &0.0126D0,0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,
- &0.104D0,2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,
- &0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,
- &0.066D0,0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,
- &0.001D0,0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,
- &0.006D0,0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,
- &0.027D0,0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,
- &0.022D0,0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,
- &0.306D0,0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,
- &0.04D0,0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,
- &0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,
- &0.062D0,3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,
- &0.0109D0,0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,
- &2*0.0016D0,0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,
- &0.0034D0,0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,
- &0.022D0,0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,
- &0.0511D0,0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,
- &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,
- &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/
- DATA (BRAT(I) ,I= 832, 997)/0.079D0,0.095D0,0.052D0,0.0078D0,
- &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
- &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,
- &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
- &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
- &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
- &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
- &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
- &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
- &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
- &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
- &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
- &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
- &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
- &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
- &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
- &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
- &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,
- &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,
- &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/
- DATA (BRAT(I) ,I= 998,1188)/0.122D0,0.006D0,0.012D0,0.035D0,
- &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,
- &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,
- &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,
- &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,
- &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0,
- &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,
- &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,
- &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,
- &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,
- &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,
- &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,
- &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,
- &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,
- &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,
- &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,
- &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,
- &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,
- &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,
- &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
- DATA (BRAT(I) ,I=1189,1381)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,
- &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
- &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,
- &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,
- &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
- &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
- &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,
- &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
- &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,
- &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0,
- &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
- &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
- &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
- &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
- &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
- &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
- &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
- &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
- &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
- &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/
- DATA (BRAT(I) ,I=1382,1582)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
- &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
- &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
- &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
- &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
- &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
- &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
- &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
- &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,
- &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,
- &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,
- &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,
- &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,
- &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,
- &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,
- &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
- &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0,
- &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,
- &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,
- &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/
- DATA (BRAT(I) ,I=1583,4150)/0.008D0,0.024D0,0.425D0,0.02D0,
- &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,0.024396D0,
- &0.045285D0,0.83119D0,2*0D0,0.000349D0,0.09878D0,0D0,0.019884D0,
- &0.02341D0,0.362776D0,0.550787D0,2*0D0,0.000152D0,0.042991D0,
- &0.013695D0,0.025421D0,0.466595D0,2*0D0,0.000196D0,0.055451D0,
- &0.438642D0,0.445781D0,0D0,0.554219D0,4*0.00335D0,0.522257D0,
- &0.464343D0,6*0D0,1D0,6*0D0,1D0,4*0.013853D0,0.562703D0,
- &0.376702D0,0.00518D0,4*0.006254D0,0.974985D0,7*0D0,4*0.148299D0,
- &0.015351D0,0D0,0.182109D0,0.167099D0,0.042247D0,0.850973D0,
- &0.005411D0,0.045025D0,0.098591D0,0.849898D0,0.021617D0,
- &0.030018D0,0.098466D0,0.294448D0,0.10945D0,0.596102D0,0.389906D0,
- &0.610094D0,3*0.0633D0,0.063299D0,0.063295D0,0.056281D0,2*0D0,
- &6*0.020495D0,2*0D0,0.327919D0,0.04099D0,0.045236D0,0.090112D0,
- &0.19874D0,0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0,
- &0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,
- &0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0,
- &0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0,
- &0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0,
- &0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,
- &0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0/
- DATA (BRAT(I) ,I=4151,4281)/0.010236D0,0.198928D0,0.000149D0,
- &0.000006D0,0.000368D0,0.080733D0,0.199344D0,0.010234D0,
- &0.000003D0,0.010236D0,0.198928D0,0.000149D0,0.000006D0,
- &0.000368D0,0.080733D0,4*0D0,0.184738D0,0.104588D0,0.184738D0,
- &0.104587D0,0.184731D0,0.09582D0,0.022902D0,0.008429D0,0.015602D0,
- &0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0,
- &0.015602D0,0.28959D0,0.01487D0,0.000008D0,0.01487D0,0.289061D0,
- &0.000492D0,0.000009D0,0.000536D0,0.27911D0,2*0.037151D0,
- &0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,0.001805D0,
- &0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0,0.090428D0,
- &0.001808D0,0.81372D0,0D0,6*1D0,0.095602D0,2*0.338272D0,
- &0.156896D0,0.019193D0,0.017993D0,0.001168D0,0.001462D0,
- &0.009608D0,0.003306D0,0.002132D0,0.003127D0,0.002132D0,
- &0.003127D0,0.00213D0,3*0D0,0.001411D0,0.00045D0,0.001411D0,
- &0.00045D0,0.001411D0,0.00045D0,2*0D0,0.097996D0,0.399787D0,
- &0.262464D0,0.185427D0,0.022683D0,0.007648D0,0.004259D0,
- &0.005925D0,0.000304D0,2*0D0,0.000304D0,0.005914D0,0.000002D0,
- &2*0D0,0.000011D0,0.001258D0,5*0D0,3*0.002005D0,0D0,0.272178D0,
- &0.022112D0,0.255165D0,0.015534D0,2*0.108965D0,0.031557D0,
- &0.005562D0,0.044965D0,0.004674D0,0.007637D0,0.020597D0/
- DATA (BRAT(I) ,I=4282,8000)/0.007636D0,0.020595D0,0.007616D0,
- &3*0D0,0.017298D0,0.004782D0,0.017298D0,0.004782D0,0.017297D0,
- &0.004782D0,2*0D0,0.055332D0,2*0.319757D0,0.121576D0,2*0.001556D0,
- &4*0D0,0.0277D0,0.021481D0,0.027699D0,0.021477D0,0.027658D0,3*0D0,
- &0.006071D0,0.01208D0,0.006071D0,0.01208D0,0.006069D0,0.01208D0,
- &2*0D0,0.035891D0,0.209476D0,0.129084D0,0.286631D0,0.10742D0,
- &0.109486D0,4*0D0,0.035282D0,0.001812D0,2*0D0,0.001812D0,
- &0.035215D0,0.000021D0,0D0,0.000001D0,0.000065D0,0.011965D0,5*0D0,
- &2*0.011947D0,0.011946D0,0D0,3649*0D0/
- DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
- &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
- &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
- &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
- &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
- &-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2,
- &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
- &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
- &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
- &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
- &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
- &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
- &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
- &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
- &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
- &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
- &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
- &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
- &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
- &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
- DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
- &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
- &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
- &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
- &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
- &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
- &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
- &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
- &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
- &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
- &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
- &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
- &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
- &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
- &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
- &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
- &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
- &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
- &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
- &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
- DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
- &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
- &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
- &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
- &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
- &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
- &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
- &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
- &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
- &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
- &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
- &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
- &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
- &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
- &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
- &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
- &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
- &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
- &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
- &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
- DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
- &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
- &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
- &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
- &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
- &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
- &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
- &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
- &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
- &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
- &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
- &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
- &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
- &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
- &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
- &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
- &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
- &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
- &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
- &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/
- DATA (KFDP(I,1),I=1403,1713)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
- &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
- &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
- &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
- &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
- &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
- &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
- &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
- &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
- &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
- &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
- &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
- &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
- &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
- &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,
- &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,
- &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
- &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
- &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
- &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/
- DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021,
- &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,
- &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,
- &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,
- &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,
- &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
- &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
- &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012,
- &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
- &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,
- &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
- &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,
- &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
- &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,
- &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
- &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,
- &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,
- &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,
- &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,
- &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/
- DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004,
- &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
- &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,
- &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,
- &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11,
- &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
- &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
- &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
- &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
- &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
- &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,
- &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12,
- &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
- &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
- &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,
- &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,
- &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
- &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,
- &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
- &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/
- DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,
- &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
- &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
- &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
- &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
- &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
- &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
- &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
- &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
- &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
- &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
- &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
- &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
- &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
- &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
- &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
- &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
- &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
- &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
- &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/
- DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,
- &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,
- &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
- &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
- &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
- &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
- &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
- &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,
- &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
- &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,
- &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,
- &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
- &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,
- &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
- &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,
- &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,
- &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
- &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
- &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
- &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/
- DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002,
- &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
- &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
- &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
- &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
- &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
- &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
- &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
- &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
- &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
- &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
- &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
- &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
- &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
- &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,
- &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,
- &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,
- &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
- &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
- &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/
- DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037,
- &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
- &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
- &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
- &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
- &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
- &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
- &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12,
- &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,
- &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,
- &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
- &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,
- &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
- &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,
- &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
- &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,
- &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,
- &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
- &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
- &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/
- DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014,
- &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
- &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
- &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
- &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,
- &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
- &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
- &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,
- &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,
- &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,
- &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,
- &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,
- &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,
- &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,
- &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,
- &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,
- &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,
- &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
- &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
- &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/
- DATA (KFDP(I,1),I=3783,4156)/1000039,1000024,1000037,1000022,
- &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,
- &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
- &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,
- &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,
- &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,
- &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,
- &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,
- &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
- &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
- &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
- &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
- &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
- &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
- &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,
- &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,
- &1,2,3,4,5,6,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,
- &5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,3100111,3200111,21,22,23,-24,21,
- &22,23,24,22,23,-24,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
- &21,22,23,24,9*11,9*-11,2*11,2*-11,9*13,9*-13,2*13,2*-13,9*15/
- DATA (KFDP(I,1),I=4157,8000)/9*-15,2*15,2*-15,1,2,3,4,5,6,11,12,
- &9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,-15,
- &3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,2*24,
- &2*3000211,2*22,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,
- &18,2*24,3*3000211,2*24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,
- &22,23,24,3000211,24,3000211,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,
- &16,17,18,2*24,-24,23,2*22,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13,
- &14,15,16,17,18,2*22,23,2*24,23,22,2*24,23,4*-1,4*-3,4*-5,4*-7,
- &-11,-13,-15,-17,3649*0/
- DATA (KFDP(I,2),I= 1, 339)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4,
- &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,6*1000006,3*7,
- &2,4,6,8,7,4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14,
- &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
- &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
- &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
- &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
- &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
- &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
- &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
- &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
- &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
- &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
- &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
- &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
- &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
- &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
- &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
- &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
- &2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,25,-1,-2,-3,-4,-5,-6/
- DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
- &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
- &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
- &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
- &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
- &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
- &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
- &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
- &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
- &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
- &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
- &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
- &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
- &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
- &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
- &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
- &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
- &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
- &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
- &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
- DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
- &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
- &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
- &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
- &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
- &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
- &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
- &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
- &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
- &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
- &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
- &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
- &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
- &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
- &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
- &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
- &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
- &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
- &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
- &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
- DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
- &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
- &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
- &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
- &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
- &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
- &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
- &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
- &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
- &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
- &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
- &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
- &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
- &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
- &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
- &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
- &4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,11,13,15,1,4,3,4,1,3,11,
- &13,15,1,4,3,4,1,3,4*22,11,13,15,1,4,3,4,1,3,22,11,13,15,1,4,3,4,
- &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,
- &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3/
- DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
- &4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,
- &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,
- &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,
- &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
- &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
- &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
- &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
- &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
- &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
- &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
- &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
- &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
- &1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,
- &-5,2,2*1,4*2,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,
- &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,
- &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,2*24,2*37,4,1,3,5,1,3,5,1,3,5,-3,
- &2*-5,5,2*6,4*5,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,
- &4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,2*5,4*6,2*24,2*37,6,4,-15,
- &16,1,3,5,1,3,5,1,3,5,-3,2*-5,11,2*12,4*11,2*-24,-37,13,15,11,15/
- DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
- &1,3,5,12,2*11,4*12,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,
- &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
- &5,1,3,5,1,3,5,14,2*13,4*14,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,
- &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
- &13,15,1,3,5,1,3,5,1,3,5,16,2*15,4*16,2*24,2*37,11,13,15,11,13,15,
- &1,3,5,1,3,5,1,3,5,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,
- &5,-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,
- &1,-1,3,-3,5,-5,1,-1,3,-3,5,-5,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,
- &-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,
- &-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,
- &-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,
- &-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,
- &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
- &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
- &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
- &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,
- &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,
- &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,
- &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3/
- DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
- &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
- &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
- &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
- &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
- &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
- &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
- &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
- &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,
- &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,
- &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,
- &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,
- &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
- &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
- &2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,
- &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
- &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
- &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
- &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
- &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
- DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
- &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
- &2*4,-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,22,23,25,35,36,22,23,11,13,
- &15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,
- &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
- &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
- &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
- &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
- &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
- &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
- &-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,
- &-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,
- &-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,
- &-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,
- &-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,
- &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
- &16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,
- &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
- &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
- &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
- DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
- &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
- &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
- &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
- &3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,
- &2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,
- &5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,
- &4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,
- &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
- &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
- &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
- &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
- &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
- &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
- &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
- &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
- &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
- &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
- &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
- &-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,1,2*2,4*1,23,25,35,36,2*-24/
- DATA (KFDP(I,2),I=3670,4183)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
- &6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,-5,2,2*1,4*2,23,25,35,
- &36,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,23,25,35,36,
- &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,
- &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,23,25,35,36,2*24,2*37,4,1,3,5,1,
- &3,5,1,3,5,-3,2*-5,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,1,3,5,1,3,
- &5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,
- &2*5,4*6,23,25,35,36,2*24,2*37,6,1,3,5,1,3,5,1,3,5,-3,2*-5,11,
- &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
- &13,15,1,3,5,1,3,5,1,3,5,13,2*14,4*13,23,25,35,36,2*-24,2*-37,13,
- &15,11,15,11,13,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,15,2*16,4*15,
- &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
- &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
- &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,
- &-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,
- &-4,-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
- &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
- &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-13,2*15,3*-1,3*-3,
- &3*-5,3*1,3*3,3*5,2*-11,2*15,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-11,
- &2*13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16/
- DATA (KFDP(I,2),I=4184,8000)/9900016,2,4,6,2,4,6,2,4,6,9900012,
- &9900014,9900016,-11,-13,-15,-13,2*-15,24,-11,-13,-15,-13,2*-15,
- &9900024,6*21,-24,-3000211,-24,-3000211,3000111,3000221,3000111,
- &3000221,2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,
- &-18,23,3000111,23,3000111,22,3000221,22,2,4,6,8,2,4,6,8,2,4,6,8,
- &2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,2*-24,-3000211,
- &2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
- &-3000211,3000211,3000221,3000113,3000223,-3000213,3000213,
- &3000113,3000223,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
- &-17,-18,24,3000211,24,3000111,3000221,3000211,3000213,3000113,
- &3000223,3000213,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,
- &3649*0/
- DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
- &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
- &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
- &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
- &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
- &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
- &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
- &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
- &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
- &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
- &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
- &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
- &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
- &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
- &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
- &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
- &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
- &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
- &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
- &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
- DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
- &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
- &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
- &4*3,4*0,4*3,6*0,4*3,0,28*3,2*0,3*4122,8*0,4,1,4,3,2*2,4*4,1,4,3,
- &2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,
- &2*2,0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
- &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
- &3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,
- &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,
- &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
- &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
- &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
- &6,-2,2,-4,4,-6,6,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,
- &-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
- &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
- &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
- &-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,
- &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
- &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
- &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
- DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
- &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
- &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
- &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,
- &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
- &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
- &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
- &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
- &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
- &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
- &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
- &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
- &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,
- &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,3*0,12,14,16,2,4,0,12,14,16,2,
- &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
- &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
- &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
- &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
- &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,
- &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1/
- DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
- &2*6,5,-5,3,-3,5,-5,1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,7*0,
- &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
- &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
- &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
- &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
- &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
- &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,
- &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,
- &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
- &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,
- &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
- &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
- &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
- &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
- &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
- &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
- &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,
- &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,
- &-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
- DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
- &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,
- &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
- &4*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,
- &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
- &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
- &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
- &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,
- &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
- &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,
- &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,3,-3,5,-5,
- &1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,351*0,-5,95*0,2,4,6,2,4,
- &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4,
- &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4,
- &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3831*0/
- DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
- &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
- &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
- &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
- &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
- &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
- &-311,20*0,-3,43*0,6*1,39*0,6*2,42*0,6*3,14*0,8*4,4*0,4*-5,4*0,
- &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
- &4*0,4*81,6*0,4*81,0,28*81,13*0,6*2101,18*81,4*0,18*81,4*0,9*81,0,
- &162*81,31*0,-211,111,6516*0/
- DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
- &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
- &3*111,-211,111,7193*0/
-
-C...PYDAT4, with particle names (character strings).
- DATA (CHAF(I,1),I= 1, 202)/'d','u','s','c','b','t','b''','t''',
- &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
- &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
- &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
- &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
- &'junction',' ','system','cluster','string','indep.','CMshower',
- &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon',
- &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega',
- &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
- &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
- &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
- &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
- &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
- &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
- &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
- &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
- &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
- &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
- &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
- &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
- DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
- &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
- &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
- &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
- &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
- &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
- &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
- &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
- &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
- &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
- &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
- &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
- &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
- &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
- &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
- &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
- &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
- &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
- &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
- &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
- DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
- &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
- &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
- &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
- &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
- &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]',
- &'bb~[3S18]','bb~[1S08]','bb~[3P08]','a_tc0','a_tc+',131*' '/
- DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
- &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
- &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
- &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
- &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
- &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
- &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
- &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
- &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
- &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
- &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
- &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
- &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
- &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
- &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
- &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
- &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
- &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
- &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
- &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
- DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
- &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
- &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
- &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
- &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
- &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
- &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
- &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
- &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
- &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
- &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
- &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
- &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
- &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
- &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
- &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
- &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
- &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
- &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
- &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
- DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
- &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
- &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
- &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',7*' ','a_tc-',
- &131*' '/
-
-C...PYDATR, with initial values for the random number generator.
- DATA MRPY/19780503,0,0,97,33,0/
-
-C...Default values for allowed processes and kinematics constraints.
- DATA MSEL/1/
- DATA MSUB/500*0/
- DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
- &5*1,5*0,6*1,4*0,4*1,16*0,16*0,4*1,4*0,6*1,5*0,5*1,0,5*1,5*0,
- &6*1,4*0,4*1,16*0/
- DATA CKIN/
- & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
- & 1.0D0, -10D0, 10D0, -40D0, 40D0,
- 1 -40D0, 40D0, -40D0, 40D0, -40D0,
- 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
- 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
- 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
- 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
- 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
- 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
- 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
- 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
- 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
- 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
- 6 -1D0, 0D0, -1D0, 0D0, -1D0,
- 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
- 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
- 8 120*0D0/
-
-C...Default values for main switches and parameters. Reset information.
- DATA (MSTP(I),I=1,100)/
- & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
- 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
- 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
- 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
- 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
- 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
- 6 2, 3, 2, 2, 1, 5, 2, 3, 0, 0,
- 7 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
- 8 1, 4, 100, 1, 1, 2, 4, 1, 1, 0,
- 9 1, 3, 1, 3, 1, 0, 0, 0, 0, 0/
- DATA (MSTP(I),I=101,200)/
- & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
- 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
- 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
- 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
- 4 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
- 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
- 8 6, 414, 2007, 11, 19, 0, 0, 0, 0, 0,
- 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
- DATA (PARP(I),I=1,100)/
- & 0.25D0, 10D0, 8*0D0,
- 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
- 2 10*0D0,
- 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0,
- 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
- 5 10*0D0,
- 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
- 7 4.0D0, 0.25D0, 5*0D0, 0.025D0, 2.0D0, 0.1D0,
- 8 1.90D0, 2.0D0, 0.5D0, 0.4D0, 0.90D0,
- 8 0.95D0, 0.7D0, 0.5D0, 1800D0, 0.16D0,
- 9 2.0D0,0.40D0,5.0D0,1.0D0,0.0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
- DATA (PARP(I),I=101,200)/
- & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
- 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
- 2 1.0D0, 0.4D0, 8*0D0,
- 3 0.01D0, 9*0D0,
- 4 1.16D0, 0.0119D0, 0.01D0, 0.01D0, 0.05D0,
- 4 9.28D0, 0.15D0, 0.02D0, 0.48D0, 0.09D0,
- 5 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
- 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
- 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
- 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
- 8 0.3D0, 0.64D0,
- 9 0.64D0, 5.0D0, 1.0D4, 1.0D4, 6*0D0/
- DATA MSTI/200*0/
- DATA PARI/200*0D0/
- DATA MINT/400*0/
- DATA VINT/400*0D0/
-
-C...Constants for the generation of the various processes.
- DATA (ISET(I),I=1,100)/
- & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
- 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
- 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
- 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
- 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
- 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
- 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
- 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
- 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
- DATA (ISET(I),I=101,200)/
- & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
- 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
- 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
- 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
- 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
- 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
- 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
- 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
- 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
- DATA (ISET(I),I=201,300)/
- & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
- 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
- 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
- 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
- 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
- DATA (ISET(I),I=301,500)/
- & 2, 39*-2,
- 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
- 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
- 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
- 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
- 9 1, 1, 2, 2, 2, 5*-2,
- & 5, 5, 18*-2,
- 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2,
- 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2/
- DATA ((KFPR(I,J),J=1,2),I=1,50)/
- & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
- & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
- 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
- 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
- 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
- 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
- 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
- 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
- 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
- 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
- DATA ((KFPR(I,J),J=1,2),I=51,100)/
- 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
- 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
- 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
- 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
- 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
- 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
- DATA ((KFPR(I,J),J=1,2),I=101,150)/
- & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
- & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
- 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
- 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
- 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
- 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
- 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
- 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
- DATA ((KFPR(I,J),J=1,2),I=151,200)/
- 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
- 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
- 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
- 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
- 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
- 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
- 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
- 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
- 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
- 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
- DATA ((KFPR(I,J),J=1,2),I=201,240)/
- & 1000011, 1000011, 2000011, 2000011, 1000011,
- & 2000011, 1000013, 1000013, 2000013, 2000013,
- & 1000013, 2000013, 1000015, 1000015, 2000015,
- & 2000015, 1000015, 2000015, 1000011, 1000012,
- 1 1000015, 1000016, 2000015, 1000016, 1000012,
- 1 1000012, 1000016, 1000016, 0, 0,
- 1 1000022, 1000022, 1000023, 1000023, 1000025,
- 1 1000025, 1000035, 1000035, 1000022, 1000023,
- 2 1000022, 1000025, 1000022, 1000035, 1000023,
- 2 1000025, 1000023, 1000035, 1000025, 1000035,
- 2 1000024, 1000024, 1000037, 1000037, 1000024,
- 2 1000037, 1000022, 1000024, 1000023, 1000024,
- 3 1000025, 1000024, 1000035, 1000024, 1000022,
- 3 1000037, 1000023, 1000037, 1000025, 1000037,
- 3 1000035, 1000037, 1000021, 1000022, 1000021,
- 3 1000023, 1000021, 1000025, 1000021, 1000035/
- DATA ((KFPR(I,J),J=1,2),I=241,280)/
- 4 1000021, 1000024, 1000021, 1000037, 1000021,
- 4 1000021, 1000021, 1000021, 0, 0,
- 4 1000002, 1000022, 2000002, 1000022, 1000002,
- 4 1000023, 2000002, 1000023, 1000002, 1000025,
- 5 2000002, 1000025, 1000002, 1000035, 2000002,
- 5 1000035, 1000001, 1000024, 2000005, 1000024,
- 5 1000001, 1000037, 2000005, 1000037, 1000002,
- 5 1000021, 2000002, 1000021, 0, 0,
- 6 1000006, 1000006, 2000006, 2000006, 1000006,
- 6 2000006, 1000006, 1000006, 2000006, 2000006,
- 6 0, 0, 0, 0, 0,
- 6 0, 0, 0, 0, 0,
- 7 1000002, 1000002, 2000002, 2000002, 1000002,
- 7 2000002, 1000002, 1000002, 2000002, 2000002,
- 7 1000002, 2000002, 1000002, 1000002, 2000002,
- 7 2000002, 1000002, 1000002, 2000002, 2000002/
- DATA ((KFPR(I,J),J=1,2),I=281,350)/
- 8 1000005, 1000002, 2000005, 2000002, 1000005,
- 8 2000002, 1000005, 1000002, 2000005, 2000002,
- 8 1000005, 2000002, 1000005, 1000005, 2000005,
- 8 2000005, 1000005, 1000005, 2000005, 2000005,
- 9 1000005, 1000005, 2000005, 2000005, 1000005,
- 9 2000005, 1000005, 1000021, 2000005, 1000021,
- 9 1000005, 2000005, 37, 25, 37,
- 9 35, 36, 25, 36, 35,
- & 37, 37, 78*0,
- 4 9900041, 0, 9900042, 0, 9900041,
- 4 11, 9900042, 11, 9900041, 13,
- 4 9900042, 13, 9900041, 15, 9900042,
- 4 15, 9900041, 9900041, 9900042, 9900042/
- DATA ((KFPR(I,J),J=1,2),I=351,400)/
- 5 9900041, 0, 9900042, 0, 9900023,
- 5 0, 9900024, 0, 0, 0,
- 5 0, 0, 0, 0, 0,
- 5 0, 0, 0, 0, 0,
- 6 24, 24, 24, 3000211, 3000211,
- 6 3000211, 22, 3000111, 22, 3000221,
- 6 23, 3000111, 23, 3000221, 24,
- 6 3000211, 0, 0, 24, 23,
- 7 24, 3000111, 3000211, 23, 3000211,
- 7 3000111, 22, 3000211, 23, 3000211,
- 7 24, 3000111, 24, 3000221, 22,
- 7 24, 22, 23, 23, 23,
- 8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
- 8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
- 9 5000039, 0, 5000039, 0, 21,
- 9 5000039, 0, 5000039, 21, 5000039,
- 9 10*0/
- DATA ((KFPR(I,J),J=1,2),I=401,500)/
- & 37, 6, 37, 6, 36*0,
- 2 443, 21, 9900443, 21, 9900441,
- 2 21, 9910441, 21, 0, 9900443,
- 2 0, 9900441, 0, 9910441, 21,
- 2 9900443, 21, 9900441, 21, 9910441,
- 3 10441, 21, 20443, 21, 445, 21, 0, 10441, 0, 20443,
- 3 0, 445, 21, 10441, 21, 20443, 21, 445, 42*0,
- 6 553, 21, 9900553, 21, 9900551,
- 6 21, 9910551, 21, 0, 9900553,
- 6 0, 9900551, 0, 9910551, 21,
- 6 9900553, 21, 9900551, 21, 9910551,
- 7 10551, 21, 20553, 21, 555, 21, 0, 10551, 0, 20553,
- 7 0, 555, 21, 10551, 21, 20553, 21, 555, 42*0/
- DATA COEF/10000*0D0/
- DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
- &4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2,
- &3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2,
- &3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1,
- &3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0,
- &4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3,
- &2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2,
- &4,0,0,0,4,0,1,3,0,0,3,0,2,4,3,0,3,4,0,0,1,0,0,1,0,0,3,4,2,0,0,2,
- &3,0,0,0,1,0,0,0,0,0,3,0,2,0,0,0,2,0,3,1,2,0,0,0,3,2,1,0,1,0,0,0,
- &4,4,3,3,2,2,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
-
-C...Treatment of resonances.
- DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
- &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,2*1,131*0/
-
-C...Character constants: name of processes.
- DATA PROC(0)/ 'All included subprocesses '/
- DATA (PROC(I),I=1,20)/
- &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
- &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
- &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
- &' ', 'W+ + W- -> h0 ',
- &' ', 'f + f'' -> f + f'' (QFD) ',
- 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
- 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
- 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
- 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
- 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
- DATA (PROC(I),I=21,40)/
- 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
- 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
- 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
- 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
- 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
- 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
- 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
- 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
- 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
- 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
- DATA (PROC(I),I=41,60)/
- 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
- 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
- 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
- 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
- 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
- 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
- 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
- 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
- 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
- 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
- DATA (PROC(I),I=61,80)/
- 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
- 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
- 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
- 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
- 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
- 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
- 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
- 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
- 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
- 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
- DATA (PROC(I),I=81,100)/
- 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
- 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
- 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
- 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
- 8'g + g -> chi_2c + g ', ' ',
- 9'Elastic scattering ', 'Single diffractive (XB) ',
- 9'Single diffractive (AX) ', 'Double diffractive ',
- 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
- 9' ', ' ',
- 9'q + gamma* -> q ', ' '/
- DATA (PROC(I),I=101,120)/
- &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
- &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
- &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
- &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
- &' ', 'f + fbar -> gamma + h0 ',
- 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
- 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
- 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
- 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
- 1' ', ' '/
- DATA (PROC(I),I=121,140)/
- 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
- 2'f + f'' -> f + f'' + h0 ',
- 2'f + f'' -> f" + f"'' + h0 ',
- 2' ', ' ',
- 2' ', ' ',
- 2' ', ' ',
- 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
- 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
- 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
- 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
- 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
- DATA (PROC(I),I=141,160)/
- 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
- 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
- 4'q + l -> LQ ', 'e + gamma -> e* ',
- 4'd + g -> d* ', 'u + g -> u* ',
- 4'g + g -> eta_tc ', ' ',
- 5'f + fbar -> H0 ', 'g + g -> H0 ',
- 5'gamma + gamma -> H0 ', ' ',
- 5' ', 'f + fbar -> A0 ',
- 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
- 5' ', ' '/
- DATA (PROC(I),I=161,180)/
- 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
- 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
- 6'f + fbar -> f'' + fbar'' (g/Z)',
- 6'f +fbar'' -> f" + fbar"'' (W) ',
- 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
- 6'q + qbar -> e + e* ', ' ',
- 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
- 7'f + f'' -> f + f'' + H0 ',
- 7'f + f'' -> f" + f"'' + H0 ',
- 7' ', 'f + fbar -> Z0 + A0 ',
- 7'f + fbar'' -> W+/- + A0 ',
- 7'f + f'' -> f + f'' + A0 ',
- 7'f + f'' -> f" + f"'' + A0 ',
- 7' '/
- DATA (PROC(I),I=181,200)/
- 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
- 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
- 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
- 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
- 8'q + g -> q + A0 ', 'g + g -> g + A0 ',
- 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
- 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
- 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
- 9' ', ' ',
- 9' ', ' '/
- DATA (PROC(I),I=201,220)/
- &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
- &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
- &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
- &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
- &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
- 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
- 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
- 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
- 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
- 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
- DATA (PROC(I),I=221,240)/
- 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
- 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
- 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
- 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
- 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
- 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
- 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
- 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
- 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
- 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
- DATA (PROC(I),I=241,260)/
- 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
- 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
- 4' ', 'qj + g -> ~qj_L + ~chi1 ',
- 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
- 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
- 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
- 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
- 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
- 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
- 5'qj + g -> ~qj_R + ~g ', ' '/
- DATA (PROC(I),I=261,300)/
- 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
- 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
- 6'g + g -> ~t_2 + ~t_2bar ', ' ',
- 6' ', ' ',
- 6' ', ' ',
- 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
- 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
- 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
- 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
- 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
- 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
- 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
- 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
- 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
- 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
- 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
- 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
- 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
- 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
- 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
- DATA (PROC(I),I=301,340)/
- &'f + fbar -> H+ + H- ', 39*' '/
- DATA (PROC(I),I=341,380)/
- 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
- 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
- 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
- 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
- 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
- 5'f + f -> f'' + f'' + H_L++/-- ',
- 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
- 5'f + fbar'' -> W_R+/- ',5*' ',
- 6' ', 'f + fbar -> W_L+ W_L- ',
- 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
- 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
- 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
- 6'f + fbar -> W+/- pi_T-/+ ', ' ',
- 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
- 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
- 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
- 7'f + fbar'' -> W+/- pi_T0 ',
- 7'f + fbar'' -> W+/- pi_T0'' ',
- 7'f + fbar'' -> gamma W+/- (ETC)','f + fbar -> gamma Z0 (ETC)',
- 7'f + fbar -> Z0 Z0 (ETC)'/
- DATA (PROC(I),I=381,420)/
- 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
- 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
- 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
- 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
- 8' ', ' ',
- 9'f + fbar -> G* ', 'g + g -> G* ',
- 9'q + qbar -> g + G* ', 'q + g -> q + G* ',
- 9'g + g -> g + G* ', ' ',
- 9 4*' ',
- &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ',
- & 18*' '/
- DATA (PROC(I),I=421,460)/
- 2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ',
- 2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ',
- 2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ',
- 2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ',
- 2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ',
- 3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ',
- 3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ',
- 3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ',
- 3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ',
- 3'q + q~ -> g + cc~[3P2(1)] ',
- 3 21 *' '/
- DATA (PROC(I),I=461,500)/
- 6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ',
- 6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ',
- 6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ',
- 6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ',
- 6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ',
- 7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ',
- 7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ',
- 7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ',
- 7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ',
- 7'q + q~ -> g + bb~[3P2(1)] ',
- 7 21 *' '/
-
-C...Cross sections and slope offsets.
- DATA SIGT/294*0D0/
-
-C...Supersymmetry switches and parameters.
- DATA IMSS/0,
- & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
- 1 89*0/
- DATA RMSS/0D0,
- & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
- 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
- 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
- 3 10*0D0,
- 4 0D0,1D0,8*0D0,
- 5 49*0D0/
-C...Initial values for R-violating SUSY couplings.
-C...Should not be changed here. See PYMSIN.
- DATA RVLAM/27*0D0/
- DATA RVLAMP/27*0D0/
- DATA RVLAMB/27*0D0/
-
-C...Technicolor switches and parameters
- DATA ITCM/0,
- & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 1 89*0/
- DATA RTCM/0D0,
- & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
- 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
- 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
- 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
- 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 1D0, 3*200D0,
- 4 200D0, 48*0D0/
-
-C...Data for histogramming routines.
- DATA IHIST/1000,20000,55,1/
- DATA INDX/1000*0/
-
-C...Data for SUSY Les Houches Accord.
- DATA CPRO/'PYTHIA ','PYTHIA '/
- DATA CVER/'6.4 ','6.4 '/
- DATA MODSEL/200*0/
- DATA PARMIN/100*0D0/
- DATA RMSOFT/101*0D0/
- DATA AU/9*0D0/
- DATA AD/9*0D0/
- DATA AE/9*0D0/
-
- END
-
-C*********************************************************************
-
-C...PYCKBD
-C...Check that BLOCK DATA PYDATA has been loaded.
-C...Should not be required, except that some compilers/linkers
-C...are pretty buggy in this respect.
-
- SUBROUTINE PYCKBD
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
-
-C...Check a few variables to see they have been sensibly initialized.
- IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0
- &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR.
- &MSTP(1).GT.5) THEN
-C...If not, abort the run right away.
- WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
- WRITE(*,*) 'The program execution is stopped now!'
- CALL PYSTOP(8)
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYTEST
-C...A simple program (disguised as subroutine) to run at installation
-C...as a check that the program works as intended.
-
- SUBROUTINE PYTEST(MTEST)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
-C...Local arrays.
- DIMENSION PSUM(5),PINI(6),PFIN(6)
-
-C...Save defaults for values that are changed.
- MSTJ1=MSTJ(1)
- MSTJ3=MSTJ(3)
- MSTJ11=MSTJ(11)
- MSTJ42=MSTJ(42)
- MSTJ43=MSTJ(43)
- MSTJ44=MSTJ(44)
- PARJ17=PARJ(17)
- PARJ22=PARJ(22)
- PARJ43=PARJ(43)
- PARJ54=PARJ(54)
- MST101=MSTJ(101)
- MST104=MSTJ(104)
- MST105=MSTJ(105)
- MST107=MSTJ(107)
- MST116=MSTJ(116)
-
-C...First part: loop over simple events to be generated.
- IF(MTEST.GE.1) CALL PYTABU(20)
- NERR=0
- DO 180 IEV=1,500
-
-C...Reset parameter values. Switch on some nonstandard features.
- MSTJ(1)=1
- MSTJ(3)=0
- MSTJ(11)=1
- MSTJ(42)=2
- MSTJ(43)=4
- MSTJ(44)=2
- PARJ(17)=0.1D0
- PARJ(22)=1.5D0
- PARJ(43)=1D0
- PARJ(54)=-0.05D0
- MSTJ(101)=5
- MSTJ(104)=5
- MSTJ(105)=0
- MSTJ(107)=1
- IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
-
-C...Ten events each for some single jets configurations.
- IF(IEV.LE.50) THEN
- ITY=(IEV+9)/10
- MSTJ(3)=-1
- IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
- IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
- IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
- IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
- IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
- IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
-
-C...Ten events each for some simple jet systems; string fragmentation.
- ELSEIF(IEV.LE.130) THEN
- ITY=(IEV-41)/10
- IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
- IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
- IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
- IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
- IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
- IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
- IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
- IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
- & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
-
-C...Seventy events with independent fragmentation and momentum cons.
- ELSEIF(IEV.LE.200) THEN
- ITY=1+(IEV-131)/16
- MSTJ(2)=1+MOD(IEV-131,4)
- MSTJ(3)=1+MOD((IEV-131)/4,4)
- IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
- IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
- IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
- & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
- IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
- & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
-
-C...A hundred events with random jets (check invariant mass).
- ELSEIF(IEV.LE.300) THEN
- 100 DO 110 J=1,5
- PSUM(J)=0D0
- 110 CONTINUE
- NJET=2D0+6D0*PYR(0)
- DO 130 I=1,NJET
- KFL=21
- IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
- IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
- EJET=5D0+20D0*PYR(0)
- THETA=ACOS(2D0*PYR(0)-1D0)
- PHI=6.2832D0*PYR(0)
- IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
- IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
- IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
- IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
- DO 120 J=1,4
- PSUM(J)=PSUM(J)+P(I,J)
- 120 CONTINUE
- 130 CONTINUE
- IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
- & (PSUM(5)+PARJ(32))**2) GOTO 100
-
-C...Fifty e+e- continuum events with matrix elements.
- ELSEIF(IEV.LE.350) THEN
- MSTJ(101)=2
- CALL PYEEVT(0,40D0)
-
-C...Fifty e+e- continuum event with varying shower options.
- ELSEIF(IEV.LE.400) THEN
- MSTJ(42)=1+MOD(IEV,2)
- MSTJ(43)=1+MOD(IEV/2,4)
- MSTJ(44)=MOD(IEV/8,3)
- CALL PYEEVT(0,90D0)
-
-C...Fifty e+e- continuum events with coherent shower.
- ELSEIF(IEV.LE.450) THEN
- CALL PYEEVT(0,500D0)
-
-C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
- ELSE
- CALL PYONIA(5,9.46D0)
- ENDIF
-
-C...Generate event. Find total momentum, energy and charge.
- DO 140 J=1,4
- PINI(J)=PYP(0,J)
- 140 CONTINUE
- PINI(6)=PYP(0,6)
- CALL PYEXEC
- DO 150 J=1,4
- PFIN(J)=PYP(0,J)
- 150 CONTINUE
- PFIN(6)=PYP(0,6)
-
-C...Check conservation of energy, momentum and charge;
-C...usually exact, but only approximate for single jets.
- MERR=0
- IF(IEV.LE.50) THEN
- IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
- & MERR=MERR+1
- EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
- IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
- IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
- ELSE
- DO 160 J=1,4
- IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
- 160 CONTINUE
- IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
- ENDIF
- IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
- & (PFIN(J),J=1,4),PFIN(6)
-
-C...Check that all KF codes are known ones, and that partons/particles
-C...satisfy energy-momentum-mass relation. Store particle statistics.
- DO 170 I=1,N
- IF(K(I,1).GT.20) GOTO 170
- IF(PYCOMP(K(I,2)).EQ.0) THEN
- WRITE(MSTU(11),5100) I
- MERR=MERR+1
- ENDIF
- PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
- IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
- & THEN
- WRITE(MSTU(11),5200) I
- MERR=MERR+1
- ENDIF
- 170 CONTINUE
- IF(MTEST.GE.1) CALL PYTABU(21)
-
-C...List all erroneous events and some normal ones.
- IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
- IF(MERR.GE.1) WRITE(MSTU(11),6400)
- CALL PYLIST(2)
- ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
- CALL PYLIST(1)
- ENDIF
-
-C...Stop execution if too many errors.
- IF(MERR.NE.0) NERR=NERR+1
- IF(NERR.GE.10) THEN
- WRITE(MSTU(11),6300)
- CALL PYLIST(1)
- CALL PYSTOP(9)
- ENDIF
- 180 CONTINUE
-
-C...Summarize result of run.
- IF(MTEST.GE.1) CALL PYTABU(22)
-
-C...Reset commonblock variables changed during run.
- MSTJ(1)=MSTJ1
- MSTJ(3)=MSTJ3
- MSTJ(11)=MSTJ11
- MSTJ(42)=MSTJ42
- MSTJ(43)=MSTJ43
- MSTJ(44)=MSTJ44
- PARJ(17)=PARJ17
- PARJ(22)=PARJ22
- PARJ(43)=PARJ43
- PARJ(54)=PARJ54
- MSTJ(101)=MST101
- MSTJ(104)=MST104
- MSTJ(105)=MST105
- MSTJ(107)=MST107
- MSTJ(116)=MST116
-
-C...Second part: complete events of various kinds.
-C...Common initial values. Loop over initiating conditions.
- MSTP(122)=MAX(0,MIN(2,MTEST))
- MDCY(PYCOMP(111),1)=0
- DO 230 IPROC=1,8
-
-C...Reset process type, kinematics cuts, and the flags used.
- MSEL=0
- DO 190 ISUB=1,500
- MSUB(ISUB)=0
- 190 CONTINUE
- CKIN(1)=2D0
- CKIN(3)=0D0
- MSTP(2)=1
- MSTP(11)=0
- MSTP(33)=0
- MSTP(81)=1
- MSTP(82)=1
- MSTP(111)=1
- MSTP(131)=0
- MSTP(133)=0
- PARP(131)=0.01D0
-
-C...Prompt photon production at fixed target.
- IF(IPROC.EQ.1) THEN
- PZSUM=300D0
- PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
- PQSUM=2D0
- MSEL=10
- CKIN(3)=5D0
- CALL PYINIT('FIXT','pi+','p',PZSUM)
-
-C...QCD processes at ISR energies.
- ELSEIF(IPROC.EQ.2) THEN
- PESUM=63D0
- PZSUM=0D0
- PQSUM=2D0
- MSEL=1
- CKIN(3)=5D0
- CALL PYINIT('CMS','p','p',PESUM)
-
-C...W production + multiple interactions at CERN Collider.
- ELSEIF(IPROC.EQ.3) THEN
- PESUM=630D0
- PZSUM=0D0
- PQSUM=0D0
- MSEL=12
- CKIN(1)=20D0
- MSTP(82)=4
- MSTP(2)=2
- MSTP(33)=3
- CALL PYINIT('CMS','p','pbar',PESUM)
-
-C...W/Z gauge boson pairs + pileup events at the Tevatron.
- ELSEIF(IPROC.EQ.4) THEN
- PESUM=1800D0
- PZSUM=0D0
- PQSUM=0D0
- MSUB(22)=1
- MSUB(23)=1
- MSUB(25)=1
- CKIN(1)=200D0
- MSTP(111)=0
- MSTP(131)=1
- MSTP(133)=2
- PARP(131)=0.04D0
- CALL PYINIT('CMS','p','pbar',PESUM)
-
-C...Higgs production at LHC.
- ELSEIF(IPROC.EQ.5) THEN
- PESUM=15400D0
- PZSUM=0D0
- PQSUM=2D0
- MSUB(3)=1
- MSUB(102)=1
- MSUB(123)=1
- MSUB(124)=1
- PMAS(25,1)=300D0
- CKIN(1)=200D0
- MSTP(81)=0
- MSTP(111)=0
- CALL PYINIT('CMS','p','p',PESUM)
-
-C...Z' production at SSC.
- ELSEIF(IPROC.EQ.6) THEN
- PESUM=40000D0
- PZSUM=0D0
- PQSUM=2D0
- MSEL=21
- PMAS(32,1)=600D0
- CKIN(1)=400D0
- MSTP(81)=0
- MSTP(111)=0
- CALL PYINIT('CMS','p','p',PESUM)
-
-C...W pair production at 1 TeV e+e- collider.
- ELSEIF(IPROC.EQ.7) THEN
- PESUM=1000D0
- PZSUM=0D0
- PQSUM=0D0
- MSUB(25)=1
- MSUB(69)=1
- MSTP(11)=1
- CALL PYINIT('CMS','e+','e-',PESUM)
-
-C...Deep inelastic scattering at a LEP+LHC ep collider.
- ELSEIF(IPROC.EQ.8) THEN
- P(1,1)=0D0
- P(1,2)=0D0
- P(1,3)=8000D0
- P(2,1)=0D0
- P(2,2)=0D0
- P(2,3)=-80D0
- PESUM=8080D0
- PZSUM=7920D0
- PQSUM=0D0
- MSUB(10)=1
- CKIN(3)=50D0
- MSTP(111)=0
- CALL PYINIT('3MOM','p','e-',PESUM)
- ENDIF
-
-C...Generate 20 events of each required type.
- DO 220 IEV=1,20
- CALL PYEVNT
- PESUMM=PESUM
- IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
-
-C...Check conservation of energy/momentum/flavour.
- PINI(1)=0D0
- PINI(2)=0D0
- PINI(3)=PZSUM
- PINI(4)=PESUMM
- PINI(6)=PQSUM
- DO 200 J=1,4
- PFIN(J)=PYP(0,J)
- 200 CONTINUE
- PFIN(6)=PYP(0,6)
- MERR=0
- DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
- DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
- DEVQ=ABS(PFIN(6)-PINI(6))
- IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
- & DEVQ.GT.0.1D0) MERR=1
- IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
- & (PFIN(J),J=1,4),PFIN(6)
-
-C...Check that all KF codes are known ones, and that partons/particles
-C...satisfy energy-momentum-mass relation.
- DO 210 I=1,N
- IF(K(I,1).GT.20) GOTO 210
- IF(PYCOMP(K(I,2)).EQ.0) THEN
- WRITE(MSTU(11),5100) I
- MERR=MERR+1
- ENDIF
- PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
- & SIGN(1D0,P(I,5))
- IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
- & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
- WRITE(MSTU(11),5200) I
- MERR=MERR+1
- ENDIF
- 210 CONTINUE
-
-C...Listing of erroneous events, and first event of each type.
- IF(MERR.GE.1) NERR=NERR+1
- IF(NERR.GE.10) THEN
- WRITE(MSTU(11),6300)
- CALL PYLIST(1)
- CALL PYSTOP(9)
- ENDIF
- IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
- IF(MERR.GE.1) WRITE(MSTU(11),6400)
- CALL PYLIST(1)
- ENDIF
- 220 CONTINUE
-
-C...List statistics for each process type.
- IF(MTEST.GE.1) CALL PYSTAT(1)
- 230 CONTINUE
-
-C...Summarize result of run.
- IF(NERR.EQ.0) WRITE(MSTU(11),6500)
- IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
-
-C...Format statements for output.
- 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
- &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
- &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
- &4(1X,F12.5),1X,F8.2)
- 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
- 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
- &'kinematics')
- 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
- &'wrong.'/5X,'Execution will be stopped after listing of event.')
- 6400 FORMAT(5X,'Faulty event follows:')
- 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
- 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
- &5X,'This should not have happened!')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYHEPC
-C...Converts PYTHIA event record contents to or from
-C...the standard event record commonblock.
-
- SUBROUTINE PYHEPC(MCONV)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-C...HEPEVT commonblock.
- PARAMETER (NMXHEP=4000)
- COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
- DOUBLE PRECISION PHEP,VHEP
- SAVE /HEPEVT/
-
-C...Store HEPEVT commonblock size (for interfacing issues).
- MSTU(8)=NMXHEP
-
-C...Conversion from PYTHIA to standard, the easy part.
- IF(MCONV.EQ.1) THEN
- NEVHEP=0
- IF(N.GT.NMXHEP) CALL PYERRM(8,
- & '(PYHEPC:) no more space in /HEPEVT/')
- NHEP=MIN(N,NMXHEP)
- DO 150 I=1,NHEP
- ISTHEP(I)=0
- IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
- IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
- IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
- IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
- IDHEP(I)=K(I,2)
- JMOHEP(1,I)=K(I,3)
- JMOHEP(2,I)=0
- IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
- JDAHEP(1,I)=K(I,4)
- JDAHEP(2,I)=K(I,5)
- ELSE
- JDAHEP(1,I)=0
- JDAHEP(2,I)=0
- ENDIF
- DO 100 J=1,5
- PHEP(J,I)=P(I,J)
- 100 CONTINUE
- DO 110 J=1,4
- VHEP(J,I)=V(I,J)
- 110 CONTINUE
-
-C...Check if new event (from pileup).
- IF(I.EQ.1) THEN
- INEW=1
- ELSE
- IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
- ENDIF
-
-C...Fill in missing mother information.
- IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
- IMO1=I-2
- 120 IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0)
- & THEN
- IMO1=IMO1-1
- GOTO 120
- ENDIF
- JMOHEP(1,I)=IMO1
- JMOHEP(2,I)=IMO1+1
- ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
- I1=K(I,3)-1
- 130 I1=I1+1
- IF(I1.GE.I) CALL PYERRM(8,
- & '(PYHEPC:) translation of inconsistent event history')
- IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130
- KC=PYCOMP(K(I1,2))
- IF(I1.LT.I.AND.KC.EQ.0) GOTO 130
- IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130
- JMOHEP(2,I)=I1
- ELSEIF(K(I,2).EQ.94) THEN
- NJET=2
- IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
- IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
- JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
- IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
- & MOD(K(I+1,4)/MSTU(5),MSTU(5))
- ENDIF
-
-C...Fill in missing daughter information.
- IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
- DO 140 I1=JDAHEP(1,I),JDAHEP(2,I)
- I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
- JDAHEP(1,I2)=I
- 140 CONTINUE
- ENDIF
- IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150
- I1=JMOHEP(1,I)
- IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150
- IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150
- IF(JDAHEP(1,I1).EQ.0) THEN
- JDAHEP(1,I1)=I
- ELSE
- JDAHEP(2,I1)=I
- ENDIF
- 150 CONTINUE
- DO 160 I=1,NHEP
- IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160
- IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
- 160 CONTINUE
-
-C...Conversion from standard to PYTHIA, the easy part.
- ELSE
- IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
- & '(PYHEPC:) no more space in /PYJETS/')
- N=MIN(NHEP,MSTU(4))
- NKQ=0
- KQSUM=0
- DO 190 I=1,N
- K(I,1)=0
- IF(ISTHEP(I).EQ.1) K(I,1)=1
- IF(ISTHEP(I).EQ.2) K(I,1)=11
- IF(ISTHEP(I).EQ.3) K(I,1)=21
- K(I,2)=IDHEP(I)
- K(I,3)=JMOHEP(1,I)
- K(I,4)=JDAHEP(1,I)
- K(I,5)=JDAHEP(2,I)
- DO 170 J=1,5
- P(I,J)=PHEP(J,I)
- 170 CONTINUE
- DO 180 J=1,4
- V(I,J)=VHEP(J,I)
- 180 CONTINUE
- V(I,5)=0D0
- IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
- I1=JDAHEP(1,I)
- IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
- & PHEP(5,I)/PHEP(4,I)
- ENDIF
-
-C...Fill in missing information on colour connection in jet systems.
- IF(ISTHEP(I).EQ.1) THEN
- KC=PYCOMP(K(I,2))
- KQ=0
- IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
- IF(KQ.NE.0) NKQ=NKQ+1
- IF(KQ.NE.2) KQSUM=KQSUM+KQ
- IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
- K(I,1)=2
- ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
- IF(K(I+1,2).EQ.21) K(I,1)=2
- ENDIF
- ENDIF
- 190 CONTINUE
- IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
- & '(PYHEPC:) input parton configuration not colour singlet')
- ENDIF
-
- END
-
-C*********************************************************************
-
-C...PYINIT
-C...Initializes the generation procedure; finds maxima of the
-C...differential cross-sections to be used for weighting.
-
- SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYDAT4/CHAF(500,2)
- CHARACTER CHAF*16
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
- &/PYINT1/,/PYINT2/,/PYINT5/
-C...Local arrays and character variables.
- DIMENSION ALAMIN(20),NFIN(20)
- CHARACTER*(*) FRAME,BEAM,TARGET
- CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
-
-C...Interface to PDFLIB.
- COMMON/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS
- COMMON/LW50512/QCDL4,QCDL5
- SAVE /W50511/
- SAVE /LW50512/
- DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5
- CHARACTER*20 PARM(20)
- DATA VALUE/20*0D0/,PARM/20*' '/
-
-C...Data:Lambda and n_f values for parton distributions..
- DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
- &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
- &NFIN/20*4/
- DATA CHLH/'lepton','hadron'/
-
-C...Check that BLOCK DATA PYDATA has been loaded.
- CALL PYCKBD
-
-C...Reset MINT and VINT arrays. Write headers.
- MSTI(53)=0
- DO 100 J=1,400
- MINT(J)=0
- VINT(J)=0D0
- 100 CONTINUE
- IF(MSTU(12).NE.12345) CALL PYLIST(0)
- IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
-
-C...Reset error counters.
- MSTU(23)=0
- MSTU(27)=0
- MSTU(30)=0
-
-C...Reset processes that should not be on.
- MSUB(96)=0
- MSUB(97)=0
-
-C...Select global FSR/ISR/UE parameter set = 'tune'
-C...See routine PYTUNE for details
- IF (MSTP(5).NE.0) THEN
- MSTP5=MSTP(5)
- CALL PYTUNE(MSTP5)
- ENDIF
-
-C...Call user process initialization routine.
- IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
- MSEL=0
- CALL UPINIT
- MSEL=0
- ENDIF
-
-C...Maximum 4 generations; set maximum number of allowed flavours.
- MSTP(1)=MIN(4,MSTP(1))
- MSTU(114)=MIN(MSTU(114),2*MSTP(1))
- MSTP(58)=MIN(MSTP(58),2*MSTP(1))
-
-C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
- DO 120 I=-20,20
- VINT(180+I)=0D0
- IA=IABS(I)
- IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
- DO 110 J=1,MSTP(1)
- IB=2*J-1+MOD(IA,2)
- IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
- IPM=(5-ISIGN(1,I))/2
- IDC=J+MDCY(IA,2)+2
- IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
- & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
- 110 CONTINUE
- ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
- VINT(180+I)=1D0
- ENDIF
- 120 CONTINUE
-
-C...Initialize parton distributions: PDFLIB.
- IF(MSTP(52).EQ.2) THEN
- PARM(1)='NPTYPE'
- VALUE(1)=1
- PARM(2)='NGROUP'
- VALUE(2)=MSTP(51)/1000
- PARM(3)='NSET'
- VALUE(3)=MOD(MSTP(51),1000)
- PARM(4)='TMAS'
- VALUE(4)=PMAS(6,1)
- CALL PDFSET_ALICE(PARM,VALUE)
- MINT(93)=1000000+MSTP(51)
- ENDIF
-
-C...Choose Lambda value to use in alpha-strong.
- MSTU(111)=MSTP(2)
- IF(MSTP(3).GE.2) THEN
- ALAM=0.2D0
- NF=4
- IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
- ALAM=ALAMIN(MSTP(51))
- NF=NFIN(MSTP(51))
- ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
- ALAM=QCDL5
- NF=5
- ELSEIF(MSTP(52).EQ.2) THEN
- ALAM=QCDL4
- NF=4
- ENDIF
- PARP(1)=ALAM
- PARP(61)=ALAM
- PARP(72)=ALAM
- PARU(112)=ALAM
- MSTU(112)=NF
- IF(MSTP(3).EQ.3) PARJ(81)=ALAM
- ENDIF
-
-C...Initialize the SUSY generation: couplings, masses,
-C...decay modes, branching ratios, and so on.
- CALL PYMSIN
-C...Initialize widths and partial widths for resonances.
- CALL PYINRE
-C...Set Z0 mass and width for e+e- routines.
- PARJ(123)=PMAS(23,1)
- PARJ(124)=PMAS(23,2)
-
-C...Identify beam and target particles and frame of process.
- CHFRAM=FRAME//' '
- CHBEAM=BEAM//' '
- CHTARG=TARGET//' '
- CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
- IF(MINT(65).EQ.1) GOTO 170
-
-C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
-C...For e-gamma allow 2 alternatives.
- MINT(121)=1
- IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
- IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
- & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
- IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
- IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
- & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
- ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
- IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
- & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
- IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
- ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
- IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
- & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
- IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
- ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
- IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
- & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
- IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
- ENDIF
- MINT(123)=MSTP(14)
- IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
- &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
- IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
- IF(MSTP(14).EQ.11) MINT(123)=0
- IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
- IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
- IF(MSTP(14).EQ.15) MINT(123)=2
- IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
- IF(MSTP(14).EQ.19) MINT(123)=3
- ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
- IF(MSTP(14).EQ.21) MINT(123)=0
- IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
- IF(MSTP(14).EQ.24) MINT(123)=1
- ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
- IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
- IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
- ENDIF
-
-C...Set up kinematics of process.
- CALL PYINKI(0)
-
-C...Set up kinematics for photons inside leptons.
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
-
-C...Precalculate flavour selection weights.
- CALL PYKFIN
-
-C...Loop over gamma-p or gamma-gamma alternatives.
- CKIN3=CKIN(3)
- MSAV48=0
- DO 160 IGA=1,MINT(121)
- CKIN(3)=CKIN3
- MINT(122)=IGA
-
-C...Select partonic subprocesses to be included in the simulation.
- CALL PYINPR
- MINT(101)=1
- MINT(102)=1
- MINT(103)=MINT(11)
- MINT(104)=MINT(12)
-
-C...Count number of subprocesses on.
- MINT(48)=0
- DO 130 ISUB=1,500
- IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
- & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
- MSUB(ISUB)=0
- ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
- & MSUB(ISUB).EQ.1) THEN
- WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
- CALL PYSTOP(1)
- ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
- WRITE(MSTU(11),5300) ISUB
- CALL PYSTOP(1)
- ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
- WRITE(MSTU(11),5400) ISUB
- CALL PYSTOP(1)
- ELSEIF(MSUB(ISUB).EQ.1) THEN
- MINT(48)=MINT(48)+1
- ENDIF
- 130 CONTINUE
-
-C...Stop or raise warning flag if no subprocesses on.
- IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
- IF(MSTP(127).NE.1) THEN
- WRITE(MSTU(11),5500)
- CALL PYSTOP(1)
- ELSE
- WRITE(MSTU(11),5700)
- MSTI(53)=1
- ENDIF
- ENDIF
- MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
- MSAV48=MSAV48+MINT(48)
-
-C...Reset variables for cross-section calculation.
- DO 150 I=0,500
- DO 140 J=1,3
- NGEN(I,J)=0
- XSEC(I,J)=0D0
- 140 CONTINUE
- 150 CONTINUE
-
-C...Find parametrized total cross-sections.
- CALL PYXTOT
- VINT(318)=VINT(317)
-
-C...Maxima of differential cross-sections.
- IF(MSTP(121).LE.1) CALL PYMAXI
-
-C...Initialize possibility of pileup events.
- IF(MINT(121).GT.1) MSTP(131)=0
- IF(MSTP(131).NE.0) CALL PYPILE(1)
-
-C...Initialize multiple interactions with variable impact parameter.
- IF(MINT(50).EQ.1) THEN
- PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
- IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
- & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
- IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
- MINT(35)=1
- CALL PYMULT(1)
- MINT(35)=3
- CALL PYMIGN(1)
- ENDIF
- ENDIF
-
-C...Save results for gamma-p and gamma-gamma alternatives.
- IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
- 160 CONTINUE
-
-C...Initialization finished.
- IF(MSAV48.EQ.0) THEN
- IF(MSTP(127).NE.1) THEN
- WRITE(MSTU(11),5500)
- CALL PYSTOP(1)
- ELSE
- WRITE(MSTU(11),5700)
- MSTI(53)=1
- ENDIF
- ENDIF
- 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
-
-C...Formats for initialization information.
- 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
- &'routines',1X,17('*'))
- 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
- &'-',A6,' interactions.'/1X,'Execution stopped!')
- 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
- &1X,'Execution stopped!')
- 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
- &1X,'Execution stopped!')
- 5500 FORMAT(1X,'Error: no subprocess switched on.'/
- &1X,'Execution stopped.')
- 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
- &22('*'))
- 5700 FORMAT(1X,'Error: no subprocess switched on.'/
- &1X,'Execution will stop if you try to generate events.')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYEVNT
-C...Administers the generation of a high-pT event via calls to
-C...a number of subroutines.
-
- SUBROUTINE PYEVNT
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYCTAG/NCT,MCT(4000,2)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/,
- &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/
-C...Local array.
- DIMENSION VTX(4)
-
-C...Optionally let PYEVNW do the whole job.
- IF(MSTP(81).GE.20) THEN
- CALL PYEVNW
- RETURN
- ENDIF
-
-C...Stop if no subprocesses on.
- IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
- WRITE(MSTU(11),5100)
- CALL PYSTOP(1)
- ENDIF
-
-C...Initial values for some counters.
- MSTU(1)=0
- MSTU(2)=0
- N=0
- MINT(5)=MINT(5)+1
- MINT(7)=0
- MINT(8)=0
- MINT(30)=0
- MINT(83)=0
- MINT(84)=MSTP(126)
- MSTU(24)=0
- MSTU70=0
- MSTJ14=MSTJ(14)
-C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
- NCT=0
- MINT(33)=0
-
-C...Let called routines know call is from PYEVNT (not PYEVNW).
- MINT(35)=1
- IF (MSTP(81).GE.10) MINT(35)=2
-
-C...If variable energies: redo incoming kinematics and cross-section.
- MSTI(61)=0
- IF(MSTP(171).EQ.1) THEN
- CALL PYINKI(1)
- IF(MSTI(61).EQ.1) THEN
- MINT(5)=MINT(5)-1
- RETURN
- ENDIF
- IF(MINT(121).GT.1) CALL PYSAVE(3,1)
- CALL PYXTOT
- ENDIF
-
-C...Loop over number of pileup events; check space left.
- IF(MSTP(131).LE.0) THEN
- NPILE=1
- ELSE
- CALL PYPILE(2)
- NPILE=MINT(81)
- ENDIF
- DO 270 IPILE=1,NPILE
- IF(MINT(84)+100.GE.MSTU(4)) THEN
- CALL PYERRM(11,
- & '(PYEVNT:) no more space in PYJETS for pileup events')
- IF(MSTU(21).GE.1) GOTO 280
- ENDIF
- MINT(82)=IPILE
-
-C...Generate variables of hard scattering.
- MINT(51)=0
- MSTI(52)=0
- 100 CONTINUE
- IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
- MINT(31)=0
- MINT(39)=0
- MINT(51)=0
- MINT(57)=0
- CALL PYRAND
- IF(MSTI(61).EQ.1) THEN
- MINT(5)=MINT(5)-1
- RETURN
- ENDIF
- IF(MINT(51).EQ.2) RETURN
- ISUB=MINT(1)
- IF(MSTP(111).EQ.-1) GOTO 260
-
-C...Loopback point if PYPREP fails, especially for junction topologies.
- NPREP=0
- MNT31S=MINT(31)
- 110 NPREP=NPREP+1
- MINT(31)=MNT31S
-
- IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
-C...Hard scattering (including low-pT):
-C...reconstruct kinematics and colour flow of hard scattering.
- MINT31=MINT(31)
- 120 MINT(31)=MINT31
- MINT(51)=0
- CALL PYSCAT
- IF(MINT(51).EQ.1) GOTO 100
- IPU1=MINT(84)+1
- IPU2=MINT(84)+2
- IF(ISUB.EQ.95) GOTO 140
-
-C...Reset statistics on activity in event.
- DO 130 J=351,359
- MINT(J)=0
- VINT(J)=0D0
- 130 CONTINUE
-
-C...Showering of initial state partons (optional).
- NFIN=N
- ALAMSV=PARJ(81)
- PARJ(81)=PARP(72)
- IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
- & CALL PYSSPA(IPU1,IPU2)
- PARJ(81)=ALAMSV
- IF(MINT(51).EQ.1) GOTO 100
-
-C...Showering of final state partons (optional).
- ALAMSV=PARJ(81)
- PARJ(81)=PARP(72)
- IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
- & THEN
- IPU3=MINT(84)+3
- IPU4=MINT(84)+4
- IF(ISET(ISUB).EQ.5) IPU4=-3
- QMAX=VINT(55)
- IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
- if(parj(200).eq.1.) then
- CALL PYSHOWQ(IPU3,IPU4,QMAX)
-
- else
- CALL PYSHOW(IPU3,IPU4,QMAX)
- endif
- ELSEIF(ISET(ISUB).EQ.11) THEN
- CALL PYADSH(NFIN)
- ENDIF
- PARJ(81)=ALAMSV
-
-C...Allow possibility for user to abort event generation.
- IVETO=0
- IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
- IF(IVETO.EQ.1) GOTO 100
-
-C...Decay of final state resonances.
- MINT(32)=0
- IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
- IF(MINT(51).EQ.1) GOTO 100
- MINT(52)=N
-
-
-C...Multiple interactions - PYTHIA 6.3 intermediate style.
- 140 IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
- IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
- CALL PYMIGN(6)
- IF(MINT(51).EQ.1) GOTO 100
- MINT(53)=N
-
-C...Beam remnant flavour and colour assignments - new scheme.
- CALL PYMIHK
- IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
- & GOTO 120
- IF(MINT(51).EQ.1) GOTO 100
-
-C...Primordial kT and beam remnant momentum sharing - new scheme.
- CALL PYMIRM
- IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
- & GOTO 120
- IF(MINT(51).EQ.1) GOTO 100
- IF(ISUB.EQ.95) MINT(31)=MINT(31)-1
-
-C...Multiple interactions - PYTHIA 6.2 style.
- ELSEIF(MINT(111).NE.12) THEN
- IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
- CALL PYMULT(6)
- MINT(53)=N
- ENDIF
-
-C...Hadron remnants and primordial kT.
- CALL PYREMN(IPU1,IPU2)
- IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
- & 110
- IF(MINT(51).EQ.1) GOTO 100
- ENDIF
-
- ELSEIF(ISUB.NE.99) THEN
-C...Diffractive and elastic scattering.
- CALL PYDIFF
-
- ELSE
-C...DIS scattering (photon flux external).
- CALL PYDISG
- IF(MINT(51).EQ.1) GOTO 100
- ENDIF
-
-C...Check that no odd resonance left undecayed.
- MINT(54)=N
- IF(MSTP(111).GE.1) THEN
- NFIX=N
- DO 150 I=MINT(84)+1,NFIX
- IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
- & K(I,2).NE.22) THEN
- KCA=PYCOMP(K(I,2))
- IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
- CALL PYRESD(I)
- IF(MINT(51).EQ.1) GOTO 100
- ENDIF
- ENDIF
- 150 CONTINUE
- ENDIF
-
-C...Boost hadronic subsystem to overall rest frame.
-C..(Only relevant when photon inside lepton beam.)
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
-
-C...Recalculate energies from momenta and masses (if desired).
- IF(MSTP(113).GE.1) THEN
- DO 160 I=MINT(83)+1,N
- IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
- & P(I,2)**2+P(I,3)**2+P(I,5)**2)
- 160 CONTINUE
- NRECAL=N
- ENDIF
-
-C...Colour reconnection before string formation
- IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)
-
-C...Rearrange partons along strings, check invariant mass cuts.
- MSTU(28)=0
- IF(MSTP(111).LE.0) MSTJ(14)=-1
- CALL PYPREP(MINT(84)+1)
- MSTJ(14)=MSTJ14
- IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
- MSTU(24)=0
- GOTO 100
- ENDIF
- IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
- IF (MINT(51).EQ.1) GOTO 100
- IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
- IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
- DO 190 I=MINT(84)+1,N
- IF(K(I,2).EQ.94) THEN
- DO 180 I1=I+1,MIN(N,I+10)
- IF(K(I1,3).EQ.I) THEN
- K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
- IF(K(I1,3).EQ.0) THEN
- DO 170 II=MINT(84)+1,I-1
- IF(K(II,2).EQ.K(I1,2)) THEN
- IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
- & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
- ENDIF
- 170 CONTINUE
- IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
- ENDIF
- ENDIF
- 180 CONTINUE
- ENDIF
- 190 CONTINUE
- CALL PYEDIT(12)
- CALL PYEDIT(14)
- IF(MSTP(125).EQ.0) CALL PYEDIT(15)
- IF(MSTP(125).EQ.0) MINT(4)=0
- DO 210 I=MINT(83)+1,N
- IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
- DO 200 I1=I+1,N
- IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
- IF(K(I1,3).EQ.I) K(I,5)=I1
- 200 CONTINUE
- ENDIF
- 210 CONTINUE
- ENDIF
-
-C...Introduce separators between sections in PYLIST event listing.
- IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
- MSTU70=1
- MSTU(71)=N
- ELSEIF(IPILE.EQ.1) THEN
- MSTU70=3
- MSTU(71)=2
- MSTU(72)=MINT(4)
- MSTU(73)=N
- ENDIF
-
-C...Go back to lab frame (needed for vertices, also in fragmentation).
- CALL PYFRAM(1)
-
-C...Set nonvanishing production vertex (optional).
- IF(MSTP(151).EQ.1) THEN
- DO 220 J=1,4
- VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
- & SIN(PARU(2)*PYR(0))
- 220 CONTINUE
- DO 240 I=MINT(83)+1,N
- DO 230 J=1,4
- V(I,J)=V(I,J)+VTX(J)
- 230 CONTINUE
- 240 CONTINUE
- ENDIF
-
-C...Perform hadronization (if desired).
- IF(MSTP(111).GE.1) THEN
- CALL PYEXEC
- IF(MSTU(24).NE.0) GOTO 100
- ENDIF
- IF(MSTP(113).GE.1) THEN
- DO 250 I=NRECAL,N
- IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
- & P(I,2)**2+P(I,3)**2+P(I,5)**2)
- 250 CONTINUE
- ENDIF
- IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
-
-C...Store event information and calculate Monte Carlo estimates of
-C...subprocess cross-sections.
- 260 IF(IPILE.EQ.1) CALL PYDOCU
-
-C...Set counters for current pileup event and loop to next one.
- MSTI(41)=IPILE
- IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
- IF(MSTU70.LT.10) THEN
- MSTU70=MSTU70+1
- MSTU(70+MSTU70)=N
- ENDIF
- MINT(83)=N
- MINT(84)=N+MSTP(126)
- IF(IPILE.LT.NPILE) CALL PYFRAM(2)
- 270 CONTINUE
-
-C...Generic information on pileup events. Reconstruct missing history.
- IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
- PARI(91)=VINT(132)
- PARI(92)=VINT(133)
- PARI(93)=VINT(134)
- IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
- ENDIF
- CALL PYEDIT(16)
-
-C...Transform to the desired coordinate frame.
- 280 CALL PYFRAM(MSTP(124))
- MSTU(70)=MSTU70
- PARU(21)=VINT(1)
-
-C...Error messages
- 5100 FORMAT(1X,'Error: no subprocess switched on.'/
- &1X,'Execution stopped.')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYEVNW
-C...Administers the generation of a high-pT event via calls to
-C...a number of subroutines for the new multiple interactions and
-C...showering framework.
-
- SUBROUTINE PYEVNW
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYCTAG/NCT,MCT(4000,2)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
- & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
- & XMI(2,240),PT2MI(240),IMISEP(0:240)
- SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
- & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
-C...Local arrays.
- DIMENSION VTX(4)
-
-C...Stop if no subprocesses on.
- IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
- WRITE(MSTU(11),5100)
- CALL PYSTOP(1)
- ENDIF
-
-C...Initial values for some counters.
- MSTU(1)=0
- MSTU(2)=0
- N=0
- MINT(5)=MINT(5)+1
- MINT(7)=0
- MINT(8)=0
- MINT(30)=0
- MINT(83)=0
- MINT(84)=MSTP(126)
- MSTU(24)=0
- MSTU70=0
- MSTJ14=MSTJ(14)
-C...Normally, use K(I,4:5) colour info rather than /PYCT/.
- NCT=0
- MINT(33)=0
-
-C...Let called routines know call is from PYEVNW (not PYEVNT).
- MINT(35)=3
-
-C...If variable energies: redo incoming kinematics and cross-section.
- MSTI(61)=0
- IF(MSTP(171).EQ.1) THEN
- CALL PYINKI(1)
- IF(MSTI(61).EQ.1) THEN
- MINT(5)=MINT(5)-1
- RETURN
- ENDIF
- IF(MINT(121).GT.1) CALL PYSAVE(3,1)
- CALL PYXTOT
- ENDIF
-
-C...Loop over number of pileup events; check space left.
- IF(MSTP(131).LE.0) THEN
- NPILE=1
- ELSE
- CALL PYPILE(2)
- NPILE=MINT(81)
- ENDIF
- DO 300 IPILE=1,NPILE
- IF(MINT(84)+100.GE.MSTU(4)) THEN
- CALL PYERRM(11,
- & '(PYEVNW:) no more space in PYJETS for pileup events')
- IF(MSTU(21).GE.1) GOTO 310
- ENDIF
- MINT(82)=IPILE
-
-C...Generate variables of hard scattering.
- MINT(51)=0
- MSTI(52)=0
- 100 CONTINUE
- IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
- MINT(31)=0
- MINT(39)=0
- MINT(36)=0
- MINT(51)=0
- MINT(57)=0
- CALL PYRAND
- IF(MSTI(61).EQ.1) THEN
- MINT(5)=MINT(5)-1
- RETURN
- ENDIF
- IF(MINT(51).EQ.2) RETURN
- ISUB=MINT(1)
- IF(MSTP(111).EQ.-1) GOTO 290
-
-C...Loopback point if PYPREP fails, especially for junction topologies.
- NPREP=0
- MNT31S=MINT(31)
- 110 NPREP=NPREP+1
- MINT(31)=MNT31S
-
- IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
-C...Hard scattering (including low-pT):
-C...reconstruct kinematics and colour flow of hard scattering.
- MINT31=MINT(31)
- 120 MINT(31)=MINT31
- MINT(51)=0
- CALL PYSCAT
- IF(MINT(51).EQ.1) GOTO 100
- NPARTD=N
- NFIN=N
-
-C...Intertwined initial state showers and multiple interactions.
-C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
-C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
- MSTP61=MSTP(61)
- IF (MINT(47).LT.2) MSTP(61)=0
- MSTP81=MSTP(81)
- IF (MINT(50).EQ.0) MSTP(81)=0
- IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
- & MINT(111).NE.12) THEN
-C...Absolute max pT2 scale for evolution: phase space limit.
- PT2MXS=0.25D0*VINT(2)
-C...Check if more constrained by ISR and MI max scales:
- PT2MXS=MIN(PT2MXS,MAX(VINT(56),VINT(62)))
-C...Loopback point in case of failure in evolution.
- LOOP=0
- 130 LOOP=LOOP+1
- MINT(51)=0
- IF(LOOP.GT.100) THEN
- CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
- & //'multiple interactions.')
- MINT(51)=1
- RETURN
- ENDIF
-
-C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
-C...once per event. (E.g. compute constants and save variables to be
-C...restored later in case of failure.)
- IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
-
-C...Initialize interleaved MI/ISR/JI evolution.
-C...PT2MAX: absolute upper limit for evolution - Initialization may
-C... return a PT2MAX which is lower than this.
-C...PT2MIN: absolute lower limit for evolution - Initialization may
-C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
- PT2MAX=PT2MXS
- PT2MIN=0D0
- CALL PYEVOL(0,PT2MAX,PT2MIN)
- IF (MINT(51).EQ.1) GOTO 130
-
-C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
-C...In principle factorized, so can be stopped and restarted.
-C...Example: stop/start at pT=10 GeV. (Commented out for now.)
-C PT2MED=MAX(10D0**2,PT2MIN)
-C CALL PYEVOL(1,PT2MAX,PT2MED)
-C IF (MINT(51).EQ.1) GOTO 160
-C PT2MAX=PT2MED
- CALL PYEVOL(1,PT2MAX,PT2MIN)
- IF (MINT(51).EQ.1) GOTO 130
-
-C...Finalize interleaved MI/ISR/JI evolution.
- CALL PYEVOL(2,PT2MAX,PT2MIN)
- IF (MINT(51).EQ.1) GOTO 130
-
- ENDIF
- MSTP(61)=MSTP61
- MSTP(81)=MSTP81
- IF(MINT(51).EQ.1) GOTO 100
-C...(MINT(52) is actually obsolete in this routine. Set anyway
-C...to ensure PYDOCU stable.)
- MINT(52)=N
- MINT(53)=N
-
-C...Beam remnants - new scheme.
- 140 IF(MINT(50).EQ.1) THEN
- IF (ISUB.EQ.95) MINT(31)=1
-
-C...Beam remnant flavour and colour assignments - new scheme.
- CALL PYMIHK
- IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
- & GOTO 120
- IF(MINT(51).EQ.1) GOTO 100
-
-C...Primordial kT and beam remnant momentum sharing - new scheme.
- CALL PYMIRM
- IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
- & GOTO 120
- IF(MINT(51).EQ.1) GOTO 100
- IF (ISUB.EQ.95) MINT(31)=0
- ELSEIF(MINT(111).NE.12) THEN
-C...Hadron remnants and primordial kT - old model.
-C...Happens e.g. for direct photon on one side.
- IPU1=IMI(1,1,1)
- IPU2=IMI(2,1,1)
- CALL PYREMN(IPU1,IPU2)
- IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
- & 110
- IF(MINT(51).EQ.1) GOTO 100
-C...PYREMN does not set colour tags for BRs, so needs to be done now.
- DO 160 I=MINT(53)+1,N
- DO 150 KCS=4,5
- IDA=MOD(K(I,KCS),MSTU(5))
- IF (IDA.NE.0) THEN
- MCT(I,KCS-3)=MCT(IDA,6-KCS)
- ELSE
- MCT(I,KCS-3)=0
- ENDIF
- 150 CONTINUE
- 160 CONTINUE
-C...Instruct PYPREP to use colour tags
- MINT(33)=1
-
- DO 360 MQGST=1,2
- DO 350 I=MINT(84)+1,N
-
-C...Look for coloured string endpoint, or (later) leftover gluon.
- IF (K(I,1).NE.3) GOTO 350
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0) GOTO 350
- KQ=KCHG(KC,2)
- IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
-
-C... Pick up loose string end with no previous tag.
- KCS=4
- IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
- IF(MCT(I,KCS-3).NE.0) GOTO 350
-
- CALL PYCTTR(I,KCS,I)
- IF(MINT(51).NE.0) RETURN
-
- 350 CONTINUE
- 360 CONTINUE
-C...Now delete any colour processing information if set (since partons
-C...otherwise not FS showered!)
- DO 170 I=MINT(84)+1,N
- IF (I.LE.N) THEN
- K(I,4)=MOD(K(I,4),MSTU(5)**2)
- K(I,5)=MOD(K(I,5),MSTU(5)**2)
- ENDIF
- 170 CONTINUE
- ENDIF
-
-C...Showering of final state partons (optional).
- ALAMSV=PARJ(81)
- PARJ(81)=PARP(72)
- IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
- & THEN
- QMAX=VINT(55)
- IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
- CALL PYPTFS(1,QMAX,0D0,PTGEN)
-C...External processes: handle successive showers.
- ELSEIF(ISET(ISUB).EQ.11) THEN
- CALL PYADSH(NFIN)
- ENDIF
- PARJ(81)=ALAMSV
-
-C...Allow possibility for user to abort event generation.
- IVETO=0
- IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
- IF(IVETO.EQ.1) GOTO 100
-
-
-C...Decay of final state resonances.
- MINT(32)=0
- IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
- CALL PYRESD(0)
- IF(MINT(51).NE.0) GOTO 100
- ENDIF
-
- IF(MINT(51).EQ.1) GOTO 100
-
- ELSEIF(ISUB.NE.99) THEN
-C...Diffractive and elastic scattering.
- CALL PYDIFF
-
- ELSE
-C...DIS scattering (photon flux external).
- CALL PYDISG
- IF(MINT(51).EQ.1) GOTO 100
- ENDIF
-
-C...Check that no odd resonance left undecayed.
- MINT(54)=N
- IF(MSTP(111).GE.1) THEN
- NFIX=N
- DO 180 I=MINT(84)+1,NFIX
- IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
- & K(I,2).NE.22) THEN
- KCA=PYCOMP(K(I,2))
- IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
- CALL PYRESD(I)
- IF(MINT(51).EQ.1) GOTO 100
- ENDIF
- ENDIF
- 180 CONTINUE
- ENDIF
-
-C...Boost hadronic subsystem to overall rest frame.
-C..(Only relevant when photon inside lepton beam.)
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
-
-C...Recalculate energies from momenta and masses (if desired).
- IF(MSTP(113).GE.1) THEN
- DO 190 I=MINT(83)+1,N
- IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
- & P(I,2)**2+P(I,3)**2+P(I,5)**2)
- 190 CONTINUE
- NRECAL=N
- ENDIF
-
-C...Colour reconnection before string formation
- CALL PYFSCR(MINT(84)+1)
-
-C...Rearrange partons along strings, check invariant mass cuts.
- MSTU(28)=0
- IF(MSTP(111).LE.0) MSTJ(14)=-1
- CALL PYPREP(MINT(84)+1)
- MSTJ(14)=MSTJ14
- IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
- MSTU(24)=0
- GOTO 100
- ENDIF
- IF(MINT(51).EQ.1) GOTO 110
- IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
- IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
- DO 220 I=MINT(84)+1,N
- IF(K(I,2).EQ.94) THEN
- DO 210 I1=I+1,MIN(N,I+10)
- IF(K(I1,3).EQ.I) THEN
- K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
- IF(K(I1,3).EQ.0) THEN
- DO 200 II=MINT(84)+1,I-1
- IF(K(II,2).EQ.K(I1,2)) THEN
- IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
- & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
- ENDIF
- 200 CONTINUE
- IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
- ENDIF
- ENDIF
- 210 CONTINUE
- ENDIF
- 220 CONTINUE
- CALL PYEDIT(12)
- CALL PYEDIT(14)
- IF(MSTP(125).EQ.0) CALL PYEDIT(15)
- IF(MSTP(125).EQ.0) MINT(4)=0
- DO 240 I=MINT(83)+1,N
- IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
- DO 230 I1=I+1,N
- IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
- IF(K(I1,3).EQ.I) K(I,5)=I1
- 230 CONTINUE
- ENDIF
- 240 CONTINUE
- ENDIF
-
-C...Introduce separators between sections in PYLIST event listing.
- IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
- MSTU70=1
- MSTU(71)=N
- ELSEIF(IPILE.EQ.1) THEN
- MSTU70=3
- MSTU(71)=2
- MSTU(72)=MINT(4)
- MSTU(73)=N
- ENDIF
-
-C...Go back to lab frame (needed for vertices, also in fragmentation).
- CALL PYFRAM(1)
-
-C...Set nonvanishing production vertex (optional).
- IF(MSTP(151).EQ.1) THEN
- DO 250 J=1,4
- VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
- & SIN(PARU(2)*PYR(0))
- 250 CONTINUE
- DO 270 I=MINT(83)+1,N
- DO 260 J=1,4
- V(I,J)=V(I,J)+VTX(J)
- 260 CONTINUE
- 270 CONTINUE
- ENDIF
-
-C...Perform hadronization (if desired).
- IF(MSTP(111).GE.1) THEN
- CALL PYEXEC
- IF(MSTU(24).NE.0) GOTO 100
- ENDIF
- IF(MSTP(113).GE.1) THEN
- DO 280 I=NRECAL,N
- IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
- & P(I,2)**2+P(I,3)**2+P(I,5)**2)
- 280 CONTINUE
- ENDIF
- IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
-
-C...Store event information and calculate Monte Carlo estimates of
-C...subprocess cross-sections.
- 290 IF(IPILE.EQ.1) CALL PYDOCU
-
-C...Set counters for current pileup event and loop to next one.
- MSTI(41)=IPILE
- IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
- IF(MSTU70.LT.10) THEN
- MSTU70=MSTU70+1
- MSTU(70+MSTU70)=N
- ENDIF
- MINT(83)=N
- MINT(84)=N+MSTP(126)
- IF(IPILE.LT.NPILE) CALL PYFRAM(2)
- 300 CONTINUE
-
-C...Generic information on pileup events. Reconstruct missing history.
- IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
- PARI(91)=VINT(132)
- PARI(92)=VINT(133)
- PARI(93)=VINT(134)
- IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
- ENDIF
- CALL PYEDIT(16)
-
-C...Transform to the desired coordinate frame.
- 310 CALL PYFRAM(MSTP(124))
- MSTU(70)=MSTU70
- PARU(21)=VINT(1)
-
-C...Error messages
- 5100 FORMAT(1X,'Error: no subprocess switched on.'/
- &1X,'Execution stopped.')
-
- RETURN
- END
-
-
-C***********************************************************************
-
-C...PYSTAT
-C...Prints out information about cross-sections, decay widths, branching
-C...ratios, kinematical limits, status codes and parameter values.
-
- SUBROUTINE PYSTAT(MSTAT)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
- PARAMETER (EPS=1D-3)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- COMMON/PYINT6/PROC(0:500)
- CHARACTER PROC*28, CHTMP*16
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
- &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
-C...Local arrays, character variables and data.
- DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
- CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
- &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
- &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
- CHARACTER*24 CHD0, CHDC(10)
- CHARACTER*6 DNAME(3)
- DATA PROGA/
- &'VMD/hadron * VMD ','VMD/hadron * direct ',
- &'VMD/hadron * anomalous ','direct * direct ',
- &'direct * anomalous ','anomalous * anomalous '/
- DATA DISGA/'e * VMD','e * anomalous'/
- DATA PROGG9/
- &'direct * direct ','direct * VMD ',
- &'direct * anomalous ','VMD * direct ',
- &'VMD * VMD ','VMD * anomalous ',
- &'anomalous * direct ','anomalous * VMD ',
- &'anomalous * anomalous ','DIS * VMD ',
- &'DIS * anomalous ','VMD * DIS ',
- &'anomalous * DIS '/
- DATA PROGG4/
- &'direct * direct ','direct * resolved ',
- &'resolved * direct ','resolved * resolved '/
- DATA PROGG2/
- &'direct * hadron ','resolved * hadron '/
- DATA PROGP4/
- &'VMD * hadron ','direct * hadron ',
- &'anomalous * hadron ','DIS * hadron '/
- DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
- &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
- &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
- &' y*_small ',' eta*_large ',' eta*_small ',
- &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
- &' x_2 ',' x_F ',' cos(theta_hard) ',
- &'m''_hard (GeV/c^2) ',' tau ',' y* ',
- &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
- &' tau'' '/
- DATA DNAME /'q ','lepton','nu '/
-
-C...Cross-sections.
- IF(MSTAT.LE.1) THEN
- IF(MINT(121).GT.1) CALL PYSAVE(5,0)
- WRITE(MSTU(11),5000)
- WRITE(MSTU(11),5100)
- WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
- DO 100 I=1,500
- IF(MSUB(I).NE.1) GOTO 100
- WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
- 100 CONTINUE
- IF(MINT(121).GT.1) THEN
- WRITE(MSTU(11),5300)
- DO 110 IGA=1,MINT(121)
- CALL PYSAVE(3,IGA)
- IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
- WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
- & XSEC(0,3)
- ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
- WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
- & XSEC(0,3)
- ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
- WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
- & XSEC(0,3)
- ELSEIF(MINT(121).EQ.4) THEN
- WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
- & XSEC(0,3)
- ELSEIF(MINT(121).EQ.2) THEN
- WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
- & XSEC(0,3)
- ELSE
- WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
- & XSEC(0,3)
- ENDIF
- 110 CONTINUE
- CALL PYSAVE(5,0)
- ENDIF
- WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
- & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
-
-C...Decay widths and branching ratios.
- ELSEIF(MSTAT.EQ.2) THEN
- WRITE(MSTU(11),5500)
- WRITE(MSTU(11),5600)
- DO 140 KC=1,500
- KF=KCHG(KC,4)
- CALL PYNAME(KF,CHKF)
- IOFF=0
- IF(KC.LE.22) THEN
- IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
- IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
- IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
- IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
- IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
- ELSE
- IF(MWID(KC).LE.0) GOTO 140
- IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
- & KF/KSUSY1.EQ.2)) GOTO 140
- ENDIF
-C...Off-shell branchings.
- IF(IOFF.EQ.1) THEN
- NGP=0
- IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
- IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
- & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
- DO 120 J=1,MDCY(KC,3)
- IDC=J+MDCY(KC,2)-1
- NGP1=0
- IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
- & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
- NGP2=0
- IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
- & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
- CALL PYNAME(KFDP(IDC,1),CHD1)
- CALL PYNAME(KFDP(IDC,2),CHD2)
- IF(KFDP(IDC,3).EQ.0) THEN
- IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
- & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
- & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
- ELSE
- CALL PYNAME(KFDP(IDC,3),CHD3)
- IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
- & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
- & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
- ENDIF
- 120 CONTINUE
-C...On-shell decays.
- ELSE
- CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
- BRFIN=1D0
- IF(WDTE(0,0).LE.0D0) BRFIN=0D0
- WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
- & STATE(MDCY(KC,1)),BRFIN
- DO 130 J=1,MDCY(KC,3)
- IDC=J+MDCY(KC,2)-1
- NGP1=0
- IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
- & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
- NGP2=0
- IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
- & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
- BRPRI=0D0
- IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
- BRFIN=0D0
- IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
- CALL PYNAME(KFDP(IDC,1),CHD1)
- CALL PYNAME(KFDP(IDC,2),CHD2)
- IF(KFDP(IDC,3).EQ.0) THEN
- IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
- & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
- & CHD2(1:10),WDTP(J),BRPRI,
- & STATE(MDME(IDC,1)),BRFIN
- ELSE
- CALL PYNAME(KFDP(IDC,3),CHD3)
- IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
- & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
- & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
- & STATE(MDME(IDC,1)),BRFIN
- ENDIF
- 130 CONTINUE
- ENDIF
- 140 CONTINUE
- WRITE(MSTU(11),6000)
-
-C...Allowed incoming partons/particles at hard interaction.
- ELSEIF(MSTAT.EQ.3) THEN
- WRITE(MSTU(11),6100)
- CALL PYNAME(MINT(11),CHAU)
- CHIN(1)=CHAU(1:12)
- CALL PYNAME(MINT(12),CHAU)
- CHIN(2)=CHAU(1:12)
- WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
- DO 150 I=-20,22
- IF(I.EQ.0) GOTO 150
- IA=IABS(I)
- IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
- IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
- CALL PYNAME(I,CHAU)
- WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
- & STATE(KFIN(2,I))
- 150 CONTINUE
- WRITE(MSTU(11),6400)
-
-C...User-defined limits on kinematical variables.
- ELSEIF(MSTAT.EQ.4) THEN
- WRITE(MSTU(11),6500)
- WRITE(MSTU(11),6600)
- SHRMAX=CKIN(2)
- IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
- WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
- PTHMIN=MAX(CKIN(3),CKIN(5))
- PTHMAX=CKIN(4)
- IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
- WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
- WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
- DO 160 I=4,14
- WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
- 160 CONTINUE
- SPRMAX=CKIN(32)
- IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
- WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
- WRITE(MSTU(11),7000)
-
-C...Status codes and parameter values.
- ELSEIF(MSTAT.EQ.5) THEN
- WRITE(MSTU(11),7100)
- WRITE(MSTU(11),7200)
- DO 170 I=1,100
- WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
- & PARP(100+I)
- 170 CONTINUE
-
-C...List of all processes implemented in the program.
- ELSEIF(MSTAT.EQ.6) THEN
- WRITE(MSTU(11),7400)
- WRITE(MSTU(11),7500)
- DO 180 I=1,500
- IF(ISET(I).LT.0) GOTO 180
- WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
- 180 CONTINUE
- WRITE(MSTU(11),7700)
-
- ELSEIF(MSTAT.EQ.7) THEN
- WRITE (MSTU(11),8000)
- NMODES(0)=0
- NMODES(10)=0
- NMODES(9)=0
- DO 290 ILR=1,2
- DO 280 KFSM=1,16
- KFSUSY=ILR*KSUSY1+KFSM
- NRVDC=0
-C...SDOWN DECAYS
- IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
- NRVDC=3
- DO 190 I=1,NRVDC
- PBRAT(I)=0D0
- NMODES(I)=0
- 190 CONTINUE
- CALL PYNAME(KFSUSY,CHTMP)
- CHD0=CHTMP//' '
- CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
- CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
- CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
- KC=PYCOMP(KFSUSY)
- DO 200 J=1,MDCY(KC,3)
- IDC=J+MDCY(KC,2)-1
- ID1=IABS(KFDP(IDC,1))
- ID2=IABS(KFDP(IDC,2))
- IF (KFDP(IDC,3).EQ.0) THEN
- IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
- & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
- PBRAT(1)=PBRAT(1)+BRAT(IDC)
- NMODES(1)=NMODES(1)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
- & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
- PBRAT(2)=PBRAT(2)+BRAT(IDC)
- NMODES(2)=NMODES(2)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
- & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
- PBRAT(3)=PBRAT(3)+BRAT(IDC)
- NMODES(3)=NMODES(3)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ENDIF
- ENDIF
- 200 CONTINUE
- ENDIF
-C...SUP DECAYS
- IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
- NRVDC=2
- DO 210 I=1,NRVDC
- NMODES(I)=0
- PBRAT(I)=0D0
- 210 CONTINUE
- CALL PYNAME(KFSUSY,CHTMP)
- CHD0=CHTMP//' '
- CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
- CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
- KC=PYCOMP(KFSUSY)
- DO 220 J=1,MDCY(KC,3)
- IDC=J+MDCY(KC,2)-1
- ID1=IABS(KFDP(IDC,1))
- ID2=IABS(KFDP(IDC,2))
- IF (KFDP(IDC,3).EQ.0) THEN
- IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
- & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
- PBRAT(1)=PBRAT(1)+BRAT(IDC)
- NMODES(1)=NMODES(1)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
- & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
- PBRAT(2)=PBRAT(2)+BRAT(IDC)
- NMODES(2)=NMODES(2)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ENDIF
- ENDIF
- 220 CONTINUE
- ENDIF
-C...SLEPTON DECAYS
- IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
- NRVDC=2
- DO 230 I=1,NRVDC
- PBRAT(I)=0D0
- NMODES(I)=0
- 230 CONTINUE
- CALL PYNAME(KFSUSY,CHTMP)
- CHD0=CHTMP//' '
- CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
- CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
- KC=PYCOMP(KFSUSY)
- DO 240 J=1,MDCY(KC,3)
- IDC=J+MDCY(KC,2)-1
- ID1=IABS(KFDP(IDC,1))
- ID2=IABS(KFDP(IDC,2))
- IF (KFDP(IDC,3).EQ.0) THEN
- IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
- & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
- PBRAT(1)=PBRAT(1)+BRAT(IDC)
- NMODES(1)=NMODES(1)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ENDIF
- IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
- & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
- PBRAT(2)=PBRAT(2)+BRAT(IDC)
- NMODES(2)=NMODES(2)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ENDIF
- ENDIF
- 240 CONTINUE
- ENDIF
-C...SNEUTRINO DECAYS
- IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
- & THEN
- NRVDC=2
- DO 250 I=1,NRVDC
- PBRAT(I)=0D0
- NMODES(I)=0
- 250 CONTINUE
- CALL PYNAME(KFSUSY,CHTMP)
- CHD0=CHTMP//' '
- CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
- CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
- KC=PYCOMP(KFSUSY)
- DO 260 J=1,MDCY(KC,3)
- IDC=J+MDCY(KC,2)-1
- ID1=IABS(KFDP(IDC,1))
- ID2=IABS(KFDP(IDC,2))
- IF (KFDP(IDC,3).EQ.0) THEN
- IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
- & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
- PBRAT(1)=PBRAT(1)+BRAT(IDC)
- NMODES(1)=NMODES(1)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ENDIF
- IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
- & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
- NMODES(2)=NMODES(2)+1
- PBRAT(2)=PBRAT(2)+BRAT(IDC)
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ENDIF
- ENDIF
- 260 CONTINUE
- ENDIF
- IF (NRVDC.NE.0) THEN
- DO 270 I=1,NRVDC
- WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
- NMODES(0)=NMODES(0)+NMODES(I)
- 270 CONTINUE
- ENDIF
- 280 CONTINUE
- 290 CONTINUE
- DO 370 KFSM=21,37
- KFSUSY=KSUSY1+KFSM
- NRVDC=0
-C...NEUTRALINO DECAYS
- IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
- NRVDC=4
- DO 300 I=1,NRVDC
- PBRAT(I)=0D0
- NMODES(I)=0
- 300 CONTINUE
- CALL PYNAME(KFSUSY,CHTMP)
- CHD0=CHTMP//' '
- CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
- CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
- CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
- CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
- KC=PYCOMP(KFSUSY)
- DO 310 J=1,MDCY(KC,3)
- IDC=J+MDCY(KC,2)-1
- ID1=IABS(KFDP(IDC,1))
- ID2=IABS(KFDP(IDC,2))
- ID3=IABS(KFDP(IDC,3))
- IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
- & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
- & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
- PBRAT(1)=PBRAT(1)+BRAT(IDC)
- NMODES(1)=NMODES(1)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
- & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
- & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
- PBRAT(2)=PBRAT(2)+BRAT(IDC)
- NMODES(2)=NMODES(2)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
- & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
- & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
- PBRAT(3)=PBRAT(3)+BRAT(IDC)
- NMODES(3)=NMODES(3)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
- & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
- & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
- PBRAT(4)=PBRAT(4)+BRAT(IDC)
- NMODES(4)=NMODES(4)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ENDIF
- 310 CONTINUE
- ENDIF
-C...CHARGINO DECAYS
- IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
- NRVDC=5
- DO 320 I=1,NRVDC
- PBRAT(I)=0D0
- NMODES(I)=0
- 320 CONTINUE
- CALL PYNAME(KFSUSY,CHTMP)
- CHD0=CHTMP//' '
- CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
- CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
- CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
- CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
- CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
- KC=PYCOMP(KFSUSY)
- DO 330 J=1,MDCY(KC,3)
- IDC=J+MDCY(KC,2)-1
- ID1=IABS(KFDP(IDC,1))
- ID2=IABS(KFDP(IDC,2))
- ID3=IABS(KFDP(IDC,3))
- IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
- & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
- & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
- PBRAT(1)=PBRAT(1)+BRAT(IDC)
- NMODES(1)=NMODES(1)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
- & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
- & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
- PBRAT(1)=PBRAT(1)+BRAT(IDC)
- NMODES(1)=NMODES(1)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
- & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
- & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
- PBRAT(2)=PBRAT(2)+BRAT(IDC)
- NMODES(2)=NMODES(2)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
- & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
- & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
- PBRAT(3)=PBRAT(3)+BRAT(IDC)
- NMODES(3)=NMODES(3)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
- & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
- & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
- PBRAT(3)=PBRAT(3)+BRAT(IDC)
- NMODES(3)=NMODES(3)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
- & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
- & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
- PBRAT(4)=PBRAT(4)+BRAT(IDC)
- NMODES(4)=NMODES(4)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
- & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
- & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
- PBRAT(4)=PBRAT(4)+BRAT(IDC)
- NMODES(4)=NMODES(4)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
- & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
- & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
- PBRAT(5)=PBRAT(5)+BRAT(IDC)
- NMODES(5)=NMODES(5)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
- & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
- & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
- PBRAT(5)=PBRAT(5)+BRAT(IDC)
- NMODES(5)=NMODES(5)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ENDIF
- 330 CONTINUE
- ENDIF
-C...GLUINO DECAYS
- IF (KFSM.EQ.21) THEN
- NRVDC=3
- DO 340 I=1,NRVDC
- PBRAT(I)=0D0
- NMODES(I)=0
- 340 CONTINUE
- CALL PYNAME(KFSUSY,CHTMP)
- CHD0=CHTMP//' '
- CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
- CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
- CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
- KC=PYCOMP(KFSUSY)
- DO 350 J=1,MDCY(KC,3)
- IDC=J+MDCY(KC,2)-1
- ID1=IABS(KFDP(IDC,1))
- ID2=IABS(KFDP(IDC,2))
- ID3=IABS(KFDP(IDC,3))
- IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
- & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
- & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
- PBRAT(1)=PBRAT(1)+BRAT(IDC)
- NMODES(1)=NMODES(1)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
- & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
- & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
- PBRAT(2)=PBRAT(2)+BRAT(IDC)
- NMODES(2)=NMODES(2)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
- & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
- & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
- PBRAT(3)=PBRAT(3)+BRAT(IDC)
- NMODES(3)=NMODES(3)+1
- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
- ENDIF
- 350 CONTINUE
- ENDIF
-
- IF (NRVDC.NE.0) THEN
- DO 360 I=1,NRVDC
- WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
- NMODES(0)=NMODES(0)+NMODES(I)
- 360 CONTINUE
- ENDIF
- 370 CONTINUE
- WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
-
- IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
- WRITE (MSTU(11),8500)
- DO 400 IRV=1,3
- DO 390 JRV=1,3
- DO 380 KRV=1,3
- WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
- & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
- 380 CONTINUE
- 390 CONTINUE
- 400 CONTINUE
- WRITE (MSTU(11),8600)
- ENDIF
- ENDIF
-
-C...Formats for printouts.
- 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
- &'Events and Cross-sections',1X,9('*'))
- 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
- &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
- &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
- &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
- &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
- &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
- &'I',12X,'I')
- 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
- &D10.3,1X,'I')
- 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
- &1X,'I',34X,'I',28X,'I',12X,'I')
- 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
- &1X,'********* Total number of errors, excluding junctions =',
- &1X,I8,' *************'/
- &1X,'********* Total number of errors, including junctions =',
- &1X,I8,' *************'/
- &1X,'********* Total number of warnings = ',
- &1X,I8,' *************'/
- &1X,'********* Fraction of events that fail fragmentation ',
- &'cuts =',1X,F8.5,' *********'/)
- 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
- &'Ratios',1X,27('*'))
- 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
- &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
- &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
- &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
- &1X,98('='))
- 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
- &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
- &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
- 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
- &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
- &1P,D10.3,0P,1X,'I')
- 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
- &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
- &1P,D10.3,0P,1X,'I')
- 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
- 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
- &'Particles at Hard Interaction',1X,7('*'))
- 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
- &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
- &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
- &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
- &78('=')/1X,'I',38X,'I',37X,'I')
- 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
- 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
- 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
- &'Kinematical Variables',1X,12('*'))
- 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
- 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
- &16X,'I')
- 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
- &1X,'<',1X,1P,D10.3,0P,16X,'I')
- 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
- 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
- 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
- &'Parameter Values',1X,12('*'))
- 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
- &'PARP(I)'/)
- 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
- 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
- &1X,13('*'))
- 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
- &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
- &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
- 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
- 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
- 8000 FORMAT(1X/ 1X/
- & 17X,'Sums over R-Violating branching ratios',1X/ 1X
- & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
- & ,'Mother --> Sum over final state flavours',4X,'I',2X
- & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
- & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
- 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
- & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
- & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
- & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
- & /1X,70('='))
- 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
- & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
- 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
- 8500 FORMAT(1X/ 1X/
- & 1X,'R-Violating couplings',1X/ 1X /
- & 1X,55('=')/
- & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
- & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
- & ,'I',15X,'I',15X,'I',15X,'I')
- 8600 FORMAT(1X,55('='))
- 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
- & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYUPEV
-C...Administers the hard-process generation required for output to the
-C...Les Houches event record.
-
- SUBROUTINE PYUPEV
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYCTAG/NCT,MCT(4000,2)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
- &/PYINT1/,/PYINT2/,/PYINT4/
-
-C...HEPEUP for output.
- INTEGER MAXNUP
- PARAMETER (MAXNUP=500)
- INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
- DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
- COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
- &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
- &VTIMUP(MAXNUP),SPINUP(MAXNUP)
- SAVE /HEPEUP/
-
-C...Stop if no subprocesses on.
- IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
- WRITE(MSTU(11),5100)
- STOP
- ENDIF
-
-C...Special flags for hard-process generation only.
- MSTP71=MSTP(71)
- MSTP(71)=0
- MST128=MSTP(128)
- MSTP(128)=1
-
-C...Initial values for some counters.
- N=0
- MINT(5)=MINT(5)+1
- MINT(7)=0
- MINT(8)=0
- MINT(30)=0
- MINT(83)=0
- MINT(84)=MSTP(126)
- MSTU(24)=0
- MSTU70=0
- MSTJ14=MSTJ(14)
-C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
- MINT(33)=0
-
-C...If variable energies: redo incoming kinematics and cross-section.
- MSTI(61)=0
- IF(MSTP(171).EQ.1) THEN
- CALL PYINKI(1)
- IF(MSTI(61).EQ.1) THEN
- MINT(5)=MINT(5)-1
- RETURN
- ENDIF
- IF(MINT(121).GT.1) CALL PYSAVE(3,1)
- CALL PYXTOT
- ENDIF
-
-C...Do not allow pileup events.
- MINT(82)=1
-
-C...Generate variables of hard scattering.
- MINT(51)=0
- MSTI(52)=0
- 100 CONTINUE
- IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
- MINT(31)=0
- MINT(51)=0
- MINT(57)=0
- CALL PYRAND
- IF(MSTI(61).EQ.1) THEN
- MINT(5)=MINT(5)-1
- RETURN
- ENDIF
- IF(MINT(51).EQ.2) RETURN
- ISUB=MINT(1)
-
- IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
-C...Hard scattering (including low-pT):
-C...reconstruct kinematics and colour flow of hard scattering.
- MINT31=MINT(31)
- 110 MINT(31)=MINT31
- MINT(51)=0
- CALL PYSCAT
- IF(MINT(51).EQ.1) GOTO 100
- IPU1=MINT(84)+1
- IPU2=MINT(84)+2
-
-C...Decay of final state resonances.
- MINT(32)=0
- IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
- & CALL PYRESD(0)
- IF(MINT(51).EQ.1) GOTO 100
- MINT(52)=N
-
-C...Longitudinal boost of hard scattering.
- BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
- CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
-
- ELSEIF(ISUB.NE.99) THEN
-C...Diffractive and elastic scattering.
- CALL PYDIFF
-
- ELSE
-C...DIS scattering (photon flux external).
- CALL PYDISG
- IF(MINT(51).EQ.1) GOTO 100
- ENDIF
-
-C...Check that no odd resonance left undecayed.
- MINT(54)=N
- NFIX=N
- DO 120 I=MINT(84)+1,NFIX
- IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
- & K(I,2).NE.22) THEN
- KCA=PYCOMP(K(I,2))
- IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
- CALL PYRESD(I)
- IF(MINT(51).EQ.1) GOTO 100
- ENDIF
- ENDIF
- 120 CONTINUE
-
-C...Boost hadronic subsystem to overall rest frame.
-C..(Only relevant when photon inside lepton beam.)
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
-
-C...Store event information and calculate Monte Carlo estimates of
-C...subprocess cross-sections.
- 130 CALL PYDOCU
-
-C...Transform to the desired coordinate frame.
- 140 CALL PYFRAM(MSTP(124))
- MSTU(70)=MSTU70
- PARU(21)=VINT(1)
-
-C...Restore special flags for hard-process generation only.
- MSTP(71)=MSTP71
- MSTP(128)=MST128
-
-C...Trace colour tags; convert to LHA style labels.
- NCT=100
- DO 150 I=MINT(84)+1,N
- MCT(I,1)=0
- MCT(I,2)=0
- 150 CONTINUE
- DO 160 I=MINT(84)+1,N
- KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
- IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
- IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
- & THEN
- IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
- IDA=MOD(K(I,4),MSTU(5))
- IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
- & MCT(IMO,2).NE.0) THEN
- MCT(I,1)=MCT(IMO,2)
- ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
- & MCT(IMO,1).NE.0) THEN
- MCT(I,1)=MCT(IMO,1)
- ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
- & MCT(IDA,2).NE.0) THEN
- MCT(I,1)=MCT(IDA,2)
- ELSE
- NCT=NCT+1
- MCT(I,1)=NCT
- ENDIF
- ENDIF
- IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
- & THEN
- IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
- IDA=MOD(K(I,5),MSTU(5))
- IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
- & MCT(IMO,1).NE.0) THEN
- MCT(I,2)=MCT(IMO,1)
- ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
- & MCT(IMO,2).NE.0) THEN
- MCT(I,2)=MCT(IMO,2)
- ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
- & MCT(IDA,1).NE.0) THEN
- MCT(I,2)=MCT(IDA,1)
- ELSE
- NCT=NCT+1
- MCT(I,2)=NCT
- ENDIF
- ENDIF
- ENDIF
- 160 CONTINUE
-
-C...Put event in HEPEUP commonblock.
- NUP=N-MINT(84)
- IDPRUP=MINT(1)
- XWGTUP=1D0
- SCALUP=VINT(53)
- AQEDUP=VINT(57)
- AQCDUP=VINT(58)
- DO 180 I=1,NUP
- IDUP(I)=K(I+MINT(84),2)
- IF(I.LE.2) THEN
- ISTUP(I)=-1
- MOTHUP(1,I)=0
- MOTHUP(2,I)=0
- ELSEIF(K(I+4,3).EQ.0) THEN
- ISTUP(I)=1
- MOTHUP(1,I)=1
- MOTHUP(2,I)=2
- ELSE
- ISTUP(I)=1
- MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
- MOTHUP(2,I)=0
- ENDIF
- IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
- & ISTUP(K(I+MINT(84),3)-MINT(84))=2
- ICOLUP(1,I)=MCT(I+MINT(84),1)
- ICOLUP(2,I)=MCT(I+MINT(84),2)
- DO 170 J=1,5
- PUP(J,I)=P(I+MINT(84),J)
- 170 CONTINUE
- VTIMUP(I)=V(I,5)
- SPINUP(I)=9D0
- 180 CONTINUE
-
-C...Optionally write out event to disk. Minimal size for time/spin fields.
- IF(MSTP(162).GT.0) THEN
- WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
- DO 190 I=1,NUP
- IF(VTIMUP(I).EQ.0D0) THEN
- WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
- & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
- & ' 0. 9.'
- ELSE
- WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
- & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
- & VTIMUP(I),' 9.'
- ENDIF
- 190 CONTINUE
-
-C...Optional extra line with parton-density information.
- IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
- & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
- ENDIF
-
-C...Error messages and other print formats.
- 5100 FORMAT(1X,'Error: no subprocess switched on.'/
- &1X,'Execution stopped.')
- 5200 FORMAT(1P,2I6,4E14.6)
- 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
- 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
- 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYUPIN
-C...Fills the HEPRUP commonblock with info on incoming beams and allowed
-C...processes, and optionally stores that information on file.
-
- SUBROUTINE PYUPIN
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
-
-C...User process initialization commonblock.
- INTEGER MAXPUP
- PARAMETER (MAXPUP=100)
- INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
- DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
- COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
- &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
- &LPRUP(MAXPUP)
- SAVE /HEPRUP/
-
-C...Store info on incoming beams.
- IDBMUP(1)=K(1,2)
- IDBMUP(2)=K(2,2)
- EBMUP(1)=P(1,4)
- EBMUP(2)=P(2,4)
- PDFGUP(1)=0
- PDFGUP(2)=0
- PDFSUP(1)=MSTP(51)
- PDFSUP(2)=MSTP(51)
-
-C...Event weighting strategy.
- IDWTUP=3
-
-C...Info on individual processes.
- NPRUP=0
- DO 100 ISUB=1,500
- IF(MSUB(ISUB).EQ.1) THEN
- NPRUP=NPRUP+1
- XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
- XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
- XMAXUP(NPRUP)=1D0
- LPRUP(NPRUP)=ISUB
- ENDIF
- 100 CONTINUE
-
-C...Write info to file.
- IF(MSTP(161).GT.0) THEN
- WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
- & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
- DO 110 IPR=1,NPRUP
- WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
- & LPRUP(IPR)
- 110 CONTINUE
- ENDIF
-
-C...Formats for printout.
- 5100 FORMAT(1P,2I8,2E14.6,6I6)
- 5200 FORMAT(1P,3E14.6,I6)
-
- RETURN
- END
-
-
-C*********************************************************************
-
-C...Combine the two old-style Pythia initialization and event files
-C...into a single Les Houches Event File.
-
- SUBROUTINE PYLHEF
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-
-C...PYTHIA commonblock: only used to provide read/write units and version.
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- SAVE /PYPARS/
-
-C...User process initialization commonblock.
- INTEGER MAXPUP
- PARAMETER (MAXPUP=100)
- INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
- DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
- COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
- &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
- &LPRUP(MAXPUP)
- SAVE /HEPRUP/
-
-C...User process event common block.
- INTEGER MAXNUP
- PARAMETER (MAXNUP=500)
- INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
- DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
- COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
- &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
- &VTIMUP(MAXNUP),SPINUP(MAXNUP)
- SAVE /HEPEUP/
-
-C...Lines to read in assumed never longer than 200 characters.
- PARAMETER (MAXLEN=200)
- CHARACTER*(MAXLEN) STRING
-
-C...Format for reading lines.
- CHARACTER*6 STRFMT
- STRFMT='(A000)'
- WRITE(STRFMT(3:5),'(I3)') MAXLEN
-
-C...Rewind initialization and event files.
- REWIND MSTP(161)
- REWIND MSTP(162)
-
-C...Write header info.
- WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
- WRITE(MSTP(163),'(A)') '<!--'
- WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
- &MSTP(181),'.',MSTP(182)
- WRITE(MSTP(163),'(A)') '-->'
-
-C...Read first line of initialization info and get number of processes.
- READ(MSTP(161),'(A)',END=400,ERR=400) STRING
- READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
- &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
-
-C...Copy initialization lines, omitting trailing blanks.
-C...Embed in <init> ... </init> block.
- WRITE(MSTP(163),'(A)') '<init>'
- DO 140 IPR=0,NPRUP
- IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
- LEN=MAXLEN+1
- 120 LEN=LEN-1
- IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
- WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
- 140 CONTINUE
- WRITE(MSTP(163),'(A)') '</init>'
-
-C...Begin event loop. Read first line of event info or already done.
- READ(MSTP(162),'(A)',END=320,ERR=400) STRING
- 200 CONTINUE
-
-C...Look at first line to know number of particles in event.
- READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
-
-C...Begin an <event> block. Copy event lines, omitting trailing blanks.
- WRITE(MSTP(163),'(A)') '<event>'
- DO 240 I=0,NUP
- IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
- LEN=MAXLEN+1
- 220 LEN=LEN-1
- IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
- WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
- 240 CONTINUE
-
-C...Copy trailing comment lines - with a # in the first column - as is.
- 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
- IF(STRING(1:1).EQ.'#') THEN
- LEN=MAXLEN+1
- 280 LEN=LEN-1
- IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
- WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
- GOTO 260
- ENDIF
-
-C..End the <event> block. Loop back to look for next event.
- WRITE(MSTP(163),'(A)') '</event>'
- GOTO 200
-
-C...Successfully reached end of event loop: write closing tag
-C...and remove temporary intermediate files (unless asked not to).
- 300 WRITE(MSTP(163),'(A)') '</event>'
- 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
- IF(MSTP(164).EQ.1) RETURN
- CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
- CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
- RETURN
-
-C...Error exit.
- 400 WRITE(*,*) ' PYLHEF file joining failed!'
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYINRE
-C...Calculates full and effective widths of gauge bosons, stores
-C...masses and widths, rescales coefficients to be used for
-C...resonance production generation.
-
- SUBROUTINE PYINRE
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYDAT4/CHAF(500,2)
- CHARACTER CHAF*16
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYINT6/PROC(0:500)
- CHARACTER PROC*28
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
- &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
-C...Local arrays and data.
- DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
- &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
-
-C...Born level couplings in MSSM Higgs doublet sector.
- XW=PARU(102)
- XWV=XW
- IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
- XW1=1D0-XW
- IF(MSTP(4).EQ.2) THEN
- TANBE=PARU(141)
- RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
- SQMZ=PMAS(23,1)**2
- SQMW=PMAS(24,1)**2
- SQMH=PMAS(25,1)**2
- SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
- SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
- SQMHC=SQMA+SQMW
- IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
- WRITE(MSTU(11),5000)
- CALL PYSTOP(101)
- ENDIF
- PMAS(35,1)=SQRT(SQMHP)
- PMAS(36,1)=SQRT(SQMA)
- PMAS(37,1)=SQRT(SQMHC)
- ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
- & (SQMA-SQMZ)))
- BESU=ATAN(TANBE)
- PARU(142)=1D0
- PARU(143)=1D0
- PARU(161)=-SIN(ALSU)/COS(BESU)
- PARU(162)=COS(ALSU)/SIN(BESU)
- PARU(163)=PARU(161)
- PARU(164)=SIN(BESU-ALSU)
- PARU(165)=PARU(164)
- PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
- PARU(171)=COS(ALSU)/COS(BESU)
- PARU(172)=SIN(ALSU)/SIN(BESU)
- PARU(173)=PARU(171)
- PARU(174)=COS(BESU-ALSU)
- PARU(175)=PARU(174)
- PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
- & SIN(BESU+ALSU)
- PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
- PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
- PARU(181)=TANBE
- PARU(182)=1D0/TANBE
- PARU(183)=PARU(181)
- PARU(184)=0D0
- PARU(185)=PARU(184)
- PARU(186)=COS(BESU-ALSU)
- PARU(187)=SIN(BESU-ALSU)
- PARU(188)=PARU(186)
- PARU(189)=PARU(187)
- PARU(190)=0D0
- PARU(195)=COS(BESU-ALSU)
- ENDIF
-
-C...Reset effective widths of gauge bosons.
- DO 110 I=1,500
- DO 100 J=1,5
- WIDS(I,J)=1D0
- 100 CONTINUE
- 110 CONTINUE
-
-C...Order resonances by increasing mass (except Z0 and W+/-).
- NRES=0
- DO 140 KC=1,500
- KF=KCHG(KC,4)
- IF(KF.EQ.0) GOTO 140
- IF(MWID(KC).EQ.0) GOTO 140
- IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
- IF(MSTP(1).LE.3) GOTO 140
- ENDIF
- IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
- IF(IMSS(1).LE.0) GOTO 140
- ENDIF
- NRES=NRES+1
- PMRES=PMAS(KC,1)
- IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
- DO 120 I1=NRES-1,1,-1
- IF(PMRES.GE.PMORD(I1)) GOTO 130
- KCORD(I1+1)=KCORD(I1)
- PMORD(I1+1)=PMORD(I1)
- 120 CONTINUE
- 130 KCORD(I1+1)=KC
- PMORD(I1+1)=PMRES
- 140 CONTINUE
-
-C...Loop over possible resonances.
- DO 180 I=1,NRES
- KC=KCORD(I)
- KF=KCHG(KC,4)
-
-C...Check that no fourth generation channels on by mistake.
- IF(MSTP(1).LE.3) THEN
- DO 150 J=1,MDCY(KC,3)
- IDC=J+MDCY(KC,2)-1
- KFA1=IABS(KFDP(IDC,1))
- KFA2=IABS(KFDP(IDC,2))
- IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
- & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
- & MDME(IDC,1)=-1
- 150 CONTINUE
- ENDIF
-
-C...Check that no supersymmetric channels on by mistake.
- IF(IMSS(1).LE.0) THEN
- DO 160 J=1,MDCY(KC,3)
- IDC=J+MDCY(KC,2)-1
- KFA1S=IABS(KFDP(IDC,1))/KSUSY1
- KFA2S=IABS(KFDP(IDC,2))/KSUSY1
- IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
- & MDME(IDC,1)=-1
- 160 CONTINUE
- ENDIF
-
-C...Find mass and evaluate width.
- PMR=PMAS(KC,1)
- IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
- IF(MWID(KC).EQ.3) MINT(63)=1
- CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
- MINT(51)=0
-
-C...Evaluate suppression factors due to non-simulated channels.
- IF(KCHG(KC,3).EQ.0) THEN
- WDTP0I=0D0
- IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
- WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
- & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
- & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
- WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
- WIDS(KC,3)=0D0
- WIDS(KC,4)=0D0
- WIDS(KC,5)=0D0
- ELSE
- IF(MWID(KC).EQ.3) MINT(63)=1
- CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
- MINT(51)=0
- WDTP0I=0D0
- IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
- WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
- & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
- & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
- & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
- WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
- WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
- WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
- & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
- & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
- WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
- & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
- & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
- ENDIF
-
-C...Set resonance widths and branching ratios;
-C...also on/off switch for decays.
- IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
- PMAS(KC,2)=WDTP(0)
- PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
- IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
- DO 170 J=1,MDCY(KC,3)
- IDC=J+MDCY(KC,2)-1
- BRAT(IDC)=0D0
- IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
- 170 CONTINUE
- ENDIF
- 180 CONTINUE
-
-C...Flavours of leptoquark: redefine charge and name.
- KFLQQ=KFDP(MDCY(42,2),1)
- KFLQL=KFDP(MDCY(42,2),2)
- KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
- &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
- LL=1
- IF(IABS(KFLQL).EQ.13) LL=2
- IF(IABS(KFLQL).EQ.15) LL=3
- CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
- &CHAF(IABS(KFLQL),1)(1:LL)//' '
- CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
-
-C...Special cases in treatment of gamma*/Z0: redefine process name.
- IF(MSTP(43).EQ.1) THEN
- PROC(1)='f + fbar -> gamma*'
- PROC(15)='f + fbar -> g + gamma*'
- PROC(19)='f + fbar -> gamma + gamma*'
- PROC(30)='f + g -> f + gamma*'
- PROC(35)='f + gamma -> f + gamma*'
- ELSEIF(MSTP(43).EQ.2) THEN
- PROC(1)='f + fbar -> Z0'
- PROC(15)='f + fbar -> g + Z0'
- PROC(19)='f + fbar -> gamma + Z0'
- PROC(30)='f + g -> f + Z0'
- PROC(35)='f + gamma -> f + Z0'
- ELSEIF(MSTP(43).EQ.3) THEN
- PROC(1)='f + fbar -> gamma*/Z0'
- PROC(15)='f + fbar -> g + gamma*/Z0'
- PROC(19)='f+ fbar -> gamma + gamma*/Z0'
- PROC(30)='f + g -> f + gamma*/Z0'
- PROC(35)='f + gamma -> f + gamma*/Z0'
- ENDIF
-
-C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
- IF(MSTP(44).EQ.1) THEN
- PROC(141)='f + fbar -> gamma*'
- ELSEIF(MSTP(44).EQ.2) THEN
- PROC(141)='f + fbar -> Z0'
- ELSEIF(MSTP(44).EQ.3) THEN
- PROC(141)='f + fbar -> Z''0'
- ELSEIF(MSTP(44).EQ.4) THEN
- PROC(141)='f + fbar -> gamma*/Z0'
- ELSEIF(MSTP(44).EQ.5) THEN
- PROC(141)='f + fbar -> gamma*/Z''0'
- ELSEIF(MSTP(44).EQ.6) THEN
- PROC(141)='f + fbar -> Z0/Z''0'
- ELSEIF(MSTP(44).EQ.7) THEN
- PROC(141)='f + fbar -> gamma*/Z0/Z''0'
- ENDIF
-
-C...Special cases in treatment of WW -> WW: redefine process name.
- IF(MSTP(45).EQ.1) THEN
- PROC(77)='W+ + W+ -> W+ + W+'
- ELSEIF(MSTP(45).EQ.2) THEN
- PROC(77)='W+ + W- -> W+ + W-'
- ELSEIF(MSTP(45).EQ.3) THEN
- PROC(77)='W+/- + W+/- -> W+/- + W+/-'
- ENDIF
-
-C...Format for error information.
- 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
- &'combination'/1X,'Execution stopped!')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYINBM
-C...Identifies the two incoming particles and the choice of frame.
-
- SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...User process initialization commonblock.
- INTEGER MAXPUP
- PARAMETER (MAXPUP=100)
- INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
- DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
- COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
- &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
- &LPRUP(MAXPUP)
- SAVE /HEPRUP/
-
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
-
-C...Local arrays, character variables and data.
- CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
- &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
- DIMENSION LEN(3),KCDE(39),PM(2)
- DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
- &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
- DATA CHCDE/ 'e- ','e+ ','nu_e ',
- &'nu_ebar ','mu- ','mu+ ','nu_mu ',
- &'nu_mubar ','tau- ','tau+ ','nu_tau ',
- &'nu_taubar ','pi+ ','pi- ','n0 ',
- &'nbar0 ','p+ ','pbar- ','gamma ',
- &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
- &'xi- ','xi0 ','omega- ','pi0 ',
- &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
- &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
- &'k+ ','k- ','ks0 ','kl0 '/
- DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
- &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
- &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
-
-C...Store initial energy. Default frame.
- VINT(290)=WIN
- MINT(111)=0
-
-C...Special user process initialization; convert to normal input.
- IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
- MINT(111)=11
- IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
- CALL PYNAME(IDBMUP(1),CHNAME)
- CHBEAM=CHNAME(1:12)
- CALL PYNAME(IDBMUP(2),CHNAME)
- CHTARG=CHNAME(1:12)
- ENDIF
-
-C...Convert character variables to lowercase and find their length.
- CHCOM(1)=CHFRAM
- CHCOM(2)=CHBEAM
- CHCOM(3)=CHTARG
- DO 130 I=1,3
- LEN(I)=12
- DO 110 LL=12,1,-1
- IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
- DO 100 LA=1,26
- IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
- & CHALP(1)(LA:LA)
- 100 CONTINUE
- 110 CONTINUE
- CHIDNT(I)=CHCOM(I)
-
-C...Fix up bar, underscore and charge in particle name (if needed).
- DO 120 LL=1,10
- IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
- CHTEMP=CHIDNT(I)
- CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
- ENDIF
- 120 CONTINUE
- IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
- CHTEMP=CHIDNT(I)
- CHIDNT(I)='nu_'//CHTEMP(3:7)
- ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
- CHIDNT(I)(1:3)='n0 '
- ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
- CHIDNT(I)(1:5)='nbar0'
- ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
- CHIDNT(I)(1:3)='p+ '
- ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
- & CHIDNT(I)(1:2).EQ.'p-') THEN
- CHIDNT(I)(1:5)='pbar-'
- ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
- CHIDNT(I)(7:7)='0'
- ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
- CHIDNT(I)(1:7)='reggeon'
- ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
- CHIDNT(I)(1:7)='pomeron'
- ENDIF
- 130 CONTINUE
-
-C...Identify free initialization.
- IF(CHCOM(1)(1:2).EQ.'no') THEN
- MINT(65)=1
- RETURN
- ENDIF
-
-C...Identify incoming beam and target particles.
- DO 160 I=1,2
- DO 140 J=1,39
- IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
- 140 CONTINUE
- PM(I)=PYMASS(MINT(10+I))
- VINT(2+I)=PM(I)
- MINT(140+I)=0
- IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
- CHTEMP=CHIDNT(I+1)(7:12)//' '
- DO 150 J=1,12
- IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
- 150 CONTINUE
- PM(I)=PYMASS(MINT(140+I))
- VINT(302+I)=PM(I)
- ENDIF
- 160 CONTINUE
- IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
- IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
- IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7)
-
-C...Identify choice of frame and input energies.
- CHINIT=' '
-
-C...Events defined in the CM frame.
- IF(CHCOM(1)(1:2).EQ.'cm') THEN
- MINT(111)=1
- S=WIN**2
- IF(MSTP(122).GE.1) THEN
- IF(CHCOM(2)(1:1).NE.'e') THEN
- LOFFS=(31-(LEN(2)+LEN(3)))/2
- CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
- & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
- & ' collider'//' '
- ELSE
- LOFFS=(30-(LEN(2)+LEN(3)))/2
- CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
- & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
- & ' collider'//' '
- ENDIF
- WRITE(MSTU(11),5200) CHINIT
- WRITE(MSTU(11),5300) WIN
- ENDIF
-
-C...Events defined in fixed target frame.
- ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
- MINT(111)=2
- S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
- IF(MSTP(122).GE.1) THEN
- LOFFS=(29-(LEN(2)+LEN(3)))/2
- CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
- & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
- & ' fixed target'//' '
- WRITE(MSTU(11),5200) CHINIT
- WRITE(MSTU(11),5400) WIN
- WRITE(MSTU(11),5500) SQRT(S)
- ENDIF
-
-C...Frame defined by user three-vectors.
- ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
- MINT(111)=3
- P(1,5)=PM(1)
- P(2,5)=PM(2)
- P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
- P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
- S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
- & (P(1,3)+P(2,3))**2
- IF(MSTP(122).GE.1) THEN
- LOFFS=(22-(LEN(2)+LEN(3)))/2
- CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
- & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
- & ' user configuration'//' '
- WRITE(MSTU(11),5200) CHINIT
- WRITE(MSTU(11),5600)
- WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
- WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
- WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
- ENDIF
-
-C...Frame defined by user four-vectors.
- ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
- MINT(111)=4
- PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
- P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
- PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
- P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
- S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
- & (P(1,3)+P(2,3))**2
- IF(MSTP(122).GE.1) THEN
- LOFFS=(22-(LEN(2)+LEN(3)))/2
- CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
- & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
- & ' user configuration'//' '
- WRITE(MSTU(11),5200) CHINIT
- WRITE(MSTU(11),5600)
- WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
- WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
- WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
- ENDIF
-
-C...Frame defined by user five-vectors.
- ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
- MINT(111)=5
- S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
- & (P(1,3)+P(2,3))**2
- IF(MSTP(122).GE.1) THEN
- LOFFS=(22-(LEN(2)+LEN(3)))/2
- CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
- & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
- & ' user configuration'//' '
- WRITE(MSTU(11),5200) CHINIT
- WRITE(MSTU(11),5600)
- WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
- WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
- WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
- ENDIF
-
-C...Frame defined by HEPRUP common block.
- ELSEIF(MINT(111).GE.11) THEN
- S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
- & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
- IF(MSTP(122).GE.1) THEN
- LOFFS=(22-(LEN(2)+LEN(3)))/2
- CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
- & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
- & ' user configuration'//' '
- WRITE(MSTU(11),5200) CHINIT
- WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
- WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
- ENDIF
-
-C...Unknown frame. Error for too low CM energy.
- ELSE
- WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
- CALL PYSTOP(7)
- ENDIF
- IF(S.LT.PARP(2)**2) THEN
- WRITE(MSTU(11),5900) SQRT(S)
- CALL PYSTOP(7)
- ENDIF
-
-C...Formats for initialization and error information.
- 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
- &1X,'Execution stopped!')
- 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
- &1X,'Execution stopped!')
- 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
- 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
- &19X,'I'/1X,'I',76X,'I'/1X,78('='))
- 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
- 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
- &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
- 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
- &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
- 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
- 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
- &1X,'Execution stopped!')
- 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
- &'generation.'/1X,'Execution stopped!')
- 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
- &'GeV beam energies',13X,'I')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYINKI
-C...Sets up kinematics, including rotations and boosts to/from CM frame.
-
- SUBROUTINE PYINKI(MODKI)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...User process initialization commonblock.
- INTEGER MAXPUP
- PARAMETER (MAXPUP=100)
- INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
- DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
- COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
- &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
- &LPRUP(MAXPUP)
- SAVE /HEPRUP/
-
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
-
-C...Set initial flavour state.
- N=2
- DO 100 I=1,2
- K(I,1)=1
- K(I,2)=MINT(10+I)
- IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
- 100 CONTINUE
-
-C...Reset boost. Do kinematics for various cases.
- DO 110 J=6,10
- VINT(J)=0D0
- 110 CONTINUE
-
-C...Set up kinematics for events defined in CM frame.
- IF(MINT(111).EQ.1) THEN
- WIN=VINT(290)
- IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
- S=WIN**2
- P(1,5)=VINT(3)
- P(2,5)=VINT(4)
- IF(MINT(141).NE.0) P(1,5)=VINT(303)
- IF(MINT(142).NE.0) P(2,5)=VINT(304)
- P(1,1)=0D0
- P(1,2)=0D0
- P(2,1)=0D0
- P(2,2)=0D0
- P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
- & (4D0*S))
- P(2,3)=-P(1,3)
- P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
- P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
-
-C...Set up kinematics for fixed target events.
- ELSEIF(MINT(111).EQ.2) THEN
- WIN=VINT(290)
- IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
- P(1,5)=VINT(3)
- P(2,5)=VINT(4)
- IF(MINT(141).NE.0) P(1,5)=VINT(303)
- IF(MINT(142).NE.0) P(2,5)=VINT(304)
- P(1,1)=0D0
- P(1,2)=0D0
- P(2,1)=0D0
- P(2,2)=0D0
- P(1,3)=WIN
- P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
- P(2,3)=0D0
- P(2,4)=P(2,5)
- S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
- VINT(10)=P(1,3)/(P(1,4)+P(2,4))
- CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
-
-C...Set up kinematics for events in user-defined frame.
- ELSEIF(MINT(111).EQ.3) THEN
- P(1,5)=VINT(3)
- P(2,5)=VINT(4)
- IF(MINT(141).NE.0) P(1,5)=VINT(303)
- IF(MINT(142).NE.0) P(2,5)=VINT(304)
- P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
- P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
- DO 120 J=1,3
- VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
- 120 CONTINUE
- CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
- VINT(7)=PYANGL(P(1,1),P(1,2))
- CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
- VINT(6)=PYANGL(P(1,3),P(1,1))
- CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
- S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
-
-C...Set up kinematics for events with user-defined four-vectors.
- ELSEIF(MINT(111).EQ.4) THEN
- PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
- P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
- PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
- P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
- DO 130 J=1,3
- VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
- 130 CONTINUE
- CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
- VINT(7)=PYANGL(P(1,1),P(1,2))
- CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
- VINT(6)=PYANGL(P(1,3),P(1,1))
- CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
- S=(P(1,4)+P(2,4))**2
-
-C...Set up kinematics for events with user-defined five-vectors.
- ELSEIF(MINT(111).EQ.5) THEN
- DO 140 J=1,3
- VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
- 140 CONTINUE
- CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
- VINT(7)=PYANGL(P(1,1),P(1,2))
- CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
- VINT(6)=PYANGL(P(1,3),P(1,1))
- CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
- S=(P(1,4)+P(2,4))**2
-
-C...Set up kinematics for events with external user processes.
- ELSEIF(MINT(111).GE.11) THEN
- P(1,5)=VINT(3)
- P(2,5)=VINT(4)
- IF(MINT(141).NE.0) P(1,5)=VINT(303)
- IF(MINT(142).NE.0) P(2,5)=VINT(304)
- P(1,1)=0D0
- P(1,2)=0D0
- P(2,1)=0D0
- P(2,2)=0D0
- P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
- P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
- P(1,4)=EBMUP(1)
- P(2,4)=EBMUP(2)
- VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
- CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
- S=(P(1,4)+P(2,4))**2
- ENDIF
-
-C...Return or error for too low CM energy.
- IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
- IF(MSTP(172).LE.1) THEN
- CALL PYERRM(23,
- & '(PYINKI:) too low invariant mass in this event')
- ELSE
- MSTI(61)=1
- RETURN
- ENDIF
- ENDIF
-
-C...Save information on incoming particles.
- VINT(1)=SQRT(S)
- VINT(2)=S
- IF(MINT(111).GE.4) THEN
- IF(MINT(141).EQ.0) THEN
- VINT(3)=P(1,5)
- IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
- ELSE
- VINT(303)=P(1,5)
- ENDIF
- IF(MINT(142).EQ.0) THEN
- VINT(4)=P(2,5)
- IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
- ELSE
- VINT(304)=P(2,5)
- ENDIF
- ENDIF
- VINT(5)=P(1,3)
- IF(MODKI.EQ.0) VINT(289)=S
- DO 150 J=1,5
- V(1,J)=0D0
- V(2,J)=0D0
- VINT(290+J)=P(1,J)
- VINT(295+J)=P(2,J)
- 150 CONTINUE
-
-C...Store pT cut-off and related constants to be used in generation.
- IF(MODKI.EQ.0) VINT(285)=CKIN(3)
- IF(MSTP(82).LE.1) THEN
- PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
- ELSE
- PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
- ENDIF
- VINT(149)=4D0*PTMN**2/S
- VINT(154)=PTMN
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYINPR
-C...Selects partonic subprocesses to be included in the simulation.
-
- SUBROUTINE PYINPR
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...User process initialization commonblock.
- INTEGER MAXPUP
- PARAMETER (MAXPUP=100)
- INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
- DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
- COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
- &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
- &LPRUP(MAXPUP)
- SAVE /HEPRUP/
-
-C...Commonblocks and character variables.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT6/PROC(0:500)
- CHARACTER PROC*28
- SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
- &/PYINT6/
- CHARACTER CHIPR*10
-
-C...Reset processes to be included.
- IF(MSEL.NE.0) THEN
- DO 100 I=1,500
- MSUB(I)=0
- 100 CONTINUE
- ENDIF
-
-C...Set running pTmin scale.
- IF(MSTP(82).LE.1) THEN
- PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
- ELSE
- PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
- ENDIF
-
-C...Begin by assuming incoming photon to enter subprocess.
- IF(MINT(11).EQ.22) MINT(15)=22
- IF(MINT(12).EQ.22) MINT(16)=22
-
-C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
- IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
- MSUB(10)=1
- MINT(123)=MINT(122)+1
-
-C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
-C...allow mixture.
-C...Here also set a few parameters otherwise normally not touched.
- ELSEIF(MINT(121).GT.1) THEN
-
-C...Parton distributions dampened at small Q2; go to low energies,
-C...alpha_s <1; no minimum pT cut-off a priori.
- IF(MSTP(18).EQ.2) THEN
- MSTP(57)=3
- PARP(2)=2D0
- PARU(115)=1D0
- CKIN(5)=0.2D0
- CKIN(6)=0.2D0
- ENDIF
-
-C...Define pT cut-off parameters and whether run involves low-pT.
- PTMVMD=PTMRUN
- VINT(154)=PTMVMD
- PTMDIR=PTMVMD
- IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
- PTMANO=PTMVMD
- IF(MSTP(15).EQ.5) PTMANO=0.60D0+
- & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
- IPTL=1
- IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
- IF(MSEL.EQ.2) IPTL=1
-
-C...Set up for p/gamma * gamma; real or virtual photons.
- IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
- & MSTP(14).EQ.30)) THEN
-
-C...Set up for p/VMD * VMD.
- IF(MINT(122).EQ.1) THEN
- MINT(123)=2
- MSUB(11)=1
- MSUB(12)=1
- MSUB(13)=1
- MSUB(28)=1
- MSUB(53)=1
- MSUB(68)=1
- IF(IPTL.EQ.1) MSUB(95)=1
- IF(MSEL.EQ.2) THEN
- MSUB(91)=1
- MSUB(92)=1
- MSUB(93)=1
- MSUB(94)=1
- ENDIF
- IF(IPTL.EQ.1) CKIN(3)=0D0
-
-C...Set up for p/VMD * direct gamma.
- ELSEIF(MINT(122).EQ.2) THEN
- MINT(123)=0
- IF(MINT(121).EQ.6) MINT(123)=5
- MSUB(131)=1
- MSUB(132)=1
- MSUB(135)=1
- MSUB(136)=1
- IF(IPTL.EQ.1) CKIN(3)=PTMDIR
-
-C...Set up for p/VMD * anomalous gamma.
- ELSEIF(MINT(122).EQ.3) THEN
- MINT(123)=3
- IF(MINT(121).EQ.6) MINT(123)=7
- MSUB(11)=1
- MSUB(12)=1
- MSUB(13)=1
- MSUB(28)=1
- MSUB(53)=1
- MSUB(68)=1
- IF(IPTL.EQ.1) MSUB(95)=1
- IF(MSEL.EQ.2) THEN
- MSUB(91)=1
- MSUB(92)=1
- MSUB(93)=1
- MSUB(94)=1
- ENDIF
- IF(IPTL.EQ.1) CKIN(3)=0D0
-
-C...Set up for DIS * p.
- ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
- & IABS(MINT(12)).GT.100)) THEN
- MINT(123)=8
- IF(IPTL.EQ.1) MSUB(99)=1
-
-C...Set up for direct * direct gamma (switch off leptons).
- ELSEIF(MINT(122).EQ.4) THEN
- MINT(123)=0
- MSUB(137)=1
- MSUB(138)=1
- MSUB(139)=1
- MSUB(140)=1
- DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
- IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
- 110 CONTINUE
- IF(IPTL.EQ.1) CKIN(3)=PTMDIR
-
-C...Set up for direct * anomalous gamma.
- ELSEIF(MINT(122).EQ.5) THEN
- MINT(123)=6
- MSUB(131)=1
- MSUB(132)=1
- MSUB(135)=1
- MSUB(136)=1
- IF(IPTL.EQ.1) CKIN(3)=PTMANO
-
-C...Set up for anomalous * anomalous gamma.
- ELSEIF(MINT(122).EQ.6) THEN
- MINT(123)=3
- MSUB(11)=1
- MSUB(12)=1
- MSUB(13)=1
- MSUB(28)=1
- MSUB(53)=1
- MSUB(68)=1
- IF(IPTL.EQ.1) MSUB(95)=1
- IF(MSEL.EQ.2) THEN
- MSUB(91)=1
- MSUB(92)=1
- MSUB(93)=1
- MSUB(94)=1
- ENDIF
- IF(IPTL.EQ.1) CKIN(3)=0D0
- ENDIF
-
-C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
- ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
-
-C...Set up for direct * direct gamma (switch off leptons).
- IF(MINT(122).EQ.1) THEN
- MINT(123)=0
- MSUB(137)=1
- MSUB(138)=1
- MSUB(139)=1
- MSUB(140)=1
- DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
- IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
- 120 CONTINUE
- IF(IPTL.EQ.1) CKIN(3)=PTMDIR
-
-C...Set up for direct * VMD and VMD * direct gamma.
- ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
- MINT(123)=5
- MSUB(131)=1
- MSUB(132)=1
- MSUB(135)=1
- MSUB(136)=1
- IF(IPTL.EQ.1) CKIN(3)=PTMDIR
-
-C...Set up for direct * anomalous and anomalous * direct gamma.
- ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
- MINT(123)=6
- MSUB(131)=1
- MSUB(132)=1
- MSUB(135)=1
- MSUB(136)=1
- IF(IPTL.EQ.1) CKIN(3)=PTMANO
-
-C...Set up for VMD*VMD.
- ELSEIF(MINT(122).EQ.5) THEN
- MINT(123)=2
- MSUB(11)=1
- MSUB(12)=1
- MSUB(13)=1
- MSUB(28)=1
- MSUB(53)=1
- MSUB(68)=1
- IF(IPTL.EQ.1) MSUB(95)=1
- IF(MSEL.EQ.2) THEN
- MSUB(91)=1
- MSUB(92)=1
- MSUB(93)=1
- MSUB(94)=1
- ENDIF
- IF(IPTL.EQ.1) CKIN(3)=0D0
-
-C...Set up for VMD * anomalous and anomalous * VMD gamma.
- ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
- MINT(123)=7
- MSUB(11)=1
- MSUB(12)=1
- MSUB(13)=1
- MSUB(28)=1
- MSUB(53)=1
- MSUB(68)=1
- IF(IPTL.EQ.1) MSUB(95)=1
- IF(MSEL.EQ.2) THEN
- MSUB(91)=1
- MSUB(92)=1
- MSUB(93)=1
- MSUB(94)=1
- ENDIF
- IF(IPTL.EQ.1) CKIN(3)=0D0
-
-C...Set up for anomalous * anomalous gamma.
- ELSEIF(MINT(122).EQ.9) THEN
- MINT(123)=3
- MSUB(11)=1
- MSUB(12)=1
- MSUB(13)=1
- MSUB(28)=1
- MSUB(53)=1
- MSUB(68)=1
- IF(IPTL.EQ.1) MSUB(95)=1
- IF(MSEL.EQ.2) THEN
- MSUB(91)=1
- MSUB(92)=1
- MSUB(93)=1
- MSUB(94)=1
- ENDIF
- IF(IPTL.EQ.1) CKIN(3)=0D0
-
-C...Set up for DIS * VMD and VMD * DIS gamma.
- ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
- MINT(123)=8
- IF(IPTL.EQ.1) MSUB(99)=1
-
-C...Set up for DIS * anomalous and anomalous * DIS gamma.
- ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
- MINT(123)=9
- IF(IPTL.EQ.1) MSUB(99)=1
- ENDIF
-
-C...Set up for gamma* * p; virtual photons = dir, res.
- ELSEIF(MINT(121).EQ.2) THEN
-
-C...Set up for direct * p.
- IF(MINT(122).EQ.1) THEN
- MINT(123)=0
- MSUB(131)=1
- MSUB(132)=1
- MSUB(135)=1
- MSUB(136)=1
- IF(IPTL.EQ.1) CKIN(3)=PTMDIR
-
-C...Set up for resolved * p.
- ELSEIF(MINT(122).EQ.2) THEN
- MINT(123)=1
- MSUB(11)=1
- MSUB(12)=1
- MSUB(13)=1
- MSUB(28)=1
- MSUB(53)=1
- MSUB(68)=1
- IF(IPTL.EQ.1) MSUB(95)=1
- IF(MSEL.EQ.2) THEN
- MSUB(91)=1
- MSUB(92)=1
- MSUB(93)=1
- MSUB(94)=1
- ENDIF
- IF(IPTL.EQ.1) CKIN(3)=0D0
- ENDIF
-
-C...Set up for gamma* * gamma*; virtual photons = dir, res.
- ELSEIF(MINT(121).EQ.4) THEN
-
-C...Set up for direct * direct gamma (switch off leptons).
- IF(MINT(122).EQ.1) THEN
- MINT(123)=0
- MSUB(137)=1
- MSUB(138)=1
- MSUB(139)=1
- MSUB(140)=1
- DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
- IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
- 130 CONTINUE
- IF(IPTL.EQ.1) CKIN(3)=PTMDIR
-
-C...Set up for direct * resolved and resolved * direct gamma.
- ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
- MINT(123)=5
- MSUB(131)=1
- MSUB(132)=1
- MSUB(135)=1
- MSUB(136)=1
- IF(IPTL.EQ.1) CKIN(3)=PTMDIR
-
-C...Set up for resolved * resolved gamma.
- ELSEIF(MINT(122).EQ.4) THEN
- MINT(123)=2
- MSUB(11)=1
- MSUB(12)=1
- MSUB(13)=1
- MSUB(28)=1
- MSUB(53)=1
- MSUB(68)=1
- IF(IPTL.EQ.1) MSUB(95)=1
- IF(MSEL.EQ.2) THEN
- MSUB(91)=1
- MSUB(92)=1
- MSUB(93)=1
- MSUB(94)=1
- ENDIF
- IF(IPTL.EQ.1) CKIN(3)=0D0
- ENDIF
-
-C...End of special set up for gamma-p and gamma-gamma.
- ENDIF
- CKIN(1)=2D0*CKIN(3)
- ENDIF
-
-C...Flavour information for individual beams.
- DO 140 I=1,2
- MINT(40+I)=1
- IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
- IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
- MINT(44+I)=MINT(40+I)
- IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
- & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
- 140 CONTINUE
-
-C...If two real gammas, whereof one direct, pick the first.
-C...For two virtual photons, keep requested order.
- IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
- IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
- MINT(41)=1
- MINT(45)=1
- ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
- & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
- MINT(41)=1
- MINT(45)=1
- ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
- & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
- MINT(42)=1
- MINT(46)=1
- ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
- & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
- MINT(41)=1
- MINT(45)=1
- ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
- & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
- MINT(42)=1
- MINT(46)=1
- ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
- MINT(41)=1
- MINT(45)=1
- ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
- MINT(42)=1
- MINT(46)=1
- ENDIF
- ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
- IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
- IF(MINT(11).EQ.22) THEN
- MINT(41)=1
- MINT(45)=1
- ELSE
- MINT(42)=1
- MINT(46)=1
- ENDIF
- ENDIF
- IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
- & '(PYINPR:) unallowed MSTP(14) code for single photon')
- ENDIF
-
-C...Flavour information on combination of incoming particles.
- MINT(43)=2*MINT(41)+MINT(42)-2
- MINT(44)=MINT(43)
- IF(MINT(123).LE.0) THEN
- IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
- IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
- ELSEIF(MINT(123).LE.3) THEN
- IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
- IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
- ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
- MINT(43)=4
- MINT(44)=1
- ENDIF
- MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
- IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
- IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
- IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
- MINT(50)=0
- IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
- MINT(107)=0
- MINT(108)=0
- IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
- IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
- & MINT(107)=2
- IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
- & MINT(107)=3
- IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
- IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
- & MINT(122).EQ.10) MINT(108)=2
- IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
- & MINT(122).EQ.11) MINT(108)=3
- IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
- ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
- IF(MINT(122).GE.3) MINT(107)=1
- IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
- ELSEIF(MINT(121).EQ.2) THEN
- IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
- IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
- ELSE
- IF(MINT(11).EQ.22) THEN
- MINT(107)=MINT(123)
- IF(MINT(123).GE.4) MINT(107)=0
- IF(MINT(123).EQ.7) MINT(107)=2
- IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
- IF(MSTP(14).EQ.28) MINT(107)=2
- IF(MSTP(14).EQ.29) MINT(107)=3
- IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
- & MINT(107)=4
- ENDIF
- IF(MINT(12).EQ.22) THEN
- MINT(108)=MINT(123)
- IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
- IF(MINT(123).EQ.7) MINT(108)=3
- IF(MSTP(14).EQ.26) MINT(108)=2
- IF(MSTP(14).EQ.27) MINT(108)=3
- IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
- IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
- & MINT(108)=4
- ENDIF
- IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
- & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
- MINTTP=MINT(107)
- MINT(107)=MINT(108)
- MINT(108)=MINTTP
- ENDIF
- ENDIF
- IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
- IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
-
-C...Select default processes according to incoming beams
-C...(already done for gamma-p and gamma-gamma with
-C...MSTP(14) = 10, 20, 25 or 30).
- IF(MINT(121).GT.1) THEN
- ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
-
- IF(MINT(43).EQ.1) THEN
-C...Lepton + lepton -> gamma/Z0 or W.
- IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
- IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
-
- ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
- & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
-C...Unresolved photon + lepton: Compton scattering.
- MSUB(133)=1
- MSUB(134)=1
-
- ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
- & .OR.MINT(12).EQ.22)) THEN
-C...DIS as pure gamma* + f -> f process.
- MSUB(99)=1
-
- ELSEIF(MINT(43).LE.3) THEN
-C...Lepton + hadron: deep inelastic scattering.
- MSUB(10)=1
-
- ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
- & MINT(12).EQ.22) THEN
-C...Two unresolved photons: fermion pair production,
-C...exclude lepton pairs.
- DO 150 ISUB=137,140
- MSUB(ISUB)=1
- 150 CONTINUE
- DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
- IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
- 160 CONTINUE
- PTMDIR=PTMRUN
- IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
- IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
- CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
-
- ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
- & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
- & MINT(12).EQ.22)) THEN
-C...Unresolved photon + hadron: photon-parton scattering.
- DO 170 ISUB=131,136
- MSUB(ISUB)=1
- 170 CONTINUE
-
- ELSEIF(MSEL.EQ.1) THEN
-C...High-pT QCD processes:
- MSUB(11)=1
- MSUB(12)=1
- MSUB(13)=1
- MSUB(28)=1
- MSUB(53)=1
- MSUB(68)=1
- PTMN=PTMRUN
- VINT(154)=PTMN
- IF(CKIN(3).LT.PTMN) MSUB(95)=1
- IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
-
- ELSE
-C...All QCD processes:
- MSUB(11)=1
- MSUB(12)=1
- MSUB(13)=1
- MSUB(28)=1
- MSUB(53)=1
- MSUB(68)=1
- MSUB(91)=1
- MSUB(92)=1
- MSUB(93)=1
- MSUB(94)=1
- MSUB(95)=1
- ENDIF
-
- ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
-C...Heavy quark production.
- MSUB(81)=1
- MSUB(82)=1
- MSUB(84)=1
- DO 180 J=1,MIN(8,MDCY(21,3))
- MDME(MDCY(21,2)+J-1,1)=0
- 180 CONTINUE
- MDME(MDCY(21,2)+MSEL-1,1)=1
- MSUB(85)=1
- DO 190 J=1,MIN(12,MDCY(22,3))
- MDME(MDCY(22,2)+J-1,1)=0
- 190 CONTINUE
- MDME(MDCY(22,2)+MSEL-1,1)=1
-
- ELSEIF(MSEL.EQ.10) THEN
-C...Prompt photon production:
- MSUB(14)=1
- MSUB(18)=1
- MSUB(29)=1
-
- ELSEIF(MSEL.EQ.11) THEN
-C...Z0/gamma* production:
- MSUB(1)=1
-
- ELSEIF(MSEL.EQ.12) THEN
-C...W+/- production:
- MSUB(2)=1
-
- ELSEIF(MSEL.EQ.13) THEN
-C...Z0 + jet:
- MSUB(15)=1
- MSUB(30)=1
-
- ELSEIF(MSEL.EQ.14) THEN
-C...W+/- + jet:
- MSUB(16)=1
- MSUB(31)=1
-
- ELSEIF(MSEL.EQ.15) THEN
-C...Z0 & W+/- pair production:
- MSUB(19)=1
- MSUB(20)=1
- MSUB(22)=1
- MSUB(23)=1
- MSUB(25)=1
-
- ELSEIF(MSEL.EQ.16) THEN
-C...h0 production:
- MSUB(3)=1
- MSUB(102)=1
- MSUB(103)=1
- MSUB(123)=1
- MSUB(124)=1
-
- ELSEIF(MSEL.EQ.17) THEN
-C...h0 & Z0 or W+/- pair production:
- MSUB(24)=1
- MSUB(26)=1
-
- ELSEIF(MSEL.EQ.18) THEN
-C...h0 production; interesting processes in e+e-.
- MSUB(24)=1
- MSUB(103)=1
- MSUB(123)=1
- MSUB(124)=1
-
- ELSEIF(MSEL.EQ.19) THEN
-C...h0, H0 and A0 production; interesting processes in e+e-.
- MSUB(24)=1
- MSUB(103)=1
- MSUB(123)=1
- MSUB(124)=1
- MSUB(153)=1
- MSUB(171)=1
- MSUB(173)=1
- MSUB(174)=1
- MSUB(158)=1
- MSUB(176)=1
- MSUB(178)=1
- MSUB(179)=1
-
- ELSEIF(MSEL.EQ.21) THEN
-C...Z'0 production:
- MSUB(141)=1
-
- ELSEIF(MSEL.EQ.22) THEN
-C...W'+/- production:
- MSUB(142)=1
-
- ELSEIF(MSEL.EQ.23) THEN
-C...H+/- production:
- MSUB(143)=1
-
- ELSEIF(MSEL.EQ.24) THEN
-C...R production:
- MSUB(144)=1
-
- ELSEIF(MSEL.EQ.25) THEN
-C...LQ (leptoquark) production.
- MSUB(145)=1
- MSUB(162)=1
- MSUB(163)=1
- MSUB(164)=1
-
- ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
-C...Production of one heavy quark (W exchange):
- MSUB(83)=1
- DO 200 J=1,MIN(8,MDCY(21,3))
- MDME(MDCY(21,2)+J-1,1)=0
- 200 CONTINUE
- MDME(MDCY(21,2)+MSEL-31,1)=1
-
-CMRENNA++Define SUSY alternatives.
- ELSEIF(MSEL.EQ.39) THEN
-C...Turn on all SUSY processes.
- IF(MINT(43).EQ.4) THEN
-C...Hadron-hadron processes.
- DO 210 I=201,301
- IF(ISET(I).GE.0) MSUB(I)=1
- 210 CONTINUE
- ELSEIF(MINT(43).EQ.1) THEN
-C...Lepton-lepton processes: QED production of squarks.
- DO 220 I=201,214
- MSUB(I)=1
- 220 CONTINUE
- MSUB(210)=0
- MSUB(211)=0
- MSUB(212)=0
- DO 230 I=216,228
- MSUB(I)=1
- 230 CONTINUE
- DO 240 I=261,263
- MSUB(I)=1
- 240 CONTINUE
- MSUB(277)=1
- MSUB(278)=1
- ENDIF
-
- ELSEIF(MSEL.EQ.40) THEN
-C...Gluinos and squarks.
- IF(MINT(43).EQ.4) THEN
- MSUB(243)=1
- MSUB(244)=1
- MSUB(258)=1
- MSUB(259)=1
- MSUB(261)=1
- MSUB(262)=1
- MSUB(264)=1
- MSUB(265)=1
- DO 250 I=271,296
- MSUB(I)=1
- 250 CONTINUE
- ELSEIF(MINT(43).EQ.1) THEN
- MSUB(277)=1
- MSUB(278)=1
- ENDIF
-
- ELSEIF(MSEL.EQ.41) THEN
-C...Stop production.
- MSUB(261)=1
- MSUB(262)=1
- MSUB(263)=1
- IF(MINT(43).EQ.4) THEN
- MSUB(264)=1
- MSUB(265)=1
- ENDIF
-
- ELSEIF(MSEL.EQ.42) THEN
-C...Slepton production.
- DO 260 I=201,214
- MSUB(I)=1
- 260 CONTINUE
- IF(MINT(43).NE.4) THEN
- MSUB(210)=0
- MSUB(211)=0
- MSUB(212)=0
- ENDIF
-
- ELSEIF(MSEL.EQ.43) THEN
-C...Neutralino/Chargino + Gluino/Squark.
- IF(MINT(43).EQ.4) THEN
- DO 270 I=237,242
- MSUB(I)=1
- 270 CONTINUE
- DO 280 I=246,254
- MSUB(I)=1
- 280 CONTINUE
- MSUB(256)=1
- ENDIF
-
- ELSEIF(MSEL.EQ.44) THEN
-C...Neutralino/Chargino pair production.
- IF(MINT(43).EQ.4) THEN
- DO 290 I=216,236
- MSUB(I)=1
- 290 CONTINUE
- ELSEIF(MINT(43).EQ.1) THEN
- DO 300 I=216,228
- MSUB(I)=1
- 300 CONTINUE
- ENDIF
-
- ELSEIF(MSEL.EQ.45) THEN
-C...Sbottom production.
- MSUB(287)=1
- MSUB(288)=1
- IF(MINT(43).EQ.4) THEN
- DO 310 I=281,296
- MSUB(I)=1
- 310 CONTINUE
- ENDIF
-
- ELSEIF(MSEL.EQ.50) THEN
-C...Pair production of technipions and gauge bosons.
- DO 320 I=361,368
- MSUB(I)=1
- 320 CONTINUE
- IF(MINT(43).EQ.4) THEN
- DO 330 I=370,377
- MSUB(I)=1
- 330 CONTINUE
- ENDIF
-
- ELSEIF(MSEL.EQ.51) THEN
-C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
- DO 340 I=381,386
- MSUB(I)=1
- 340 CONTINUE
-
- ELSEIF(MSEL.EQ.61) THEN
-C...Charmonium production in colour octet model, with recoiling parton.
- DO 342 I=421,439
- MSUB(I)=1
- 342 CONTINUE
-
- ELSEIF(MSEL.EQ.62) THEN
-C...Bottomonium production in colour octet model, with recoiling parton.
- DO 344 I=461,479
- MSUB(I)=1
- 344 CONTINUE
-
- ELSEIF(MSEL.EQ.63) THEN
-C...Charmonium and bottomonium production in colour octet model.
- DO 346 I=421,439
- MSUB(I)=1
- MSUB(I+40)=1
- 346 CONTINUE
- ENDIF
-
-C...Find heaviest new quark flavour allowed in processes 81-84.
- KFLQM=1
- DO 350 I=1,MIN(8,MDCY(21,3))
- IDC=I+MDCY(21,2)-1
- IF(MDME(IDC,1).LE.0) GOTO 350
- KFLQM=I
- 350 CONTINUE
- IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
- &KFLQM=MSTP(7)
- MINT(55)=KFLQM
- KFPR(81,1)=KFLQM
- KFPR(81,2)=KFLQM
- KFPR(82,1)=KFLQM
- KFPR(82,2)=KFLQM
- KFPR(83,1)=KFLQM
- KFPR(84,1)=KFLQM
- KFPR(84,2)=KFLQM
-
-C...Find heaviest new fermion flavour allowed in process 85.
- KFLFM=1
- DO 360 I=1,MIN(12,MDCY(22,3))
- IDC=I+MDCY(22,2)-1
- IF(MDME(IDC,1).LE.0) GOTO 360
- KFLFM=KFDP(IDC,1)
- 360 CONTINUE
- IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
- &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
- MINT(56)=KFLFM
- KFPR(85,1)=KFLFM
- KFPR(85,2)=KFLFM
-
-C...Import relevant information on external user processes.
- IF(MINT(111).GE.11) THEN
- IPYPR=0
- DO 390 IUP=1,NPRUP
-C...Find next empty PYTHIA process number slot and enable it.
- 370 IPYPR=IPYPR+1
- IF(IPYPR.GT.500) CALL PYERRM(26,
- & '(PYINPR.) no more empty slots for user processes')
- IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
- IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
- ISET(IPYPR)=11
-C...Overwrite KFPR with references back to process number and ID.
- KFPR(IPYPR,1)=IUP
- KFPR(IPYPR,2)=LPRUP(IUP)
-C...Process title.
- WRITE(CHIPR,'(I10)') LPRUP(IUP)
- ICHIN=1
- DO 380 ICH=1,9
- IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
- 380 CONTINUE
- PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
-C...Switch on process.
- MSUB(IPYPR)=1
- 390 CONTINUE
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYXTOT
-C...Parametrizes total, elastic and diffractive cross-sections
-C...for different energies and beams. Donnachie-Landshoff for
-C...total and Schuler-Sjostrand for elastic and diffractive.
-C...Process code IPROC:
-C...= 1 : p + p;
-C...= 2 : pbar + p;
-C...= 3 : pi+ + p;
-C...= 4 : pi- + p;
-C...= 5 : pi0 + p;
-C...= 6 : phi + p;
-C...= 7 : J/psi + p;
-C...= 11 : rho + rho;
-C...= 12 : rho + phi;
-C...= 13 : rho + J/psi;
-C...= 14 : phi + phi;
-C...= 15 : phi + J/psi;
-C...= 16 : J/psi + J/psi;
-C...= 21 : gamma + p (DL);
-C...= 22 : gamma + p (VDM).
-C...= 23 : gamma + pi (DL);
-C...= 24 : gamma + pi (VDM);
-C...= 25 : gamma + gamma (DL);
-C...= 26 : gamma + gamma (VDM).
-
- SUBROUTINE PYXTOT
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
- SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
-C...Local arrays.
- DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
- &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
- &CEFFD(10,9),SIGTMP(6,0:5)
-
-C...Common constants.
- DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
- &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
- &FACDD/0.0084D0/
-
-C...Number of multiple processes to be evaluated (= 0 : undefined).
- DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
-C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
- DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
- &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
- &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
- DATA YPAR/
- &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
- &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
- &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
-
-C...Beam and target hadron class:
-C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
- DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
- DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
-C...Characteristic class masses, slope parameters, beta = sqrt(X).
- DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
- DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
- DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
-
-C...Fitting constants used in parametrizations of diffractive results.
- DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
- DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
- DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
- &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
- &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
- &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
- &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
- &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
- &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
- &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
- &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
- &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
- &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
- DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
- &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
- &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
- &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
- &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
- &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
- &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
- &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
- &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
- &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
- &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
- &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
- &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
- &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
- &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
- &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
-
-C...Parameters. Combinations of the energy.
- AEM=PARU(101)
- PMTH=PARP(102)
- S=VINT(2)
- SRT=VINT(1)
- SEPS=S**EPS
- SETA=S**ETA
- SLOG=LOG(S)
-
-C...Ratio of gamma/pi (for rescaling in parton distributions).
- VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
- &(XPAR(5)*SEPS+YPAR(5)*SETA)
- VINT(317)=1D0
- IF(MINT(50).NE.1) RETURN
-
-C...Order flavours of incoming particles: KF1 < KF2.
- IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
- KF1=IABS(MINT(11))
- KF2=IABS(MINT(12))
- IORD=1
- ELSE
- KF1=IABS(MINT(12))
- KF2=IABS(MINT(11))
- IORD=2
- ENDIF
- ISGN12=ISIGN(1,MINT(11)*MINT(12))
-
-C...Find process number (for lookup tables).
- IF(KF1.GT.1000) THEN
- IPROC=1
- IF(ISGN12.LT.0) IPROC=2
- ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
- IPROC=3
- IF(ISGN12.LT.0) IPROC=4
- IF(KF1.EQ.111) IPROC=5
- ELSEIF(KF1.GT.100) THEN
- IPROC=11
- ELSEIF(KF2.GT.1000) THEN
- IPROC=21
- IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
- ELSEIF(KF2.GT.100) THEN
- IPROC=23
- IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
- ELSE
- IPROC=25
- IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
- ENDIF
-
-C... Number of multiple processes to be stored; beam/target side.
- NPR=NPROC(IPROC)
- MINT(101)=1
- MINT(102)=1
- IF(NPR.EQ.3) THEN
- MINT(100+IORD)=4
- ELSEIF(NPR.EQ.6) THEN
- MINT(101)=4
- MINT(102)=4
- ENDIF
- N1=0
- IF(MINT(101).EQ.4) N1=4
- N2=0
- IF(MINT(102).EQ.4) N2=4
-
-C...Do not do any more for user-set or undefined cross-sections.
- IF(MSTP(31).LE.0) RETURN
- IF(NPR.EQ.0) CALL PYERRM(26,
- &'(PYXTOT:) cross section for this process not yet implemented')
-
-C...Parameters. Combinations of the energy.
- AEM=PARU(101)
- PMTH=PARP(102)
- S=VINT(2)
- SRT=VINT(1)
- SEPS=S**EPS
- SETA=S**ETA
- SLOG=LOG(S)
-
-C...Loop over multiple processes (for VDM).
- DO 110 I=1,NPR
- IF(NPR.EQ.1) THEN
- IPR=IPROC
- ELSEIF(NPR.EQ.3) THEN
- IPR=I+4
- IF(KF2.LT.1000) IPR=I+10
- ELSEIF(NPR.EQ.6) THEN
- IPR=I+10
- ENDIF
-
-C...Evaluate hadron species, mass, slope contribution and fit number.
- IHA=IHADA(IPR)
- IHB=IHADB(IPR)
- PMA=PMHAD(IHA)
- PMB=PMHAD(IHB)
- BHA=BHAD(IHA)
- BHB=BHAD(IHB)
- ISD=IFITSD(IPR)
- IDD=IFITDD(IPR)
-
-C...Skip if energy too low relative to masses.
- DO 100 J=0,5
- SIGTMP(I,J)=0D0
- 100 CONTINUE
- IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
-
-C...Total cross-section. Elastic slope parameter and cross-section.
- SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
- BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
- SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
-
-C...Diffractive scattering A + B -> X + B.
- BSD=2D0*BHB
- SQML=(PMA+PMTH)**2
- SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
- SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
- & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
- BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
- SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
- & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
- SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
-
-C...Diffractive scattering A + B -> A + X.
- BSD=2D0*BHA
- SQML=(PMB+PMTH)**2
- SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
- SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
- & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
- BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
- SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
- & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
- SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
-
-C...Order single diffractive correctly.
- IF(IORD.EQ.2) THEN
- SIGSAV=SIGTMP(I,2)
- SIGTMP(I,2)=SIGTMP(I,3)
- SIGTMP(I,3)=SIGSAV
- ENDIF
-
-C...Double diffractive scattering A + B -> X1 + X2.
- YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
- DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
- SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
- IF(YEFF.LE.0) SUM1=0D0
- SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
- SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
- SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
- SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
- & (2D0*ALP)
- SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
- SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
- SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
- & (2D0*ALP)
- BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
- SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
- SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
- & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
- SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
-
-C...Non-diffractive by unitarity.
- SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
- & SIGTMP(I,4)
- 110 CONTINUE
-
-C...Put temporary results in output array: only one process.
- IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
- DO 120 J=0,5
- SIGT(0,0,J)=SIGTMP(1,J)
- 120 CONTINUE
-
-C...Beam multiple processes.
- ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
- IF(MINT(107).EQ.2) THEN
- VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
- ELSE
- VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
- & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
- ENDIF
- IF(MSTP(20).GT.0) THEN
- VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
- ENDIF
- DO 140 I=1,4
- IF(MINT(107).EQ.2) THEN
- CONV=(AEM/PARP(160+I))*VINT(317)
- ELSEIF(VINT(154).GT.PARP(15)) THEN
- CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
- & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
- ELSE
- CONV=0D0
- ENDIF
- I1=MAX(1,I-1)
- DO 130 J=0,5
- SIGT(I,0,J)=CONV*SIGTMP(I1,J)
- 130 CONTINUE
- 140 CONTINUE
- DO 150 J=0,5
- SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
- 150 CONTINUE
-
-C...Target multiple processes.
- ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
- IF(MINT(108).EQ.2) THEN
- VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
- ELSE
- VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
- & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
- ENDIF
- IF(MSTP(20).GT.0) THEN
- VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
- ENDIF
- DO 170 I=1,4
- IF(MINT(108).EQ.2) THEN
- CONV=(AEM/PARP(160+I))*VINT(317)
- ELSEIF(VINT(154).GT.PARP(15)) THEN
- CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
- & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
- ELSE
- CONV=0D0
- ENDIF
- IV=MAX(1,I-1)
- DO 160 J=0,5
- SIGT(0,I,J)=CONV*SIGTMP(IV,J)
- 160 CONTINUE
- 170 CONTINUE
- DO 180 J=0,5
- SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
- 180 CONTINUE
-
-C...Both beam and target multiple processes.
- ELSE
- IF(MINT(107).EQ.2) THEN
- VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
- ELSE
- VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
- & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
- ENDIF
- IF(MINT(108).EQ.2) THEN
- VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
- ELSE
- VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
- & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
- ENDIF
- IF(MSTP(20).GT.0) THEN
- VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
- & VINT(308)))**MSTP(20)
- ENDIF
- DO 210 I1=1,4
- DO 200 I2=1,4
- IF(MINT(107).EQ.2) THEN
- CONV=(AEM/PARP(160+I1))*VINT(317)
- ELSEIF(VINT(154).GT.PARP(15)) THEN
- CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
- & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
- ELSE
- CONV=0D0
- ENDIF
- IF(MINT(108).EQ.2) THEN
- CONV=CONV*(AEM/PARP(160+I2))
- ELSEIF(VINT(154).GT.PARP(15)) THEN
- CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
- & (1D0/PARP(15)**2-1D0/VINT(154)**2)
- ELSE
- CONV=0D0
- ENDIF
- IF(I1.LE.2) THEN
- IV=MAX(1,I2-1)
- ELSEIF(I2.LE.2) THEN
- IV=MAX(1,I1-1)
- ELSEIF(I1.EQ.I2) THEN
- IV=2*I1-2
- ELSE
- IV=5
- ENDIF
- DO 190 J=0,5
- JV=J
- IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
- SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
- 190 CONTINUE
- 200 CONTINUE
- 210 CONTINUE
- DO 230 J=0,5
- DO 220 I=1,4
- SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
- SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
- 220 CONTINUE
- SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
- 230 CONTINUE
- ENDIF
-
-C...Scale up uniformly for Donnachie-Landshoff parametrization.
- IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
- RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
- DO 260 I1=0,N1
- DO 250 I2=0,N2
- DO 240 J=0,5
- SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
- 240 CONTINUE
- 250 CONTINUE
- 260 CONTINUE
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYMAXI
-C...Finds optimal set of coefficients for kinematical variable selection
-C...and the maximum of the part of the differential cross-section used
-C...in the event weighting.
-
- SUBROUTINE PYMAXI
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-
-C...User process initialization commonblock.
- INTEGER MAXPUP
- PARAMETER (MAXPUP=100)
- INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
- DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
- COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
- &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
- &LPRUP(MAXPUP)
- SAVE /HEPRUP/
-
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- COMMON/PYINT6/PROC(0:500)
- CHARACTER PROC*28
- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
- COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
- COMMON/PYTCCO/COEFX(194:380,2)
- COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
- &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
- &/PYTCSM/,/TCPARA/
-C...Local arrays, character variables and data.
- LOGICAL IOK
- CHARACTER CVAR(4)*4
- DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
- &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
- &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
- DATA CVAR/'tau ','tau''','y* ','cth '/
- DATA SIGSSM/3*0D0/
-
-C...Initial values and loop over subprocesses.
- NPOSI=0
- VINT(143)=1D0
- VINT(144)=1D0
- XSEC(0,1)=0D0
- ITECH=0
- DO 460 ISUB=1,500
- MINT(1)=ISUB
- MINT(51)=0
-
-C...Find maximum weight factors for photon flux.
- IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
- ENDIF
-
-C...Select subprocess to study: skip cases not applicable.
- IF(ISET(ISUB).EQ.11) THEN
- IF(MSUB(ISUB).NE.1) GOTO 460
-C...User process intialization: cross section model dependent.
- IF(IABS(IDWTUP).EQ.1) THEN
- IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
- & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
- XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
- ELSE
- IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
- & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
- & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
- IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
- & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
- XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
- ENDIF
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
- & WTGAGA*XSEC(ISUB,1)
- NPOSI=NPOSI+1
- GOTO 450
- ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
- CALL PYSIGH(NCHN,SIGS)
- XSEC(ISUB,1)=SIGS
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
- & WTGAGA*XSEC(ISUB,1)
- IF(MSUB(ISUB).NE.1) GOTO 460
- NPOSI=NPOSI+1
- GOTO 450
- ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
- CALL PYSIGH(NCHN,SIGS)
- XSEC(ISUB,1)=SIGS
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
- & WTGAGA*XSEC(ISUB,1)
- IF(XSEC(ISUB,1).EQ.0D0) THEN
- MSUB(ISUB)=0
- ELSE
- NPOSI=NPOSI+1
- ENDIF
- GOTO 450
- ELSEIF(ISUB.EQ.96) THEN
- IF(MINT(50).EQ.0) GOTO 460
- IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
- & GOTO 460
- IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
- ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
- & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
- IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
- ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
- IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
- ELSE
- IF(MSUB(ISUB).NE.1) GOTO 460
- ENDIF
- ISTSB=ISET(ISUB)
- IF(ISUB.EQ.96) ISTSB=2
- IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
- MWTXS=0
- IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
- & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
-
-C...Find resonances (explicit or implicit in cross-section).
- MINT(72)=0
- KFR1=0
- IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
- KFR1=KFPR(ISUB,1)
- ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
- & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
- KFR1=23
- ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
- & .OR.ISUB.EQ.177) THEN
- KFR1=24
- ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
- KFR1=25
- IF(MSTP(46).EQ.5) THEN
- KFR1=89
- PMAS(89,1)=PARP(45)
- PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
- ENDIF
- ENDIF
- CKMX=CKIN(2)
- IF(CKMX.LE.0D0) CKMX=VINT(1)
- KCR1=PYCOMP(KFR1)
- IF(KFR1.NE.0) THEN
- IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
- & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
- ENDIF
- IF(KFR1.NE.0) THEN
- TAUR1=PMAS(KCR1,1)**2/VINT(2)
- GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
- MINT(72)=1
- MINT(73)=KFR1
- VINT(73)=TAUR1
- VINT(74)=GAMR1
- ENDIF
- KFR2=0
- KFR3=0
- IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
- $ (ISUB.GE.361.AND.ISUB.LE.380))
- $ THEN
- KFR2=23
- IF(ISUB.EQ.141) THEN
- KCR2=PYCOMP(KFR2)
- IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
- & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
- KFR2=0
- ELSE
- TAUR2=PMAS(KCR2,1)**2/VINT(2)
- GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
- MINT(72)=2
- MINT(74)=KFR2
- VINT(75)=TAUR2
- VINT(76)=GAMR2
- ENDIF
- ELSEIF(ITECH.EQ.0) THEN
- ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
- ITECH=1
- KFR1=KTECHN+113
- KCR1=PYCOMP(KFR1)
- KFR2=KTECHN+223
- KCR2=PYCOMP(KFR2)
- KFR3=KTECHN+115
- KCR3=PYCOMP(KFR3)
- IRES=0
-C...Order the resonances
- IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
- KCT=KCR3
- KCR3=KCR2
- KCR2=KCT
- ENDIF
- IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
- KCT=KCR3
- KCR3=KCR1
- KCR1=KCT
- ENDIF
- IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
- KCT=KCR2
- KCR2=KCR1
- KCR1=KCT
- ENDIF
- DO 101 I=1,3
- IF(I.EQ.1) THEN
- SHN0=PMAS(KCR1,1)**2
- ELSEIF(I.EQ.2) THEN
- IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
- SHN0=PMAS(KCR2,1)**2
- ELSEIF(I.EQ.3) THEN
- IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
- SHN0=PMAS(KCR3,1)**2
- ENDIF
- AEM=PYALEM(SHN0)
- FAR=SQRT(AEM/ALPRHT)
- SHN=SHN0*(1D0-FAR)
- CALL PYTECM(SHN,S1,WIDO,1)
- RES=SHN-S1
- SHN=S1*.99D0
- SHSTEP=2D0
- 102 SHN=SHN+SHSTEP
- CALL PYTECM(SHN,S1,WIDO,1)
- IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
- IOK=.FALSE.
- IF(IRES.GT.0) THEN
- IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
- ELSEIF(IRES.EQ.0) THEN
- IOK=.TRUE.
- ENDIF
- IF(IOK) THEN
- IRES=IRES+1
- XMAS(IRES)=SQRT(S1)
- XWID(IRES)=WIDO
- ENDIF
- ENDIF
- RES=SHN-S1
- IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
- 101 CONTINUE
- JRES=0
- KFR1=KTECHN+213
- KCR1=PYCOMP(KFR1)
- KFR2=KTECHN+215
- KCR2=PYCOMP(KFR2)
- IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
- KCT=KCR2
- KCR2=KCR1
- KCR1=KCT
- ENDIF
- DO 103 I=1,2
- IF(I.EQ.1) THEN
- SHN0=PMAS(KCR1,1)**2
- ELSEIF(I.EQ.2) THEN
- IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
- SHN0=PMAS(KCR2,1)**2
- ENDIF
- AEM=PYALEM(SHN0)
- FAR=SQRT(AEM/ALPRHT)
- SHN=SHN0*(1D0-FAR)
- CALL PYTECM(SHN,S1,WIDO,2)
- RES=SHN-S1
- SHN=S1*.99D0
- SHSTEP=2D0
- 104 SHN=SHN+SHSTEP
- CALL PYTECM(SHN,S1,WIDO,2)
- IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
- IOK=.FALSE.
- IF(JRES.GT.0) THEN
- IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
- ELSEIF(JRES.EQ.0) THEN
- IOK=.TRUE.
- ENDIF
- IF(IOK) THEN
- JRES=JRES+1
- YMAS(JRES)=SQRT(S1)
- YWID(JRES)=WIDO
- ENDIF
- ENDIF
- RES=SHN-S1
- IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
- 103 CONTINUE
- ENDIF
- IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
- & ISUB.EQ.379.OR.ISUB.EQ.380) THEN
- MINT(72)=IRES
- IF(IRES.GE.1) THEN
- VINT(73)=XMAS(1)**2/VINT(2)
- VINT(74)=XMAS(1)*XWID(1)/VINT(2)
- TAUR1=VINT(73)
- GAMR1=VINT(74)
- XM1=XMAS(1)
- XG1=XWID(1)
- KFR1=1
- ENDIF
- IF(IRES.GE.2) THEN
- VINT(75)=XMAS(2)**2/VINT(2)
- VINT(76)=XMAS(2)*XWID(2)/VINT(2)
- TAUR2=VINT(75)
- GAMR2=VINT(76)
- XM2=XMAS(2)
- XG2=XWID(2)
- KFR2=2
- ENDIF
- IF(IRES.EQ.3) THEN
- VINT(77)=XMAS(3)**2/VINT(2)
- VINT(78)=XMAS(3)*XWID(3)/VINT(2)
- TAUR3=VINT(77)
- GAMR3=VINT(78)
- XM3=XMAS(3)
- XG3=XWID(3)
- KFR3=3
- ENDIF
-C...Charged current: rho+- and a+-
- ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
- MINT(72)=IRES
- IF(JRES.GE.1) THEN
- VINT(73)=YMAS(1)**2/VINT(2)
- VINT(74)=YMAS(1)*YWID(1)/VINT(2)
- KFR1=1
- TAUR1=VINT(73)
- GAMR1=VINT(74)
- XM1=YMAS(1)
- XG1=YWID(1)
- ENDIF
- IF(JRES.GE.2) THEN
- VINT(75)=YMAS(2)**2/VINT(2)
- VINT(76)=YMAS(2)*YWID(2)/VINT(2)
- KFR2=2
- TAUR2=VINT(73)
- GAMR2=VINT(74)
- XM2=YMAS(2)
- XG2=YWID(2)
- ENDIF
- KFR3=0
- ENDIF
- IF(ISUB.NE.141) THEN
- IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
- & .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
- IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
- & .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
- IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
- & .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
- IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
-
- ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
- MINT(72)=2
- ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
- MINT(72)=2
- MINT(74)=KFR3
- VINT(75)=TAUR3
- VINT(76)=GAMR3
- ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
- MINT(72)=2
- MINT(73)=KFR2
- VINT(73)=TAUR2
- VINT(74)=GAMR2
- MINT(74)=KFR3
- VINT(75)=TAUR3
- VINT(76)=GAMR3
- ELSEIF(KFR1.NE.0) THEN
- MINT(72)=1
- ELSEIF(KFR2.NE.0) THEN
- MINT(72)=1
- MINT(73)=KFR2
- VINT(73)=TAUR2
- VINT(74)=GAMR2
- ELSEIF(KFR3.NE.0) THEN
- MINT(72)=1
- MINT(73)=KFR3
- VINT(73)=TAUR3
- VINT(74)=GAMR3
- ELSE
- MINT(72)=0
- ENDIF
- ELSE
- IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
-
- ELSEIF(KFR2.NE.0) THEN
- KFR1=KFR2
- TAUR1=TAUR2
- GAMR1=GAMR2
- MINT(72)=1
- MINT(73)=KFR1
- VINT(73)=TAUR1
- VINT(74)=GAMR1
- KFR2=0
- ELSE
- MINT(72)=0
- ENDIF
- ENDIF
- ENDIF
-
-C...Find product masses and minimum pT of process.
- SQM3=0D0
- SQM4=0D0
- MINT(71)=0
- VINT(71)=CKIN(3)
- VINT(80)=1D0
- IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
- NBW=0
- DO 110 I=1,2
- PMMN(I)=0D0
- IF(KFPR(ISUB,I).EQ.0) THEN
- ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
- & PARP(41)) THEN
- IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
- IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
- ELSE
- NBW=NBW+1
-C...This prevents SUSY/t particles from becoming too light.
- KFLW=KFPR(ISUB,I)
- IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
- KCW=PYCOMP(KFLW)
- PMMN(I)=PMAS(KCW,1)
- DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
- IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
- PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
- & PMAS(PYCOMP(KFDP(IDC,2)),1)
- IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
- & PMAS(PYCOMP(KFDP(IDC,3)),1)
- PMMN(I)=MIN(PMMN(I),PMSUM)
- ENDIF
- 100 CONTINUE
- ELSEIF(KFLW.EQ.6) THEN
- PMMN(I)=PMAS(24,1)+PMAS(5,1)
- ENDIF
- ENDIF
- 110 CONTINUE
- IF(NBW.GE.1) THEN
- CKIN41=CKIN(41)
- CKIN43=CKIN(43)
- CKIN(41)=MAX(PMMN(1),CKIN(41))
- CKIN(43)=MAX(PMMN(2),CKIN(43))
- CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
- CKIN(41)=CKIN41
- CKIN(43)=CKIN43
- IF(MINT(51).EQ.1) THEN
- WRITE(MSTU(11),5100) ISUB
- MSUB(ISUB)=0
- GOTO 460
- ENDIF
- SQM3=PQM3**2
- SQM4=PQM4**2
- ENDIF
- IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
- IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
- IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
- VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
- ELSEIF(ISUB.EQ.96) THEN
- VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
- ENDIF
- ENDIF
- VINT(63)=SQM3
- VINT(64)=SQM4
-
-C...Prepare for additional variable choices in 2 -> 3.
- IF(ISTSB.EQ.5) THEN
- VINT(201)=0D0
- IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
- VINT(206)=VINT(201)
- IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
- VINT(204)=PMAS(23,1)
- IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
- IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
- IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
- & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
- & VINT(204)=VINT(201)
- VINT(209)=VINT(204)
- IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
- ENDIF
-
-C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
- IPEAK7=0
- NPTS(1)=2+2*MINT(72)
- IF(MINT(47).EQ.1) THEN
- IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
- ELSEIF(MINT(47).GE.5) THEN
- IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN
- NPTS(1)=NPTS(1)+1
- IPEAK7=1
- ENDIF
- ENDIF
- NPTS(2)=1
- IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
- IF(MINT(47).GE.2) NPTS(2)=2
- IF(MINT(47).GE.5) NPTS(2)=3
- ENDIF
- NPTS(3)=1
- IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
- NPTS(3)=3
- IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
- IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
- ENDIF
- NPTS(4)=1
- IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
- NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
-
-C...Reset coefficients of cross-section weighting.
- DO 120 J=1,20
- COEF(ISUB,J)=0D0
- 120 CONTINUE
- IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
- & .AND.ISUB.LE.380)) THEN
- DO 125 J=1,2
- COEFX(ISUB,J)=0D0
- 125 CONTINUE
- ENDIF
- COEF(ISUB,1)=1D0
- COEF(ISUB,8)=0.5D0
- COEF(ISUB,9)=0.5D0
- COEF(ISUB,13)=1D0
- COEF(ISUB,18)=1D0
- MCTH=0
- MTAUP=0
- METAUP=0
- VINT(23)=0D0
- VINT(26)=0D0
- SIGSAM=0D0
-
-C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
-C...in grid of phase space points.
- CALL PYKLIM(1)
- METAU=MINT(51)
- NACC=0
- DO 150 ITRY=1,NTRY
- MINT(51)=0
- IF(METAU.EQ.1) GOTO 150
- IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
- MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
- IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
- MTAU=7
- ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
- MTAU=MTAU+1
- ENDIF
- RTAU=0.5D0
-C...Special case when both resonances have same mass,
-C...as is often the case in process 194.
-c IF(MINT(72).GE.2) THEN
-c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
-c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
-c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
-c RTAU=0.4D0
-c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
-c RTAU=0.6D0
-c ENDIF
-c ENDIF
-c ENDIF
- CALL PYKMAP(1,MTAU,RTAU)
- IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
- METAUP=MINT(51)
- ENDIF
- IF(METAUP.EQ.1) GOTO 150
- IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
- & .EQ.0) THEN
- MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
- CALL PYKMAP(4,MTAUP,0.5D0)
- ENDIF
- IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
- CALL PYKLIM(2)
- MEYST=MINT(51)
- ENDIF
- IF(MEYST.EQ.1) GOTO 150
- IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
- MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
- IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
- CALL PYKMAP(2,MYST,0.5D0)
- CALL PYKLIM(3)
- MECTH=MINT(51)
- ENDIF
- IF(MECTH.EQ.1) GOTO 150
- IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
- MCTH=1+MOD(ITRY-1,NPTS(4))
- CALL PYKMAP(3,MCTH,0.5D0)
- ENDIF
- IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
-
-C...Store position and limits.
- MINT(51)=0
- CALL PYKLIM(0)
- IF(MINT(51).EQ.1) GOTO 150
- NACC=NACC+1
- MVARPT(NACC,1)=MTAU
- MVARPT(NACC,2)=MTAUP
- MVARPT(NACC,3)=MYST
- MVARPT(NACC,4)=MCTH
- DO 130 J=1,30
- VINTPT(NACC,J)=VINT(10+J)
- 130 CONTINUE
-
-C...Normal case: calculate cross-section.
- IF(ISTSB.NE.5) THEN
- CALL PYSIGH(NCHN,SIGS)
- IF(MWTXS.EQ.1) THEN
- CALL PYEVWT(WTXS)
- SIGS=WTXS*SIGS
- ENDIF
-
-C..2 -> 3: find highest value out of a number of tries.
- ELSE
- SIGS=0D0
- DO 140 IKIN3=1,MSTP(129)
- CALL PYKMAP(5,0,0D0)
- IF(MINT(51).EQ.1) GOTO 140
- CALL PYSIGH(NCHN,SIGTMP)
- IF(MWTXS.EQ.1) THEN
- CALL PYEVWT(WTXS)
- SIGTMP=WTXS*SIGTMP
- ENDIF
- IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
- 140 CONTINUE
- ENDIF
-
-C...Store cross-section.
- SIGSPT(NACC)=SIGS
- IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
- IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
- & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
- 150 CONTINUE
- IF(NACC.EQ.0) THEN
- WRITE(MSTU(11),5100) ISUB
- MSUB(ISUB)=0
- GOTO 460
- ELSEIF(SIGSAM.EQ.0D0) THEN
- WRITE(MSTU(11),5300) ISUB
- MSUB(ISUB)=0
- GOTO 460
- ENDIF
- IF(ISUB.NE.96) NPOSI=NPOSI+1
-
-C...Calculate integrals in tau over maximal phase space limits.
- TAUMIN=VINT(11)
- TAUMAX=VINT(31)
- ATAU1=LOG(TAUMAX/TAUMIN)
- IF(NPTS(1).GE.2) THEN
- ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
- ENDIF
- IF(NPTS(1).GE.4) THEN
- ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
- ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
- & GAMR1
- ENDIF
- IF(NPTS(1).GE.6) THEN
- ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
- ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
- & GAMR2
- ENDIF
- IF(NPTS(1).GE.8) THEN
- ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
- ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
- & GAMR3
- ENDIF
- IF(IPEAK7.EQ.1) THEN
- ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
- ENDIF
-
-C...Reset. Sum up cross-sections in points calculated.
- DO 320 IVAR=1,4
- IF(NPTS(IVAR).EQ.1) GOTO 320
- IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
- NBIN=NPTS(IVAR)
- DO 170 J1=1,NBIN
- NAREL(J1)=0
- WTREL(J1)=0D0
- COEFU(J1)=0D0
- DO 160 J2=1,NBIN
- WTMAT(J1,J2)=0D0
- 160 CONTINUE
- 170 CONTINUE
- DO 180 IACC=1,NACC
- IBIN=MVARPT(IACC,IVAR)
- IF(IVAR.EQ.1) THEN
- IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
- IBIN=IBIN-1
- ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
- IBIN=3+2*MINT(72)
- ENDIF
- ENDIF
- IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
- NAREL(IBIN)=NAREL(IBIN)+1
- WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
-
-C...Sum up tau cross-section pieces in points used.
- IF(IVAR.EQ.1) THEN
- TAU=VINTPT(IACC,11)
- WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
- WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
- IF(NBIN.GE.4) THEN
- WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
- WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
- & ((TAU-TAUR1)**2+GAMR1**2)
- ENDIF
- IF(NBIN.GE.6) THEN
- WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
- WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
- & ((TAU-TAUR2)**2+GAMR2**2)
- ENDIF
- IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
- WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
- & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
- ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
- WTMAT(IBIN,7)=WTMAT(IBIN,7)
- & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
- ENDIF
- IF(MINT(72).EQ.3) THEN
- WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
- & +(ATAU1/ATAU8)/(TAU+TAUR3)
- WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
- & +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
- ENDIF
-C...Sum up tau' cross-section pieces in points used.
- ELSEIF(IVAR.EQ.2) THEN
- TAU=VINTPT(IACC,11)
- TAUP=VINTPT(IACC,16)
- TAUPMN=VINTPT(IACC,6)
- TAUPMX=VINTPT(IACC,26)
- ATAUP1=LOG(TAUPMX/TAUPMN)
- ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
- WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
- WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
- & (1D0-TAU/TAUP)**3/TAUP
- IF(NBIN.GE.3) THEN
- ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
- WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
- & TAUP/MAX(2D-10,1D0-TAUP)
- ENDIF
-
-C...Sum up y* cross-section pieces in points used.
- ELSEIF(IVAR.EQ.3) THEN
- YST=VINTPT(IACC,12)
- YSTMIN=VINTPT(IACC,2)
- YSTMAX=VINTPT(IACC,22)
- AYST0=YSTMAX-YSTMIN
- AYST1=0.5D0*(YSTMAX-YSTMIN)**2
- AYST2=AYST1
- AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
- WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
- WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
- WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
- IF(MINT(45).EQ.3) THEN
- TAUE=VINTPT(IACC,11)
- IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
- YST0=-0.5D0*LOG(TAUE)
- AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
- & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
- WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
- & MAX(1D-10,1D0-EXP(YST-YST0))
- ENDIF
- IF(MINT(46).EQ.3) THEN
- TAUE=VINTPT(IACC,11)
- IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
- YST0=-0.5D0*LOG(TAUE)
- AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
- & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
- WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
- & MAX(1D-10,1D0-EXP(-YST-YST0))
- ENDIF
-
-C...Sum up cos(theta-hat) cross-section pieces in points used.
- ELSE
- RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
- RSQM=1D0+RM34
- CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
- CTHMIN=-CTHMAX
- IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
- & (TAUMAX*VINT(2)))
- ACTH1=CTHMAX-CTHMIN
- ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
- ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
- ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
- ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
- CTH=VINTPT(IACC,13)
- WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
- WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
- & MAX(RM34,RSQM-CTH)
- WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
- & MAX(RM34,RSQM+CTH)
- WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
- & MAX(RM34,RSQM-CTH)**2
- WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
- & MAX(RM34,RSQM+CTH)**2
- ENDIF
- 180 CONTINUE
-
-C...Check that equation system solvable.
- IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
- MSOLV=1
- WTRELS=0D0
- DO 190 IBIN=1,NBIN
- IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
- & IRED=1,NBIN),WTREL(IBIN)
- IF(NAREL(IBIN).EQ.0) MSOLV=0
- WTRELS=WTRELS+WTREL(IBIN)
- 190 CONTINUE
- IF(ABS(WTRELS).LT.1D-20) MSOLV=0
-
-C...Solve to find relative importance of cross-section pieces.
- IF(MSOLV.EQ.1) THEN
- DO 200 IBIN=1,NBIN
- WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
- 200 CONTINUE
- DO 230 IRED=1,NBIN-1
- DO 220 IBIN=IRED+1,NBIN
- IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
- MSOLV=0
- GOTO 260
- ENDIF
- RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
- WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
- DO 210 ICOE=IRED,NBIN
- WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
- 210 CONTINUE
- 220 CONTINUE
- 230 CONTINUE
- DO 250 IRED=NBIN,1,-1
- DO 240 ICOE=IRED+1,NBIN
- WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
- 240 CONTINUE
- COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
- 250 CONTINUE
- ENDIF
-
-C...Share evenly if failure.
- 260 IF(MSOLV.EQ.0) THEN
- DO 270 IBIN=1,NBIN
- COEFU(IBIN)=1D0
- WTRELN(IBIN)=0.1D0
- IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
- & WTREL(IBIN)/WTRELS)
- 270 CONTINUE
- ENDIF
-
-C...Normalize coefficients, with piece shared democratically.
- COEFSU=0D0
- WTRELS=0D0
- DO 280 IBIN=1,NBIN
- COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
- COEFSU=COEFSU+COEFU(IBIN)
- WTRELS=WTRELS+WTRELN(IBIN)
- 280 CONTINUE
- IF(COEFSU.GT.0D0) THEN
- DO 290 IBIN=1,NBIN
- COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
- & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
- 290 CONTINUE
- ELSE
- DO 300 IBIN=1,NBIN
- COEFO(IBIN)=1D0/NBIN
- 300 CONTINUE
- ENDIF
- IF(IVAR.EQ.1) IOFF=0
- IF(IVAR.EQ.2) IOFF=17
- IF(IVAR.EQ.3) IOFF=7
- IF(IVAR.EQ.4) IOFF=12
- DO 310 IBIN=1,NBIN
- ICOF=IOFF+IBIN
- IF(IVAR.EQ.1) THEN
- IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
- ICOF=7
- ENDIF
- ENDIF
- IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
- IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
- COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
- ELSE
- COEF(ISUB,ICOF)=COEFO(IBIN)
- ENDIF
- 310 CONTINUE
-
- IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
- & (COEFO(IBIN),IBIN=1,NBIN)
-
- 320 CONTINUE
-
-C...Find two most promising maxima among points previously determined.
- DO 330 J=1,4
- IACCMX(J)=0
- SIGSMX(J)=0D0
- 330 CONTINUE
- NMAX=0
- DO 390 IACC=1,NACC
- DO 340 J=1,30
- VINT(10+J)=VINTPT(IACC,J)
- 340 CONTINUE
- IF(ISTSB.NE.5) THEN
- CALL PYSIGH(NCHN,SIGS)
- IF(MWTXS.EQ.1) THEN
- CALL PYEVWT(WTXS)
- SIGS=WTXS*SIGS
- ENDIF
- ELSE
- SIGS=0D0
- DO 350 IKIN3=1,MSTP(129)
- CALL PYKMAP(5,0,0D0)
- IF(MINT(51).EQ.1) GOTO 350
- CALL PYSIGH(NCHN,SIGTMP)
- IF(MWTXS.EQ.1) THEN
- CALL PYEVWT(WTXS)
- SIGTMP=WTXS*SIGTMP
- ENDIF
- IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
- 350 CONTINUE
- ENDIF
- IEQ=0
- DO 360 IMV=1,NMAX
- IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
- 360 CONTINUE
- IF(IEQ.EQ.0) THEN
- DO 370 IMV=NMAX,1,-1
- IIN=IMV+1
- IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
- IACCMX(IMV+1)=IACCMX(IMV)
- SIGSMX(IMV+1)=SIGSMX(IMV)
- 370 CONTINUE
- IIN=1
- 380 IACCMX(IIN)=IACC
- SIGSMX(IIN)=SIGS
- IF(NMAX.LE.1) NMAX=NMAX+1
- ENDIF
- 390 CONTINUE
-
-C...Read out starting position for search.
- IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
- SIGSAM=SIGSMX(1)
- DO 440 IMAX=1,NMAX
- IACC=IACCMX(IMAX)
- MTAU=MVARPT(IACC,1)
- MTAUP=MVARPT(IACC,2)
- MYST=MVARPT(IACC,3)
- MCTH=MVARPT(IACC,4)
- VTAU=0.5D0
- VYST=0.5D0
- VCTH=0.5D0
- VTAUP=0.5D0
-
-C...Starting point and step size in parameter space.
- DO 430 IRPT=1,2
- DO 420 IVAR=1,4
- IF(NPTS(IVAR).EQ.1) GOTO 420
- IF(IVAR.EQ.1) VVAR=VTAU
- IF(IVAR.EQ.2) VVAR=VTAUP
- IF(IVAR.EQ.3) VVAR=VYST
- IF(IVAR.EQ.4) VVAR=VCTH
- IF(IVAR.EQ.1) MVAR=MTAU
- IF(IVAR.EQ.2) MVAR=MTAUP
- IF(IVAR.EQ.3) MVAR=MYST
- IF(IVAR.EQ.4) MVAR=MCTH
- IF(IRPT.EQ.1) VDEL=0.1D0
- IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
- & 0.98D0-VVAR))
- IF(IRPT.EQ.1) VMAR=0.02D0
- IF(IRPT.EQ.2) VMAR=0.002D0
- IMOV0=1
- IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
- DO 410 IMOV=IMOV0,8
-
-C...Define new point in parameter space.
- IF(IMOV.EQ.0) THEN
- INEW=2
- VNEW=VVAR
- ELSEIF(IMOV.EQ.1) THEN
- INEW=3
- VNEW=VVAR+VDEL
- ELSEIF(IMOV.EQ.2) THEN
- INEW=1
- VNEW=VVAR-VDEL
- ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
- & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
- VVAR=VVAR+VDEL
- SIGSSM(1)=SIGSSM(2)
- SIGSSM(2)=SIGSSM(3)
- INEW=3
- VNEW=VVAR+VDEL
- ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
- & VVAR-2D0*VDEL.GT.VMAR) THEN
- VVAR=VVAR-VDEL
- SIGSSM(3)=SIGSSM(2)
- SIGSSM(2)=SIGSSM(1)
- INEW=1
- VNEW=VVAR-VDEL
- ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
- VDEL=0.5D0*VDEL
- VVAR=VVAR+VDEL
- SIGSSM(1)=SIGSSM(2)
- INEW=2
- VNEW=VVAR
- ELSE
- VDEL=0.5D0*VDEL
- VVAR=VVAR-VDEL
- SIGSSM(3)=SIGSSM(2)
- INEW=2
- VNEW=VVAR
- ENDIF
-
-C...Convert to relevant variables and find derived new limits.
- ILERR=0
- IF(IVAR.EQ.1) THEN
- VTAU=VNEW
- CALL PYKMAP(1,MTAU,VTAU)
- IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
- CALL PYKLIM(4)
- IF(MINT(51).EQ.1) ILERR=1
- ENDIF
- ENDIF
- IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
- & ILERR.EQ.0) THEN
- IF(IVAR.EQ.2) VTAUP=VNEW
- CALL PYKMAP(4,MTAUP,VTAUP)
- ENDIF
- IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
- CALL PYKLIM(2)
- IF(MINT(51).EQ.1) ILERR=1
- ENDIF
- IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
- IF(IVAR.EQ.3) VYST=VNEW
- CALL PYKMAP(2,MYST,VYST)
- CALL PYKLIM(3)
- IF(MINT(51).EQ.1) ILERR=1
- ENDIF
- IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
- & ILERR.EQ.0) THEN
- IF(IVAR.EQ.4) VCTH=VNEW
- CALL PYKMAP(3,MCTH,VCTH)
- ENDIF
- IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
-
-C...Evaluate cross-section. Save new maximum. Final maximum.
- IF(ILERR.NE.0) THEN
- SIGS=0.
- ELSEIF(ISTSB.NE.5) THEN
- CALL PYSIGH(NCHN,SIGS)
- IF(MWTXS.EQ.1) THEN
- CALL PYEVWT(WTXS)
- SIGS=WTXS*SIGS
- ENDIF
- ELSE
- SIGS=0D0
- DO 400 IKIN3=1,MSTP(129)
- CALL PYKMAP(5,0,0D0)
- IF(MINT(51).EQ.1) GOTO 400
- CALL PYSIGH(NCHN,SIGTMP)
- IF(MWTXS.EQ.1) THEN
- CALL PYEVWT(WTXS)
- SIGTMP=WTXS*SIGTMP
- ENDIF
- IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
- 400 CONTINUE
- ENDIF
- SIGSSM(INEW)=SIGS
- IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
- IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
- & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
- 410 CONTINUE
- 420 CONTINUE
- 430 CONTINUE
- 440 CONTINUE
- IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
- XSEC(ISUB,1)=1.05D0*SIGSAM
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
- & WTGAGA*XSEC(ISUB,1)
- 450 CONTINUE
- IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
- & PARP(174)*XSEC(ISUB,1)
- IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
- 460 CONTINUE
- MINT(51)=0
-
-C...Print summary table.
- IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
- IF(MSTP(127).NE.1) THEN
- WRITE(MSTU(11),5900)
- CALL PYSTOP(1)
- ELSE
- WRITE(MSTU(11),6400)
- MSTI(53)=1
- ENDIF
- ENDIF
- IF(MSTP(122).GE.1) THEN
- WRITE(MSTU(11),6000)
- WRITE(MSTU(11),6100)
- DO 470 ISUB=1,500
- IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
- IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
- IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
- & GOTO 470
- IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
- IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
- & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
- IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
- WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
- 470 CONTINUE
- WRITE(MSTU(11),6300)
- ENDIF
-
-C...Format statements for maximization results.
- 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
- &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
- &'cth',9X,'tau''',7X,'sigma')
- 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
- &'phase space.'/1X,'Process switched off!')
- 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
- 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
- &'cross-section.'/1X,'Process switched off!')
- 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
- 5500 FORMAT(1X,1P,10D11.3)
- 5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
- 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
- &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
- 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
- 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
- &'cross-section.'/1X,'Execution stopped!')
- 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
- &'cross-section maximum search',1X,8('*'))
- 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
- &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
- &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
- 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
- 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
- 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
- &'cross-section.'/
- &1X,'Execution will stop if you try to generate events.')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYPILE
-C...Initializes multiplicity distribution and selects mutliplicity
-C...of pileup events, i.e. several events occuring at the same
-C...beam crossing.
-
- SUBROUTINE PYPILE(MPILE)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
- SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
-C...Local arrays and saved variables.
- DIMENSION WTI(0:200)
- SAVE IMIN,IMAX,WTI,WTS
-
-C...Sum of allowed cross-sections for pileup events.
- IF(MPILE.EQ.1) THEN
- VINT(131)=SIGT(0,0,5)
- IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
- IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
- IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
- IF(MSTP(133).LE.0) RETURN
-
-C...Initialize multiplicity distribution at maximum.
- XNAVE=VINT(131)*PARP(131)
- IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
- INAVE=MAX(1,MIN(200,NINT(XNAVE)))
- WTI(INAVE)=1D0
- WTS=WTI(INAVE)
- WTN=WTI(INAVE)*INAVE
-
-C...Find shape of multiplicity distribution below maximum.
- IMIN=INAVE
- DO 100 I=INAVE-1,1,-1
- IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
- IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
- IF(WTI(I).LT.1D-6) GOTO 110
- WTS=WTS+WTI(I)
- WTN=WTN+WTI(I)*I
- IMIN=I
- 100 CONTINUE
-
-C...Find shape of multiplicity distribution above maximum.
- 110 IMAX=INAVE
- DO 120 I=INAVE+1,200
- IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
- IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
- IF(WTI(I).LT.1D-6) GOTO 130
- WTS=WTS+WTI(I)
- WTN=WTN+WTI(I)*I
- IMAX=I
- 120 CONTINUE
- 130 VINT(132)=XNAVE
- VINT(133)=WTN/WTS
- IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
- & WTS/(WTS+WTI(1)/XNAVE)
- IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
- IF(MSTP(133).GE.2) VINT(134)=XNAVE
-
-C...Pick multiplicity of pileup events.
- ELSE
- IF(MSTP(133).LE.0) THEN
- MINT(81)=MAX(1,MSTP(134))
- ELSE
- WTR=WTS*PYR(0)
- DO 140 I=IMIN,IMAX
- MINT(81)=I
- WTR=WTR-WTI(I)
- IF(WTR.LE.0D0) GOTO 150
- 140 CONTINUE
- 150 CONTINUE
- ENDIF
- ENDIF
-
-C...Format statement for error message.
- 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
- &'crossing too large, ',1P,D12.4)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSAVE
-C...Saves and restores parameter and cross section values for the
-C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
-C...Also makes random choice between alternatives.
-
- SUBROUTINE PYSAVE(ISAVE,IGA)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
- SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
-C...Local arrays and saved variables.
- DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
- &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
- &INTCP(15,20),RECP(15,20)
- SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
-
-C...Save list of subprocesses and cross-section information.
- IF(ISAVE.EQ.1) THEN
- ICP=0
- DO 120 I=1,500
- IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
- ICP=ICP+1
- NSUBCP(IGA,ICP)=I
- MSUBCP(IGA,ICP)=MSUB(I)
- DO 100 J=1,20
- COEFCP(IGA,ICP,J)=COEF(I,J)
- 100 CONTINUE
- DO 110 J=1,3
- NGENCP(IGA,ICP,J)=NGEN(I,J)
- XSECCP(IGA,ICP,J)=XSEC(I,J)
- 110 CONTINUE
- 120 CONTINUE
- NCP(IGA)=ICP
- DO 130 J=1,3
- NGENCP(IGA,0,J)=NGEN(0,J)
- XSECCP(IGA,0,J)=XSEC(0,J)
- 130 CONTINUE
- DO 160 I1=0,6
- DO 150 I2=0,6
- DO 140 J=0,5
- SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
- 140 CONTINUE
- 150 CONTINUE
- 160 CONTINUE
-
-C...Save various common process variables.
- DO 170 J=1,10
- INTCP(IGA,J)=MINT(40+J)
- 170 CONTINUE
- INTCP(IGA,11)=MINT(101)
- INTCP(IGA,12)=MINT(102)
- INTCP(IGA,13)=MINT(107)
- INTCP(IGA,14)=MINT(108)
- INTCP(IGA,15)=MINT(123)
- RECP(IGA,1)=CKIN(3)
- RECP(IGA,2)=VINT(318)
-
-C...Save cross-section information only.
- ELSEIF(ISAVE.EQ.2) THEN
- DO 190 ICP=1,NCP(IGA)
- I=NSUBCP(IGA,ICP)
- DO 180 J=1,3
- NGENCP(IGA,ICP,J)=NGEN(I,J)
- XSECCP(IGA,ICP,J)=XSEC(I,J)
- 180 CONTINUE
- 190 CONTINUE
- DO 200 J=1,3
- NGENCP(IGA,0,J)=NGEN(0,J)
- XSECCP(IGA,0,J)=XSEC(0,J)
- 200 CONTINUE
-
-C...Choose between allowed alternatives.
- ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
- IF(ISAVE.EQ.4) THEN
- XSUMCP=0D0
- DO 210 IG=1,MINT(121)
- XSUMCP=XSUMCP+XSECCP(IG,0,1)
- 210 CONTINUE
- XSUMCP=XSUMCP*PYR(0)
- DO 220 IG=1,MINT(121)
- IGA=IG
- XSUMCP=XSUMCP-XSECCP(IG,0,1)
- IF(XSUMCP.LE.0D0) GOTO 230
- 220 CONTINUE
- 230 CONTINUE
- ENDIF
-
-C...Restore cross-section information.
- DO 240 I=1,500
- MSUB(I)=0
- 240 CONTINUE
- DO 270 ICP=1,NCP(IGA)
- I=NSUBCP(IGA,ICP)
- MSUB(I)=MSUBCP(IGA,ICP)
- DO 250 J=1,20
- COEF(I,J)=COEFCP(IGA,ICP,J)
- 250 CONTINUE
- DO 260 J=1,3
- NGEN(I,J)=NGENCP(IGA,ICP,J)
- XSEC(I,J)=XSECCP(IGA,ICP,J)
- 260 CONTINUE
- 270 CONTINUE
- DO 280 J=1,3
- NGEN(0,J)=NGENCP(IGA,0,J)
- XSEC(0,J)=XSECCP(IGA,0,J)
- 280 CONTINUE
- DO 310 I1=0,6
- DO 300 I2=0,6
- DO 290 J=0,5
- SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
- 290 CONTINUE
- 300 CONTINUE
- 310 CONTINUE
-
-C...Restore various common process variables.
- DO 320 J=1,10
- MINT(40+J)=INTCP(IGA,J)
- 320 CONTINUE
- MINT(101)=INTCP(IGA,11)
- MINT(102)=INTCP(IGA,12)
- MINT(107)=INTCP(IGA,13)
- MINT(108)=INTCP(IGA,14)
- MINT(123)=INTCP(IGA,15)
- CKIN(3)=RECP(IGA,1)
- CKIN(1)=2D0*CKIN(3)
- VINT(318)=RECP(IGA,2)
-
-C...Sum up cross-section info (for PYSTAT).
- ELSEIF(ISAVE.EQ.5) THEN
- DO 330 I=1,500
- MSUB(I)=0
- NGEN(I,1)=0
- NGEN(I,3)=0
- XSEC(I,3)=0D0
- 330 CONTINUE
- NGEN(0,1)=0
- NGEN(0,2)=0
- NGEN(0,3)=0
- XSEC(0,3)=0
- DO 350 IG=1,MINT(121)
- DO 340 ICP=1,NCP(IG)
- I=NSUBCP(IG,ICP)
- IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
- NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
- NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
- XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
- 340 CONTINUE
- NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
- NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
- NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
- XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
- 350 CONTINUE
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYGAGA
-C...For lepton beams it gives photon-hadron or photon-photon systems
-C...to be treated with the ordinary machinery and combines this with a
-C...description of the lepton -> lepton + photon branching.
-
- SUBROUTINE PYGAGA(IGAGA,WTGAGA)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
- &/PYINT5/
-C...Local variables and data statement.
- DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
- &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
- SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
- DATA EPS/1D-4/
-
-C...Initialize generation of photons inside leptons.
- IF(IGAGA.EQ.1) THEN
-
-C...Save quantities on incoming lepton system.
- VINT(301)=VINT(1)
- VINT(302)=VINT(2)
- PMS(1)=VINT(303)**2
- IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
- PMS(2)=VINT(304)**2
- IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
- PMC(3)=VINT(302)-PMS(1)-PMS(2)
- W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
-
-C...Calculate range of x and Q2 values allowed in generation.
- DO 100 I=1,2
- PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
- IF(MINT(140+I).NE.0) THEN
- XMIN(I)=MAX(CKIN(59+2*I),EPS)
- XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
- & PMC(I),1D0-EPS)
- YMIN=MAX(CKIN(71+2*I),EPS)
- YMAX=MIN(CKIN(72+2*I),1D0-EPS)
- IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
- & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
- XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
- THEMIN=MAX(CKIN(67+2*I),0D0)
- THEMAX=MIN(CKIN(68+2*I),PARU(1))
- IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
- Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
- & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
- & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
- Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
- & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
- & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
- IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
-C...W limits when lepton on one side only.
- IF(MINT(143-I).EQ.0) THEN
- XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
- IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
- & (CKIN(78)**2-PMS(3-I))/PMC(I))
- ENDIF
- ENDIF
- 100 CONTINUE
-
-C...W limits when lepton on both sides.
- IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
- IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
- & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
- IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
- & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
- IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
- XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
- & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
- XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
- & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
- ELSE
- XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
- XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
- ENDIF
- ENDIF
-
-C...Q2 and W values and photon flux weight factors for initialization.
- ELSEIF(IGAGA.EQ.2) THEN
- ISUB=MINT(1)
- MINT(15)=0
- MINT(16)=0
-
-C...W value for photon on one or both sides, and for processes
-C...with gamma-gamma cross section peaked at small shat.
- IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
- VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
- ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
- VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
- ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
- VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
- IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
- ELSE
- VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
- IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
- ENDIF
- VINT(1)=SQRT(MAX(0D0,VINT(2)))
-
-C...Upper estimate of photon flux weight factor.
-C...Initialization Q2 scale. Flag incoming unresolved photon.
- WTGAGA=1D0
- DO 110 I=1,2
- IF(MINT(140+I).NE.0) THEN
- WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
- & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
- IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
- & THEN
- Q2INIT=5D0+Q2MIN(3-I)
- ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
- Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
- ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
- Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
- ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
- & (ISUB.EQ.139.AND.I.EQ.1)) THEN
- Q2INIT=VINT(2)/3D0
- ELSEIF(ISUB.EQ.140) THEN
- Q2INIT=VINT(2)/2D0
- ELSE
- Q2INIT=Q2MIN(I)
- ENDIF
- VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
- IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
- & MINT(14+I)=22
- VINT(306+I)=VINT(2+I)**2
- ENDIF
- 110 CONTINUE
- VINT(320)=WTGAGA
-
-C...Update pTmin and cross section information.
- IF(MSTP(82).LE.1) THEN
- PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
- ELSE
- PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
- ENDIF
- VINT(149)=4D0*PTMN**2/VINT(2)
- VINT(154)=PTMN
- CALL PYXTOT
- VINT(318)=VINT(317)
-
-C...Generate photons inside leptons and
-C...calculate photon flux weight factors.
- ELSEIF(IGAGA.EQ.3) THEN
- ISUB=MINT(1)
- MINT(15)=0
- MINT(16)=0
-
-C...Generate phase space point and check against cuts.
- LOOP=0
- 120 LOOP=LOOP+1
- DO 130 I=1,2
- IF(MINT(140+I).NE.0) THEN
-C...Pick x and Q2
- X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
- Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
-C...Cuts on internal consistency in x and Q2.
- IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
- IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
- & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
-C...Cuts on y and theta.
- Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
- IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
- RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
- & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
- THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
- IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
- IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
- & GOTO 120
-
-C...Phi angle isotropic. Reconstruct pT.
- PHI(I)=PARU(2)*PYR(0)
- PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
- & PMS(I))*SIN(THETA(I))
-
-C...Store info on variables selected, for documentation purposes.
- VINT(2+I)=-SQRT(Q2(I))
- VINT(304+I)=X(I)
- VINT(306+I)=Q2(I)
- VINT(308+I)=Y(I)
- VINT(310+I)=THETA(I)
- VINT(312+I)=PHI(I)
- ELSE
- VINT(304+I)=1D0
- VINT(306+I)=0D0
- VINT(308+I)=1D0
- VINT(310+I)=0D0
- VINT(312+I)=0D0
- ENDIF
- 130 CONTINUE
-
-C...Cut on W combines info from two sides.
- IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
- W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
- & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
- & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
- & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
- IF(W2.LT.W2MIN) GOTO 120
- IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
- PMS1=-Q2(1)
- PMS2=-Q2(2)
- ELSEIF(MINT(141).NE.0) THEN
- W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
- PMS1=-Q2(1)
- PMS2=PMS(2)
- ELSEIF(MINT(142).NE.0) THEN
- W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
- PMS1=PMS(1)
- PMS2=-Q2(2)
- ENDIF
-
-C...Store kinematics info for photon(s) in subsystem cm frame.
- VINT(2)=W2
- VINT(1)=SQRT(W2)
- VINT(291)=0D0
- VINT(292)=0D0
- VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
- VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
- VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
- VINT(296)=0D0
- VINT(297)=0D0
- VINT(298)=-VINT(293)
- VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
- VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
-
-C...Assign weight for photon flux; different for transverse and
-C...longitudinal photons. Flag incoming unresolved photon.
- WTGAGA=1D0
- DO 140 I=1,2
- IF(MINT(140+I).NE.0) THEN
- WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
- & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
- IF(MSTP(16).EQ.0) THEN
- XY=X(I)
- ELSE
- WTGAGA=WTGAGA*X(I)/Y(I)
- XY=Y(I)
- ENDIF
- IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
- WTGAGA=WTGAGA*(1D0-XY)
- ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
- WTGAGA=WTGAGA*(1D0-XY)
- ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
- WTGAGA=WTGAGA*(1D0-XY)
- ELSE
- WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
- & PMS(I)*XY**2/Q2(I))
- ENDIF
- IF(MINT(106+I).EQ.0) MINT(14+I)=22
- ENDIF
- 140 CONTINUE
- VINT(319)=WTGAGA
- MINT(143)=LOOP
-
-C...Update pTmin and cross section information.
- IF(MSTP(82).LE.1) THEN
- PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
- ELSE
- PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
- ENDIF
- VINT(149)=4D0*PTMN**2/VINT(2)
- VINT(154)=PTMN
- CALL PYXTOT
-
-C...Reconstruct kinematics of photons inside leptons.
- ELSEIF(IGAGA.EQ.4) THEN
-
-C...Make place for incoming particles and scattered leptons.
- MOVE=3
- IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
- MINT(4)=MINT(4)+MOVE
- DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
- IF(K(I,1).EQ.21) THEN
- DO 150 J=1,5
- K(I+MOVE,J)=K(I,J)
- P(I+MOVE,J)=P(I,J)
- V(I+MOVE,J)=V(I,J)
- 150 CONTINUE
- IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
- & K(I+MOVE,3)=K(I,3)+MOVE
- IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
- & K(I+MOVE,4)=K(I,4)+MOVE
- IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
- & K(I+MOVE,5)=K(I,5)+MOVE
- ENDIF
- 160 CONTINUE
- DO 170 I=MINT(84)+1,N
- IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
- & K(I,3)=K(I,3)+MOVE
- 170 CONTINUE
-
-C...Fill in incoming particles.
- DO 190 I=MINT(83)+1,MINT(83)+MOVE
- DO 180 J=1,5
- K(I,J)=0
- P(I,J)=0D0
- V(I,J)=0D0
- 180 CONTINUE
- 190 CONTINUE
- DO 200 I=1,2
- K(MINT(83)+I,1)=21
- IF(MINT(140+I).NE.0) THEN
- K(MINT(83)+I,2)=MINT(140+I)
- P(MINT(83)+I,5)=VINT(302+I)
- ELSE
- K(MINT(83)+I,2)=MINT(10+I)
- P(MINT(83)+I,5)=VINT(2+I)
- ENDIF
- P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
- & VINT(302))*(-1D0)**(I+1)
- P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
- 200 CONTINUE
-
-C...New mother-daughter relations in documentation section.
- IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
- K(MINT(83)+1,4)=MINT(83)+3
- K(MINT(83)+1,5)=MINT(83)+5
- K(MINT(83)+2,4)=MINT(83)+4
- K(MINT(83)+2,5)=MINT(83)+6
- K(MINT(83)+3,3)=MINT(83)+1
- K(MINT(83)+5,3)=MINT(83)+1
- K(MINT(83)+4,3)=MINT(83)+2
- K(MINT(83)+6,3)=MINT(83)+2
- ELSEIF(MINT(141).NE.0) THEN
- K(MINT(83)+1,4)=MINT(83)+3
- K(MINT(83)+1,5)=MINT(83)+4
- K(MINT(83)+2,4)=MINT(83)+5
- K(MINT(83)+3,3)=MINT(83)+1
- K(MINT(83)+4,3)=MINT(83)+1
- K(MINT(83)+5,3)=MINT(83)+2
- ELSEIF(MINT(142).NE.0) THEN
- K(MINT(83)+1,4)=MINT(83)+4
- K(MINT(83)+2,4)=MINT(83)+3
- K(MINT(83)+2,5)=MINT(83)+5
- K(MINT(83)+3,3)=MINT(83)+2
- K(MINT(83)+4,3)=MINT(83)+1
- K(MINT(83)+5,3)=MINT(83)+2
- ENDIF
-
-C...Fill scattered lepton(s).
- DO 210 I=1,2
- IF(MINT(140+I).NE.0) THEN
- LSC=MINT(83)+MIN(I+2,MOVE)
- K(LSC,1)=21
- K(LSC,2)=MINT(140+I)
- P(LSC,1)=PT(I)*COS(PHI(I))
- P(LSC,2)=PT(I)*SIN(PHI(I))
- P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
- P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
- & (-1D0)**(I-1)
- P(LSC,5)=VINT(302+I)
- ENDIF
- 210 CONTINUE
-
-C...Find incoming four-vectors to subprocess.
- K(N+1,1)=21
- IF(MINT(141).NE.0) THEN
- DO 220 J=1,4
- P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
- 220 CONTINUE
- ELSE
- DO 230 J=1,4
- P(N+1,J)=P(MINT(83)+1,J)
- 230 CONTINUE
- ENDIF
- K(N+2,1)=21
- IF(MINT(142).NE.0) THEN
- DO 240 J=1,4
- P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
- 240 CONTINUE
- ELSE
- DO 250 J=1,4
- P(N+2,J)=P(MINT(83)+2,J)
- 250 CONTINUE
- ENDIF
-
-C...Define boost and rotation between hadronic subsystem and
-C...collision rest frame; boost hadronic subsystem to this frame.
- DO 260 J=1,3
- BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
- 260 CONTINUE
- CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
- BPHI=PYANGL(P(N+1,1),P(N+1,2))
- CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
- BTHETA=PYANGL(P(N+1,3),P(N+1,1))
- CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
- & BETA(3))
-
-C...Add on scattered leptons to final state.
- DO 280 I=1,2
- IF(MINT(140+I).NE.0) THEN
- LSC=MINT(83)+MIN(I+2,MOVE)
- N=N+1
- DO 270 J=1,5
- K(N,J)=K(LSC,J)
- P(N,J)=P(LSC,J)
- V(N,J)=V(LSC,J)
- 270 CONTINUE
- K(N,1)=1
- K(N,3)=LSC
- ENDIF
- 280 CONTINUE
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRAND
-C...Generates quantities characterizing the high-pT scattering at the
-C...parton level according to the matrix elements. Chooses incoming,
-C...reacting partons, their momentum fractions and one of the possible
-C...subprocesses.
-
- SUBROUTINE PYRAND
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-
-C...User process initialization and event commonblocks.
- INTEGER MAXPUP
- PARAMETER (MAXPUP=100)
- INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
- DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
- COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
- &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
- &LPRUP(MAXPUP)
- INTEGER MAXNUP
- PARAMETER (MAXNUP=500)
- INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
- DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
- COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
- &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
- &VTIMUP(MAXNUP),SPINUP(MAXNUP)
- SAVE /HEPRUP/,/HEPEUP/
-
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYTCCO/COEFX(194:380,2)
- COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
- &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
- &/TCPARA/
-C...Local arrays.
- DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
-
-C...Parameters and data used in elastic/diffractive treatment.
- DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
- &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
-
-C...Initial values, specifically for (first) semihard interaction.
- MINT(10)=0
- MINT(17)=0
- MINT(18)=0
- VINT(143)=1D0
- VINT(144)=1D0
- VINT(157)=0D0
- VINT(158)=0D0
- MFAIL=0
- IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
- ISUB=0
- ISTSB=0
- LOOP=0
- 100 LOOP=LOOP+1
- MINT(51)=0
- MINT(143)=1
- VINT(97)=1D0
-
-C...Start by assuming incoming photon is entering subprocess.
- IF(MINT(11).EQ.22) THEN
- MINT(15)=22
- VINT(307)=VINT(3)**2
- ENDIF
- IF(MINT(12).EQ.22) THEN
- MINT(16)=22
- VINT(308)=VINT(4)**2
- ENDIF
- MINT(103)=MINT(11)
- MINT(104)=MINT(12)
-
-C...Choice of process type - first event of pileup.
- INMULT=0
- IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
- ELSEIF(MINT(82).EQ.1) THEN
-
-C...For gamma-p or gamma-gamma first pick between alternatives.
- IGA=0
- IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
- MINT(122)=IGA
-
-C...For real gamma + gamma with different nature, flip at random.
- IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
- & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
- MINTSV=MINT(41)
- MINT(41)=MINT(42)
- MINT(42)=MINTSV
- MINTSV=MINT(45)
- MINT(45)=MINT(46)
- MINT(46)=MINTSV
- MINTSV=MINT(107)
- MINT(107)=MINT(108)
- MINT(108)=MINTSV
- IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
- ENDIF
-
-C...Pick process type, possibly by user process machinery.
-C...(If the latter, also event will be picked here.)
- IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
- CALL UPEVNT
- CALL PYUPRE
- ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
- CALL UPEVNT
- CALL PYUPRE
- ISUB=0
- 110 ISUB=ISUB+1
- IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
- & ISUB.LT.500) GOTO 110
- ELSE
- RSUB=XSEC(0,1)*PYR(0)
- DO 120 I=1,500
- IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
- ISUB=I
- RSUB=RSUB-XSEC(I,1)
- IF(RSUB.LE.0D0) GOTO 130
- 120 CONTINUE
- 130 IF(ISUB.EQ.95) ISUB=96
- IF(ISUB.EQ.96) INMULT=1
- IF(ISET(ISUB).EQ.11) THEN
- IDPRUP=KFPR(ISUB,2)
- CALL UPEVNT
- CALL PYUPRE
- ENDIF
- ENDIF
-
-C...Choice of inclusive process type - pileup events.
- ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
- RSUB=VINT(131)*PYR(0)
- ISUB=96
- IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
- IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
- IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
- IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
- & ISUB=91
- IF(ISUB.EQ.96) INMULT=1
- ENDIF
-
-C...Choice of photon energy and flux factor inside lepton.
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
- CALL PYGAGA(3,WTGAGA)
- IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
- CKIN(3)=MAX(VINT(285),VINT(154))
- CKIN(1)=2D0*CKIN(3)
- ENDIF
-C...When necessary set direct/resolved photon by hand.
- ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
- IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
- IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
- ENDIF
-
-C...Restrict direct*resolved processes to pTmin >= Q,
-C...to avoid doublecounting with DIS.
- IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
- IF(MINT(15).EQ.22) THEN
- CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
- ELSE
- CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
- ENDIF
- CKIN(1)=2D0*CKIN(3)
- ENDIF
-
-C...Set up for multiple interactions (may include impact parameter).
- IF(INMULT.EQ.1) THEN
- IF(MINT(35).LE.1) CALL PYMULT(2)
- IF(MINT(35).GE.2) CALL PYMIGN(2)
- ENDIF
-
-C...Loopback point for minimum bias in photon physics.
- LOOP2=0
- 140 LOOP2=LOOP2+1
- IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
- IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
- IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
- &NGEN(97,1)=NGEN(97,1)+MINT(143)
- MINT(1)=ISUB
- ISTSB=ISET(ISUB)
-
-C...Random choice of flavour for some SUSY processes.
- IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
-C...~e_L ~nu_e or ~mu_L ~nu_mu.
- IF(ISUB.EQ.210) THEN
- KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
- KFPR(ISUB,2)=KFPR(ISUB,1)+1
-C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
- ELSEIF(ISUB.EQ.213) THEN
- KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
- KFPR(ISUB,2)=KFPR(ISUB,1)
-C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
- ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
- & ISUB.NE.257) THEN
- IF(ISUB.GE.258) THEN
- RKF=4D0
- ELSE
- RKF=5D0
- ENDIF
- IF(MOD(ISUB,2).EQ.0) THEN
- KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
- ELSE
- KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
- ENDIF
-C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
- ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
- IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
- KSU1=KSUSY1
- KSU2=KSUSY1
- ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
- KSU1=KSUSY2
- KSU2=KSUSY2
- ELSEIF(PYR(0).LT.0.5D0) THEN
- KSU1=KSUSY1
- KSU2=KSUSY2
- ELSE
- KSU1=KSUSY2
- KSU2=KSUSY1
- ENDIF
- KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
- KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
-C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
- ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
- KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
- KFPR(ISUB,2)=KFPR(ISUB,1)
- ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
- KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
- KFPR(ISUB,2)=KFPR(ISUB,1)
-C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
- ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
- IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
- KSU1=KSUSY1
- KSU2=KSUSY1
- ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
- KSU1=KSUSY2
- KSU2=KSUSY2
- ELSEIF(PYR(0).LT.0.5D0) THEN
- KSU1=KSUSY1
- KSU2=KSUSY2
- ELSE
- KSU1=KSUSY2
- KSU2=KSUSY1
- ENDIF
- IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
- RKF=5D0
- ELSE
- RKF=4D0
- ENDIF
- KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
- ENDIF
- ENDIF
-
-C...Find resonances (explicit or implicit in cross-section).
- MINT(72)=0
- KFR1=0
- IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
- KFR1=KFPR(ISUB,1)
- ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
- & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
- KFR1=23
- ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
- & ISUB.EQ.177) THEN
- KFR1=24
- ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
- KFR1=25
- IF(MSTP(46).EQ.5) THEN
- KFR1=89
- PMAS(89,1)=PARP(45)
- PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
- ENDIF
- ENDIF
- CKMX=CKIN(2)
- IF(CKMX.LE.0D0) CKMX=VINT(1)
- KCR1=PYCOMP(KFR1)
- IF(KFR1.NE.0) THEN
- IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
- & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
- ENDIF
- IF(KFR1.NE.0) THEN
- TAUR1=PMAS(KCR1,1)**2/VINT(2)
- GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
- MINT(72)=1
- MINT(73)=KFR1
- VINT(73)=TAUR1
- VINT(74)=GAMR1
- ENDIF
- KFR2=0
- KFR3=0
- IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
- $(ISUB.GE.361.AND.ISUB.LE.380))
- $THEN
- KFR2=23
- IF(ISUB.EQ.141) THEN
- KCR2=PYCOMP(KFR2)
- IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
- & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
- KFR2=0
- ELSE
- TAUR2=PMAS(KCR2,1)**2/VINT(2)
- GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
- MINT(72)=2
- MINT(74)=KFR2
- VINT(75)=TAUR2
- VINT(76)=GAMR2
- ENDIF
-C...3 resonances at work: rho, omega, a
- ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
- & .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
- MINT(72)=IRES
- IF(IRES.GE.1) THEN
- VINT(73)=XMAS(1)**2/VINT(2)
- VINT(74)=XMAS(1)*XWID(1)/VINT(2)
- TAUR1=VINT(73)
- GAMR1=VINT(74)
- KFR1=1
- ENDIF
- IF(IRES.GE.2) THEN
- VINT(75)=XMAS(2)**2/VINT(2)
- VINT(76)=XMAS(2)*XWID(2)/VINT(2)
- TAUR2=VINT(75)
- GAMR2=VINT(76)
- KFR2=2
- ENDIF
- IF(IRES.EQ.3) THEN
- VINT(77)=XMAS(3)**2/VINT(2)
- VINT(78)=XMAS(3)*XWID(3)/VINT(2)
- TAUR3=VINT(77)
- GAMR3=VINT(78)
- KFR3=3
- ENDIF
-C...Charged current: rho+- and a+-
- ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
- MINT(72)=IRES
- IF(JRES.GE.1) THEN
- VINT(73)=YMAS(1)**2/VINT(2)
- VINT(74)=YMAS(1)*YWID(1)/VINT(2)
- KFR1=1
- TAUR1=VINT(73)
- GAMR1=VINT(74)
- ENDIF
- IF(JRES.GE.2) THEN
- VINT(75)=YMAS(2)**2/VINT(2)
- VINT(76)=YMAS(2)*YWID(2)/VINT(2)
- KFR2=2
- TAUR2=VINT(73)
- GAMR2=VINT(74)
- ENDIF
- KFR3=0
- ENDIF
- IF(ISUB.NE.141) THEN
- IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
-
- ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
- MINT(72)=2
- ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
- MINT(72)=2
- MINT(74)=KFR3
- VINT(75)=TAUR3
- VINT(76)=GAMR3
- ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
- MINT(72)=2
- MINT(73)=KFR2
- VINT(73)=TAUR2
- VINT(74)=GAMR2
- MINT(74)=KFR3
- VINT(75)=TAUR3
- VINT(76)=GAMR3
- ELSEIF(KFR1.NE.0) THEN
- MINT(72)=1
- ELSEIF(KFR2.NE.0) THEN
- MINT(72)=1
- MINT(73)=KFR2
- VINT(73)=TAUR2
- VINT(74)=GAMR2
- ELSEIF(KFR3.NE.0) THEN
- MINT(72)=1
- MINT(73)=KFR3
- VINT(73)=TAUR3
- VINT(74)=GAMR3
- ELSE
- MINT(72)=0
- ENDIF
- ELSE
- IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
-
- ELSEIF(KFR2.NE.0) THEN
- KFR1=KFR2
- TAUR1=TAUR2
- GAMR1=GAMR2
- MINT(72)=1
- MINT(73)=KFR1
- VINT(73)=TAUR1
- VINT(74)=GAMR1
- KFR2=0
- ELSE
- MINT(72)=0
- ENDIF
- ENDIF
- ENDIF
-
-C...Find product masses and minimum pT of process,
-C...optionally with broadening according to a truncated Breit-Wigner.
- VINT(63)=0D0
- VINT(64)=0D0
- MINT(71)=0
- VINT(71)=CKIN(3)
- IF(MINT(82).GE.2) VINT(71)=0D0
- VINT(80)=1D0
- IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
- NBW=0
- DO 160 I=1,2
- PMMN(I)=0D0
- IF(KFPR(ISUB,I).EQ.0) THEN
- ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
- & PARP(41)) THEN
- VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
- ELSE
- NBW=NBW+1
-C...This prevents SUSY/t particles from becoming too light.
- KFLW=KFPR(ISUB,I)
- IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
- KCW=PYCOMP(KFLW)
- PMMN(I)=PMAS(KCW,1)
- DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
- IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
- PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
- & PMAS(PYCOMP(KFDP(IDC,2)),1)
- IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
- & PMAS(PYCOMP(KFDP(IDC,3)),1)
- PMMN(I)=MIN(PMMN(I),PMSUM)
- ENDIF
- 150 CONTINUE
- ELSEIF(KFLW.EQ.6) THEN
- PMMN(I)=PMAS(24,1)+PMAS(5,1)
- ENDIF
- ENDIF
- 160 CONTINUE
- IF(NBW.GE.1) THEN
- CKIN41=CKIN(41)
- CKIN43=CKIN(43)
- CKIN(41)=MAX(PMMN(1),CKIN(41))
- CKIN(43)=MAX(PMMN(2),CKIN(43))
- CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
- CKIN(41)=CKIN41
- CKIN(43)=CKIN43
- IF(MINT(51).EQ.1) THEN
- IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
- IF(MFAIL.EQ.1) THEN
- MSTI(61)=1
- RETURN
- ENDIF
- GOTO 100
- ENDIF
- VINT(63)=PQM3**2
- VINT(64)=PQM4**2
- ENDIF
- IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
- IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
- ENDIF
-
-C...Prepare for additional variable choices in 2 -> 3.
- IF(ISTSB.EQ.5) THEN
- VINT(201)=0D0
- IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
- VINT(206)=VINT(201)
- IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
- VINT(204)=PMAS(23,1)
- IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
- & VINT(204)=PMAS(24,1)
- IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
- IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
- & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
- & VINT(204)=VINT(201)
- VINT(209)=VINT(204)
- IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
- ENDIF
-
-C...Select incoming VDM particle (rho/omega/phi/J/psi).
- IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
- &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
- VRN=PYR(0)*SIGT(0,0,5)
- IF(MINT(101).LE.1) THEN
- I1MN=0
- I1MX=0
- ELSE
- I1MN=1
- I1MX=MINT(101)
- ENDIF
- IF(MINT(102).LE.1) THEN
- I2MN=0
- I2MX=0
- ELSE
- I2MN=1
- I2MX=MINT(102)
- ENDIF
- DO 180 I1=I1MN,I1MX
- KFV1=110*I1+3
- DO 170 I2=I2MN,I2MX
- KFV2=110*I2+3
- VRN=VRN-SIGT(I1,I2,5)
- IF(VRN.LE.0D0) GOTO 190
- 170 CONTINUE
- 180 CONTINUE
- 190 IF(MINT(101).GE.2) MINT(103)=KFV1
- IF(MINT(102).GE.2) MINT(104)=KFV2
- ENDIF
-
- IF(ISTSB.EQ.0) THEN
-C...Elastic scattering or single or double diffractive scattering.
-
-C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
- MINT(103)=MINT(11)
- MINT(104)=MINT(12)
- PMM(1)=VINT(3)
- PMM(2)=VINT(4)
- IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
- JJ=ISUB-90
- VRN=PYR(0)*SIGT(0,0,JJ)
- IF(MINT(101).LE.1) THEN
- I1MN=0
- I1MX=0
- ELSE
- I1MN=1
- I1MX=MINT(101)
- ENDIF
- IF(MINT(102).LE.1) THEN
- I2MN=0
- I2MX=0
- ELSE
- I2MN=1
- I2MX=MINT(102)
- ENDIF
- DO 210 I1=I1MN,I1MX
- KFV1=110*I1+3
- DO 200 I2=I2MN,I2MX
- KFV2=110*I2+3
- VRN=VRN-SIGT(I1,I2,JJ)
- IF(VRN.LE.0D0) GOTO 220
- 200 CONTINUE
- 210 CONTINUE
- 220 IF(MINT(101).GE.2) THEN
- MINT(103)=KFV1
- PMM(1)=PYMASS(KFV1)
- ENDIF
- IF(MINT(102).GE.2) THEN
- MINT(104)=KFV2
- PMM(2)=PYMASS(KFV2)
- ENDIF
- ENDIF
- VINT(67)=PMM(1)
- VINT(68)=PMM(2)
-
-C...Select mass for GVMD states (rejecting previous assignment).
- Q0S=4D0*PARP(15)**2
- Q1S=4D0*VINT(154)**2
- LOOP3=0
- 230 LOOP3=LOOP3+1
- DO 240 JT=1,2
- IF(MINT(106+JT).EQ.3) THEN
- PS=VINT(2+JT)**2
- PMM(JT)=(Q0S+PS)*(Q1S+PS)/
- & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
- IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
- & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
- ENDIF
- 240 CONTINUE
- IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
- IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
- & GOTO 230
- GOTO 100
- ENDIF
-
-C...Side/sides of diffractive system.
- MINT(17)=0
- MINT(18)=0
- IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
- IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
-
-C...Find masses of particles and minimal masses of diffractive states.
- DO 250 JT=1,2
- PDIF(JT)=PMM(JT)
- VINT(68+JT)=PDIF(JT)
- IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
- 250 CONTINUE
- SH=VINT(2)
- SQM1=PMM(1)**2
- SQM2=PMM(2)**2
- SQM3=PDIF(1)**2
- SQM4=PDIF(2)**2
- SMRES1=(PMM(1)+PMRC)**2
- SMRES2=(PMM(2)+PMRC)**2
-
-C...Find elastic slope and lower limit diffractive slope.
- IHA=MAX(2,IABS(MINT(103))/110)
- IF(IHA.GE.5) IHA=1
- IHB=MAX(2,IABS(MINT(104))/110)
- IF(IHB.GE.5) IHB=1
- IF(ISUB.EQ.91) THEN
- BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
- ELSEIF(ISUB.EQ.92) THEN
- BMN=MAX(2D0,2D0*BHAD(IHB))
- ELSEIF(ISUB.EQ.93) THEN
- BMN=MAX(2D0,2D0*BHAD(IHA))
- ELSEIF(ISUB.EQ.94) THEN
- BMN=2D0*ALP*4D0
- ENDIF
-
-C...Determine maximum possible t range and coefficient of generation.
- SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
- SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
- THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
- THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
- THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
- & (SQM1*SQM4-SQM2*SQM3)/SH
- THL=-0.5D0*(THA+THB)
- THU=THC/THL
- THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
-
-C...Select diffractive mass/masses according to dm^2/m^2.
- LOOP3=0
- 260 LOOP3=LOOP3+1
- DO 270 JT=1,2
- IF(MINT(16+JT).EQ.0) THEN
- PDIF(2+JT)=PDIF(JT)
- ELSE
- PMMIN=PDIF(JT)
- PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
- PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
- ENDIF
- 270 CONTINUE
- SQM3=PDIF(3)**2
- SQM4=PDIF(4)**2
-
-C..Additional mass factors, including resonance enhancement.
- IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
- IF(LOOP3.LT.100) GOTO 260
- GOTO 100
- ENDIF
- IF(ISUB.EQ.92) THEN
- FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
- IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
- ELSEIF(ISUB.EQ.93) THEN
- FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
- IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
- ELSEIF(ISUB.EQ.94) THEN
- FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
- & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
- & (1D0+CRES*SMRES2/(SMRES2+SQM4))
- IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
- ENDIF
-
-C...Select t according to exp(Bmn*t) and correct to right slope.
- TH=THU+LOG(1D0+THRND*PYR(0))/BMN
- IF(ISUB.GE.92) THEN
- IF(ISUB.EQ.92) THEN
- BADD=2D0*ALP*LOG(SH/SQM3)
- IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
- ELSEIF(ISUB.EQ.93) THEN
- BADD=2D0*ALP*LOG(SH/SQM4)
- IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
- ELSEIF(ISUB.EQ.94) THEN
- BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
- ENDIF
- IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
- ENDIF
-
-C...Check whether m^2 and t choices are consistent.
- SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
- THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
- THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
- IF(THB.LE.1D-8) GOTO 260
- THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
- & (SQM1*SQM4-SQM2*SQM3)/SH
- THLM=-0.5D0*(THA+THB)
- THUM=THC/THLM
- IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
-
-C...Information to output.
- VINT(21)=1D0
- VINT(22)=0D0
- VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
- VINT(45)=TH
- VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
- VINT(63)=PDIF(3)**2
- VINT(64)=PDIF(4)**2
- VINT(283)=PMM(1)**2/4D0
- VINT(284)=PMM(2)**2/4D0
-
-C...Note: in the following, by In is meant the integral over the
-C...quantity multiplying coefficient cn.
-C...Choose tau according to h1(tau)/tau, where
-C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
-C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
-C...I1/I5*c5*1/(tau+tau_R') +
-C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
-C...I1/I7*c7*tau/(1.-tau), and
-C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
- ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
- CALL PYKLIM(1)
- IF(MINT(51).NE.0) THEN
- IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
- IF(MFAIL.EQ.1) THEN
- MSTI(61)=1
- RETURN
- ENDIF
- GOTO 100
- ENDIF
- RTAU=PYR(0)
- MTAU=1
- IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
- IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
- IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
- IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
- & MTAU=5
- IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
- & COEF(ISUB,5)) MTAU=6
- IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
- & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
-C...Additional check to handle techni-processes with extra resonance
-C....Only modify tau treatment
- IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
- & THEN
- IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
- & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
- IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
- & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
- & +COEFX(ISUB,1)) MTAU=9
- ENDIF
- CALL PYKMAP(1,MTAU,PYR(0))
-
-C...2 -> 3, 4 processes:
-C...Choose tau' according to h4(tau,tau')/tau', where
-C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
-C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
- IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
- CALL PYKLIM(4)
- IF(MINT(51).NE.0) THEN
- IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
- IF(MFAIL.EQ.1) THEN
- MSTI(61)=1
- RETURN
- ENDIF
- GOTO 100
- ENDIF
- RTAUP=PYR(0)
- MTAUP=1
- IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
- IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
- CALL PYKMAP(4,MTAUP,PYR(0))
- ENDIF
-
-C...Choose y* according to h2(y*), where
-C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
-C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
-C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
-C...and c1 + c2 + c3 + c4 + c5 = 1.
- CALL PYKLIM(2)
- IF(MINT(51).NE.0) THEN
- IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
- IF(MFAIL.EQ.1) THEN
- MSTI(61)=1
- RETURN
- ENDIF
- GOTO 100
- ENDIF
- RYST=PYR(0)
- MYST=1
- IF(RYST.GT.COEF(ISUB,8)) MYST=2
- IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
- IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
- IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
- & COEF(ISUB,11)) MYST=5
- CALL PYKMAP(2,MYST,PYR(0))
-
-C...2 -> 2 processes:
-C...Choose cos(theta-hat) (cth) according to h3(cth), where
-C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
-C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
-C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
-C...and c0 + c1 + c2 + c3 + c4 = 1.
- CALL PYKLIM(3)
- IF(MINT(51).NE.0) THEN
- IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
- IF(MFAIL.EQ.1) THEN
- MSTI(61)=1
- RETURN
- ENDIF
- GOTO 100
- ENDIF
- IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
- RCTH=PYR(0)
- MCTH=1
- IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
- IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
- IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
- IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
- & COEF(ISUB,16)) MCTH=5
- CALL PYKMAP(3,MCTH,PYR(0))
- ENDIF
-
-C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
- IF(ISTSB.EQ.5) THEN
- CALL PYKMAP(5,0,0D0)
- IF(MINT(51).NE.0) THEN
- IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
- IF(MFAIL.EQ.1) THEN
- MSTI(61)=1
- RETURN
- ENDIF
- GOTO 100
- ENDIF
- ENDIF
-
-C...DIS as f + gamma* -> f process: set dummy values.
- ELSEIF(ISTSB.EQ.8) THEN
- VINT(21)=0.9D0
- VINT(22)=0D0
- VINT(23)=0D0
- VINT(47)=0D0
- VINT(48)=0D0
-
-C...Low-pT or multiple interactions (first semihard interaction).
- ELSEIF(ISTSB.EQ.9) THEN
- IF(MINT(35).LE.1) CALL PYMULT(3)
- IF(MINT(35).GE.2) CALL PYMIGN(3)
- ISUB=MINT(1)
-
-C...Study user-defined process: kinematics plus weight.
- ELSEIF(ISTSB.EQ.11) THEN
- IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
- & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
- MSTI(51)=0
- IF(NUP.LE.0) THEN
- MINT(51)=2
- MSTI(51)=1
- IF(MINT(82).EQ.1) THEN
- NGEN(0,1)=NGEN(0,1)-1
- NGEN(ISUB,1)=NGEN(ISUB,1)-1
- ENDIF
- IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
- RETURN
- ENDIF
-
-C...Extract cross section event weight.
- IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
- SIGS=1D-9*XWGTUP
- ELSE
- SIGS=1D-9*XSECUP(KFPR(ISUB,1))
- ENDIF
- IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
- VINT(97)=SIGN(1D0,XWGTUP)
- ELSE
- VINT(97)=1D-9*XWGTUP
- ENDIF
-
-C...Construct 'trivial' kinematical variables needed.
- KFL1=IDUP(1)
- KFL2=IDUP(2)
- VINT(41)=PUP(4,1)/EBMUP(1)
- VINT(42)=PUP(4,2)/EBMUP(2)
- IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
- CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
- & '(listing follows):')
- CALL PYLIST(7)
- ENDIF
- VINT(21)=VINT(41)*VINT(42)
- VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
- VINT(44)=VINT(21)*VINT(2)
- VINT(43)=SQRT(MAX(0D0,VINT(44)))
- VINT(55)=SCALUP
- IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
- VINT(56)=VINT(55)**2
- VINT(57)=AQEDUP
- VINT(58)=AQCDUP
-
-C...Construct other kinematical variables needed (approximately).
- VINT(23)=0D0
- VINT(26)=VINT(21)
- VINT(45)=-0.5D0*VINT(44)
- VINT(46)=-0.5D0*VINT(44)
- VINT(49)=VINT(43)
- VINT(50)=VINT(44)
- VINT(51)=VINT(55)
- VINT(52)=VINT(56)
- VINT(53)=VINT(55)
- VINT(54)=VINT(56)
- VINT(25)=0D0
- VINT(48)=0D0
- IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
- & '(PYRAND:) unacceptable ISTUP code for incoming particles')
- DO 280 IUP=3,NUP
- IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
- & '(PYRAND:) unacceptable ISTUP code for particles')
- IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
- & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
- IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
- & PUP(2,IUP)**2)
- 280 CONTINUE
- VINT(47)=SQRT(VINT(48))
- ENDIF
-
-C...Choose azimuthal angle.
- VINT(24)=0D0
- IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
-
-C...Check against user cuts on kinematics at parton level.
- MINT(51)=0
- IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
- IF(MINT(51).NE.0) THEN
- IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
- IF(MFAIL.EQ.1) THEN
- MSTI(61)=1
- RETURN
- ENDIF
- GOTO 100
- ENDIF
- IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
- MCUT=0
- IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
- & CALL PYKCUT(MCUT)
- IF(MCUT.NE.0) THEN
- IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
- IF(MFAIL.EQ.1) THEN
- MSTI(61)=1
- RETURN
- ENDIF
- GOTO 100
- ENDIF
- ENDIF
-
-C...Calculate differential cross-section for different subprocesses.
- IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
- SIGSOR=SIGS
- SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
-
-C...Multiply cross section by lepton -> photon flux factor.
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
- SIGS=WTGAGA*SIGS
- DO 290 ICHN=1,NCHN
- SIGH(ICHN)=WTGAGA*SIGH(ICHN)
- 290 CONTINUE
- SIGLPT=WTGAGA*SIGLPT
- ENDIF
-
-C...Multiply cross-section by user-defined weights.
- IF(MSTP(173).EQ.1) THEN
- SIGS=PARP(173)*SIGS
- DO 300 ICHN=1,NCHN
- SIGH(ICHN)=PARP(173)*SIGH(ICHN)
- 300 CONTINUE
- SIGLPT=PARP(173)*SIGLPT
- ENDIF
- WTXS=1D0
- SIGSWT=SIGS
- VINT(99)=1D0
- VINT(100)=1D0
- IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
- IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
- & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
- SIGSWT=WTXS*SIGS
- VINT(99)=WTXS
- IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
- ENDIF
-
-C...Calculations for Monte Carlo estimate of all cross-sections.
- IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
- IF(MSTP(142).LE.1) THEN
- XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
- ELSE
- XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
- ENDIF
- ELSEIF(MINT(82).EQ.1) THEN
- XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
- ENDIF
- IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
- &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
-
-C...Multiple interactions: store results of cross-section calculation.
- IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
- VINT(153)=SIGSOR
- IF(MINT(35).LE.1) CALL PYMULT(4)
- IF(MINT(35).GE.2) CALL PYMIGN(4)
- ENDIF
-
-C...Ratio of actual to maximum cross section.
- IF(ISTSB.NE.11) THEN
- VIOL=SIGSWT/XSEC(ISUB,1)
- IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
- ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
- VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
- ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
- VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
- ELSE
- VIOL=1D0
- ENDIF
-
-C...Check that weight not negative.
- IF(MSTP(123).LE.0) THEN
- IF(VIOL.LT.-1D-3) THEN
- WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
- IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
- & VINT(22),VINT(23),VINT(26)
- CALL PYSTOP(2)
- ENDIF
- ELSE
- IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
- VINT(109)=VIOL
- IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
- IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
- & VINT(22),VINT(23),VINT(26)
- ENDIF
- ENDIF
-
-C...Weighting using estimate of maximum of differential cross-section.
- RATND=1D0
- IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
- IF(VIOL.LT.PYR(0)) THEN
- IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
- IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
- GOTO 100
- ENDIF
- ELSEIF(MFAIL.EQ.0) THEN
- RATND=SIGLPT/XSEC(95,1)
- VIOL=VIOL/RATND
- IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
- IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
- & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
- IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
- ISUB=0
- GOTO 100
- ENDIF
- IF(VIOL.LT.PYR(0)) THEN
- GOTO 140
- ENDIF
- ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
- IF(VIOL.LT.PYR(0)) THEN
- MSTI(61)=1
- IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
- RETURN
- ENDIF
- ELSE
- RATND=SIGLPT/XSEC(95,1)
- IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
- MSTI(61)=1
- IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
- RETURN
- ENDIF
- VIOL=VIOL/RATND
- IF(VIOL.LT.PYR(0)) THEN
- IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
- GOTO 100
- ENDIF
- ENDIF
-
-C...Check for possible violation of estimated maximum of differential
-C...cross-section used in weighting.
- IF(MSTP(123).LE.0) THEN
- IF(VIOL.GT.1D0) THEN
- WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
- IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
- & VINT(22),VINT(23),VINT(26)
- CALL PYSTOP(2)
- ENDIF
- ELSEIF(MSTP(123).EQ.1) THEN
- IF(VIOL.GT.VINT(108)) THEN
- VINT(108)=VIOL
- IF(VIOL.GT.1.0001D0) THEN
- MINT(10)=1
- WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
- IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
- & VINT(22),VINT(23),VINT(26)
- ENDIF
- ENDIF
- ELSEIF(VIOL.GT.VINT(108)) THEN
- VINT(108)=VIOL
- IF(VIOL.GT.1D0) THEN
- MINT(10)=1
- IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
- IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
- & THEN
- XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
- IF(KFPR(ISUB,1).LE.9) THEN
- IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
- & XMAXUP(KFPR(ISUB,1))
- ELSEIF(KFPR(ISUB,1).LE.99) THEN
- IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
- & XMAXUP(KFPR(ISUB,1))
- ELSE
- IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
- & XMAXUP(KFPR(ISUB,1))
- ENDIF
- ENDIF
- IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
- XDIF=XSEC(ISUB,1)*(VIOL-1D0)
- XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
- IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
- & XSEC(0,1)=XSEC(0,1)+XDIF
- IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
- & VINT(22),VINT(23),VINT(26)
- IF(ISUB.LE.9) THEN
- IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
- ELSEIF(ISUB.LE.99) THEN
- IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
- ELSE
- IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
- ENDIF
- ENDIF
- VINT(108)=1D0
- ENDIF
- ENDIF
-
-C...Multiple interactions: choose impact parameter (if not already done).
- IF(MINT(39).EQ.0) VINT(148)=1D0
- IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
- &MSTP(82).GE.3) THEN
- IF(MINT(35).LE.1) CALL PYMULT(5)
- IF(MINT(35).GE.2) CALL PYMIGN(5)
- IF(VINT(150).LT.PYR(0)) THEN
- IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
- IF(MFAIL.EQ.1) THEN
- MSTI(61)=1
- RETURN
- ENDIF
- GOTO 100
- ENDIF
- ENDIF
- IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
- IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
- IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
- IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
- ENDIF
- IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
-
-C...Choose flavour of reacting partons (and subprocess).
- IF(ISTSB.GE.11) GOTO 320
- RSIGS=SIGS*PYR(0)
- QT2=VINT(48)
- RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
- &(VINT(1)/PARP(89))**PARP(90))**2))**2)
- IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
- &PYR(0).GT.RQQBAR)) THEN
- DO 310 ICHN=1,NCHN
- KFL1=ISIG(ICHN,1)
- KFL2=ISIG(ICHN,2)
- MINT(2)=ISIG(ICHN,3)
- RSIGS=RSIGS-SIGH(ICHN)
- IF(RSIGS.LE.0D0) GOTO 320
- 310 CONTINUE
-
-C...Multiple interactions: choose qqbar preferentially at small pT.
- ELSEIF(ISUB.EQ.96) THEN
- MINT(105)=MINT(103)
- MINT(109)=MINT(107)
- CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
- MINT(105)=MINT(104)
- MINT(109)=MINT(108)
- CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
- MINT(1)=11
- MINT(2)=1
- IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
-
-C...Low-pT: choose string drawing configuration.
- ELSE
- KFL1=21
- KFL2=21
- RSIGS=6D0*PYR(0)
- MINT(2)=1
- IF(RSIGS.GT.1D0) MINT(2)=2
- IF(RSIGS.GT.2D0) MINT(2)=3
- ENDIF
-
-C...Reassign QCD process. Partons before initial state radiation.
- 320 IF(MINT(2).GT.10) THEN
- MINT(1)=MINT(2)/10
- MINT(2)=MOD(MINT(2),10)
- ENDIF
- IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
- &NGEN(MINT(1),2)+1
- MINT(15)=KFL1
- MINT(16)=KFL2
- MINT(13)=MINT(15)
- MINT(14)=MINT(16)
- VINT(141)=VINT(41)
- VINT(142)=VINT(42)
- VINT(151)=0D0
- VINT(152)=0D0
-
-C...Calculate x value of photon for parton inside photon inside e.
- DO 350 JT=1,2
- MINT(18+JT)=0
- VINT(154+JT)=0D0
- MSPLI=0
- IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
- IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
- IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
- IF(MSPLI.EQ.2) THEN
- KFLH=MINT(14+JT)
- XHRD=VINT(140+JT)
- Q2HRD=VINT(54)
- MINT(105)=MINT(102+JT)
- MINT(109)=MINT(106+JT)
- VINT(120)=VINT(2+JT)
- IF(MSTP(57).LE.1) THEN
- CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
- ELSE
- CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
- ENDIF
- WTMX=4D0*XPQ(KFLH)
- IF(MSTP(13).EQ.2) THEN
- Q2PMS=Q2HRD/PMAS(11,1)**2
- WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
- ENDIF
- 330 XE=XHRD**PYR(0)
- XG=MIN(1D0-1D-10,XHRD/XE)
- IF(MSTP(57).LE.1) THEN
- CALL PYPDFU(22,XG,Q2HRD,XPQ)
- ELSE
- CALL PYPDFL(22,XG,Q2HRD,XPQ)
- ENDIF
- WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
- IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
- IF(WT.LT.PYR(0)*WTMX) GOTO 330
- MINT(18+JT)=1
- VINT(154+JT)=XE
- DO 340 KFLS=-25,25
- XSFX(JT,KFLS)=XPQ(KFLS)
- 340 CONTINUE
- ENDIF
- 350 CONTINUE
-
-C...Pick scale where photon is resolved.
- Q0S=PARP(15)**2
- Q1S=VINT(154)**2
- VINT(283)=0D0
- IF(MINT(107).EQ.3) THEN
- IF(MSTP(66).EQ.1) THEN
- VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
- ELSEIF(MSTP(66).EQ.2) THEN
- PS=VINT(3)**2
- Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
- & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
- Q2INT=SQRT(Q0S*Q2EFF)
- VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
- ELSEIF(MSTP(66).EQ.3) THEN
- VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
- ELSEIF(MSTP(66).GE.4) THEN
- PS=0.25D0*VINT(3)**2
- VINT(283)=(Q0S+PS)*(Q1S+PS)/
- & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
- ENDIF
- ENDIF
- VINT(284)=0D0
- IF(MINT(108).EQ.3) THEN
- IF(MSTP(66).EQ.1) THEN
- VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
- ELSEIF(MSTP(66).EQ.2) THEN
- PS=VINT(4)**2
- Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
- & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
- Q2INT=SQRT(Q0S*Q2EFF)
- VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
- ELSEIF(MSTP(66).EQ.3) THEN
- VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
- ELSEIF(MSTP(66).GE.4) THEN
- PS=0.25D0*VINT(4)**2
- VINT(284)=(Q0S+PS)*(Q1S+PS)/
- & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
- ENDIF
- ENDIF
- IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
-
-C...Format statements for differential cross-section maximum violations.
- 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
- &'in event',1X,I7,'D0'/1X,'Execution stopped!')
- 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
- &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
- 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
- &'in event',1X,I7)
- 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
- &'in event',1X,I7,'D0'/1X,'Execution stopped!')
- 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
- &'in event',1X,I7)
- 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
- 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
- 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
- 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
- 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
- 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSCAT
-C...Finds outgoing flavours and event type; sets up the kinematics
-C...and colour flow of the hard scattering
-
- SUBROUTINE PYSCAT
-
-C...Double precision and integer declarations
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Parameter statement for maximum size of showers.
- PARAMETER (MAXNUR=1000)
-
-C...User process event common block.
- INTEGER MAXNUP
- PARAMETER (MAXNUP=500)
- INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
- DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
- COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
- &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
- &VTIMUP(MAXNUP),SPINUP(MAXNUP)
- SAVE /HEPEUP/
-
-C...Commonblocks.
- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
- SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
- &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
- &/PYTCSM/
-C...Local arrays and saved variables
- DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
- &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
- SAVE VINTSV
-
-C...Read out process
- ISUB=MINT(1)
- ISUBSV=ISUB
-
-C...Restore information for low-pT processes
- IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
- DO 100 J=41,66
- 100 VINT(J)=VINTSV(J)
- ENDIF
-
-C...Convert H' or A process into equivalent H one
- IHIGG=1
- KFHIGG=25
- IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
- &ISUB.LE.190)) THEN
- IHIGG=2
- IF(MOD(ISUB-1,10).GE.5) IHIGG=3
- KFHIGG=33+IHIGG
- IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
- IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
- IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
- IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
- IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
- IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
- IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
- IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
- IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
- IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
- IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
- IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
- ENDIF
-
- IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
-
-C...Convert bottomonium process into equivalent charmonium ones.
- IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
-
-C...Choice of subprocess, number of documentation lines
- IDOC=6+ISET(ISUB)
- IF(ISUB.EQ.95) IDOC=8
- IF(ISET(ISUB).EQ.5) IDOC=9
- IF(ISET(ISUB).EQ.11) IDOC=4+NUP
- MINT(3)=IDOC-6
- IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
- MINT(4)=IDOC
- IPU1=MINT(84)+1
- IPU2=MINT(84)+2
- IPU3=MINT(84)+3
- IPU4=MINT(84)+4
- IPU5=MINT(84)+5
- IPU6=MINT(84)+6
-
-C...Reset K, P and V vectors. Store incoming particles
- DO 120 JT=1,MSTP(126)+100
- I=MINT(83)+JT
- IF(I.GT.MSTU(4)) GOTO 120
- DO 110 J=1,5
- K(I,J)=0
- P(I,J)=0D0
- V(I,J)=0D0
- 110 CONTINUE
- 120 CONTINUE
- DO 140 JT=1,2
- I=MINT(83)+JT
- K(I,1)=21
- K(I,2)=MINT(10+JT)
- DO 130 J=1,5
- P(I,J)=VINT(285+5*JT+J)
- 130 CONTINUE
- 140 CONTINUE
- MINT(6)=2
- KFRES=0
-
-C...Store incoming partons in their CM-frame. Save pdf value.
- SH=VINT(44)
- SHR=SQRT(SH)
- SHP=VINT(26)*VINT(2)
- SHPR=SQRT(SHP)
- SHUSER=SHR
- IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
- DO 150 JT=1,2
- I=MINT(84)+JT
- K(I,1)=14
- K(I,2)=MINT(14+JT)
- K(I,3)=MINT(83)+2+JT
- P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
- P(I,4)=0.5D0*SHUSER
- VINT(38+JT)=XSFX(JT,MINT(14+JT))
- 150 CONTINUE
-
-C...Copy incoming partons to documentation lines
- DO 170 JT=1,2
- I1=MINT(83)+4+JT
- I2=MINT(84)+JT
- K(I1,1)=21
- K(I1,2)=K(I2,2)
- K(I1,3)=I1-2
- DO 160 J=1,5
- P(I1,J)=P(I2,J)
- 160 CONTINUE
- 170 CONTINUE
-
-C...Choose new quark/lepton flavour for relevant annihilation graphs
- IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
- &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
- IGLGA=21
- IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
- CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
- 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
- DO 190 I=1,MDCY(IGLGA,3)
- KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
- RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
- IF(RKFL.LE.0D0) GOTO 200
- 190 CONTINUE
- 200 CONTINUE
- IF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.2) THEN
- IF(KFLF.GE.4) GOTO 180
- ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.4) THEN
- KFLF=4
- MINT(2)=MINT(2)-2
- ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385) THEN
- KFLF=5
- MINT(2)=MINT(2)-4
- ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
- & .AND.IABS(KFLF).GE.3) THEN
- FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
- & VINT(44)**2
- FACCIB=VINT(46)**2/RTCM(41)**4
- IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
- ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
- KFLF=5
- MINT(2)=1
- ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
- IF(KFLF.EQ.5) GOTO 180
- ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
- IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
- ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
- IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
- ENDIF
- ENDIF
-
-C...Final state flavours and colour flow: default values
- JS=1
- MINT(21)=MINT(15)
- MINT(22)=MINT(16)
- MINT(23)=0
- MINT(24)=0
- KCC=20
- KCS=ISIGN(1,MINT(15))
-
- IF(ISET(ISUB).EQ.11) THEN
-C...User-defined processes: find products
- MINT(3)=0
- DO 210 IUP=3,NUP
- IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
- ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
- MINT(21+IUP)=IDUP(IUP)
- ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
- & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
- ELSEIF(IDUP(IUP).EQ.0) THEN
- ELSE
- MINT(3)=MINT(3)+1
- IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
- ENDIF
- 210 CONTINUE
-
- ELSEIF(ISUB.LE.10) THEN
- IF(ISUB.EQ.1) THEN
-C...f + fbar -> gamma*/Z0
- KFRES=23
-
- ELSEIF(ISUB.EQ.2) THEN
-C...f + fbar' -> W+/-
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- KFRES=ISIGN(24,KCH1+KCH2)
-
- ELSEIF(ISUB.EQ.3) THEN
-C...f + fbar -> h0 (or H0, or A0)
- KFRES=KFHIGG
-
- ELSEIF(ISUB.EQ.4) THEN
-C...gamma + W+/- -> W+/-
-
- ELSEIF(ISUB.EQ.5) THEN
-C...Z0 + Z0 -> h0
- XH=SH/SHP
- MINT(21)=MINT(15)
- MINT(22)=MINT(16)
- PMQ(1)=PYMASS(MINT(21))
- PMQ(2)=PYMASS(MINT(22))
- 220 JT=INT(1.5D0+PYR(0))
- ZMIN=2D0*PMQ(JT)/SHPR
- ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
- & (SHPR*(SHPR-PMQ(3-JT)))
- ZMAX=MIN(1D0-XH,ZMAX)
- Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
- IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
- & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
- SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
- IF(SQC1.LT.1D-8) GOTO 220
- C1=SQRT(SQC1)
- C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
- CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
- CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
- Z(3-JT)=1D0-XH/(1D0-Z(JT))
- SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
- IF(SQC1.LT.1D-8) GOTO 220
- C1=SQRT(SQC1)
- C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
- CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
- CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
- PHIR=PARU(2)*PYR(0)
- CPHI=COS(PHIR)
- ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
- & SQRT(1D0-CTHE(2)**2)*CPHI
- Z1=2D0-Z(JT)
- Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
- Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
- Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
- & PMQ(3-JT)**2/SHP))
- ZMIN=2D0*PMQ(3-JT)/SHPR
- ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
- ZMAX=MIN(1D0-XH,ZMAX)
- IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
- KCC=22
- KFRES=25
-
- ELSEIF(ISUB.EQ.6) THEN
-C...Z0 + W+/- -> W+/-
-
- ELSEIF(ISUB.EQ.7) THEN
-C...W+ + W- -> Z0
-
- ELSEIF(ISUB.EQ.8) THEN
-C...W+ + W- -> h0
- XH=SH/SHP
- 230 DO 260 JT=1,2
- I=MINT(14+JT)
- IA=IABS(I)
- IF(IA.LE.10) THEN
- RVCKM=VINT(180+I)*PYR(0)
- DO 240 J=1,MSTP(1)
- IB=2*J-1+MOD(IA,2)
- IPM=(5-ISIGN(1,I))/2
- IDC=J+MDCY(IA,2)+2
- IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
- MINT(20+JT)=ISIGN(IB,I)
- RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
- IF(RVCKM.LE.0D0) GOTO 250
- 240 CONTINUE
- ELSE
- IB=2*((IA+1)/2)-1+MOD(IA,2)
- MINT(20+JT)=ISIGN(IB,I)
- ENDIF
- 250 PMQ(JT)=PYMASS(MINT(20+JT))
- 260 CONTINUE
- JT=INT(1.5D0+PYR(0))
- ZMIN=2D0*PMQ(JT)/SHPR
- ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
- & (SHPR*(SHPR-PMQ(3-JT)))
- ZMAX=MIN(1D0-XH,ZMAX)
- IF(ZMIN.GE.ZMAX) GOTO 230
- Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
- IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
- & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
- SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
- IF(SQC1.LT.1D-8) GOTO 230
- C1=SQRT(SQC1)
- C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
- CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
- CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
- Z(3-JT)=1D0-XH/(1D0-Z(JT))
- SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
- IF(SQC1.LT.1D-8) GOTO 230
- C1=SQRT(SQC1)
- C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
- CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
- CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
- PHIR=PARU(2)*PYR(0)
- CPHI=COS(PHIR)
- ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
- & SQRT(1D0-CTHE(2)**2)*CPHI
- Z1=2D0-Z(JT)
- Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
- Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
- Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
- & PMQ(3-JT)**2/SHP))
- ZMIN=2D0*PMQ(3-JT)/SHPR
- ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
- ZMAX=MIN(1D0-XH,ZMAX)
- IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
- KCC=22
- KFRES=25
-
- ELSEIF(ISUB.EQ.10) THEN
-C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
- IF(MINT(2).EQ.1) THEN
- KCC=22
- ELSE
-C...W exchange: need to mix flavours according to CKM matrix
- DO 280 JT=1,2
- I=MINT(14+JT)
- IA=IABS(I)
- IF(IA.LE.10) THEN
- RVCKM=VINT(180+I)*PYR(0)
- DO 270 J=1,MSTP(1)
- IB=2*J-1+MOD(IA,2)
- IPM=(5-ISIGN(1,I))/2
- IDC=J+MDCY(IA,2)+2
- IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
- MINT(20+JT)=ISIGN(IB,I)
- RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
- IF(RVCKM.LE.0D0) GOTO 280
- 270 CONTINUE
- ELSE
- IB=2*((IA+1)/2)-1+MOD(IA,2)
- MINT(20+JT)=ISIGN(IB,I)
- ENDIF
- 280 CONTINUE
- KCC=22
- ENDIF
- ENDIF
-
- ELSEIF(ISUB.LE.20) THEN
- IF(ISUB.EQ.11) THEN
-C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
- KCC=MINT(2)
- IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
-
- ELSEIF(ISUB.EQ.12) THEN
-C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
- MINT(21)=ISIGN(KFLF,MINT(15))
- MINT(22)=-MINT(21)
- KCC=4
-
- ELSEIF(ISUB.EQ.13) THEN
-C...f + fbar -> g + g; th arbitrary
- MINT(21)=21
- MINT(22)=21
- KCC=MINT(2)+4
-
- ELSEIF(ISUB.EQ.14) THEN
-C...f + fbar -> g + gamma; th arbitrary
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=21
- MINT(23-JS)=22
- KCC=17+JS
-
- ELSEIF(ISUB.EQ.15) THEN
-C...f + fbar -> g + Z0; th arbitrary
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=21
- MINT(23-JS)=23
- KCC=17+JS
-
- ELSEIF(ISUB.EQ.16) THEN
-C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
- MINT(20+JS)=21
- MINT(23-JS)=ISIGN(24,KCH1+KCH2)
- KCC=17+JS
-
- ELSEIF(ISUB.EQ.17) THEN
-C...f + fbar -> g + h0; th arbitrary
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=21
- MINT(23-JS)=25
- KCC=17+JS
-
- ELSEIF(ISUB.EQ.18) THEN
-C...f + fbar -> gamma + gamma; th arbitrary
- MINT(21)=22
- MINT(22)=22
-
- ELSEIF(ISUB.EQ.19) THEN
-C...f + fbar -> gamma + Z0; th arbitrary
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=22
- MINT(23-JS)=23
-
- ELSEIF(ISUB.EQ.20) THEN
-C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
-C...(p(fbar')-p(W+))**2
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
- MINT(20+JS)=22
- MINT(23-JS)=ISIGN(24,KCH1+KCH2)
- ENDIF
-
- ELSEIF(ISUB.LE.30) THEN
- IF(ISUB.EQ.21) THEN
-C...f + fbar -> gamma + h0; th arbitrary
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=22
- MINT(23-JS)=25
-
- ELSEIF(ISUB.EQ.22) THEN
-C...f + fbar -> Z0 + Z0; th arbitrary
- MINT(21)=23
- MINT(22)=23
-
- ELSEIF(ISUB.EQ.23) THEN
-C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
- MINT(20+JS)=23
- MINT(23-JS)=ISIGN(24,KCH1+KCH2)
-
- ELSEIF(ISUB.EQ.24) THEN
-C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=23
- MINT(23-JS)=KFHIGG
-
- ELSEIF(ISUB.EQ.25) THEN
-C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
- MINT(21)=-ISIGN(24,MINT(15))
- MINT(22)=-MINT(21)
-
- ELSEIF(ISUB.EQ.26) THEN
-C...f + fbar' -> W+/- + h0 (or H0, or A0);
-C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
- MINT(20+JS)=ISIGN(24,KCH1+KCH2)
- MINT(23-JS)=KFHIGG
-
- ELSEIF(ISUB.EQ.27) THEN
-C...f + fbar -> h0 + h0
-
- ELSEIF(ISUB.EQ.28) THEN
-C...f + g -> f + g; th = (p(f)-p(f))**2
- IF(MINT(15).EQ.21) JS=2
- KCC=MINT(2)+6
- IF(MINT(15).EQ.21) KCC=KCC+2
- IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
- IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
-
- ELSEIF(ISUB.EQ.29) THEN
-C...f + g -> f + gamma; th = (p(f)-p(f))**2
- IF(MINT(15).EQ.21) JS=2
- MINT(23-JS)=22
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.30) THEN
-C...f + g -> f + Z0; th = (p(f)-p(f))**2
- IF(MINT(15).EQ.21) JS=2
- MINT(23-JS)=23
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
- ENDIF
-
- ELSEIF(ISUB.LE.40) THEN
- IF(ISUB.EQ.31) THEN
-C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
- RVCKM=VINT(180+I)*PYR(0)
- DO 290 J=1,MSTP(1)
- IB=2*J-1+MOD(IA,2)
- IPM=(5-ISIGN(1,I))/2
- IDC=J+MDCY(IA,2)+2
- IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
- MINT(20+JS)=ISIGN(IB,I)
- RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
- IF(RVCKM.LE.0D0) GOTO 300
- 290 CONTINUE
- 300 KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.32) THEN
-C...f + g -> f + h0; th = (p(f)-p(f))**2
- IF(MINT(15).EQ.21) JS=2
- MINT(23-JS)=25
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.33) THEN
-C...f + gamma -> f + g; th=(p(f)-p(f))**2
- IF(MINT(15).EQ.22) JS=2
- MINT(23-JS)=21
- KCC=24+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.34) THEN
-C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
- IF(MINT(15).EQ.22) JS=2
- KCC=22
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.35) THEN
-C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
- IF(MINT(15).EQ.22) JS=2
- MINT(23-JS)=23
- KCC=22
-
- ELSEIF(ISUB.EQ.36) THEN
-C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
- IF(MINT(15).EQ.22) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
- IF(IA.LE.10) THEN
- RVCKM=VINT(180+I)*PYR(0)
- DO 310 J=1,MSTP(1)
- IB=2*J-1+MOD(IA,2)
- IPM=(5-ISIGN(1,I))/2
- IDC=J+MDCY(IA,2)+2
- IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
- MINT(20+JS)=ISIGN(IB,I)
- RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
- IF(RVCKM.LE.0D0) GOTO 320
- 310 CONTINUE
- ELSE
- IB=2*((IA+1)/2)-1+MOD(IA,2)
- MINT(20+JS)=ISIGN(IB,I)
- ENDIF
- 320 KCC=22
-
- ELSEIF(ISUB.EQ.37) THEN
-C...f + gamma -> f + h0
-
- ELSEIF(ISUB.EQ.38) THEN
-C...f + Z0 -> f + g
-
- ELSEIF(ISUB.EQ.39) THEN
-C...f + Z0 -> f + gamma
-
- ELSEIF(ISUB.EQ.40) THEN
-C...f + Z0 -> f + Z0
- ENDIF
-
- ELSEIF(ISUB.LE.50) THEN
- IF(ISUB.EQ.41) THEN
-C...f + Z0 -> f' + W+/-
-
- ELSEIF(ISUB.EQ.42) THEN
-C...f + Z0 -> f + h0
-
- ELSEIF(ISUB.EQ.43) THEN
-C...f + W+/- -> f' + g
-
- ELSEIF(ISUB.EQ.44) THEN
-C...f + W+/- -> f' + gamma
-
- ELSEIF(ISUB.EQ.45) THEN
-C...f + W+/- -> f' + Z0
-
- ELSEIF(ISUB.EQ.46) THEN
-C...f + W+/- -> f' + W+/-
-
- ELSEIF(ISUB.EQ.47) THEN
-C...f + W+/- -> f' + h0
-
- ELSEIF(ISUB.EQ.48) THEN
-C...f + h0 -> f + g
-
- ELSEIF(ISUB.EQ.49) THEN
-C...f + h0 -> f + gamma
-
- ELSEIF(ISUB.EQ.50) THEN
-C...f + h0 -> f + Z0
- ENDIF
-
- ELSEIF(ISUB.LE.60) THEN
- IF(ISUB.EQ.51) THEN
-C...f + h0 -> f' + W+/-
-
- ELSEIF(ISUB.EQ.52) THEN
-C...f + h0 -> f + h0
-
- ELSEIF(ISUB.EQ.53) THEN
-C...g + g -> f + fbar; th arbitrary
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(KFLF,KCS)
- MINT(22)=-MINT(21)
- KCC=MINT(2)+10
-
- ELSEIF(ISUB.EQ.54) THEN
-C...g + gamma -> f + fbar; th arbitrary
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(KFLF,KCS)
- MINT(22)=-MINT(21)
- KCC=27
- IF(MINT(16).EQ.21) KCC=28
-
- ELSEIF(ISUB.EQ.55) THEN
-C...g + Z0 -> f + fbar
-
- ELSEIF(ISUB.EQ.56) THEN
-C...g + W+/- -> f + fbar'
-
- ELSEIF(ISUB.EQ.57) THEN
-C...g + h0 -> f + fbar
-
- ELSEIF(ISUB.EQ.58) THEN
-C...gamma + gamma -> f + fbar; th arbitrary
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(KFLF,KCS)
- MINT(22)=-MINT(21)
- KCC=21
-
- ELSEIF(ISUB.EQ.59) THEN
-C...gamma + Z0 -> f + fbar
-
- ELSEIF(ISUB.EQ.60) THEN
-C...gamma + W+/- -> f + fbar'
- ENDIF
-
- ELSEIF(ISUB.LE.70) THEN
- IF(ISUB.EQ.61) THEN
-C...gamma + h0 -> f + fbar
-
- ELSEIF(ISUB.EQ.62) THEN
-C...Z0 + Z0 -> f + fbar
-
- ELSEIF(ISUB.EQ.63) THEN
-C...Z0 + W+/- -> f + fbar'
-
- ELSEIF(ISUB.EQ.64) THEN
-C...Z0 + h0 -> f + fbar
-
- ELSEIF(ISUB.EQ.65) THEN
-C...W+ + W- -> f + fbar
-
- ELSEIF(ISUB.EQ.66) THEN
-C...W+/- + h0 -> f + fbar'
-
- ELSEIF(ISUB.EQ.67) THEN
-C...h0 + h0 -> f + fbar
-
- ELSEIF(ISUB.EQ.68) THEN
-C...g + g -> g + g; th arbitrary
- KCC=MINT(2)+12
- KCS=(-1)**INT(1.5D0+PYR(0))
-
- ELSEIF(ISUB.EQ.69) THEN
-C...gamma + gamma -> W+ + W-; th arbitrary
- MINT(21)=24
- MINT(22)=-24
- KCC=21
-
- ELSEIF(ISUB.EQ.70) THEN
-C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
- IF(MINT(15).EQ.22) MINT(21)=23
- IF(MINT(16).EQ.22) MINT(22)=23
- KCC=21
- ENDIF
-
- ELSEIF(ISUB.LE.80) THEN
- IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
-C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
- XH=SH/SHP
- MINT(21)=MINT(15)
- MINT(22)=MINT(16)
- PMQ(1)=PYMASS(MINT(21))
- PMQ(2)=PYMASS(MINT(22))
- 330 JT=INT(1.5D0+PYR(0))
- ZMIN=2D0*PMQ(JT)/SHPR
- ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
- & (SHPR*(SHPR-PMQ(3-JT)))
- ZMAX=MIN(1D0-XH,ZMAX)
- Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
- IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
- & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
- SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
- IF(SQC1.LT.1D-8) GOTO 330
- C1=SQRT(SQC1)
- C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
- CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
- CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
- Z(3-JT)=1D0-XH/(1D0-Z(JT))
- SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
- IF(SQC1.LT.1D-8) GOTO 330
- C1=SQRT(SQC1)
- C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
- CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
- CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
- PHIR=PARU(2)*PYR(0)
- CPHI=COS(PHIR)
- ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
- & SQRT(1D0-CTHE(2)**2)*CPHI
- Z1=2D0-Z(JT)
- Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
- Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
- Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
- & PMQ(3-JT)**2/SHP))
- ZMIN=2D0*PMQ(3-JT)/SHPR
- ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
- ZMAX=MIN(1D0-XH,ZMAX)
- IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
- KCC=22
-
- ELSEIF(ISUB.EQ.73) THEN
-C...Z0 + W+/- -> Z0 + W+/-
- JS=MINT(2)
- XH=SH/SHP
- 340 JT=3-MINT(2)
- I=MINT(14+JT)
- IA=IABS(I)
- IF(IA.LE.10) THEN
- RVCKM=VINT(180+I)*PYR(0)
- DO 350 J=1,MSTP(1)
- IB=2*J-1+MOD(IA,2)
- IPM=(5-ISIGN(1,I))/2
- IDC=J+MDCY(IA,2)+2
- IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
- MINT(20+JT)=ISIGN(IB,I)
- RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
- IF(RVCKM.LE.0D0) GOTO 360
- 350 CONTINUE
- ELSE
- IB=2*((IA+1)/2)-1+MOD(IA,2)
- MINT(20+JT)=ISIGN(IB,I)
- ENDIF
- 360 PMQ(JT)=PYMASS(MINT(20+JT))
- MINT(23-JT)=MINT(17-JT)
- PMQ(3-JT)=PYMASS(MINT(23-JT))
- JT=INT(1.5D0+PYR(0))
- ZMIN=2D0*PMQ(JT)/SHPR
- ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
- & (SHPR*(SHPR-PMQ(3-JT)))
- ZMAX=MIN(1D0-XH,ZMAX)
- IF(ZMIN.GE.ZMAX) GOTO 340
- Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
- IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
- & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
- SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
- IF(SQC1.LT.1D-8) GOTO 340
- C1=SQRT(SQC1)
- C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
- CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
- CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
- Z(3-JT)=1D0-XH/(1D0-Z(JT))
- SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
- IF(SQC1.LT.1D-8) GOTO 340
- C1=SQRT(SQC1)
- C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
- CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
- CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
- PHIR=PARU(2)*PYR(0)
- CPHI=COS(PHIR)
- ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
- & SQRT(1D0-CTHE(2)**2)*CPHI
- Z1=2D0-Z(JT)
- Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
- Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
- Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
- & PMQ(3-JT)**2/SHP))
- ZMIN=2D0*PMQ(3-JT)/SHPR
- ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
- ZMAX=MIN(1D0-XH,ZMAX)
- IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
- KCC=22
-
- ELSEIF(ISUB.EQ.74) THEN
-C...Z0 + h0 -> Z0 + h0
-
- ELSEIF(ISUB.EQ.75) THEN
-C...W+ + W- -> gamma + gamma
-
- ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
-C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
- XH=SH/SHP
- 370 DO 400 JT=1,2
- I=MINT(14+JT)
- IA=IABS(I)
- IF(IA.LE.10) THEN
- RVCKM=VINT(180+I)*PYR(0)
- DO 380 J=1,MSTP(1)
- IB=2*J-1+MOD(IA,2)
- IPM=(5-ISIGN(1,I))/2
- IDC=J+MDCY(IA,2)+2
- IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
- MINT(20+JT)=ISIGN(IB,I)
- RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
- IF(RVCKM.LE.0D0) GOTO 390
- 380 CONTINUE
- ELSE
- IB=2*((IA+1)/2)-1+MOD(IA,2)
- MINT(20+JT)=ISIGN(IB,I)
- ENDIF
- 390 PMQ(JT)=PYMASS(MINT(20+JT))
- 400 CONTINUE
- JT=INT(1.5D0+PYR(0))
- ZMIN=2D0*PMQ(JT)/SHPR
- ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
- & (SHPR*(SHPR-PMQ(3-JT)))
- ZMAX=MIN(1D0-XH,ZMAX)
- IF(ZMIN.GE.ZMAX) GOTO 370
- Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
- IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
- & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
- SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
- IF(SQC1.LT.1D-8) GOTO 370
- C1=SQRT(SQC1)
- C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
- CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
- CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
- Z(3-JT)=1D0-XH/(1D0-Z(JT))
- SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
- IF(SQC1.LT.1D-8) GOTO 370
- C1=SQRT(SQC1)
- C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
- CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
- CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
- PHIR=PARU(2)*PYR(0)
- CPHI=COS(PHIR)
- ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
- & SQRT(1D0-CTHE(2)**2)*CPHI
- Z1=2D0-Z(JT)
- Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
- Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
- Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
- & PMQ(3-JT)**2/SHP))
- ZMIN=2D0*PMQ(3-JT)/SHPR
- ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
- ZMAX=MIN(1D0-XH,ZMAX)
- IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
- KCC=22
-
- ELSEIF(ISUB.EQ.78) THEN
-C...W+/- + h0 -> W+/- + h0
-
- ELSEIF(ISUB.EQ.79) THEN
-C...h0 + h0 -> h0 + h0
-
- ELSEIF(ISUB.EQ.80) THEN
-C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
- IF(MINT(15).EQ.22) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
- IB=3-IA
- MINT(20+JS)=ISIGN(IB,I)
- KCC=22
- ENDIF
-
- ELSEIF(ISUB.LE.90) THEN
- IF(ISUB.EQ.81) THEN
-C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
- MINT(21)=ISIGN(MINT(55),MINT(15))
- MINT(22)=-MINT(21)
- KCC=4
-
- ELSEIF(ISUB.EQ.82) THEN
-C...g + g -> Q + Qbar; th arbitrary
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(MINT(55),KCS)
- MINT(22)=-MINT(21)
- KCC=MINT(2)+10
-
- ELSEIF(ISUB.EQ.83) THEN
-C...f + q -> f' + Q; th = (p(f) - p(f'))**2
- KFOLD=MINT(16)
- IF(MINT(2).EQ.2) KFOLD=MINT(15)
- KFAOLD=IABS(KFOLD)
- IF(KFAOLD.GT.10) THEN
- KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
- ELSE
- RCKM=VINT(180+KFOLD)*PYR(0)
- IPM=(5-ISIGN(1,KFOLD))/2
- KFANEW=-MOD(KFAOLD+1,2)
- 410 KFANEW=KFANEW+2
- IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
- IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
- IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
- & VCKM(KFAOLD/2,(KFANEW+1)/2)
- IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
- & VCKM(KFANEW/2,(KFAOLD+1)/2)
- ENDIF
- IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
- ENDIF
- IF(MINT(2).EQ.1) THEN
- MINT(21)=ISIGN(MINT(55),MINT(15))
- MINT(22)=ISIGN(KFANEW,MINT(16))
- ELSE
- MINT(21)=ISIGN(KFANEW,MINT(15))
- MINT(22)=ISIGN(MINT(55),MINT(16))
- JS=2
- ENDIF
- KCC=22
-
- ELSEIF(ISUB.EQ.84) THEN
-C...g + gamma -> Q + Qbar; th arbitary
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(MINT(55),KCS)
- MINT(22)=-MINT(21)
- KCC=27
- IF(MINT(16).EQ.21) KCC=28
-
- ELSEIF(ISUB.EQ.85) THEN
-C...gamma + gamma -> F + Fbar; th arbitary
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(MINT(56),KCS)
- MINT(22)=-MINT(21)
- KCC=21
-
- ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
-C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
- MINT(21)=KFPR(ISUB,1)
- MINT(22)=KFPR(ISUB,2)
- KCC=24
- KCS=(-1)**INT(1.5D0+PYR(0))
- ENDIF
-
- ELSEIF(ISUB.LE.100) THEN
- IF(ISUB.EQ.95) THEN
-C...Low-pT ( = energyless g + g -> g + g)
- KCC=MINT(2)+12
- KCS=(-1)**INT(1.5D0+PYR(0))
-
- ELSEIF(ISUB.EQ.96) THEN
-C...Multiple interactions (should be reassigned to QCD process)
- ENDIF
-
- ELSEIF(ISUB.LE.110) THEN
- IF(ISUB.EQ.101) THEN
-C...g + g -> gamma*/Z0
- KCC=21
- KFRES=22
-
- ELSEIF(ISUB.EQ.102) THEN
-C...g + g -> h0 (or H0, or A0)
- KCC=21
- KFRES=KFHIGG
-
- ELSEIF(ISUB.EQ.103) THEN
-C...gamma + gamma -> h0 (or H0, or A0)
- KCC=21
- KFRES=KFHIGG
-
- ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
-C...g + g -> chi_0c or chi_2c.
- KCC=21
- KFRES=KFPR(ISUB,1)
-
- ELSEIF(ISUB.EQ.106) THEN
-C...g + g -> J/Psi + gamma
- MINT(21)=KFPR(ISUB,1)
- MINT(22)=KFPR(ISUB,2)
- KCC=21
-
- ELSEIF(ISUB.EQ.107) THEN
-C...g + gamma -> J/Psi + g
- MINT(21)=KFPR(ISUB,1)
- MINT(22)=KFPR(ISUB,2)
- KCC=22
- IF(MINT(16).EQ.22) KCC=33
-
- ELSEIF(ISUB.EQ.108) THEN
-C...gamma + gamma -> J/Psi + gamma
- MINT(21)=KFPR(ISUB,1)
- MINT(22)=KFPR(ISUB,2)
-
- ELSEIF(ISUB.EQ.110) THEN
-C...f + fbar -> gamma + h0; th arbitrary
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=22
- MINT(23-JS)=KFHIGG
- ENDIF
-
- ELSEIF(ISUB.LE.120) THEN
- IF(ISUB.EQ.111) THEN
-C...f + fbar -> g + h0; th arbitrary
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=21
- MINT(23-JS)=KFHIGG
- KCC=17+JS
-
- ELSEIF(ISUB.EQ.112) THEN
-C...f + g -> f + h0; th = (p(f) - p(f))**2
- IF(MINT(15).EQ.21) JS=2
- MINT(23-JS)=KFHIGG
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.113) THEN
-C...g + g -> g + h0; th arbitrary
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(23-JS)=KFHIGG
- KCC=22+JS
- KCS=(-1)**INT(1.5D0+PYR(0))
-
- ELSEIF(ISUB.EQ.114) THEN
-C...g + g -> gamma + gamma; th arbitrary
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(21)=22
- MINT(22)=22
- KCC=21
-
- ELSEIF(ISUB.EQ.115) THEN
-C...g + g -> g + gamma; th arbitrary
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(23-JS)=22
- KCC=22+JS
- KCS=(-1)**INT(1.5D0+PYR(0))
-
- ELSEIF(ISUB.EQ.116) THEN
-C...g + g -> gamma + Z0
-
- ELSEIF(ISUB.EQ.117) THEN
-C...g + g -> Z0 + Z0
-
- ELSEIF(ISUB.EQ.118) THEN
-C...g + g -> W+ + W-
- ENDIF
-
- ELSEIF(ISUB.LE.140) THEN
- IF(ISUB.EQ.121) THEN
-C...g + g -> Q + Qbar + h0
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
- MINT(22)=-MINT(21)
- KCC=11+INT(0.5D0+PYR(0))
- KFRES=KFHIGG
-
- ELSEIF(ISUB.EQ.122) THEN
-C...q + qbar -> Q + Qbar + h0
- MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
- MINT(22)=-MINT(21)
- KCC=4
- KFRES=KFHIGG
-
- ELSEIF(ISUB.EQ.123) THEN
-C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
-C...inner process)
- KCC=22
- KFRES=KFHIGG
-
- ELSEIF(ISUB.EQ.124) THEN
-C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
-C...inner process)
- DO 430 JT=1,2
- I=MINT(14+JT)
- IA=IABS(I)
- IF(IA.LE.10) THEN
- RVCKM=VINT(180+I)*PYR(0)
- DO 420 J=1,MSTP(1)
- IB=2*J-1+MOD(IA,2)
- IPM=(5-ISIGN(1,I))/2
- IDC=J+MDCY(IA,2)+2
- IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
- MINT(20+JT)=ISIGN(IB,I)
- RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
- IF(RVCKM.LE.0D0) GOTO 430
- 420 CONTINUE
- ELSE
- IB=2*((IA+1)/2)-1+MOD(IA,2)
- MINT(20+JT)=ISIGN(IB,I)
- ENDIF
- 430 CONTINUE
- KCC=22
- KFRES=KFHIGG
-
- ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
-C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
- IF(MINT(15).EQ.22) JS=2
- MINT(23-JS)=21
- KCC=24+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
-C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
- IF(MINT(15).EQ.22) JS=2
- KCC=22
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
-C...g + gamma*_(T,L) -> f + fbar; th arbitrary
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(KFLF,KCS)
- MINT(22)=-MINT(21)
- KCC=27
- IF(MINT(16).EQ.21) KCC=28
-
- ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
-C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(KFLF,KCS)
- MINT(22)=-MINT(21)
- KCC=21
-
- ENDIF
-
- ELSEIF(ISUB.LE.160) THEN
- IF(ISUB.EQ.141) THEN
-C...f + fbar -> gamma*/Z0/Z'0
- KFRES=32
-
- ELSEIF(ISUB.EQ.142) THEN
-C...f + fbar' -> W'+/-
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- KFRES=ISIGN(34,KCH1+KCH2)
-
- ELSEIF(ISUB.EQ.143) THEN
-C...f + fbar' -> H+/-
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- KFRES=ISIGN(37,KCH1+KCH2)
-
- ELSEIF(ISUB.EQ.144) THEN
-C...f + fbar' -> R
- KFRES=ISIGN(41,MINT(15)+MINT(16))
-
- ELSEIF(ISUB.EQ.145) THEN
-C...q + l -> LQ (leptoquark)
- IF(IABS(MINT(16)).LE.8) JS=2
- KFRES=ISIGN(42,MINT(14+JS))
- KCC=28+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.146) THEN
-C...e + gamma -> e* (excited lepton)
- IF(MINT(15).EQ.22) JS=2
- KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
- KCC=22
-
- ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
-C...q + g -> q* (excited quark)
- IF(MINT(15).EQ.21) JS=2
- KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
- KCC=30+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.149) THEN
-C...g + g -> eta_tc
- KFRES=KTECHN+331
- KCC=23
- KCS=(-1)**INT(1.5D0+PYR(0))
- ENDIF
-
- ELSEIF(ISUB.LE.200) THEN
- IF(ISUB.EQ.161) THEN
-C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
- IB=IA+MOD(IA,2)-MOD(IA+1,2)
- MINT(20+JS)=ISIGN(IB,I)
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.162) THEN
-C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
- IF(MINT(15).EQ.21) JS=2
- MINT(20+JS)=ISIGN(42,MINT(14+JS))
- KFLQL=KFDP(MDCY(42,2),2)
- MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.163) THEN
-C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(42,KCS)
- MINT(22)=-MINT(21)
- KCC=MINT(2)+10
-
- ELSEIF(ISUB.EQ.164) THEN
-C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
- MINT(21)=ISIGN(42,MINT(15))
- MINT(22)=-MINT(21)
- KCC=4
-
- ELSEIF(ISUB.EQ.165) THEN
-C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
- MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
- MINT(22)=-MINT(21)
-
- ELSEIF(ISUB.EQ.166) THEN
-C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
- IF(MOD(MINT(15),2).EQ.0) THEN
- MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
- MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
- ELSE
- MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
- MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
- ENDIF
-
- ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
-C...q + q' -> q" + q* (excited quark)
- KFQSTR=KFPR(ISUB,2)
- KFQEXC=MOD(KFQSTR,KEXCIT)
- JS=MINT(2)
- MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
- IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
- & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
- KCC=22
- JS=3-JS
-
- ELSEIF(ISUB.EQ.169) THEN
-C...q + qbar -> e + e* (excited lepton)
- KFQSTR=KFPR(ISUB,2)
- KFQEXC=MOD(KFQSTR,KEXCIT)
- JS=MINT(2)
- MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
- MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
- JS=3-JS
-
- ELSEIF(ISUB.EQ.191) THEN
-C...f + fbar -> rho_tc0.
- KFRES=KTECHN+113
-
- ELSEIF(ISUB.EQ.192) THEN
-C...f + fbar' -> rho_tc+/-
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
-
- ELSEIF(ISUB.EQ.193) THEN
-C...f + fbar -> omega_tc0.
- KFRES=KTECHN+223
-
- ELSEIF(ISUB.EQ.194) THEN
-C...f + fbar -> f' + fbar' via mixture of s-channel
-C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
- MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
- MINT(22)=-MINT(21)
-
- ELSEIF(ISUB.EQ.195) THEN
-C...f + fbar' -> f'' + fbar''' via s-channel
-C...rho_tc+ th=(p(f)-p(f'))**2
-C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
- IF(MOD(MINT(15),2).EQ.0) THEN
- MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
- MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
- ELSE
- MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
- MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
- ENDIF
- ENDIF
-
-CMRENNA++
- ELSEIF(ISUB.LE.215) THEN
- IF(ISUB.EQ.201) THEN
-C...f + fbar -> ~e_L + ~e_Lbar
- MINT(21)=ISIGN(KSUSY1+11,KCS)
- MINT(22)=-MINT(21)
-
- ELSEIF(ISUB.EQ.202) THEN
-C...f + fbar -> ~e_R + ~e_Rbar
- MINT(21)=ISIGN(KSUSY2+11,KCS)
- MINT(22)=-MINT(21)
-
- ELSEIF(ISUB.EQ.203) THEN
-C...f + fbar -> ~e_L + ~e_Rbar
- IF(MINT(15).LT.0) JS=2
- IF(MINT(2).EQ.1) THEN
- MINT(20+JS)=KFPR(ISUB,1)
- MINT(23-JS)=-KFPR(ISUB,2)
- ELSE
- MINT(20+JS)=-KFPR(ISUB,1)
- MINT(23-JS)=KFPR(ISUB,2)
- ENDIF
-
- ELSEIF(ISUB.EQ.204) THEN
-C...f + fbar -> ~mu_L + ~mu_Lbar
- MINT(21)=ISIGN(KSUSY1+13,KCS)
- MINT(22)=-MINT(21)
-
- ELSEIF(ISUB.EQ.205) THEN
-C...f + fbar -> ~mu_R + ~mu_Rbar
- MINT(21)=ISIGN(KSUSY2+13,KCS)
- MINT(22)=-MINT(21)
-
- ELSEIF(ISUB.EQ.206) THEN
-C...f + fbar -> ~mu_L + ~mu_Rbar
- IF(MINT(15).LT.0) JS=2
- IF(MINT(2).EQ.1) THEN
- MINT(20+JS)=KFPR(ISUB,1)
- MINT(23-JS)=-KFPR(ISUB,2)
- ELSE
- MINT(20+JS)=-KFPR(ISUB,1)
- MINT(23-JS)=KFPR(ISUB,2)
- ENDIF
-
- ELSEIF(ISUB.EQ.207) THEN
-C...f + fbar -> ~tau_1 + ~tau_1bar
- MINT(21)=ISIGN(KSUSY1+15,KCS)
- MINT(22)=-MINT(21)
-
- ELSEIF(ISUB.EQ.208) THEN
-C...f + fbar -> ~tau_2 + ~tau_2bar
- MINT(21)=ISIGN(KSUSY2+15,KCS)
- MINT(22)=-MINT(21)
-
- ELSEIF(ISUB.EQ.209) THEN
-C...f + fbar -> ~tau_1 + ~tau_2bar
- IF(MINT(15).LT.0) JS=2
- IF(MINT(2).EQ.1) THEN
- MINT(20+JS)=KFPR(ISUB,1)
- MINT(23-JS)=-KFPR(ISUB,2)
- ELSE
- MINT(20+JS)=-KFPR(ISUB,1)
- MINT(23-JS)=KFPR(ISUB,2)
- ENDIF
-
- ELSEIF(ISUB.EQ.210) THEN
-C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
- MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
-
- ELSEIF(ISUB.EQ.211) THEN
-C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
- MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
-
- ELSEIF(ISUB.EQ.212) THEN
-C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
- MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
-
- ELSEIF(ISUB.EQ.213) THEN
-C...f + fbar -> ~nul + ~nulbar
- MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
- MINT(22)=-MINT(21)
-
- ELSEIF(ISUB.EQ.214) THEN
-C...f + fbar -> ~nutau + ~nutaubar
- MINT(21)=ISIGN(KSUSY1+16,KCS)
- MINT(22)=-MINT(21)
- ENDIF
-
- ELSEIF(ISUB.LE.225) THEN
- IF(ISUB.EQ.216) THEN
-C...f + fbar -> ~chi01 + ~chi01
- MINT(21)=KSUSY1+22
- MINT(22)=KSUSY1+22
-
- ELSEIF(ISUB.EQ.217) THEN
-C...f + fbar -> ~chi02 + ~chi02
- MINT(21)=KSUSY1+23
- MINT(22)=KSUSY1+23
-
- ELSEIF(ISUB.EQ.218 ) THEN
-C...f + fbar -> ~chi03 + ~chi03
- MINT(21)=KSUSY1+25
- MINT(22)=KSUSY1+25
-
- ELSEIF(ISUB.EQ.219 ) THEN
-C...f + fbar -> ~chi04 + ~chi04
- MINT(21)=KSUSY1+35
- MINT(22)=KSUSY1+35
-
- ELSEIF(ISUB.EQ.220 ) THEN
-C...f + fbar -> ~chi01 + ~chi02
- IF(MINT(15).LT.0) JS=2
-C IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=KSUSY1+22
- MINT(23-JS)=KSUSY1+23
-
- ELSEIF(ISUB.EQ.221 ) THEN
-C...f + fbar -> ~chi01 + ~chi03
- IF(MINT(15).LT.0) JS=2
-C IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=KSUSY1+22
- MINT(23-JS)=KSUSY1+25
-
- ELSEIF(ISUB.EQ.222) THEN
-C...f + fbar -> ~chi01 + ~chi04
- IF(MINT(15).LT.0) JS=2
-C IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=KSUSY1+22
- MINT(23-JS)=KSUSY1+35
-
- ELSEIF(ISUB.EQ.223) THEN
-C...f + fbar -> ~chi02 + ~chi03
- IF(MINT(15).LT.0) JS=2
-C IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=KSUSY1+23
- MINT(23-JS)=KSUSY1+25
-
- ELSEIF(ISUB.EQ.224) THEN
-C...f + fbar -> ~chi02 + ~chi04
- IF(MINT(15).LT.0) JS=2
-C IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=KSUSY1+23
- MINT(23-JS)=KSUSY1+35
-
- ELSEIF(ISUB.EQ.225) THEN
-C...f + fbar -> ~chi03 + ~chi04
- IF(MINT(15).LT.0) JS=2
-C IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=KSUSY1+25
- MINT(23-JS)=KSUSY1+35
- ENDIF
-
- ELSEIF(ISUB.LE.236) THEN
- IF(ISUB.EQ.226) THEN
-C...f + fbar -> ~chi+-1 + ~chi-+1
-C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- MINT(21)=ISIGN(KSUSY1+24,KCH1)
- MINT(22)=-MINT(21)
-
- ELSEIF(ISUB.EQ.227) THEN
-C...f + fbar -> ~chi+-2 + ~chi-+2
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- MINT(21)=ISIGN(KSUSY1+37,KCH1)
- MINT(22)=-MINT(21)
-
- ELSEIF(ISUB.EQ.228) THEN
-C...f + fbar -> ~chi+-1 + ~chi-+2
-C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
-C...js=1 if pyr<.5, js=2 if pyr>.5
-C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
-C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
-C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
-C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=INT(1-KCH1)/2
- IF(MINT(2).EQ.1) THEN
- MINT(21)= ISIGN(KSUSY1+24,KCH1)
- MINT(22)= -ISIGN(KSUSY1+37,KCH1)
-c IF(KCH2.EQ.0) JS=2
- ELSE
- MINT(21)= ISIGN(KSUSY1+37,KCH1)
- MINT(22)= -ISIGN(KSUSY1+24,KCH1)
- JS=2
-c IF(KCH2.EQ.1) JS=2
- ENDIF
-
- ELSEIF(ISUB.EQ.229) THEN
-C...q + qbar' -> ~chi01 + ~chi+-1
-C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
-C...CHECK THIS
- IF(MOD(MINT(15),2).EQ.0) JS=2
- MINT(20+JS)=KSUSY1+22
- MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
-
- ELSEIF(ISUB.EQ.230) THEN
-C...q + qbar' -> ~chi02 + ~chi+-1
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- IF(MOD(MINT(15),2).EQ.0) JS=2
- MINT(20+JS)=KSUSY1+23
- MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
-
- ELSEIF(ISUB.EQ.231) THEN
-C...q + qbar' -> ~chi03 + ~chi+-1
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- IF(MOD(MINT(15),2).EQ.0) JS=2
- MINT(20+JS)=KSUSY1+25
- MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
-
- ELSEIF(ISUB.EQ.232) THEN
-C...q + qbar' -> ~chi04 + ~chi+-1
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- IF(MOD(MINT(15),2).EQ.0) JS=2
- MINT(20+JS)=KSUSY1+35
- MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
-
- ELSEIF(ISUB.EQ.233) THEN
-C...q + qbar' -> ~chi01 + ~chi+-2
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- IF(MOD(MINT(15),2).EQ.0) JS=2
- MINT(20+JS)=KSUSY1+22
- MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
-
- ELSEIF(ISUB.EQ.234) THEN
-C...q + qbar' -> ~chi02 + ~chi+-2
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- IF(MOD(MINT(15),2).EQ.0) JS=2
- MINT(20+JS)=KSUSY1+23
- MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
-
- ELSEIF(ISUB.EQ.235) THEN
-C...q + qbar' -> ~chi03 + ~chi+-2
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- IF(MOD(MINT(15),2).EQ.0) JS=2
- MINT(20+JS)=KSUSY1+25
- MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
-
- ELSEIF(ISUB.EQ.236) THEN
-C...q + qbar' -> ~chi04 + ~chi+-2
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- IF(MOD(MINT(15),2).EQ.0) JS=2
- MINT(20+JS)=KSUSY1+35
- MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
- ENDIF
-
- ELSEIF(ISUB.LE.245) THEN
- IF(ISUB.EQ.237) THEN
-C...q + qbar -> ~chi01 + ~g
-C...th arbitrary
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=KSUSY1+21
- MINT(23-JS)=KSUSY1+22
- KCC=17+JS
-
- ELSEIF(ISUB.EQ.238) THEN
-C...q + qbar -> ~chi02 + ~g
-C...th arbitrary
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=KSUSY1+21
- MINT(23-JS)=KSUSY1+23
- KCC=17+JS
-
- ELSEIF(ISUB.EQ.239) THEN
-C...q + qbar -> ~chi03 + ~g
-C...th arbitrary
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=KSUSY1+21
- MINT(23-JS)=KSUSY1+25
- KCC=17+JS
-
- ELSEIF(ISUB.EQ.240) THEN
-C...q + qbar -> ~chi04 + ~g
-C...th arbitrary
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=KSUSY1+21
- MINT(23-JS)=KSUSY1+35
- KCC=17+JS
-
- ELSEIF(ISUB.EQ.241) THEN
-C...q + qbar' -> ~chi+-1 + ~g
-C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
-C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
-C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
-C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
-C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- JS=1
- IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
- MINT(20+JS)=KSUSY1+21
- MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
- KCC=17+JS
-
- ELSEIF(ISUB.EQ.242) THEN
-C...q + qbar' -> ~chi+-2 + ~g
-C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
-C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
-C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
-C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
-C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- JS=1
- IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
- MINT(20+JS)=KSUSY1+21
- MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
- KCC=17+JS
-
- ELSEIF(ISUB.EQ.243) THEN
-C...q + qbar -> ~g + ~g ; th arbitrary
- MINT(21)=KSUSY1+21
- MINT(22)=KSUSY1+21
- KCC=MINT(2)+4
-
- ELSEIF(ISUB.EQ.244) THEN
-C...g + g -> ~g + ~g ; th arbitrary
- KCC=MINT(2)+12
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=KSUSY1+21
- MINT(22)=KSUSY1+21
- ENDIF
-
- ELSEIF(ISUB.LE.260) THEN
- IF(ISUB.EQ.246) THEN
-C...qj + g -> ~qj_L + ~chi01
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(20+JS)=ISIGN(KSUSY1+IA,I)
- MINT(23-JS)=KSUSY1+22
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.247) THEN
-C...qj + g -> ~qj_R + ~chi01
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(20+JS)=ISIGN(KSUSY2+IA,I)
- MINT(23-JS)=KSUSY1+22
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.248) THEN
-C...qj + g -> ~qj_L + ~chi02
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(20+JS)=ISIGN(KSUSY1+IA,I)
- MINT(23-JS)=KSUSY1+23
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.249) THEN
-C...qj + g -> ~qj_R + ~chi02
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(20+JS)=ISIGN(KSUSY2+IA,I)
- MINT(23-JS)=KSUSY1+23
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.250) THEN
-C...qj + g -> ~qj_L + ~chi03
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(20+JS)=ISIGN(KSUSY1+IA,I)
- MINT(23-JS)=KSUSY1+25
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.251) THEN
-C...qj + g -> ~qj_R + ~chi03
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(20+JS)=ISIGN(KSUSY2+IA,I)
- MINT(23-JS)=KSUSY1+25
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.252) THEN
-C...qj + g -> ~qj_L + ~chi04
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(20+JS)=ISIGN(KSUSY1+IA,I)
- MINT(23-JS)=KSUSY1+35
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.253) THEN
-C...qj + g -> ~qj_R + ~chi04
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(20+JS)=ISIGN(KSUSY2+IA,I)
- MINT(23-JS)=KSUSY1+35
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.254) THEN
-C...qj + g -> ~qk_L + ~chi+-1
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
- IB=-IA+INT((IA+1)/2)*4-1
- MINT(20+JS)=ISIGN(KSUSY1+IB,I)
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.255) THEN
-C...qj + g -> ~qk_L + ~chi+-1
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
- IB=-IA+INT((IA+1)/2)*4-1
- MINT(20+JS)=ISIGN(KSUSY2+IB,I)
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.256) THEN
-C...qj + g -> ~qk_L + ~chi+-2
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- IB=-IA+INT((IA+1)/2)*4-1
- MINT(20+JS)=ISIGN(KSUSY1+IB,I)
- MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.257) THEN
-C...qj + g -> ~qk_R + ~chi+-2
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- IB=-IA+INT((IA+1)/2)*4-1
- MINT(20+JS)=ISIGN(KSUSY2+IB,I)
- MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.258) THEN
-C...qj + g -> ~qj_L + ~g
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(20+JS)=ISIGN(KSUSY1+IA,I)
- MINT(23-JS)=KSUSY1+21
- KCC=MINT(2)+6
- IF(JS.EQ.2) KCC=KCC+2
- KCS=ISIGN(1,I)
-
- ELSEIF(ISUB.EQ.259) THEN
-C...qj + g -> ~qj_R + ~g
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(20+JS)=ISIGN(KSUSY2+IA,I)
- MINT(23-JS)=KSUSY1+21
- KCC=MINT(2)+6
- IF(JS.EQ.2) KCC=KCC+2
- KCS=ISIGN(1,I)
- ENDIF
-
- ELSEIF(ISUB.LE.270) THEN
- IF(ISUB.EQ.261) THEN
-C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
- ISGN=1
- IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
- MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
- MINT(22)=-MINT(21)
-C...Correct color combination
- IF(MINT(43).EQ.4) KCC=4
-
- ELSEIF(ISUB.EQ.262) THEN
-C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
- ISGN=1
- IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
- MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
- MINT(22)=-MINT(21)
-C...Correct color combination
- IF(MINT(43).EQ.4) KCC=4
-
- ELSEIF(ISUB.EQ.263) THEN
-C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
- IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
- & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
- MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
- MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
- ELSE
- JS=2
- MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
- MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
- ENDIF
-C...Correct color combination
- IF(MINT(43).EQ.4) KCC=4
-
- ELSEIF(ISUB.EQ.264) THEN
-C...g + g -> ~t_1 + ~t_1bar; th arbitrary
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
- MINT(22)=-MINT(21)
- KCC=MINT(2)+10
-
- ELSEIF(ISUB.EQ.265) THEN
-C...g + g -> ~t_2 + ~t_2bar; th arbitrary
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
- MINT(22)=-MINT(21)
- KCC=MINT(2)+10
- ENDIF
-
- ELSEIF(ISUB.LE.296) THEN
- IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
-C...qi + qj -> ~qi_L + ~qj_L
- KCC=MINT(2)
- IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
- MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
- MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
-
- ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
-C...qi + qj -> ~qi_R + ~qj_R
- KCC=MINT(2)
- IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
- MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
- MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
-
- ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
-C...qi + qj -> ~qi_L + ~qj_R
- MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
- MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
- KCC=MINT(2)
- IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
-
- ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
-C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
- MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
- MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
- KCC=MINT(2)
- IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
-
- ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
-C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
- MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
- MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
- KCC=MINT(2)
- IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
-
- ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
-C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
- MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
- MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
- KCC=MINT(2)
- IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
-
- ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
-C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
- ISGN=1
- IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
- MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
- MINT(22)=-MINT(21)
- IF(MINT(43).EQ.4) KCC=4
-
- ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
-C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
- ISGN=1
- IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
- MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
- MINT(22)=-MINT(21)
- IF(MINT(43).EQ.4) KCC=4
-
- ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
-C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
-C...pure LL + RR
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
- MINT(22)=-MINT(21)
- KCC=MINT(2)+10
-
- ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
-C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
- MINT(22)=-MINT(21)
- KCC=MINT(2)+10
-
- ELSEIF(ISUB.EQ.294) THEN
-C...qj + g -> ~qj_L + ~g
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(20+JS)=ISIGN(KSUSY1+IA,I)
- MINT(23-JS)=KSUSY1+21
- KCC=MINT(2)+6
- IF(JS.EQ.2) KCC=KCC+2
- KCS=ISIGN(1,I)
-
- ELSEIF(ISUB.EQ.295) THEN
-C...qj + g -> ~qj_R + ~g
- IF(MINT(15).EQ.21) JS=2
- I=MINT(14+JS)
- IA=IABS(I)
- MINT(20+JS)=ISIGN(KSUSY2+IA,I)
- MINT(23-JS)=KSUSY1+21
- KCC=MINT(2)+6
- IF(JS.EQ.2) KCC=KCC+2
- KCS=ISIGN(1,I)
- ENDIF
-
- ELSEIF(ISUB.LE.340) THEN
-
- IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
-C...q + qbar' -> H+ + H0
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
- MINT(20+JS)=ISIGN(37,KCH1+KCH2)
- MINT(23-JS)=KFPR(ISUB,2)
- ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
-C...f + fbar -> A0 + H0; th arbitrary
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=KFPR(ISUB,1)
- MINT(23-JS)=KFPR(ISUB,2)
- ELSEIF(ISUB.EQ.301) THEN
-C...f + fbar -> H+ H-
- MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
- MINT(22)=-MINT(21)
- ENDIF
-CMRENNA--
-
- ELSEIF(ISUB.LE.360) THEN
-
- IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
-C...l + l -> H_L++/--, H_R++/--
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
-
- ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
-C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
- IF(MINT(15).EQ.22) JS=2
- MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
- MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
- KCC=22
-
- ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
-C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
- MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
- MINT(22)=-MINT(21)
-
- ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
-C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
-C...as inner process).
- DO 450 JT=1,2
- I=MINT(14+JT)
- IA=IABS(I)
- IF(IA.LE.10) THEN
- RVCKM=VINT(180+I)*PYR(0)
- DO 440 J=1,MSTP(1)
- IB=2*J-1+MOD(IA,2)
- IPM=(5-ISIGN(1,I))/2
- IDC=J+MDCY(IA,2)+2
- IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
- MINT(20+JT)=ISIGN(IB,I)
- RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
- IF(RVCKM.LE.0D0) GOTO 450
- 440 CONTINUE
- ELSE
- IB=2*((IA+1)/2)-1+MOD(IA,2)
- MINT(20+JT)=ISIGN(IB,I)
- ENDIF
- 450 CONTINUE
- KCC=22
- KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
- IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
-
- ELSEIF(ISUB.EQ.353) THEN
-C...f + fbar -> Z_R0
- KFRES=KFPR(ISUB,1)
-
- ELSEIF(ISUB.EQ.354) THEN
-C...f + fbar' -> W+/-
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
-
- ENDIF
-
- ELSEIF(ISUB.LE.380) THEN
-
- IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
-C...f + fbar -> charged+ charged- technicolor
- KSW=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
- MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
-
- ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
-C...f + fbar -> neutral neutral technicolor
- MINT(21)=KFPR(ISUB,1)
- MINT(22)=KFPR(ISUB,2)
-
- ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
-C...f + fbar' -> neutral charged technicolor
- IN=1
- IC=2
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
- MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
- MINT(20+JS)=KFPR(ISUB,IN)
-
- ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
-C...f + fbar' -> charged neutral technicolor
- IN=2
- IC=1
- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
- KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
- IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
- MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
- MINT(23-JS)=KFPR(ISUB,IN)
- ENDIF
-
- ELSEIF(ISUB.LE.400) THEN
- IF(ISUB.EQ.381) THEN
-C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
- KCC=MINT(2)
- IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
-
- ELSEIF(ISUB.EQ.382) THEN
-C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
- MINT(21)=ISIGN(KFLF,MINT(15))
- MINT(22)=-MINT(21)
- KCC=4
-
- ELSEIF(ISUB.EQ.383) THEN
-C...f + fbar -> g + g; th arbitrary, TC extensions
- MINT(21)=21
- MINT(22)=21
- KCC=MINT(2)+4
-
- ELSEIF(ISUB.EQ.384) THEN
-C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
- IF(MINT(15).EQ.21) JS=2
- KCC=MINT(2)+6
- IF(MINT(15).EQ.21) KCC=KCC+2
- IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
- IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
-
- ELSEIF(ISUB.EQ.385) THEN
-C...g + g -> f + fbar; th arbitrary, TC extensions
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(KFLF,KCS)
- MINT(22)=-MINT(21)
- KCC=MINT(2)+10
-
- ELSEIF(ISUB.EQ.386) THEN
-C...g + g -> g + g; th arbitrary, TC extensions
- KCC=MINT(2)+12
- KCS=(-1)**INT(1.5D0+PYR(0))
-
- ELSEIF(ISUB.EQ.387) THEN
-C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
- MINT(21)=ISIGN(MINT(55),MINT(15))
- MINT(22)=-MINT(21)
- KCC=4
-
- ELSEIF(ISUB.EQ.388) THEN
-C...g + g -> Q + Qbar; th arbitrary, TC extensions
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(MINT(55),KCS)
- MINT(22)=-MINT(21)
- KCC=MINT(2)+10
-
- ELSEIF(ISUB.EQ.391) THEN
-C...f + fbar -> G*.
- KFRES=KFPR(ISUB,1)
-
- ELSEIF(ISUB.EQ.392) THEN
-C...g + g -> G*.
- KCC=21
- KFRES=KFPR(ISUB,1)
-
- ELSEIF(ISUB.EQ.393) THEN
-C...q + qbar -> g + G*; th arbitrary.
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(20+JS)=KFPR(ISUB,1)
- MINT(23-JS)=KFPR(ISUB,2)
- KCC=17+JS
-
- ELSEIF(ISUB.EQ.394) THEN
-C...q + g -> q + G*; th = (p(f) - p(f))**2
- IF(MINT(15).EQ.21) JS=2
- MINT(23-JS)=KFPR(ISUB,2)
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.EQ.395) THEN
-C...g + g -> G* + g; th arbitrary.
- IF(PYR(0).GT.0.5D0) JS=2
- MINT(23-JS)=KFPR(ISUB,2)
- KCC=22+JS
- ENDIF
-
- ELSEIF(ISUB.LE.420) THEN
- IF(ISUB.EQ.401) THEN
-C...g + g -> t + b + H+/-
- KCS=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
- MINT(22)=ISIGN(5,-KCS)
- KCC=11+INT(0.5D0+PYR(0))
- KFRES=ISIGN(KFHIGG,-KCS)
-
- ELSEIF(ISUB.EQ.402) THEN
-C...q + qbar -> t + b + H+/-
- KFL=(-1)**INT(1.5D0+PYR(0))
- MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
- MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
- KCC=4
- KFRES=ISIGN(KFHIGG,-KFL*KCS)
- ENDIF
-
-C...QUARKONIA+++
-C...Additional code by Stefan Wolf
- ELSEIF(ISUB.LE.430) THEN
- IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
-C...g + g -> QQ~[n] + g
-C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
-C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
-C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
-C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
-C...or from ISUB.EQ.68 (for ISUB.NE.421)
-C...[g + g -> g + g; th arbitrary]
- MINT(21)=KFPR(ISUBSV,1)
- MINT(22)=KFPR(ISUBSV,2)
- IF(ISUB.EQ.421) THEN
- KCC=24
- KCS=(-1)**INT(1.5D0+PYR(0))
- ELSE
- KCC=MINT(2)+12
- KCS=(-1)**INT(1.5D0+PYR(0))
- ENDIF
-
- ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
-C...q + g -> q + QQ~[n]
-C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
-C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
-C...KCC copied from ISUB.EQ.28
-C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
- IF(MINT(15).EQ.21) JS=2
- MINT(23-JS)=KFPR(ISUBSV,2)
- KCC=MINT(2)+6
- IF(MINT(15).EQ.21) KCC=KCC+2
- IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
- IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
-
- ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
-C...q + q~ -> g + QQ~[n]
-C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
-C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
-C...KCC copied from ISUB.EQ.13
-C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
- IF(PYR(0).GT.0.5) JS=2
- MINT(20+JS)=21
- MINT(23-JS)=KFPR(ISUBSV,2)
- KCC=MINT(2)+4
- ENDIF
-
- ELSEIF(ISUB.LE.440) THEN
- IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
-C...g + g -> QQ~[n] + g
-C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
-C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
-C...KCC and KCS copied from ISUB.EQ.86-89
-C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
- MINT(21)=KFPR(ISUBSV,1)
- MINT(22)=KFPR(ISUBSV,2)
- KCC=24
- KCS=(-1)**INT(1.5D0+PYR(0))
-
- ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
-C...q + g -> q + QQ~[n]
-C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
-C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
-C...KCC and KCS copied from ISUB.EQ.112
-C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
- IF(MINT(15).EQ.21) JS=2
- MINT(23-JS)=KFPR(ISUBSV,2)
- KCC=15+JS
- KCS=ISIGN(1,MINT(14+JS))
-
- ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
-C...q + q~ -> g + QQ~[n]
-C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
-C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
-C...KCC copied from ISUB.EQ.111
-C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
- IF(PYR(0).GT.0.5) JS=2
- MINT(20+JS)=21
- MINT(23-JS)=KFPR(ISUBSV,2)
- KCC=17+JS
- ENDIF
-C...QUARKONIA---
-
- ENDIF
-
- IF(ISET(ISUB).EQ.11) THEN
-C...Store documentation for user-defined processes
- BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
- KUPPO(1)=MINT(83)+5
- KUPPO(2)=MINT(83)+6
- I=MINT(83)+6
- DO 470 IUP=3,NUP
- KUPPO(IUP)=0
- IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
- IDOC=IDOC-1
- MINT(4)=MINT(4)-1
- GOTO 470
- ENDIF
- I=I+1
- KUPPO(IUP)=I
- K(I,1)=21
- K(I,2)=IDUP(IUP)
- IF(IDUP(IUP).EQ.0) K(I,2)=90
- K(I,3)=0
- IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
- K(I,4)=0
- K(I,5)=0
- DO 460 J=1,5
- P(I,J)=PUP(J,IUP)
- 460 CONTINUE
- V(I,5)=VTIMUP(IUP)
- 470 CONTINUE
- CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
- & -BEZUP)
-
-C...Store final state partons for user-defined processes
- N=IPU2
- DO 490 IUP=3,NUP
- N=N+1
- K(N,1)=1
- IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
- K(N,2)=IDUP(IUP)
- IF(IDUP(IUP).EQ.0) K(N,2)=90
- IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
- K(N,3)=KUPPO(IUP)
- ELSE
- K(N,3)=MINT(84)+MOTHUP(1,IUP)
- ENDIF
- K(N,4)=0
- K(N,5)=0
-C...Search for daughters of intermediate colourless particles.
- IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
- DO 475 IUPDAU=IUP+1,NUP
- IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
- & N+IUPDAU-IUP
- IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
- 475 CONTINUE
- ENDIF
- DO 480 J=1,5
- P(N,J)=PUP(J,IUP)
- 480 CONTINUE
- V(N,5)=VTIMUP(IUP)
- 490 CONTINUE
- CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
-
-C...Arrange colour flow for user-defined processes
- NLBL=0
- DO 540 IUP1=1,NUP
- I1=MINT(84)+IUP1
- IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
- IF(K(I1,1).EQ.1) K(I1,1)=3
- IF(K(I1,1).EQ.11) K(I1,1)=14
-C...Find a not yet considered colour/anticolour line.
- DO 530 ISDE1=1,2
- IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
- NMAT=0
- DO 500 ILBL=1,NLBL
- IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
- 500 CONTINUE
- IF(NMAT.EQ.0) THEN
- NLBL=NLBL+1
- ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
-C...Find all others belonging to same line.
- I3=I1
- I4=0
- DO 520 IUP2=IUP1+1,NUP
- I2=MINT(84)+IUP2
- DO 510 ISDE2=1,2
- IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
- IF(ISDE2.EQ.ISDE1) THEN
- K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
- K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
- I3=I2
- ELSEIF(I4.NE.0) THEN
- K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
- K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
- I4=I2
- ELSEIF(IUP2.LE.2) THEN
- K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
- K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
- I4=I2
- ELSE
- K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
- K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
- I4=I2
- ENDIF
- ENDIF
- 510 CONTINUE
- 520 CONTINUE
- ENDIF
- 530 CONTINUE
- 540 CONTINUE
-
- ELSEIF(IDOC.EQ.7) THEN
-C...Resonance not decaying; store kinematics
- I=MINT(83)+7
- K(IPU3,1)=1
- K(IPU3,2)=KFRES
- K(IPU3,3)=I
- P(IPU3,4)=SHUSER
- P(IPU3,5)=SHUSER
- K(I,1)=21
- K(I,2)=KFRES
- P(I,4)=SHUSER
- P(I,5)=SHUSER
- N=IPU3
- MINT(21)=KFRES
- MINT(22)=0
-
-C...Special cases: colour flow in coloured resonances
- KCRES=PYCOMP(KFRES)
- IF(KCHG(KCRES,2).NE.0) THEN
- K(IPU3,1)=3
- DO 550 J=1,2
- JC=J
- IF(KCS.EQ.-1) JC=3-J
- IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
- & MINT(84)+ICOL(KCC,1,JC)
- IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
- & MINT(84)+ICOL(KCC,2,JC)
- IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
- & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
- 550 CONTINUE
- ELSE
- K(IPU1,4)=IPU2
- K(IPU1,5)=IPU2
- K(IPU2,4)=IPU1
- K(IPU2,5)=IPU1
- ENDIF
-
- ELSEIF(IDOC.EQ.8) THEN
-C...2 -> 2 processes: store outgoing partons in their CM-frame
- DO 560 JT=1,2
- I=MINT(84)+2+JT
- KCA=PYCOMP(MINT(20+JT))
- K(I,1)=1
- IF(KCHG(KCA,2).NE.0) K(I,1)=3
- K(I,2)=MINT(20+JT)
- K(I,3)=MINT(83)+IDOC+JT-2
- KFAA=IABS(K(I,2))
- IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
- P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
- ELSE
- P(I,5)=PYMASS(K(I,2))
- ENDIF
- IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
- & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
- 560 CONTINUE
- IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
- KFA1=IABS(MINT(21))
- KFA2=IABS(MINT(22))
- IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
- & THEN
- MINT(51)=1
- RETURN
- ENDIF
- P(IPU3,5)=0D0
- P(IPU4,5)=0D0
- ENDIF
- P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
- P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
- P(IPU4,4)=SHR-P(IPU3,4)
- P(IPU4,3)=-P(IPU3,3)
- N=IPU4
- MINT(7)=MINT(83)+7
- MINT(8)=MINT(83)+8
-
-C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
- CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
-
- ELSEIF(IDOC.EQ.9) THEN
-C...2 -> 3 processes: store outgoing partons in their CM frame
- DO 570 JT=1,2
- I=MINT(84)+2+JT
- KCA=PYCOMP(MINT(20+JT))
- K(I,1)=1
- IF(KCHG(KCA,2).NE.0) K(I,1)=3
- K(I,2)=MINT(20+JT)
- K(I,3)=MINT(83)+IDOC+JT-3
- JTA=JT
-C...t and b in opposide order in event list as compared to
-C...matrix element?
- IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
- IF(IABS(K(I,2)).LE.22) THEN
- P(I,5)=PYMASS(K(I,2))
- ELSE
- P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
- ENDIF
- PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
- P(I,1)=PT*COS(VINT(198+5*JTA))
- P(I,2)=PT*SIN(VINT(198+5*JTA))
- 570 CONTINUE
- K(IPU5,1)=1
- K(IPU5,2)=KFRES
- K(IPU5,3)=MINT(83)+IDOC
- P(IPU5,5)=SHR
- P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
- P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
- PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
- PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
- PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
- PMT3=SQRT(PMS3)
- P(IPU5,3)=PMT3*SINH(VINT(211))
- P(IPU5,4)=PMT3*COSH(VINT(211))
- PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
- SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
- IF(SQL12.LE.0D0) THEN
- MINT(51)=1
- RETURN
- ENDIF
- P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
- & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
- P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
- IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
-C...t and b in opposide order in event list as compared to
-C...matrix element
- P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
- & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
- P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
- END IF
- P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
- P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
- MINT(23)=KFRES
- N=IPU5
- MINT(7)=MINT(83)+7
- MINT(8)=MINT(83)+8
-
- ELSEIF(IDOC.EQ.11) THEN
-C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
- PHI(1)=PARU(2)*PYR(0)
- PHI(2)=PHI(1)-PHIR
- DO 580 JT=1,2
- I=MINT(84)+2+JT
- K(I,1)=1
- IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
- K(I,2)=MINT(20+JT)
- K(I,3)=MINT(83)+IDOC+JT-2
- P(I,5)=PYMASS(K(I,2))
- IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
- MINT(51)=1
- RETURN
- ENDIF
- PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
- PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
- P(I,1)=PTABS*COS(PHI(JT))
- P(I,2)=PTABS*SIN(PHI(JT))
- P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
- P(I,4)=0.5D0*SHPR*Z(JT)
- IZW=MINT(83)+6+JT
- K(IZW,1)=21
- K(IZW,2)=23
- IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
- K(IZW,3)=IZW-2
- P(IZW,1)=-P(I,1)
- P(IZW,2)=-P(I,2)
- P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
- P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
- P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
- 580 CONTINUE
- I=MINT(83)+9
- K(IPU5,1)=1
- K(IPU5,2)=KFRES
- K(IPU5,3)=I
- P(IPU5,5)=SHR
- P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
- P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
- P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
- P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
- K(I,1)=21
- K(I,2)=KFRES
- DO 590 J=1,5
- P(I,J)=P(IPU5,J)
- 590 CONTINUE
- N=IPU5
- MINT(23)=KFRES
-
- ELSEIF(IDOC.EQ.12) THEN
-C...Z0 and W+/- scattering: store bosons and outgoing partons
- PHI(1)=PARU(2)*PYR(0)
- PHI(2)=PHI(1)-PHIR
- JTRAN=INT(1.5D0+PYR(0))
- DO 600 JT=1,2
- I=MINT(84)+2+JT
- K(I,1)=1
- IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
- K(I,2)=MINT(20+JT)
- K(I,3)=MINT(83)+IDOC+JT-2
- P(I,5)=PYMASS(K(I,2))
- IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
- PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
- PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
- P(I,1)=PTABS*COS(PHI(JT))
- P(I,2)=PTABS*SIN(PHI(JT))
- P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
- P(I,4)=0.5D0*SHPR*Z(JT)
- IZW=MINT(83)+6+JT
- K(IZW,1)=21
- IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
- K(IZW,2)=23
- ELSE
- K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
- ENDIF
- K(IZW,3)=IZW-2
- P(IZW,1)=-P(I,1)
- P(IZW,2)=-P(I,2)
- P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
- P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
- P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
- IPU=MINT(84)+4+JT
- K(IPU,1)=3
- K(IPU,2)=KFPR(ISUB,JT)
- IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
- IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
- K(IPU,3)=MINT(83)+8+JT
- IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
- P(IPU,5)=PYMASS(K(IPU,2))
- ELSE
- P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
- ENDIF
- MINT(22+JT)=K(IPU,2)
- 600 CONTINUE
-C...Find rotation and boost for hard scattering subsystem
- I1=MINT(83)+7
- I2=MINT(83)+8
- BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
- BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
- BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
- GAMCM=(P(I1,4)+P(I2,4))/SHR
- BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
- PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
- PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
- PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
- THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
- PHICM=PYANGL(PX,PY)
-C...Store hard scattering subsystem. Rotate and boost it
- SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
- & P(IPU6,5)**2
- PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
- CTHWZ=VINT(23)
- STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
- PHIWZ=VINT(24)-PHICM
- P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
- P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
- P(IPU5,3)=PABS*CTHWZ
- P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
- P(IPU6,1)=-P(IPU5,1)
- P(IPU6,2)=-P(IPU5,2)
- P(IPU6,3)=-P(IPU5,3)
- P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
- CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
- DO 620 JT=1,2
- I1=MINT(83)+8+JT
- I2=MINT(84)+4+JT
- K(I1,1)=21
- K(I1,2)=K(I2,2)
- DO 610 J=1,5
- P(I1,J)=P(I2,J)
- 610 CONTINUE
- 620 CONTINUE
- N=IPU6
- MINT(7)=MINT(83)+9
- MINT(8)=MINT(83)+10
- ENDIF
-
- IF(ISET(ISUB).EQ.11) THEN
- ELSEIF(IDOC.GE.8) THEN
-C...Store colour connection indices
- DO 630 J=1,2
- JC=J
- IF(KCS.EQ.-1) JC=3-J
- IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
- & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
- IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
- & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
- IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
- & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
- IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
- & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
- 630 CONTINUE
-
-C...Copy outgoing partons to documentation lines
- IMAX=2
- IF(IDOC.EQ.9) IMAX=3
- DO 650 I=1,IMAX
- I1=MINT(83)+IDOC-IMAX+I
- I2=MINT(84)+2+I
- K(I1,1)=21
- K(I1,2)=K(I2,2)
- IF(IDOC.LE.9) K(I1,3)=0
- IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
- DO 640 J=1,5
- P(I1,J)=P(I2,J)
- 640 CONTINUE
- 650 CONTINUE
-
- ELSEIF(IDOC.EQ.9) THEN
-C...Store colour connection indices
- DO 660 J=1,2
- JC=J
- IF(KCS.EQ.-1) JC=3-J
- IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
- & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
- & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
- IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
- & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
- & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
- IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
- & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
- IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
- & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
- 660 CONTINUE
-
-C...Copy outgoing partons to documentation lines
- DO 680 I=1,3
- I1=MINT(83)+IDOC-3+I
- I2=MINT(84)+2+I
- K(I1,1)=21
- K(I1,2)=K(I2,2)
- K(I1,3)=0
- DO 670 J=1,5
- P(I1,J)=P(I2,J)
- 670 CONTINUE
- 680 CONTINUE
- ENDIF
-
-C...Copy outgoing partons to list of allowed radiators.
- NPART=0
- IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
- DO 690 I=MINT(84)+3,N
- NPART=NPART+1
- IPART(NPART)=I
- PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
- 690 CONTINUE
- ENDIF
-
-C...Low-pT events: remove gluons used for string drawing purposes
- IF(ISUB.EQ.95) THEN
- IF(MINT(35).LE.1) THEN
- K(IPU3,1)=K(IPU3,1)+10
- K(IPU4,1)=K(IPU4,1)+10
- ENDIF
- DO 700 J=41,66
- VINTSV(J)=VINT(J)
- VINT(J)=0D0
- 700 CONTINUE
- DO 720 I=MINT(83)+5,MINT(83)+8
- DO 710 J=1,5
- P(I,J)=0D0
- 710 CONTINUE
- 720 CONTINUE
- ENDIF
-
- RETURN
- END
-
-C***********************************************************************
-
-C...PYEVOL
-C...Handles intertwined pT-ordered spacelike initial-state parton
-C...and multiple interactions.
-
- SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
-C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
-C...MODE = 0 : (Re-)initialize ISR/MI evolution.
-C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...External
- EXTERNAL PYALPS
- DOUBLE PRECISION PYALPS
-C...Parameter statement for maximum size of showers.
- PARAMETER (MAXNUR=1000)
-C...Commonblocks.
- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
- & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
- & XMI(2,240),PT2MI(240),IMISEP(0:240)
- COMMON/PYCTAG/NCT,MCT(4000,2)
- COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
- & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
- COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
-C...Local arrays and saved variables.
- DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
- SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
- & ,PSAV,KSAV,VSAV
-
- SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
- & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
-
-C----------------------------------------------------------------------
-C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
-C...done only once per event, while MODE=0 is repeated each time the
-C...evolution needs to be restarted.
- IF (MODE.EQ.-1) THEN
- ISUBHD=MINT(1)
- NSAV=N
- NPARTS=NPART
-C...Store hard scattering variables
- M15SV=MINT(15)
- M16SV=MINT(16)
- M21SV=MINT(21)
- M22SV=MINT(22)
- DO 100 J=11,80
- VINTSV(J)=VINT(J)
- 100 CONTINUE
- DO 120 J=1,5
- DO 110 IS=1,4
- I=IS+MINT(84)
- PSAV(IS,J)=P(I,J)
- KSAV(IS,J)=K(I,J)
- VSAV(IS,J)=V(I,J)
- 110 CONTINUE
- 120 CONTINUE
-
-C...Set shat for hardest scattering
- SHAT(1)=VINT(44)
- IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
- & *VINT(2)
-
-C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
- RMC=PMAS(4,1)
- RMB=PMAS(5,1)
- ALAM4=PARP(61)
- IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
- IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
- ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
-
-C----------------------------------------------------------------------
-C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
-C...interaction initiators, with no previous evolution. Check the input
-C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
-C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
-C...smaller than the CM energy / 2.)
- ELSEIF (MODE.EQ.0) THEN
-C...Reset counters and switches
- N=NSAV
- NPART=NPARTS
- MINT(30)=0
- MINT(31)=1
- MINT(36)=1
-C...Reset hard scattering variables
- MINT(1)=ISUBHD
- DO 130 J=11,80
- VINT(J)=VINTSV(J)
- 130 CONTINUE
- DO 150 J=1,5
- DO 140 IS=1,4
- I=IS+MINT(84)
- P(I,J)=PSAV(IS,J)
- K(I,J)=KSAV(IS,J)
- V(I,J)=VSAV(IS,J)
- P(MINT(83)+4+IS,J)=PSAV(IS,J)
- V(MINT(83)+4+IS,J)=VSAV(IS,J)
- 140 CONTINUE
- 150 CONTINUE
-C...Reset statistics on activity in event.
- DO 160 J=351,359
- MINT(J)=0
- VINT(J)=0D0
- 160 CONTINUE
-C...Reset extra companion reweighting factor
- VINT(140)=1D0
-
-C...We do not generate MI for soft process (ISUB=95), but the
-C...initialization must be done regardless, for later purposes.
- MINT(36)=1
-
-C...Initialize multiple interactions.
- CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
- IF(MINT(51).NE.0) RETURN
-
-C...Decide whether quarks in hard scattering were valence or sea
- PT2HD=VINT(54)
- DO 170 JS=1,2
- MINT(30)=JS
- CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
- IF(MINT(51).NE.0) RETURN
- 170 CONTINUE
-
-C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
- VINT(18)=0D0
- IF(MSTP(70).EQ.0) THEN
- PT20=PARP(62)**2
- PT2MIN=MAX(PT2MIN,PT20,(1.1D0*ALAM3)**2)
- ELSEIF(MSTP(70).EQ.1) THEN
- PT20=(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2
- PT2MIN=MAX(PT2MIN,PT20,(1.1D0*ALAM3)**2)
- ELSE
- VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
- PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
- ENDIF
-C...Also store PT2MIN in VINT(17).
- 180 VINT(17)=PT2MIN
-
-C...Set FS masses zero now.
- VINT(63)=0D0
- VINT(64)=0D0
-
-C...Initialize IS showers with VINT(56) as max scale.
- PT2ISR=VINT(56)
- CALL PYPTIS(-1,PT2ISR,PT2MIN,PT2DUM,IFAIL)
- IF(MINT(51).NE.0) RETURN
-
- RETURN
-
-C----------------------------------------------------------------------
-C...MODE= 1: Evolve event from PTMAX to PTMIN.
- ELSEIF (MODE.EQ.1) THEN
-
-C...Skip if no phase space.
- 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
-
-C...Starting pT2 max scale (to be udpated successively).
- PT2CMX=PT2MAX
-
-C...Evolve two sides of the event to find which branches at highest pT.
- 200 JSMX=-1
- MIMX=0
- PT2MX=0D0
-
-C...Loop over current shower initiators.
- IF (MSTP(61).GE.1) THEN
- DO 230 MI=1,MINT(31)
- IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
- ISUB=96
- IF (MI.EQ.1) ISUB=ISUBHD
- MINT(1)=ISUB
- MINT(36)=MI
-C...Set up shat, initiator x values, and x remaining in BR.
- VINT(44)=SHAT(MI)
- VINT(141)=XMI(1,MI)
- VINT(142)=XMI(2,MI)
- VINT(143)=1D0
- VINT(144)=1D0
- DO 210 JI=1,MINT(31)
- IF (JI.EQ.MINT(36)) GOTO 210
- VINT(143)=VINT(143)-XMI(1,JI)
- VINT(144)=VINT(144)-XMI(2,JI)
- 210 CONTINUE
-C...Loop over sides.
-C...Generate trial branchings for this interaction. The hardest
-C...branching so far is automatically updated if necessary in /PYISMX/.
- DO 220 JS=1,2
- MINT(30)=JS
- CALL PYPTIS(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
- IF (MINT(51).NE.0) RETURN
- 220 CONTINUE
- 230 CONTINUE
- ENDIF
-
-C...Generate trial additional interaction.
- MINT(36)=MINT(31)+1
- 240 IF (MOD(MSTP(81),10).GE.1) THEN
- MINT(1)=96
-C...Set up X remaining in BR.
- VINT(143)=1D0
- VINT(144)=1D0
- DO 250 JI=1,MINT(31)
- VINT(143)=VINT(143)-XMI(1,JI)
- VINT(144)=VINT(144)-XMI(2,JI)
- 250 CONTINUE
-C...Generate trial interaction
- 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
- IF (MINT(51).EQ.1) RETURN
- ENDIF
-
-C...And the winner is:
- IF (PT2MX.LT.PT2MIN) THEN
- GOTO 330
- ELSEIF (JSMX.EQ.0) THEN
-C...Accept additional interaction (may still fail).
- CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
- IF(MINT(51).NE.0) RETURN
- IF (IFAIL.EQ.0) THEN
- SHAT(MINT(36))=VINT(44)
-C...Decide on flavours (valence/sea/companion).
- DO 270 JS=1,2
- MINT(30)=JS
- CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
- IF(MINT(51).NE.0) RETURN
- 270 CONTINUE
- ENDIF
- ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
-C...Reconstruct kinematics of acceptable ISR branching.
-C...Set up shat, initiator x values, and x remaining in BR.
- MINT(30)=JSMX
- MINT(36)=MIMX
- VINT(44)=SHAT(MINT(36))
- VINT(141)=XMI(1,MINT(36))
- VINT(142)=XMI(2,MINT(36))
- VINT(143)=1D0
- VINT(144)=1D0
- DO 280 JI=1,MINT(31)
- IF (JI.EQ.MINT(36)) GOTO 280
- VINT(143)=VINT(143)-XMI(1,JI)
- VINT(144)=VINT(144)-XMI(2,JI)
- 280 CONTINUE
- PT2NEW=PT2MX
- CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
- IF (MINT(51).EQ.1) RETURN
- ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
-C...Bookeep joining. Cannot (yet) be constructed kinematically.
- MINT(354)=MINT(354)+1
- VINT(354)=VINT(354)+SQRT(PT2MX)
- IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
- MJOIND(JSMX-2,MJN1MX)=MJN2MX
- MJOIND(JSMX-2,MJN2MX)=MJN1MX
- ENDIF
-
-C...Update PT2 iteration scale.
- PT2CMX=PT2MX
-
-C...Loop back to continue evolution.
- IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
- CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
- ELSE
- IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
- ENDIF
-
-C----------------------------------------------------------------------
-C...MODE= 2: (Re-)store user information on hardest interaction etc.
- ELSEIF (MODE.EQ.2) THEN
-
-C...Revert to "ordinary" meanings of some parameters.
- 290 DO 310 JS=1,2
- MINT(12+JS)=K(IMI(JS,1,1),2)
- VINT(140+JS)=XMI(JS,1)
- IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
- VINT(142+JS)=1D0
- DO 300 MI=1,MINT(31)
- VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
- 300 CONTINUE
- 310 CONTINUE
-
-C...Restore saved quantities for hardest interaction.
- MINT(1)=ISUBHD
- MINT(15)=M15SV
- MINT(16)=M16SV
- MINT(21)=M21SV
- MINT(22)=M22SV
- DO 320 J=11,80
- VINT(J)=VINTSV(J)
- 320 CONTINUE
-
- ENDIF
-
- 330 RETURN
- END
-
-C*********************************************************************
-
-C...PYSSPA
-C...Generates spacelike parton showers.
-
- SUBROUTINE PYSSPA(IPU1,IPU2)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
- &/PYINT2/,/PYINT3/
-C...Local arrays and data.
- DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
- &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
- &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
- &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
- &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
- DATA IS/2*0/
-
-C...Read out basic information; set global Q^2 scale.
- IPUS1=IPU1
- IPUS2=IPU2
- ISUB=MINT(1)
- Q2MX=VINT(56)
- VINT2R=VINT(2)*VINT(143)*VINT(144)
- IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
- &MIN(VINT2R,PARP(67)*VINT(56))
- FCQ2MX=1D0
-
-C...Define which processes ME corrections have been implemented for.
- MECOR=0
- IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
- IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
- & ISUB.EQ.144) MECOR=1
- IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
- IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
- ENDIF
-
-C...Initialize QCD evolution and check phase space.
- Q2MNC=PARP(62)**2
- Q2MNCS(1)=Q2MNC
- Q2MNCS(2)=Q2MNC
- IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
- Q0S=PARP(15)**2
- PS=VINT(3)**2
- Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
- & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
- Q2INT=SQRT(Q0S*Q2EFF)
- Q2MNCS(1)=MAX(Q2MNC,Q2INT)
- ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
- Q2MNCS(1)=MAX(Q2MNC,VINT(283))
- ENDIF
- IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
- Q0S=PARP(15)**2
- PS=VINT(4)**2
- Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
- & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
- Q2INT=SQRT(Q0S*Q2EFF)
- Q2MNCS(2)=MAX(Q2MNC,Q2INT)
- ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
- Q2MNCS(2)=MAX(Q2MNC,VINT(284))
- ENDIF
- MCEV=0
- ALAMS=PARU(112)
- PARU(112)=PARP(61)
- FQ2C=1D0
- TCMX=0D0
- IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
- MCEV=1
- IF(MSTP(64).EQ.1) FQ2C=PARP(63)
- IF(MSTP(64).EQ.2) FQ2C=PARP(64)
- TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
- IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
- & MCEV=0
- ENDIF
-
-C...Initialize QED evolution and check phase space.
- MEEV=0
- XEE=1D-10
- SPME=PMAS(11,1)**2
- IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
- &SPME=PMAS(13,1)**2
- IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
- &SPME=PMAS(15,1)**2
- Q2MNE=MAX(PARP(68)**2,2D0*SPME)
- TEMX=0D0
- FWTE=10D0
- IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
- MEEV=1
- TEMX=LOG(Q2MX/SPME)
- IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
- ENDIF
- IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
- MEEV=2
- TEMX=TCMX
- FWTE=1D0
- ENDIF
- IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
-
-C...Loopback point in case of failure to reconstruct kinematics.
- NS=N
- LOOP=0
- MNT352=MINT(352)
- MNT353=MINT(353)
- VNT352=VINT(352)
- VNT353=VINT(353)
- 100 LOOP=LOOP+1
- IF(LOOP.GT.100) THEN
- MINT(51)=1
- RETURN
- ENDIF
- N=NS
- MINT(352)=MNT352
- MINT(353)=MNT353
- VINT(352)=VNT352
- VINT(353)=VNT353
-
-C...Initial values: flavours, momenta, virtualities.
- DO 120 JT=1,2
- MORE(JT)=1
- KFBEAM(JT)=MINT(10+JT)
- IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
- KFLS(JT)=MINT(14+JT)
- KFLS(JT+2)=KFLS(JT)
- XS(JT)=VINT(40+JT)
- IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
- IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
- ZS(JT)=1D0
- Q2S(JT)=FCQ2MX*Q2MX
- DQ2(JT)=0D0
- TEVCSV(JT)=TCMX
- ALAM(JT)=PARP(61)
- THE2(JT)=1D0
- TEVESV(JT)=TEMX
- MCESV(JT)=0
-C...Calculate initial parton distribution weights.
- MINT(105)=MINT(102+JT)
- MINT(109)=MINT(106+JT)
- VINT(120)=VINT(2+JT)
-C.... ALICE
-C.... Store side in MINT(124)
- MINT(124) = JT
-C....
- IF(XS(JT).LT.1D0-XEE) THEN
- IF(MINT(31).GE.2) MINT(30)=JT
- IF(MSTP(57).LE.1) THEN
- CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
- ELSE
- CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
- ENDIF
- ENDIF
- DO 110 KFL=-25,25
- XFS(JT,KFL)=XFB(KFL)
- 110 CONTINUE
-C...Special kinematics check for c/b quarks (that g -> c cbar or
-C...b bbar kinematically possible).
- KFLCB=IABS(KFLS(JT))
- IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
- IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
- MINT(51)=1
- RETURN
- ENDIF
- ENDIF
- 120 CONTINUE
- DSH=VINT(44)
- IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
-
-C...Find if interference with final state partons.
- MFIS=0
- IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
- IF(MFIS.NE.0) THEN
- DO 140 I=1,2
- KCFI(I)=0
- KCA=PYCOMP(IABS(KFLS(I)))
- IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
- NFIS(I)=0
- IF(KCFI(I).NE.0) THEN
- IF(I.EQ.1) IPFS=IPUS1
- IF(I.EQ.2) IPFS=IPUS2
- DO 130 J=1,2
- ICSI=MOD(K(IPFS,3+J),MSTU(5))
- IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
- & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
- NFIS(I)=NFIS(I)+1
- THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
- & P(ICSI,2)**2))
- IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
- ENDIF
- 130 CONTINUE
- ENDIF
- 140 CONTINUE
- IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
- ENDIF
-
-C...Pick up leg with highest virtuality.
- JTOLD=1
- 150 N=N+1
- JT=1
- IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
- IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
- IF(MORE(JT).EQ.0) JT=3-JT
- JTOLD=JT
- KFLB=KFLS(JT)
- XB=XS(JT)
- DO 160 KFL=-25,25
- XFB(KFL)=XFS(JT,KFL)
- 160 CONTINUE
- DSHR=2D0*SQRT(DSH)
- DSHZ=DSH/ZS(JT)
-
-C...Check if allowed to branch.
- MCEV=0
- IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
- MCEV=1
- XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
- IF(XB.GE.1D0-2D0*XEC) MCEV=0
- ENDIF
- MEEV=0
- IF(MINT(44+JT).EQ.3) THEN
- MEEV=1
- IF(XB.GE.1D0-2D0*XEE) MEEV=0
- IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
- & MEEV=0
-C***Currently kill QED shower for resolved photoproduction.
- IF(MINT(18+JT).EQ.1) MEEV=0
-C***Currently kill shower for W inside electron.
- IF(IABS(KFLB).EQ.24) THEN
- MCEV=0
- MEEV=0
- ENDIF
- ENDIF
- IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
- &MEEV=2
- IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
- Q2B=0D0
- GOTO 260
- ENDIF
-
-C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
- Q2B=Q2S(JT)
- TEVCB=TEVCSV(JT)
- TEVEB=TEVESV(JT)
- IF(MSTP(62).LE.1) THEN
- IF(ZS(JT).GT.0.99999D0) THEN
- Q2B=Q2S(JT)
- ELSE
- Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
- & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
- & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
- ENDIF
- IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
- IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
- ENDIF
- IF(MCEV.EQ.1) THEN
- ALSDUM=PYALPS(FQ2C*Q2B)
- TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
- ALAM(JT)=PARU(117)
- B0=(33D0-2D0*MSTU(118))/6D0
- ENDIF
- IF(MEEV.EQ.2) TEVEB=TEVCB
- TEVCBS=TEVCB
- TEVEBS=TEVEB
-
-C...Select side for interference with final state partons.
- IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
- IFI=N-NS
- ISFI(IFI)=0
- IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
- ISFI(IFI)=1
- ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
- IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
- ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
- ISFI(IFI)=1
- IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
- ENDIF
- ENDIF
-
-C...Calculate preweighting factor for ME-corrected processes.
- IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
-
-C...Calculate Altarelli-Parisi weights.
- DO 170 KFL=-25,25
- WTAPC(KFL)=0D0
- WTAPE(KFL)=0D0
- WTSF(KFL)=0D0
- 170 CONTINUE
-C...q -> q (g or gamma emission), g -> q.
- IF(IABS(KFLB).LE.10) THEN
- WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
- WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
- EQ2=1D0/9D0
- IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
- IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
- & (XEC*(1D0-XEC)))
- IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
- WTAPC(KFLB)=WTFF*WTAPC(KFLB)
- WTAPC(21)=WTGF*WTAPC(21)
- WTAPE(KFLB)=WTFF*WTAPE(KFLB)
- ENDIF
-C...f -> f, gamma -> f.
- ELSEIF(IABS(KFLB).LE.20) THEN
- WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
- WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
- WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
- IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
- IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
- WTAPE(KFLB)=WTFF*WTAPE(KFLB)
- WTAPE(22)=WTGF*WTAPE(22)
- ENDIF
-C...f -> g, g -> g.
- ELSEIF(KFLB.EQ.21) THEN
- WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
- DO 180 KFL=1,MSTP(58)
- WTAPC(KFL)=WTAPQ
- WTAPC(-KFL)=WTAPQ
- 180 CONTINUE
- WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
- IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
- DO 190 KFL=1,MSTP(58)
- WTAPC(KFL)=WTFG*WTAPC(KFL)
- WTAPC(-KFL)=WTFG*WTAPC(-KFL)
- 190 CONTINUE
- WTAPC(21)=WTGG*WTAPC(21)
- ENDIF
-C...f -> gamma, W+, W-.
- ELSEIF(KFLB.EQ.22) THEN
- WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
- WTAPE(11)=WTAPF
- WTAPE(-11)=WTAPF
- IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
- WTAPE(11)=WTFG*WTAPE(11)
- WTAPE(-11)=WTFG*WTAPE(-11)
- ENDIF
- ELSEIF(KFLB.EQ.24) THEN
- WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
- & (XEE*(XB+XEE)))/XB
- ELSEIF(KFLB.EQ.-24) THEN
- WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
- & (XEE*(XB+XEE)))/XB
- ENDIF
-
-C...Calculate parton distribution weights and sum.
- NTRY=0
- 200 NTRY=NTRY+1
- IF(NTRY.GT.500) THEN
- MINT(51)=1
- RETURN
- ENDIF
- WTSUMC=0D0
- WTSUME=0D0
- XFBO=MAX(1D-10,XFB(KFLB))
- DO 210 KFL=-25,25
- WTSF(KFL)=XFB(KFL)/XFBO
- WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
- WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
- 210 CONTINUE
- WTSUMC=MAX(0.0001D0,WTSUMC)
- WTSUME=MAX(0.0001D0/FWTE,WTSUME)
-
-C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
- NTRY2=0
- 220 NTRY2=NTRY2+1
- IF(NTRY2.GT.500) THEN
- MINT(51)=1
- RETURN
- ENDIF
- IF(MCEV.EQ.1) THEN
- IF(MSTP(64).LE.0) THEN
- TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
- ELSEIF(MSTP(64).EQ.1) THEN
- TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
- ELSE
- TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
- ENDIF
- ENDIF
- IF(MEEV.EQ.1) THEN
- TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
- & (PARU(101)*FWTE*WTSUME*TEMX)))
- ELSEIF(MEEV.EQ.2) THEN
- TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
- ENDIF
-
-C...Translate t into Q2 scale; choose between QCD and QED evolution.
- 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
- IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
- IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
-C...Ensure that Q2 is above threshold for charm/bottom.
- KFLCB=IABS(KFLB)
- IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
- &MCEV.EQ.1) THEN
- IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
- Q2CB=1.1D0*PMAS(KFLCB,1)**2
- TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
- FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
- ENDIF
- ENDIF
- IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
- &MEEV.EQ.2) THEN
- IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
- ENDIF
- MCE=0
- IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
- ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
- IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
- ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
- IF(Q2EB.GT.Q2MNE) MCE=2
- ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
- IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
- ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
- IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
- IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
- ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
- MCE=1
- IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
- IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
- ELSE
- MCE=2
- IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
- IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
- ENDIF
-
-C...Evolution possibly ended. Update t values.
- IF(MCE.EQ.0) THEN
- Q2B=0D0
- GOTO 260
- ELSEIF(MCE.EQ.1) THEN
- Q2B=Q2CB
- Q2REF=FQ2C*Q2B
- IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
- IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
- ELSE
- Q2B=Q2EB
- Q2REF=Q2B
- IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
- ENDIF
-
-C...Select flavour for branching parton.
- IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
- IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
- KFLA=-25
- 240 KFLA=KFLA+1
- IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
- IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
- IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
- IF(KFLA.EQ.25) THEN
- Q2B=0D0
- GOTO 260
- ENDIF
-
-C...Choose z value and corrective weight.
- WTZ=0D0
-C...q -> q + g or q -> q + gamma.
- IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
- Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
- & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
- WTZ=0.5D0*(1D0+Z**2)
-C...q -> g + q.
- ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
- Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
- WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
-C...f -> f + gamma.
- ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
- IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
- Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
- & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
- ELSE
- Z=XB+XB*(XEE/(1D0-XEE))*
- & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
- ENDIF
- WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
-C...f -> gamma + f.
- ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
- Z=XB+XB*(XEE/(1D0-XEE))*
- & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
- WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
-C...f -> W+- + f.
- ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
- Z=XB+XB*(XEE/(1D0-XEE))*
- & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
- WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
- & (Q2B/(Q2B+PMAS(24,1)**2))
-C...g -> q + qbar.
- ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
- Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
- WTZ=1D0-2D0*Z*(1D0-Z)
-C...g -> g + g.
- ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
- Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
- WTZ=(1D0-Z*(1D0-Z))**2
-C...gamma -> f + fbar.
- ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
- Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
- WTZ=1D0-2D0*Z*(1D0-Z)
- ENDIF
- IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
-
-C...Option with resummation of soft gluon emission as effective z shift.
- IF(MCE.EQ.1) THEN
- IF(MSTP(65).GE.1) THEN
- RSOFT=6D0
- IF(KFLB.NE.21) RSOFT=8D0/3D0
- Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
- IF(Z.LE.XB) GOTO 220
- ENDIF
-
-C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
- IF(MSTP(64).GE.2) THEN
- IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
- ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
- IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
- IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
- ENDIF
- ENDIF
-
-C...Remove kinematically impossible branchings.
- UHAT=Q2B-DSH*(1D0-Z)/Z
- IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
-
-C...Select phi angle of branching at random.
- PHIBR=PARU(2)*PYR(0)
-
-C...Matrix-element corrections for some processes.
- IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
- IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
- CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
- WTZ=WTZ*WTME/WTFF
- ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
- CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
- WTZ=WTZ*WTME/WTGF
- ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
- CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
- WTZ=WTZ*WTME/WTFG
- ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
- CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
- WTZ=WTZ*WTME/WTGG
- ENDIF
- ENDIF
-
-C...Impose angular constraint in first branching from interference
-C...with final state partons.
- IF(MCE.EQ.1) THEN
- IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
- THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
- IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
- IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
- ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
- IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
- ENDIF
- ENDIF
-
-C...Option with angular ordering requirement.
- IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
- THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
- IF(THE2T.GT.THE2(JT)) GOTO 220
- ENDIF
- ENDIF
-
-C...Weighting with new parton distributions.
- MINT(105)=MINT(102+JT)
- MINT(109)=MINT(106+JT)
- VINT(120)=VINT(2+JT)
-C.... ALICE
-C.... Store side in MINT(124)
- MINT(124)=JT
-C....
- IF(MINT(31).GE.2) MINT(30)=JT
- IF(MSTP(57).LE.1) THEN
- CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
- ELSE
- CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
- ENDIF
- XFBN=XFN(KFLB)
- IF(XFBN.LT.1D-20) THEN
- IF(KFLA.EQ.KFLB) THEN
- TEVCB=TEVCBS
- TEVEB=TEVEBS
- WTAPC(KFLB)=0D0
- WTAPE(KFLB)=0D0
- GOTO 200
- ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
- TEVCB=0.5D0*(TEVCBS+TEVCB)
- GOTO 230
- ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
- TEVEB=0.5D0*(TEVEBS+TEVEB)
- GOTO 230
- ELSE
- XFBN=1D-10
- XFN(KFLB)=XFBN
- ENDIF
- ENDIF
- DO 250 KFL=-25,25
- XFB(KFL)=XFN(KFL)
- 250 CONTINUE
- XA=XB/Z
-C.... ALICE
-C.... Store side in MINT(124)
- MINT(124) = JT
-C....
- IF(MINT(31).GE.2) MINT(30)=JT
- IF(MSTP(57).LE.1) THEN
- CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
- ELSE
- CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
- ENDIF
- XFAN=XFA(KFLA)
- IF(XFAN.LT.1D-20) GOTO 200
- WTSFA=WTSF(KFLA)
- IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
-
-C...Define two hard scatterers in their CM-frame.
- 260 IF(N.EQ.NS+2) THEN
- DQ2(JT)=Q2B
- DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
- DO 280 JR=1,2
- I=NS+JR
- IF(JR.EQ.1) IPO=IPUS1
- IF(JR.EQ.2) IPO=IPUS2
- DO 270 J=1,5
- K(I,J)=0
- P(I,J)=0D0
- V(I,J)=0D0
- 270 CONTINUE
- K(I,1)=14
- K(I,2)=KFLS(JR+2)
- K(I,4)=IPO
- K(I,5)=IPO
- P(I,3)=DPLCM*(-1)**(JR+1)
- P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
- P(I,5)=-SQRT(DQ2(JR))
- K(IPO,1)=14
- K(IPO,3)=I
- K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
- K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
- 280 CONTINUE
-
-C...Find maximum allowed mass of timelike parton.
- ELSEIF(N.GT.NS+2) THEN
- JR=3-JT
- DQ2(3)=Q2B
- DPC(1)=P(IS(1),4)
- DPC(2)=P(IS(2),4)
- DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
- DPD(1)=DSH+DQ2(JR)+DQ2(JT)
- DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
- DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
- DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
- IKIN=0
- IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
- & 1D-10*DPD(1)) IKIN=1
- IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
- & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
- IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
- & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
-
-C...Generate timelike parton shower (if required).
- IT=N
- DO 290 J=1,5
- K(IT,J)=0
- P(IT,J)=0D0
- V(IT,J)=0D0
- 290 CONTINUE
-C...f -> f + g (gamma).
- IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
- K(IT,2)=21
- IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
-C...f -> g (gamma, W+-) + f.
- ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
- K(IT,2)=KFLB
- IF(KFLS(JT+2).EQ.24) THEN
- K(IT,2)=-12
- ELSEIF(KFLS(JT+2).EQ.-24) THEN
- K(IT,2)=12
- ENDIF
-C...g (gamma) -> f + fbar, g + g.
- ELSE
- K(IT,2)=-KFLS(JT+2)
- IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
- ENDIF
- K(IT,1)=3
- IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
- & IABS(K(IT,2)).EQ.22) K(IT,1)=1
- P(IT,5)=PYMASS(K(IT,2))
- IF(DMSMA.LE.P(IT,5)**2) GOTO 100
- IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
- MSTJ48=MSTJ(48)
- PARJ85=PARJ(85)
- P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
- P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
- IF(MSTP(63).EQ.1) THEN
- Q2TIM=DMSMA
- ELSEIF(MSTP(63).EQ.2) THEN
- Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
- ELSE
- Q2TIM=DMSMA
- MSTJ(48)=1
- IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
- IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
- & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
- PARJ(85)=SQRT(MAX(0D0,DPT2))*
- & (1D0/P(IT,4)+1D0/P(IS(JT),4))
- ENDIF
- if(parj(200).ne.1.) CALL PYSHOW(IT,0,SQRT(Q2TIM))
- if(parj(200).eq.1.) CALL PYSHOWQ(IT,0,SQRT(Q2TIM))
- MSTJ(48)=MSTJ48
- PARJ(85)=PARJ85
- IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
- ENDIF
-
-C...Reconstruct kinematics of branching: timelike parton shower.
- DMS=P(IT,5)**2
- IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
- IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
- & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
- & (4D0*DSH*DPC(3)**2)
- IF(DPT2.LT.0D0) GOTO 100
- DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
- & DSHR)/DPC(3)-DPC(3)
- P(IT,1)=SQRT(DPT2)
- P(IT,3)=DPB(1)*(-1)**(JT+1)
- P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
- IF(N.GE.IT+1) THEN
- DPB(1)=SQRT(DPB(1)**2+DPT2)
- DPB(2)=SQRT(DPB(1)**2+DMS)
- DPB(3)=P(IT+1,3)
- DPB(4)=SQRT(DPB(3)**2+DMS)
- DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
- & DPB(1))
- CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
- THE=PYANGL(P(IT,3),P(IT,1))
- CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
- ENDIF
-
-C...Reconstruct kinematics of branching: spacelike parton.
- DO 300 J=1,5
- K(N+1,J)=0
- P(N+1,J)=0D0
- V(N+1,J)=0D0
- 300 CONTINUE
- K(N+1,1)=14
- K(N+1,2)=KFLB
- P(N+1,1)=P(IT,1)
- P(N+1,3)=P(IT,3)+P(IS(JT),3)
- P(N+1,4)=P(IT,4)+P(IS(JT),4)
- P(N+1,5)=-SQRT(DQ2(3))
-
-C...Define colour flow of branching.
- K(IS(JT),3)=N+1
- K(IT,3)=N+1
- IM1=N+1
- IM2=N+1
-C...f -> f + gamma (Z, W).
- IF(IABS(K(IT,2)).GE.22) THEN
- K(IT,1)=1
- ID1=IS(JT)
- ID2=IS(JT)
-C...f -> gamma (Z, W) + f.
- ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
- ID1=IT
- ID2=IT
-C...gamma -> q + qbar, g + g.
- ELSEIF(K(N+1,2).EQ.22) THEN
- ID1=IS(JT)
- ID2=IT
- IM1=ID2
- IM2=ID1
-C...q -> q + g.
- ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
- ID1=IT
- ID2=IS(JT)
-C...q -> g + q.
- ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
- ID1=IS(JT)
- ID2=IT
-C...qbar -> qbar + g.
- ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
- ID1=IS(JT)
- ID2=IT
-C...qbar -> g + qbar.
- ELSEIF(K(N+1,2).LT.0) THEN
- ID1=IT
- ID2=IS(JT)
-C...g -> g + g; g -> q + qbar.
- ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
- ID1=IS(JT)
- ID2=IT
- ELSE
- ID1=IT
- ID2=IS(JT)
- ENDIF
- IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
- IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
- K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
- K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
- IF(ID1.NE.ID2) THEN
- K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
- K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
- ENDIF
- N=N+1
- IF(K(IT,1).EQ.1) THEN
- K(IT,4)=0
- K(IT,5)=0
- ENDIF
-
-C...Boost to new CM-frame.
- DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
- DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
- IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
- CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
- IR=N+(JT-1)*(IS(1)-N)
- CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
- & 0D0,0D0,0D0)
-
-C...Global statistics.
- MINT(352)=MINT(352)+1
- VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
- IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
- ENDIF
-
-C...Update kinematics variables.
- IS(JT)=N
- DQ2(JT)=Q2B
- IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
- DSH=DSHZ
-
-C...Save quantities; loop back.
- Q2S(JT)=Q2B
- DPHI(JT)=PHIBR
- MCESV(JT)=MCE
- IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
- &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
- KFLS(JT+2)=KFLS(JT)
- KFLS(JT)=KFLA
- XS(JT)=XA
- ZS(JT)=Z
- DO 310 KFL=-25,25
- XFS(JT,KFL)=XFA(KFL)
- 310 CONTINUE
- TEVCSV(JT)=TEVCB
- TEVESV(JT)=TEVEB
- ELSE
- MORE(JT)=0
- IF(JT.EQ.1) IPU1=N
- IF(JT.EQ.2) IPU2=N
- ENDIF
- IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
- CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
- IF(MSTU(21).GE.1) N=NS
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
-
-C...Boost hard scattering partons to frame of shower initiators.
- DO 320 J=1,3
- ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
- 320 CONTINUE
- K(N+2,1)=1
- DO 330 J=1,5
- P(N+2,J)=P(NS+1,J)
- 330 CONTINUE
- CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
- ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
- ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
- IMIN=MINT(83)+5
- IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
- CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
- CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
-
-C...Store user information. Reset Lambda value.
- IF(MINT(31).LE.1) THEN
- K(IPU1,3)=MINT(83)+3
- K(IPU2,3)=MINT(83)+4
- ELSE
- K(IPU1,3)=MINT(83)+1
- K(IPU2,3)=MINT(83)+2
- ENDIF
- DO 340 JT=1,2
- MINT(12+JT)=KFLS(JT)
- VINT(140+JT)=XS(JT)
- IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
- IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
- 340 CONTINUE
- PARU(112)=ALAMS
-
- RETURN
- END
-C*********************************************************************
-
-C...PYPTIS
-C...Generates pT-ordered spacelike initial-state parton showers and
-C...trial joinings.
-C...MODE=-1: Initialize ISR from scratch, starting from the hardest
-C... interaction initiators at PT2NOW.
-C...MODE= 0: Generate a trial branching on interaction MINT(36), side
-C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
-C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
-C... is below PT2CUT.
-C... (Also generate test joinings if MSTP(96)=1.)
-C...MODE= 1: Accept stored shower branching. Update event record etc.
-C...PT2NOW : Starting (max) PT2 scale for evolution.
-C...PT2CUT : Lower limit for evolution.
-C...PT2 : Result of evolution. Generated PT2 for trial emission.
-C...IFAIL : Status return code. IFAIL=0 when all is well.
-
- SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement for maximum size of showers.
- PARAMETER (MAXNUR=1000)
-C...Commonblocks.
- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
- & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
- & XMI(2,240),PT2MI(240),IMISEP(0:240)
- COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
- & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
- COMMON/PYCTAG/NCT,MCT(4000,2)
- COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
- SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
- & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
-C...Local variables
- DIMENSION ZSAV(2,240),PT2SAV(2,240),
- & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
- & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
- & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
- SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
- & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
-C...For check on excessive weights.
- CHARACTER CHWT*12
-
-C...Only give errors for very large weights, otherwise just warnings
- DATA WTEMAX /1.5D0/
-C...Only give errors for large pT, otherwise just warnings
- DATA PTEMAX /5D0/
-
- IFAIL=-1
-
-C----------------------------------------------------------------------
-C...MODE=-1: Initialize initial state showers from scratch, i.e.
-C...starting from the hardest interaction initiators.
- IF (MODE.EQ.-1) THEN
-C...Set hard scattering SHAT.
- SHTNOW(1)=VINT(44)
-C...Mass thresholds and Lambda for QCD evolution.
- AEM2PI=PARU(101)/PARU(2)
- RMB=PMAS(5,1)
- RMC=PMAS(4,1)
- ALAM4=PARP(61)
- IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
- IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
- ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
- ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
- RMB2=RMB**2
- RMC2=RMC**2
-C...Massive quark forced creation threshold (in M**2).
- TMIN=1.01D0
-C...Set upper limit for X (ensures some X left for beam remnant).
- XMXC=1D0-2D0*PARP(111)/VINT(1)
-
- IF (MSTP(61).GE.1) THEN
-C...Initial values: flavours, momenta, virtualities.
- DO 100 JS=1,2
- NISGEN(JS,1)=0
-
-C...Special kinematics check for c/b quarks (that g -> c cbar or
-C...b bbar kinematically possible).
- KFLB=K(IMI(JS,1,1),2)
- KFLCB=IABS(KFLB)
- IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
-C...Check PT2MAX > mQ^2
- IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
- CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
- & 'No Q creation possible.')
- MINT(51)=1
- RETURN
- ELSE
-C...Check for physical z values (m == MQ / sqrt(s))
-C...For creation diagram, x < z < (1-m)/(1+m(1-m))
- FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
- ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
- IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
- CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
- & 'Q creation.')
- MINT(51)=1
- RETURN
- ENDIF
- ENDIF
- ENDIF
- 100 CONTINUE
- ENDIF
-
- MINT(354)=0
-C...Zero joining array
- DO 110 MJ=1,240
- MJOIND(1,MJ)=0
- MJOIND(2,MJ)=0
- 110 CONTINUE
-
-C----------------------------------------------------------------------
-C...MODE= 0: Generate a trial branching on interaction MINT(36) side
-C...MINT(30). Store if emission PT2 scale is largest so far.
-C...Also generate test joinings if MSTP(96)=1.
- ELSEIF(MODE.EQ.0) THEN
- IFAIL=-1
- MECOR=0
- ISUB=MINT(1)
- JS=MINT(30)
-C...No shower for structureless beam
- IF (MINT(44+JS).EQ.1) RETURN
- MI=MINT(36)
- SHAT=VINT(44)
-C...Absolute shower max scale = VINT(56)
- PT2=MIN(PT2NOW,VINT(56))
- IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
-C...Define for which processes ME corrections have been implemented.
- IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
- IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
- & .142.OR.ISUB.EQ.144) MECOR=1
- IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
- IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
-C...Calculate preweighting factor for ME-corrected processes.
- IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
- ENDIF
-C...Basic info on daughter for which to find mother.
- KFLB=K(IMI(JS,MI,1),2)
- KFLBA=IABS(KFLB)
-C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
-C...second companion.
- KSVCB=MAX(-1,IMI(JS,MI,2))
-C...Treat "first" companion of a pair like an ordinary sea quark
-C...(except that creation diagram is not allowed)
- IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
-C...X (rescaled to [0,1])
- XB=XMI(JS,MI)/VINT(142+JS)
-C...Massive quarks (use physical masses.)
- RMQ2=0D0
- MQMASS=0
- IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
- RMQ2=RMC2
- IF (KFLBA.EQ.5) RMQ2=RMB2
-C...Special threshold treatment for non-photon beams
- IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
- ENDIF
-
-C...Flags for parton distribution calls.
- MINT(105)=MINT(102+JS)
- MINT(109)=MINT(106+JS)
- VINT(120)=VINT(2+JS)
-
-C...Calculate initial parton distribution weights.
- IF(XB.GE.XMXC) THEN
- RETURN
- ELSEIF(MQMASS.EQ.0) THEN
- CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
- ELSE
-C...Initialize massive quark PT2 dependent pdf underestimate.
- PT20=PT2
- CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
-C.!.Tentative treatment of massive valence quarks.
- XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
- XG0=XFB(21)
- TPM0=LOG(PT20/RMQ2)
- WPDF0=TPM0*XG0/XQ0
- ENDIF
- IF (KFLBA.LE.6) THEN
-C...For quarks, only include respective sea, val, or cmp part.
- IF (KSVCB.LE.0) THEN
- XFB(KFLB)=XPSVC(KFLB,KSVCB)
- ELSE
-C...Find companion's companion
- MISEA=0
- 120 MISEA=MISEA+1
- IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
- XS=XMI(JS,MISEA)
- XREM=VINT(142+JS)
- YS=XS/(XREM+XS)
-C...Momentum fraction of the companion quark.
-C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
- YB=XB*(1D0-YS)
- XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
- ENDIF
- ENDIF
-
-C...Determine overestimated z range: switch at c and b masses.
- 130 IF (PT2.GT.TMIN*RMB2) THEN
- IZRG=3
- PT2MNE=MAX(TMIN*RMB2,PT2CUT)
- B0=23D0/6D0
- ALAM2=ALAM5**2
- ELSEIF(PT2.GT.TMIN*RMC2) THEN
- IZRG=2
- PT2MNE=MAX(TMIN*RMC2,PT2CUT)
- B0=25D0/6D0
- ALAM2=ALAM4**2
- ELSE
- IZRG=1
- PT2MNE=PT2CUT
- B0=27D0/6D0
- ALAM2=ALAM3**2
- ENDIF
-C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
- ALAM2=ALAM2/PARP(64)
-C...Overestimated ZMAX:
- IF (MQMASS.EQ.0) THEN
-C...Massless
- ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
- & /PT2MNE)-1D0)
- ELSE
-C...Massive (limit for bremsstrahlung diagram > creation)
- FMQ=SQRT(RMQ2/SHTNOW(MI))
- ZMAX=1D0/(1D0+FMQ)
- ENDIF
- ZMIN=XB/XMXC
-
-C...If kinematically impossible then do not evolve.
- IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
-
-C...Reset Altarelli-Parisi and PDF weights.
- DO 140 KFL=-5,5
- WTAP(KFL)=0D0
- WTPDF(KFL)=0D0
- 140 CONTINUE
- WTAP(21)=0D0
- WTPDF(21)=0D0
-C...Zero joining weights and compute X(partner) and X(mother) values.
- IF (MSTP(96).NE.0) THEN
- NJN=0
- DO 150 MJ=1,MINT(31)
- WTAPJ(MJ)=0D0
- WTPDFJ(MJ)=0D0
- X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
- Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
- & +XMI(JS,MI))
- 150 CONTINUE
- ENDIF
-
-C...Approximate Altarelli-Parisi weights (integrated AP dz).
-C...q -> q, g -> q or q -> q + gamma (already set which).
- IF(KFLBA.LE.5) THEN
-C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
- IF (KSVCB.LT.0) THEN
- WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
- ELSE
- RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
- RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
- WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
- ENDIF
- WTAP(21)=0.5D0*(ZMAX-ZMIN)
- WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
- IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
- IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
- WTAP(KFLB)=WTFF*WTAP(KFLB)
- WTAP(21)=WTGF*WTAP(21)
- WTAPE=WTFF*WTAPE
- ENDIF
- IF (KSVCB.GE.1) THEN
-C...Kill normal creation but add joining diagrams for cmp quark.
- WTAP(21)=0D0
- IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
- CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
- & " quark here. Not handled yet, giving up!")
- PT2=0D0
- MINT(51)=1
- RETURN
- ENDIF
-C...Check for possible joinings
- IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
-C...Find companion's companion.
- MJ=0
- 160 MJ=MJ+1
- IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
- IF (MJOIND(JS,MJ).EQ.0) THEN
- Y(MI)=YB+YS
- Z=YB/Y(MI)
- WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
- IF (WTAPJ(MJ).GT.1D-6) THEN
- NJN=1
- ELSE
- WTAPJ(MJ)=0D0
- ENDIF
- ENDIF
-C...Add trial gluon joinings.
- DO 170 MJ=1,MINT(31)
- KFLC=K(IMI(JS,MJ,1),2)
- IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
- Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
- WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
- IF (WTAPJ(MJ).GT.1D-6) THEN
- NJN=NJN+1
- ELSE
- WTAPJ(MJ)=0D0
- ENDIF
- 170 CONTINUE
- ENDIF
- ELSEIF (IMI(JS,MI,2).GE.0) THEN
-C...Kill creation diagram for val quarks and sea quarks with companions.
- WTAP(21)=0D0
- ELSEIF (MQMASS.EQ.0) THEN
-C...Extra safety factor for massless sea quark creation.
- WTAP(21)=WTAP(21)*1.25D0
- ENDIF
-
-C... q -> g, g -> g.
- ELSEIF(KFLB.EQ.21) THEN
-C...Here we decide later whether a quark picked up is valence or
-C...sea, so we maintain the extra factor sqrt(z) since we deal
-C...with the *sum* of sea and valence in this context.
- WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
-C...new: do not allow backwards evol to pick up heavy flavour.
- DO 180 KFL=1,MIN(3,MSTP(58))
- WTAP(KFL)=WTAPQ
- WTAP(-KFL)=WTAPQ
- 180 CONTINUE
- WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
- IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
- WTAPQ=WTFG*WTAPQ
- WTAP(21)=WTGG*WTAP(21)
- ENDIF
-C...Check for possible joinings (companions handled separately above)
- IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
- & THEN
- DO 190 MJ=1,MINT(31)
- IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
- KSVCC=IMI(JS,MJ,2)
- IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
- IF (KSVCC.GE.1) GOTO 190
- KFLC=K(IMI(JS,MJ,1),2)
-C...Only try g -> g + g once.
- IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
- Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
- IF (KFLC.EQ.21) THEN
- WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
- ELSE
- WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
- ENDIF
- IF (WTAPJ(MJ).GT.1D-6) THEN
- NJN=NJN+1
- ELSE
- WTAPJ(MJ)=0D0
- ENDIF
- 190 CONTINUE
- ENDIF
- ENDIF
-
-C...Initialize massive quark evolution
- IF (MQMASS.NE.0) THEN
- RML=(RMQ2+VINT(18))/ALAM2
- TML=LOG(RML)
- TPL=LOG((PT2+VINT(18))/ALAM2)
- TPM=LOG((PT2+VINT(18))/RMQ2)
- WN=WTAP(21)*WPDF0/B0
- ENDIF
-
-
-C...Loopback point for iteration
- NTRY=0
- NTHRES=0
- 200 NTRY=NTRY+1
- IF(NTRY.GT.500) THEN
- CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
- MINT(51)=1
- RETURN
- ENDIF
-
-C... Calculate PDF weights and sum for evolution rate.
- WTSUM=0D0
- XFBO=MAX(1D-10,XFB(KFLB))
- DO 210 KFL=-5,5
- WTPDF(KFL)=XFB(KFL)/XFBO
- WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
- 210 CONTINUE
-C...Only add gluon mother diagram for massless KFLB.
- IF(MQMASS.EQ.0) THEN
- WTPDF(21)=XFB(21)/XFBO
- WTSUM=WTSUM+WTAP(21)*WTPDF(21)
- ENDIF
- WTSUM=MAX(0.0001D0,WTSUM)
- WTSUMS=WTSUM
-C...Add joining diagrams where applicable.
- WTJOIN=0D0
- IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
- DO 220 MJ=1,MINT(31)
- IF (WTAPJ(MJ).LT.1D-3) GOTO 220
- WTPDFJ(MJ)=1D0/XFBO
-C...x and x*pdf (+ sea/val) for parton C.
- KFLC=K(IMI(JS,MJ,1),2)
- KFLCA=IABS(KFLC)
- KSVCC=MAX(-1,IMI(JS,MJ,2))
- IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
- MINT(30)=JS
- MINT(36)=MJ
- CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
- MINT(36)=MI
- IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
- XFJ(KFLC)=XPSVC(KFLC,KSVCC)
- ELSEIF (KSVCC.GE.1) THEN
- print*, 'error! parton C is companion!'
- ENDIF
- WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
-C...x and x*pdf (+ sea/val) for parton A.
- KFLA=21
- KSVCA=0
- IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
- KFLA=KFLB
- KSVCA=KSVCB
- ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
- KFLA=KFLC
- KSVCA=KSVCC
- ENDIF
- MINT(30)=JS
- IF (KSVCA.LE.0) THEN
-C...Consider C the "evolved" parton if B is gluon. Val/sea
-C...counting will then be done correctly in PYPDFU.
- IF (KFLBA.EQ.21) MINT(36)=MJ
- CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
- MINT(36)=MI
- IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
- ELSE
-C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
- XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
- ENDIF
- WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
- WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
- 220 CONTINUE
- ENDIF
-
-C...Pick normal pT2 (in overestimated z range).
- 230 PT2OLD=PT2
- WTSUM=WTSUMS
- PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
- KFLC=21
-
-C...Evolve q -> q gamma separately, pick it if larger pT.
- IF(KFLBA.LE.5) THEN
- PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
- IF(PT2QED.GT.PT2) THEN
- PT2=PT2QED
- KFLC=22
- KFLA=KFLB
- ENDIF
- ENDIF
-
-C... Evolve massive quark creation separately.
- MCRQQ=0
- IF (MQMASS.NE.0) THEN
- PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM)))
- & -VINT(18)
-C... Ensure mininimum PT2CR and force creation near threshold.
- IF (PT2CR.LT.TMIN*RMQ2) THEN
- NTHRES=NTHRES+1
- IF (NTHRES.GT.50) THEN
- CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
- & 'massive quark creation. Gave up trying.')
- MINT(51)=1
- RETURN
- ENDIF
- PT2=0D0
- PT2CR=TMIN*RMQ2
- MCRQQ=2
- ENDIF
-C... Select largest PT2 (brems or creation):
- IF (PT2CR.GT.PT2) THEN
- MCRQQ=MAX(MCRQQ,1)
- WTSUM=0D0
- PT2=PT2CR
- KFLA=21
- ELSE
- MCRQQ=0
- KFLA=KFLB
- ENDIF
-C... Compute logarithms for this PT2
- TPL=LOG((PT2+VINT(18))/ALAM2)
- TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
- WTCRQQ=TPM/LOG(PT2/RMQ2)
- ENDIF
-
-C...Evolve joining separately
- MJOIN=0
- IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
- PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
- & -VINT(18)
- IF (PT2JN.GE.PT2) THEN
- MJOIN=1
- PT2=PT2JN
- ENDIF
- ENDIF
-
-C...Loopback if crossed c/b mass thresholds.
- IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
- PT2=RMB2
- GOTO 130
- ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
- PT2=RMC2
- GOTO 130
- ENDIF
-
-C...Speed up shower. Skip if higher-PT acceptable branching
-C...already found somewhere else.
-C...Also finish if below lower cutoff.
-
- IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN
-
-C...Select parton A flavour (massive Q handled above.)
- IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
- WTRAN=PYR(0)*WTSUM
- KFLA=-6
- 240 KFLA=KFLA+1
- WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
- IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
- IF(KFLA.EQ.6) KFLA=21
- ELSEIF (MJOIN.EQ.1) THEN
-C...Tentative joining accept/reject.
- WTRAN=PYR(0)*WTJOIN
- MJ=0
- 250 MJ=MJ+1
- WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
- IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
- IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
- CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
- & ' Rejected.')
- GOTO 230
- ENDIF
-C...x*pdf (+ sea/val) at new pT2 for parton B.
- IF (KSVCB.LE.0) THEN
- MINT(30)=JS
- CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
- IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
- ELSE
-C...Companion distributions do not evolve.
- XFB(KFLB)=XFBO
- ENDIF
- WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
- KFLC=K(IMI(JS,MJ,1),2)
- KFLCA=IABS(KFLC)
- KSVCC=MAX(-1,IMI(JS,MJ,2))
- IF (KSVCB.GE.1) KSVCC=-1
-C...x*pdf (+ sea/val) at new pT2 for parton C.
- MINT(30)=JS
- MINT(36)=MJ
- CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
- MINT(36)=MI
- IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
- WTVETO=WTVETO/XFJ(KFLC)
-C...x and x*pdf (+ sea/val) at new pT2 for parton A.
- KFLA=21
- KSVCA=0
- IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
- KFLA=KFLB
- KSVCA=KSVCB
- ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
- KFLA=KFLC
- KSVCA=KSVCC
- ENDIF
- IF (KSVCA.LE.0) THEN
- MINT(30)=JS
- IF (KFLB.EQ.21) MINT(36)=MJ
- CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
- MINT(36)=MI
- IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
- ELSE
- XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
- ENDIF
- WTVETO=WTVETO*XFJ(KFLA)
-C...Monte Carlo veto.
- IF (WTVETO.LT.PYR(0)) GOTO 200
-C...If accept, save PT2 of this joining.
- IF (PT2.GT.PT2MX) THEN
- PT2MX=PT2
- JSMX=2+JS
- MJN1MX=MJ
- MJN2MX=MI
- WTAPJ(MJ)=0D0
- NJN=0
- ENDIF
-C...Exit and continue evolution.
- GOTO 380
- ENDIF
- KFLAA=IABS(KFLA)
-
-C...Choose z value (still in overestimated range) and corrective weight.
-C...Unphysical z will be rejected below when Q2 has is computed.
- WTZ=0D0
-
-C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
-C...q -> q + g or q -> q + gamma (already set which).
- IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
- IF (KSVCB.LT.0) THEN
- Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
- ELSE
- ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
- Z=((1-ZFAC)/(1+ZFAC))**2
- ENDIF
- WTZ=0.5D0*(1D0+Z**2)
-C...Massive weight correction.
- IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
-C...Valence quark weight correction (extra sqrt)
- IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
-
-C...q -> g + q.
-C...NB: MQ>0 not yet implemented. Forced absent above.
- ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
- KFLC=KFLA
- Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
- WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
-
-C...g -> q + qbar.
- ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
- KFLC=-KFLB
- Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
- WTZ=Z**2+(1D0-Z)**2
-C...Massive correction
- IF (MQMASS.NE.0) THEN
- WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
-C...Extra safety margin for light sea quark creation
- ELSEIF (KSVCB.LT.0) THEN
- WTZ=WTZ/1.25D0
- ENDIF
-
-C...g -> g + g.
- ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
- KFLC=21
- Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
- & (ZMAX*(1D0-ZMIN)))**PYR(0))
- WTZ=(1D0-Z*(1D0-Z))**2
- ENDIF
-
-C...Derive Q2 from pT2.
- Q2B=PT2/(1D0-Z)
- IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
-
-C...Loopback if outside allowed z range for given pT2.
- RM2C=PYMASS(KFLC)**2
- PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
- IF (PT2ADJ.LT.1D-6) GOTO 230
-
-C...Loopback if nonordered in angle/rapidity.
- IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
- IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
- & GOTO 230
- ENDIF
-
-C...Select phi angle of branching at random.
- PHI=PARU(2)*PYR(0)
-
-C...Matrix-element corrections for some processes.
- IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
- IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
- CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
- WTZ=WTZ*WTME/WTFF
- ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
- CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
- WTZ=WTZ*WTME/WTGF
- ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
- CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
- WTZ=WTZ*WTME/WTFG
- ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
- CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
- WTZ=WTZ*WTME/WTGG
- ENDIF
- ENDIF
-
-C...Parton distributions at new pT2 but old x.
- MINT(30)=JS
- CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
-C...Treat val and cmp separately
- IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
- IF (KSVCB.GE.1)
- & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
- XFBN=XFN(KFLB)
- IF(XFBN.LT.1D-20) THEN
- IF(KFLA.EQ.KFLB) THEN
- WTAP(KFLB)=0D0
- GOTO 200
- ELSE
- XFBN=1D-10
- XFN(KFLB)=XFBN
- ENDIF
- ENDIF
- DO 260 KFL=-5,5
- XFB(KFL)=XFN(KFL)
- 260 CONTINUE
- XFB(21)=XFN(21)
-
-C...Parton distributions at new pT2 and new x.
- XA=XB/Z
- MINT(30)=JS
- CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
- IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
-C...q -> q + g: only consider respective sea, val, or cmp content.
- IF (KSVCB.LE.0) THEN
- XFA(KFLA)=XPSVC(KFLA,KSVCB)
- ELSE
- YA=XA*(1D0-YS)
- XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
- ENDIF
- ENDIF
- XFAN=XFA(KFLA)
- IF(XFAN.LT.1D-20) THEN
- GOTO 200
- ENDIF
-
-C...If weighting fails continue evolution.
- WTTOT=0D0
- IF (MCRQQ.EQ.0) THEN
- WTPDFA=1D0/WTPDF(KFLA)
- WTTOT=WTZ*XFAN/XFBN*WTPDFA
- ELSEIF(MCRQQ.EQ.1) THEN
- WTPDFA=TPM/WPDF0
- WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
- XBEST=TPM/TPM0*XQ0
- ELSEIF(MCRQQ.EQ.2) THEN
-C...Force massive quark creation.
- WTTOT=1D0
- ENDIF
-
-C...Loop back if trial emission fails.
- IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
- WTACC=((1D0+PT2)/(0.25D0+PT2))**2
- IF(WTTOT.LT.0D0) THEN
- WRITE(CHWT,'(1P,E12.4)') WTTOT
- CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
- ELSEIF(WTTOT.GT.WTACC) THEN
- WRITE(CHWT,'(1P,E12.4)') WTTOT
- IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
-C...Too high weight: write out as error, but do not update error counter.
- IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
- CALL PYERRM(19,
- & '(PYPTIS:) Weight '//CHWT//' above unity')
- IF (PT2.GT.PTEMAX) PTEMAX=PT2
- IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
- ELSE
- CALL PYERRM(9,
- & '(PYPTIS:) Weight '//CHWT//' above unity')
- ENDIF
-C...Useful for debugging but commented out for distribution:
-C print*, 'JS, MI',JS, MI
-C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
-C print*, 'A -> B C',KFLA, KFLB, KFLC
-C XFAO=XFBO/WTPDFA
-C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
- ENDIF
-
-C...Save acceptable branching.
- IF(PT2.GT.PT2MX) THEN
- MIMX=MINT(36)
- JSMX=JS
- PT2MX=PT2
- KFLAMX=KFLA
- KFLCMX=KFLC
- RM2CMX=RM2C
- Q2BMX=Q2B
- ZMX=Z
- PT2AMX=PT2ADJ
- PHIMX=PHI
- ENDIF
-
-C----------------------------------------------------------------------
-C...MODE= 1: Accept stored shower branching. Update event record etc.
- ELSEIF (MODE.EQ.1) THEN
- MI=MIMX
- JS=JSMX
- SHAT=SHTNOW(MI)
- SIDE=3D0-2D0*JS
-C...Shift down rest of event record to make room for insertion.
- IT=IMISEP(MI)+1
- IM=IT+1
- IS=IMI(JS,MI,1)
- DO 280 I=N,IT,-1
- IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
- KT1=K(I,4)/MSTU(5)**2
- KT2=K(I,5)/MSTU(5)**2
- ID1=MOD(K(I,4),MSTU(5))
- ID2=MOD(K(I,5),MSTU(5))
- IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
- IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
- IF (ID1.GE.IT) ID1=ID1+2
- IF (ID2.GE.IT) ID2=ID2+2
- IF (IM1.GE.IT) IM1=IM1+2
- IF (IM2.GE.IT) IM2=IM2+2
- K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
- K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
- DO 270 IX=1,5
- K(I+2,IX)=K(I,IX)
- P(I+2,IX)=P(I,IX)
- V(I+2,IX)=V(I,IX)
- 270 CONTINUE
- MCT(I+2,1)=MCT(I,1)
- MCT(I+2,2)=MCT(I,2)
- 280 CONTINUE
- N=N+2
-C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
- DO 290 JI=1,MINT(31)
- IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
- IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
- IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
- IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
- IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
-C...Also update companion pointers to the present mother.
- IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
- 290 CONTINUE
- DO 300 IFS=1,NPART
- IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
- 300 CONTINUE
-C...Zero entries dedicated for new timelike and mother partons.
- DO 320 I=IT,IT+1
- DO 310 J=1,5
- K(I,J)=0
- P(I,J)=0D0
- V(I,J)=0D0
- 310 CONTINUE
- MCT(I,1)=0
- MCT(I,2)=0
- 320 CONTINUE
-
-C...Define timelike and new mother partons. History.
- K(IT,1)=3
- K(IT,2)=KFLCMX
- K(IM,1)=14
- K(IM,2)=KFLAMX
- K(IS,3)=IM
- K(IT,3)=IM
-C...Set mother origin = side.
- K(IM,3)=MINT(83)+JS+2
- IF(MI.GE.2) K(IM,3)=MINT(83)+JS
-
-C...Define colour flow of branching.
- IM1=IM
- IM2=IM
-C...q -> q + gamma.
- IF(K(IT,2).EQ.22) THEN
- K(IT,1)=1
- ID1=IS
- ID2=IS
-C...q -> q + g.
- ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
- ID1=IT
- ID2=IS
-C...q -> g + q.
- ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
- ID1=IS
- ID2=IT
-C...qbar -> qbar + g.
- ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
- ID1=IS
- ID2=IT
-C...qbar -> g + qbar.
- ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
- ID1=IT
- ID2=IS
-C...g -> g + g; g -> q + qbar..
- ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
- ID1=IS
- ID2=IT
- ELSE
- ID1=IT
- ID2=IS
- ENDIF
- IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
- IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
- K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
- K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
- IF(ID1.NE.ID2) THEN
- K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
- K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
- ENDIF
- IF(K(IT,1).EQ.1) THEN
- K(IT,4)=0
- K(IT,5)=0
- ENDIF
-C...Update IMI and colour tag arrays.
- IMI(JS,MI,1)=IM
- DO 330 MC=1,2
- MCT(IT,MC)=0
- MCT(IM,MC)=0
- 330 CONTINUE
- DO 340 JCS=4,5
- KCS=JCS
-C...If mother flag not yet set for spacelike parton, trace it.
- IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
- IF(MINT(51).NE.0) RETURN
- 340 CONTINUE
- DO 350 JCS=4,5
- KCS=JCS
-C...If mother flag not yet set for timelike parton, trace it.
- IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
- IF(MINT(51).NE.0) RETURN
- 350 CONTINUE
-
-C...Boost recoiling parton to compensate for Q2 scale.
- BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
- & (1D0+(1D0+Q2BMX/SHAT)**2)
- IR=IMI(3-JS,MI,1)
- CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
-
-C...Define system to be rotated and boosted
-C...(not including the 2 just added partons)
-C...(but including the docu lines for first interaction)
- IMIN=IMISEP(MI-1)+1
- IF (MI.EQ.1) IMIN=MINT(83)+5
- IMAX=IMISEP(MI)-2
-
-C...Rotate back system in phi to compensate for subsequent rotation.
- CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
-
-C...Define kinematics of new partons in old frame.
- IMAX=IMISEP(MI)
- P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
- P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
- & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
- P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
- P(IT,1)=P(IM,1)
- P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
- P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
- P(IT,5)=SQRT(RM2CMX)
-
-C...Update internal line, now spacelike
- P(IS,1)=P(IM,1)-P(IT,1)
- P(IS,2)=P(IM,2)-P(IT,2)
- P(IS,3)=P(IM,3)-P(IT,3)
- P(IS,4)=P(IM,4)-P(IT,4)
- P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
-C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
- IF (P(IS,5).LT.0D0) THEN
- P(IS,5)=-SQRT(ABS(P(IS,5)))
- ELSE
- P(IS,5)=SQRT(P(IS,5))
- ENDIF
-
-C...Boost entire system and rotate to new frame.
-C...(including docu lines)
- BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
- BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
- IF(BETAX**2+BETAZ**2.GE.1D0) THEN
- CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
- MINT(51)=1
- IFAIL=-1
- RETURN
- ENDIF
- CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
- I1=IMI(1,MI,1)
- THETA=PYANGL(P(I1,3),P(I1,1))
- CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
-
-C...Global statistics.
- MINT(352)=MINT(352)+1
- VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
- IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
-
-C...Add parton with relevant pT scale for timelike shower.
- IF (K(IT,2).NE.22) THEN
- NPART=NPART+1
- IPART(NPART)=IT
- PTPART(NPART)=SQRT(PT2AMX)
- ENDIF
-
-C...Update saved variables.
- SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
- NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
- XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
- PT2SAV(JSMX,MIMX)=PT2MX
- ZSAV(JS,MIMX)=ZMX
-
- KSA=IABS(K(IS,2))
- KMA=IABS(K(IM,2))
- IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
-C...Gluon reconstructs to quark.
-C...Decide whether newly created quark is valence or sea:
- MINT(30)=JS
- CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
- IF(MINT(51).NE.0) RETURN
- ENDIF
- IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
-C...Quark reconstructs to gluon.
-C...Now some guy may have lost his companion. Check.
- ICMP=IMI(JS,MI,2)
- IF (ICMP.GT.0) THEN
- CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
- & //' away. Cannot handle that yet. Giving up.')
- MINT(51)=1
- RETURN
- ELSEIF(ICMP.LT.0) THEN
-C...A sea quark with companion still in BR was reconstructed to a gluon.
-C...Companion should now be removed from the beam remnant.
-C...(Momentum integral is automatically updated in next call to PYPDFU.)
- ICMP=-ICMP
- IFL=-K(IS,2)
- DO 370 JCMP=ICMP,NVC(JS,IFL)-1
- XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
- DO 360 JI=1,MINT(31)
- KMI=-IMI(JS,JI,2)
- JFL=-K(IMI(JS,JI,1),2)
- IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
- & ,2)+1
- 360 CONTINUE
- 370 CONTINUE
- NVC(JS,IFL)=NVC(JS,IFL)-1
- ENDIF
-C...Set gluon IMI(JS,MI,2) = 0.
- IMI(JS,MI,2)=0
- ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
-C...Quark reconstructing to quark. If sea with companion still in BR
-C...then update associated x value.
-C...(Momentum integral is automatically updated in next call to PYPDFU.)
- IF (IMI(JS,MI,2).LT.0) THEN
- ICMP=-IMI(JS,MI,2)
- IFL=-K(IS,2)
- XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
- ENDIF
- ENDIF
-
- ENDIF
-
-C...If reached this point, normal exit.
- 380 IFAIL=0
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYMEMX
-C...Generates maximum ME weight in some initial-state showers.
-C...Inparameter MECOR: kind of hard scattering process
-C...Outparameter WTFF: maximum weight for fermion -> fermion
-C... WTGF: maximum weight for gluon/photon -> fermion
-C... WTFG: maximum weight for fermion -> gluon/photon
-C... WTGG: maximum weight for gluon -> gluon
-
- SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
-
-C...Default maximum weight.
- WTFF=1D0
- WTGF=1D0
- WTFG=1D0
- WTGG=1D0
-
-C...Select maximum weight by process.
- IF(MECOR.EQ.1) THEN
- WTFF=1D0
- WTGF=3D0
- ELSEIF(MECOR.EQ.2) THEN
- WTFG=1D0
- WTGG=1D0
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYMEWT
-C...Calculates actual ME weight in some initial-state showers.
-C...Inparameter MECOR: kind of hard scattering process
-C... IFLCB: flavour combination of branching,
-C... 1 for fermion -> fermion,
-C... 2 for gluon/photon -> fermion
-C... 3 for fermion -> gluon/photon,
-C... 4 for gluon -> gluon
-C... Q2: Q2 value of shower branching
-C... Z: Z value of branching
-C...In+outparameter PHIBR: azimuthal angle of branching
-C...Outparameter WTME: actual ME weight
-
- SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
-
-C...Default output.
- WTME=1D0
-
-C...Define kinematics of shower branching in Mandelstam variables.
- SQM=VINT(44)
- SH=SQM/Z
- TH=-Q2
- UH=Q2-SQM*(1D0-Z)/Z
-
-C...Matrix-element corrections for f + fbar -> s-channel vector boson.
- IF(MECOR.EQ.1) THEN
- IF(IFLCB.EQ.1) THEN
- WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
- ELSEIF(IFLCB.EQ.2) THEN
- WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
- ENDIF
-
-C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
- ELSEIF(MECOR.EQ.2) THEN
- IF(IFLCB.EQ.3) THEN
- WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
- ELSEIF(IFLCB.EQ.4) THEN
- WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
- ENDIF
-
-C...Matrix-element corrections for q + qbar -> Higgs (h0)
- ELSEIF(MECOR.EQ.3) THEN
- IF(IFLCB.EQ.2) THEN
- WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
- 1 (SH**2+2D0*SQM*(SQM-SH))
- ENDIF
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYPTMI
-C...Handles the generation of additional interactions in the new
-C...multiple interactions framework.
-C...MODE=-1 : Initalize MI from scratch.
-C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
-C... Sudakov for PT2, abort if below PT2CUT.
-C...MODE= 1 : Accept interaction at PT2NOW and store variables.
-C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
-C...PT2NOW : Starting (max) PT2 scale for evolution.
-C...PT2CUT : Lower limit for evolution.
-C...PT2 : Result of evolution. Generated PT2 for trial interaction.
-C...IFAIL : Status return code.
-C... = 0: All is well.
-C... < 0: Phase space exhausted, generation to be terminated.
-C... > 0: Additional interaction vetoed, but continue evolution.
-
- SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement for maximum size of showers.
- PARAMETER (MAXNUR=1000)
-C...Commonblocks.
- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
- COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
- & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
- & XMI(2,240),PT2MI(240),IMISEP(0:240)
- COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
- & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
- COMMON/PYCTAG/NCT,MCT(4000,2)
-C...Local arrays and saved variables.
- DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
-
- SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
- & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
- & /PYISMX/,/PYCTAG/
- SAVE XT2FAC,SIGS
-
- IFAIL=0
-C...Set MI subprocess = QCD 2 -> 2.
- ISUB=96
-
-C----------------------------------------------------------------------
-C...MODE=-1: Initialize from scratch
- IF (MODE.EQ.-1) THEN
-C...Initialize PT2 array.
- PT2MI(1)=VINT(54)
-C...Initialize list of incoming beams and partons from two sides.
- DO 110 JS=1,2
- DO 100 MI=1,240
- IMI(JS,MI,1)=0
- IMI(JS,MI,2)=0
- 100 CONTINUE
- NMI(JS)=1
- IMI(JS,1,1)=MINT(84)+JS
- IMI(JS,1,2)=0
- XMI(JS,1)=VINT(40+JS)
-C...Rescale x values to fractions of photon energy.
- IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
-C...Hard reset: hard interaction initiators motherless by definition.
- K(MINT(84)+JS,3)=2+JS
- K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
- K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
- 110 CONTINUE
- IMISEP(0)=MINT(84)
- IMISEP(1)=N
- IF (MOD(MSTP(81),10).GE.1) THEN
- IF(MSTP(82).LE.1) THEN
- SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
- & ,5))
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
- & VINT(317)/(VINT(318)*VINT(320))
- XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
- ELSE
- XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
- & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
- ENDIF
- ENDIF
-C...Zero entries relating to scatterings beyond the first.
- DO 120 MI=2,240
- IMI(1,MI,1)=0
- IMI(2,MI,1)=0
- IMI(1,MI,2)=0
- IMI(2,MI,2)=0
- IMISEP(MI)=IMISEP(1)
- PT2MI(MI)=0D0
- XMI(1,MI)=0D0
- XMI(2,MI)=0D0
- 120 CONTINUE
-C...Initialize factors for PDF reshaping.
- DO 140 JS=1,2
- KFBEAM(JS)=MINT(10+JS)
- IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
- KFABM=IABS(KFBEAM(JS))
- KFSBM=ISIGN(1,KFBEAM(JS))
-
-C...Zero flavour content of incoming beam particle.
- KFIVAL(JS,1)=0
- KFIVAL(JS,2)=0
- KFIVAL(JS,3)=0
-C... Flavour content of baryon.
- IF(KFABM.GT.1000) THEN
- KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
- KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
- KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
-C... Flavour content of pi+-, K+-.
- ELSEIF(KFABM.EQ.211) THEN
- KFIVAL(JS,1)=KFSBM*2
- KFIVAL(JS,2)=-KFSBM
- ELSEIF(KFABM.EQ.321) THEN
- KFIVAL(JS,1)=-KFSBM*3
- KFIVAL(JS,2)=KFSBM*2
-C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
- ENDIF
-
-C...Zero initial valence and companion content.
- DO 130 IFL=-6,6
- NVC(JS,IFL)=0
- 130 CONTINUE
- 140 CONTINUE
-C...Set up colour line tags starting from hard interaction initiators.
- NCT=0
-C...Reset colour tag array and colour processing flags.
- DO 150 I=IMISEP(0)+1,N
- MCT(I,1)=0
- MCT(I,2)=0
- K(I,4)=MOD(K(I,4),MSTU(5)**2)
- K(I,5)=MOD(K(I,5),MSTU(5)**2)
- 150 CONTINUE
-C... Consider each side in turn.
- DO 170 JS=1,2
- I1=IMI(JS,1,1)
- I2=IMI(3-JS,1,1)
- DO 160 JCS=4,5
- IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
- & GOTO 160
- IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
- KCS=JCS
- CALL PYCTTR(I1,KCS,I2)
- IF(MINT(51).NE.0) RETURN
- 160 CONTINUE
- 170 CONTINUE
-
-C...Range checking for companion quark pdf large-x param.
- IF (MSTP(87).LT.0) THEN
- CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
- & ' MSTP(87)=0')
- MSTP(87)=0
- ELSEIF (MSTP(87).GT.4) THEN
- CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
- & ' MSTP(87)=4')
- MSTP(87)=4
- ENDIF
-
-C----------------------------------------------------------------------
-C...MODE=0: Generate trial interaction. Return codes:
-C...IFAIL < 0: Phase space exhausted, generation to be terminated.
-C...IFAIL = 0: Additional interaction generated at PT2.
-C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
- ELSEIF (MODE.EQ.0) THEN
-C...Abolute MI max scale = VINT(62)
- XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
- 180 IF(MSTP(82).LE.1) THEN
- XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
- IF(XT2.LT.VINT(149)) IFAIL=-2
- ELSE
- IF(XT2.LE.0.01001D0*VINT(149)) THEN
- IFAIL=-3
- ELSE
- XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
- & LOG(PYR(0)))-VINT(149)
- ENDIF
- ENDIF
-C...Also exit if below lower limit or if higher trial branching
-C...already found.
- PT2=0.25D0*VINT(2)*XT2
- IF (PT2.LE.PT2CUT) IFAIL=-4
- IF (PT2.LE.PT2MX) IFAIL=-5
- IF (IFAIL.NE.0) THEN
- PT2=0D0
- RETURN
- ENDIF
- IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
- VINT(25)=4D0*PT2/VINT(2)
- XT2=VINT(25)
-
-C...Choose tau and y*. Calculate cos(theta-hat).
- IF(PYR(0).LE.COEF(ISUB,1)) THEN
- TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
- TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
- ELSE
- TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
- ENDIF
- VINT(21)=TAU
-C...New: require shat > 1.
- IF(TAU*VINT(2).LT.1D0) GOTO 180
- CALL PYKLIM(2)
- RYST=PYR(0)
- MYST=1
- IF(RYST.GT.COEF(ISUB,8)) MYST=2
- IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
- CALL PYKMAP(2,MYST,PYR(0))
- VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
-
-C...Check that x not used up. Accept or reject kinematical variables.
- X1M=SQRT(TAU)*EXP(VINT(22))
- X2M=SQRT(TAU)*EXP(-VINT(22))
- IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
- VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
- CALL PYSIGH(NCHN,SIGS)
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
- IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
-
-C...Save if highest PT so far.
- IF (PT2.GT.PT2MX) THEN
- JSMX=0
- MIMX=MINT(31)+1
- PT2MX=PT2
- ENDIF
-
-C----------------------------------------------------------------------
-C...MODE=1: Generate and save accepted scattering.
- ELSEIF (MODE.EQ.1) THEN
- PT2=PT2NOW
-C...Reset K, P, V, and MCT vectors.
- DO 200 I=N+1,N+4
- DO 190 J=1,5
- K(I,J)=0
- P(I,J)=0D0
- V(I,J)=0D0
- 190 CONTINUE
- MCT(I,1)=0
- MCT(I,2)=0
- 200 CONTINUE
-
- NTRY=0
-C...Choose flavour of reacting partons (and subprocess).
- 210 NTRY=NTRY+1
- IF (NTRY.GT.50) THEN
- CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
- & //'interaction. Giving up!')
- MINT(51)=1
- RETURN
- ENDIF
- RSIGS=SIGS*PYR(0)
- DO 220 ICHN=1,NCHN
- KFL1=ISIG(ICHN,1)
- KFL2=ISIG(ICHN,2)
- ICONMI=ISIG(ICHN,3)
- RSIGS=RSIGS-SIGH(ICHN)
- IF(RSIGS.LE.0D0) GOTO 230
- 220 CONTINUE
-
-C...Reassign to appropriate process codes.
- 230 ISUBMI=ICONMI/10
- ICONMI=MOD(ICONMI,10)
-
-C...Choose new quark flavour for annihilation graphs
- IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
- SH=VINT(21)*VINT(2)
- CALL PYWIDT(21,SH,WDTP,WDTE)
- 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
- DO 250 I=1,MDCY(21,3)
- KFLF=KFDP(I+MDCY(21,2)-1,1)
- RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
- IF(RKFL.LE.0D0) GOTO 260
- 250 CONTINUE
- 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
- IF(KFLF.GE.4) GOTO 240
- ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
- KFLF=4
- ICONMI=ICONMI-2
- ELSEIF(ISUBMI.EQ.53) THEN
- KFLF=5
- ICONMI=ICONMI-4
- ENDIF
- ENDIF
-
-C...Final state flavours and colour flow: default values
- JS=1
- KFL3=KFL1
- KFL4=KFL2
- KCC=20
- KCS=ISIGN(1,KFL1)
-
- IF(ISUBMI.EQ.11) THEN
-C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
- KCC=ICONMI
- IF(KFL1*KFL2.LT.0) KCC=KCC+2
-
- ELSEIF(ISUBMI.EQ.12) THEN
-C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
- KFL3=ISIGN(KFLF,KFL1)
- KFL4=-KFL3
- KCC=4
-
- ELSEIF(ISUBMI.EQ.13) THEN
-C...f + fbar -> g + g; th arbitrary
- KFL3=21
- KFL4=21
- KCC=ICONMI+4
-
- ELSEIF(ISUBMI.EQ.28) THEN
-C...f + g -> f + g; th = (p(f)-p(f))**2
- IF(KFL1.EQ.21) JS=2
- KCC=ICONMI+6
- IF(KFL1.EQ.21) KCC=KCC+2
- IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
- IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
-
- ELSEIF(ISUBMI.EQ.53) THEN
-C...g + g -> f + fbar; th arbitrary
- KCS=(-1)**INT(1.5D0+PYR(0))
- KFL3=ISIGN(KFLF,KCS)
- KFL4=-KFL3
- KCC=ICONMI+10
-
- ELSEIF(ISUBMI.EQ.68) THEN
-C...g + g -> g + g; th arbitrary
- KCC=ICONMI+12
- KCS=(-1)**INT(1.5D0+PYR(0))
- ENDIF
-
-C...Check that massive sea quarks have non-zero phase space for g -> Q Q
- IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
- & .OR.IABS(KFL4).EQ.5) THEN
- RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
- IF (PT2.LE.1.05*RMMAX2) THEN
- IF (NTRY.EQ.1) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
- & //' created below threshold. Rejected.')
- GOTO 210
- ENDIF
- ENDIF
-
-C...Store flavours of scattering.
- MINT(13)=KFL1
- MINT(14)=KFL2
- MINT(15)=KFL1
- MINT(16)=KFL2
- MINT(21)=KFL3
- MINT(22)=KFL4
-
-C...Set flavours and mothers of scattering partons.
- K(N+1,1)=14
- K(N+2,1)=14
- K(N+3,1)=3
- K(N+4,1)=3
- K(N+1,2)=KFL1
- K(N+2,2)=KFL2
- K(N+3,2)=KFL3
- K(N+4,2)=KFL4
- K(N+1,3)=MINT(83)+1
- K(N+2,3)=MINT(83)+2
- K(N+3,3)=N+1
- K(N+4,3)=N+2
-
-C...Store colour connection indices.
- DO 270 J=1,2
- JC=J
- IF(KCS.EQ.-1) JC=3-J
- IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
- IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
- IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
- IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
- 270 CONTINUE
-
-C...Store incoming and outgoing partons in their CM-frame.
- SHR=SQRT(VINT(21))*VINT(1)
- P(N+1,3)=0.5D0*SHR
- P(N+1,4)=0.5D0*SHR
- P(N+2,3)=-0.5D0*SHR
- P(N+2,4)=0.5D0*SHR
- P(N+3,5)=PYMASS(K(N+3,2))
- P(N+4,5)=PYMASS(K(N+4,2))
- IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
- IFAIL=1
- RETURN
- ENDIF
- P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
- P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
- P(N+4,4)=SHR-P(N+3,4)
- P(N+4,3)=-P(N+3,3)
-
-C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
- PHI=PARU(2)*PYR(0)
- CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
-
-C...Global statistics.
- MINT(351)=MINT(351)+1
- VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
- IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
-
-C...Keep track of loose colour ends and information on scattering.
- MINT(31)=MINT(31)+1
- MINT(36)=MINT(31)
- PT2MI(MINT(36))=PT2
- IMISEP(MINT(31))=N+4
- DO 280 JS=1,2
- IMI(JS,MINT(31),1)=N+JS
- IMI(JS,MINT(31),2)=0
- XMI(JS,MINT(31))=VINT(40+JS)
- NMI(JS)=NMI(JS)+1
-C...Update cumulative counters
- VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
- VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
- 280 CONTINUE
-
-C...Add to list of final state partons
- IPART(NPART+1)=N+3
- IPART(NPART+2)=N+4
- PTPART(NPART+1)=SQRT(PT2)
- PTPART(NPART+2)=SQRT(PT2)
- NPART=NPART+2
-
-C...Initialize ISR
- NISGEN(1,MINT(31))=0
- NISGEN(2,MINT(31))=0
-
-C...Update ER
- N=N+4
- IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
- CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
- MINT(51)=1
- RETURN
- ENDIF
-
-C...Finally, assign colour tags to new partons
- DO 300 JS=1,2
- I1=IMI(JS,MINT(31),1)
- I2=IMI(3-JS,MINT(31),1)
- DO 290 JCS=4,5
- IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
- & GOTO 290
- IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
- KCS=JCS
- CALL PYCTTR(I1,KCS,I2)
- IF(MINT(51).NE.0) RETURN
- 290 CONTINUE
- 300 CONTINUE
-
-C----------------------------------------------------------------------
-C...MODE=2: Decide whether quarks in last scattering were valence,
-C...companion, or sea.
- ELSEIF (MODE.EQ.2) THEN
- JS=MINT(30)
- MI=MINT(36)
- PT2=PT2NOW
- KFSBM=ISIGN(1,MINT(10+JS))
- IFL=K(IMI(JS,MI,1),2)
- IMI(JS,MI,2)=0
- IF (IABS(IFL).GE.6) THEN
- IF (IABS(IFL).EQ.6) THEN
- CALL PYERRM(29,'(PYPTMI:) top in initial state!')
- ENDIF
- RETURN
- ENDIF
-C...Get PDFs at X(rescaled) and PT2 of the current initiator.
-C...(Do not include the parton itself in the X rescaling.)
- X=XMI(JS,MI)
- XRSC=X/(VINT(142+JS)+X)
-C...Note: XPSVC = x*pdf.
- MINT(30)=JS
- CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
- SEA=XPSVC(IFL,-1)
- VAL=XPSVC(IFL,0)
- CMP=0D0
- DO 310 IVC=1,NVC(JS,IFL)
- CMP=CMP+XPSVC(IFL,IVC)
- 310 CONTINUE
-
-C...Decide (Extra factor x cancels in the dvision).
- 320 RVCS=PYR(0)*(SEA+VAL+CMP)
- IVNOW=1
- 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
-C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
- IVNOW=0
- IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
- IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
- IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
- IF(KFIVAL(JS,1).EQ.0) THEN
- IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
- IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
- IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
- & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
- ELSE
-C...Count down valence remaining. Do not count current scattering.
- DO 340 I1=1,NMI(JS)
- IF (I1.EQ.MINT(36)) GOTO 340
- IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
- & IVNOW=IVNOW-1
- 340 CONTINUE
- ENDIF
- IF(IVNOW.EQ.0) GOTO 330
-C...Mark valence.
- IMI(JS,MI,2)=0
-C...Sets valence content of gamma, pi0, K0S, K0L if not done.
- IF(KFIVAL(JS,1).EQ.0) THEN
- IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
- KFIVAL(JS,1)=IFL
- KFIVAL(JS,2)=-IFL
- ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
- KFIVAL(JS,1)=IFL
- IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
- IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
- ENDIF
- ENDIF
-
- ELSEIF (RVCS.LE.VAL+SEA) THEN
-C...If sea, add opposite sign companion parton. Store X and I.
- NVC(JS,-IFL)=NVC(JS,-IFL)+1
- XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
-C...Set pointer to companion
- IMI(JS,MI,2)=-NVC(JS,-IFL)
-
- ELSE
-C...If companion, decide which one.
- IF (NVC(JS,IFL).EQ.0) THEN
- CMP=0D0
- CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
- GOTO 320
- ENDIF
- CMPSUM=VAL+SEA
- ISEL=0
- 350 ISEL=ISEL+1
- CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
- IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
-C...Find original sea (anti-)quark. Do not consider current scattering.
- IASSOC=0
- DO 360 I1=1,NMI(JS)
- IF (I1.EQ.MINT(36)) GOTO 360
- IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
- IF (-IMI(JS,I1,2).EQ.ISEL) THEN
- IMI(JS,MI,2)=IMI(JS,I1,1)
- IMI(JS,I1,2)=IMI(JS,MI,1)
- ENDIF
- 360 CONTINUE
-C...Mark companion "out-kicked".
- XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
- ENDIF
-
- ENDIF
- RETURN
- END
-
-C*********************************************************************
-
-C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
-C...Giving the x*f pdf of a companion quark, with its partner at XS,
-C...using an approximate gluon density like (1-X)^NPOW/X. The value
-C...corresponds to an unrescaled range between 0 and 1-X.
-
- FUNCTION PYFCMP(XC,XS,NPOW)
- IMPLICIT NONE
- DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
- INTEGER NPOW
-
- PYFCMP=0D0
-C...Parent gluon momentum fraction
- Y=XC+XS
- IF (Y.GE.1D0) RETURN
-C...Common factor (includes factor XC, since PYFCMP=x*f)
- FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
-C...Store normalized companion x*f distribution.
- IF (NPOW.LE.0) THEN
- PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
- ELSEIF (NPOW.EQ.1) THEN
- PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
- ELSEIF (NPOW.EQ.2) THEN
- PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
- & +3D0*XS*(1D0+XS)*LOG(XS)))
- ELSEIF (NPOW.EQ.3) THEN
- PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
- & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
- ELSEIF (NPOW.GE.4) THEN
- PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
- & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
- ENDIF
- RETURN
- END
-
-C*********************************************************************
-
-C...PYPCMP: Auxiliary to PYPDFU.
-C...Giving the momentum integral of a companion quark, with its
-C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
-C...The value corresponds to an unrescaled range between 0 and 1-XS.
-
- FUNCTION PYPCMP(XS,NPOW)
- IMPLICIT NONE
- DOUBLE PRECISION XS, PYPCMP
- INTEGER NPOW
- IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
- PYPCMP=0D0
- ELSEIF (NPOW.LE.0) THEN
- PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
- PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
- ELSEIF (NPOW.EQ.1) THEN
- PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
- & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
- ELSEIF (NPOW.EQ.2) THEN
- PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
- & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
- PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
- & -3D0*XS*LOG(XS)*(1+XS)))
- ELSEIF (NPOW.EQ.3) THEN
- PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
- & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
- PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
- & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
- ELSE
- PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
- & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
- PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
- & -6D0*XS*LOG(XS)*(1D0+XS)))
- ENDIF
- RETURN
- END
-
-C*********************************************************************
-
-C...PYUPRE
-C...Rearranges contents of the HEPEUP commonblock so that
-C...mothers precede daughters and daughters of a decay are
-C...listed consecutively.
-
- SUBROUTINE PYUPRE
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-
-C...User process event common block.
- INTEGER MAXNUP
- PARAMETER (MAXNUP=500)
- INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
- DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
- COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
- &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
- &VTIMUP(MAXNUP),SPINUP(MAXNUP)
- SAVE /HEPEUP/
-
-C...Local arrays.
- DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
- &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
- &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
-
-C...Check whether a rearrangement is required.
- NEED=0
- DO 100 IUP=1,NUP
- IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
- 100 CONTINUE
- DO 110 IUP=2,NUP
- IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
- 110 CONTINUE
-
- IF(NEED.NE.0) THEN
-C...Find the new order that particles should have.
- NEWPOS(0)=0
- NNEW=0
- INEW=-1
- 120 INEW=INEW+1
- DO 130 IUP=1,NUP
- IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
- NNEW=NNEW+1
- NEWPOS(NNEW)=IUP
- ENDIF
- 130 CONTINUE
- IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
- IF(NNEW.NE.NUP) THEN
- CALL PYERRM(2,
- & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
- RETURN
- ENDIF
-
-C...Copy old info into temporary storage.
- DO 150 I=1,NUP
- IDUPT(I)=IDUP(I)
- ISTUPT(I)=ISTUP(I)
- MOTUPT(1,I)=MOTHUP(1,I)
- MOTUPT(2,I)=MOTHUP(2,I)
- ICOUPT(1,I)=ICOLUP(1,I)
- ICOUPT(2,I)=ICOLUP(2,I)
- DO 140 J=1,5
- PUPT(J,I)=PUP(J,I)
- 140 CONTINUE
- VTIUPT(I)=VTIMUP(I)
- SPIUPT(I)=SPINUP(I)
- 150 CONTINUE
-
-C...Copy info back into HEPEUP in right order.
- DO 180 I=1,NUP
- IOLD=NEWPOS(I)
- IDUP(I)=IDUPT(IOLD)
- ISTUP(I)=ISTUPT(IOLD)
- MOTHUP(1,I)=0
- MOTHUP(2,I)=0
- DO 160 IMOT=1,I-1
- IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
- IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
- 160 CONTINUE
- IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
- MOTHSW=MOTHUP(1,I)
- MOTHUP(1,I)=MOTHUP(2,I)
- MOTHUP(2,I)=MOTHSW
- ENDIF
- ICOLUP(1,I)=ICOUPT(1,IOLD)
- ICOLUP(2,I)=ICOUPT(2,IOLD)
- DO 170 J=1,5
- PUP(J,I)=PUPT(J,IOLD)
- 170 CONTINUE
- VTIMUP(I)=VTIUPT(IOLD)
- SPINUP(I)=SPIUPT(IOLD)
- 180 CONTINUE
- ENDIF
-
-c...If incoming particles are massive recalculate to put them massless.
- IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
- PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
- PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
- PUP(4,1)=0.5D0*PPLUS
- PUP(3,1)=PUP(4,1)
- PUP(5,1)=0D0
- PUP(4,2)=0.5D0*PMINUS
- PUP(3,2)=-PUP(4,2)
- PUP(5,2)=0D0
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYADSH
-C...Administers the generation of successive final-state showers
-C...in external processes.
-
- SUBROUTINE PYADSH(NFIN)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement for maximum size of showers.
- PARAMETER (MAXNUR=1000)
-C...Commonblocks.
- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYCTAG/NCT,MCT(4000,2)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
-C...Local array.
- DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
-
-C...Set primary vertex.
- DO 100 J=1,5
- V(MINT(83)+5,J)=0D0
- V(MINT(83)+6,J)=0D0
- V(MINT(84)+1,J)=0D0
- V(MINT(84)+2,J)=0D0
- 100 CONTINUE
-
-C...Isolate systems of particles with the same mother.
- NSYS=0
- IMS=-1
- DO 140 I=MINT(84)+3,NFIN
- IM=K(I,3)
- IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
- IF(IM.NE.IMS) THEN
- NSYS=NSYS+1
- IBEG(NSYS)=I
- IMS=IM
- ENDIF
-
-C...Set production vertices.
- IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
- & THEN
- DO 110 J=1,4
- V(I,J)=0D0
- 110 CONTINUE
- ELSE
- DO 120 J=1,4
- V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
- 120 CONTINUE
- ENDIF
- IF(MSTP(125).GE.1) THEN
- IDOC=I-MSTP(126)+4
- DO 130 J=1,5
- V(IDOC,J)=V(I,J)
- 130 CONTINUE
- ENDIF
- 140 CONTINUE
-
-C...End loop over systems. Return if no showers to be performed.
- IBEG(NSYS+1)=NFIN+1
- IF(MSTP(71).LE.0) RETURN
-
-C...Loop through systems of particles; check that sensible size.
- DO 270 ISYS=1,NSYS
- NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
- IF(MINT(35).LE.1) THEN
- IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
- GOTO 270
- ELSEIF(NSIZ.LE.1) THEN
- CALL PYERRM(2,'(PYADSH:) only one particle in system')
- GOTO 270
- ELSEIF(NSIZ.GT.80) THEN
- CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
- GOTO 270
- ENDIF
- ENDIF
-
-C...Save status codes and daughters of showering particles; reset them.
- DO 150 J=1,4
- PSUM(J)=0D0
- 150 CONTINUE
- DO 170 II=1,NSIZ
- I=IBEG(ISYS)-1+II
- KSAV(II,1)=K(I,1)
- IF(K(I,1).GT.10) THEN
- K(I,1)=1
- IF(KSAV(II,1).EQ.14) K(I,1)=3
- ENDIF
- IF(KSAV(II,1).LE.10) THEN
- ELSEIF(K(I,1).EQ.1) THEN
- KSAV(II,4)=K(I,4)
- KSAV(II,5)=K(I,5)
- K(I,4)=0
- K(I,5)=0
- ELSE
- KSAV(II,4)=MOD(K(I,4),MSTU(5))
- KSAV(II,5)=MOD(K(I,5),MSTU(5))
- K(I,4)=K(I,4)-KSAV(II,4)
- K(I,5)=K(I,5)-KSAV(II,5)
- ENDIF
- DO 160 J=1,4
- PSUM(J)=PSUM(J)+P(I,J)
- 160 CONTINUE
- 170 CONTINUE
-
-C...Perform shower.
- QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
- & PSUM(3)**2))
- IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
- NSAV=N
- IF(MINT(35).LE.1) THEN
- IF(NSIZ.EQ.2) THEN
- if(parj(200).eq.1.) CALL PYSHOWQ(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
- if(parj(200).ne.1.) CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
- ELSE
- if(parj(200).ne.1.) CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
- if(parj(200).eq.1.) CALL PYSHOWQ(IBEG(ISYS),-NSIZ,QMAX)
- ENDIF
-
-C...For external processes, first call, also ISR partons radiate.
-C...Can use existing PYPART list, removing partons that radiate later.
- ELSEIF(ISYS.EQ.1) THEN
- NPARTN=0
- DO 175 II=1,NPART
- IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
- NPARTN=NPARTN+1
- IPART(NPARTN)=IPART(II)
- PTPART(NPARTN)=PTPART(II)
- ENDIF
- 175 CONTINUE
- NPART=NPARTN
- CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
- ELSE
-C...For subsequent calls use the systems excluded above.
- NPART=NSIZ
- NPARTD=0
- DO 180 II=1,NSIZ
- I=IBEG(ISYS)-1+II
- IPART(II)=I
- PTPART(II)=0.5D0*QMAX
- 180 CONTINUE
- CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
- ENDIF
-
-C...Look up showered copies of original showering particles.
- DO 260 II=1,NSIZ
- I=IBEG(ISYS)-1+II
- IMV=I
-C...Particles without daughters need not be studied.
- IF(KSAV(II,1).LE.10) GOTO 260
- IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
- ELSEIF(K(I,1).EQ.11) THEN
- 190 IMV=MOD(K(IMV,4),MSTU(5))
- IF(K(IMV,1).EQ.11) GOTO 190
- ELSE
- KDA1=MOD(K(I,4),MSTU(5))
- IF(KDA1.GT.0) THEN
- IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
- ENDIF
- KDA2=MOD(K(I,5),MSTU(5))
- IF(KDA2.GT.0) THEN
- IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
- ENDIF
- DO 200 I3=I+1,N
- IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
- & THEN
- IMV=I3
- KDA1=MOD(K(I3,4),MSTU(5))
- IF(KDA1.GT.0) THEN
- IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
- ENDIF
- KDA2=MOD(K(I3,5),MSTU(5))
- IF(KDA2.GT.0) THEN
- IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
- ENDIF
- ENDIF
- 200 CONTINUE
- ENDIF
-
-C...Restore daughter info of original partons to showered copies.
- IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
- IF(KSAV(II,1).LE.10) THEN
- ELSEIF(K(I,1).EQ.1) THEN
- K(IMV,4)=KSAV(II,4)
- K(IMV,5)=KSAV(II,5)
- ELSE
- K(IMV,4)=K(IMV,4)+KSAV(II,4)
- K(IMV,5)=K(IMV,5)+KSAV(II,5)
- ENDIF
-
-C...Reset mother info of existing daughters to showered copies.
- DO 210 I3=IBEG(ISYS+1),NFIN
- IF(K(I3,3).EQ.I) K(I3,3)=IMV
- IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
- IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
- IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
- ENDIF
- 210 CONTINUE
-
-C...Boost all original daughters to new frame of showered copy.
-C...Also update their colour tags.
- IF(IMV.NE.I) THEN
- DO 220 J=1,3
- BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
- 220 CONTINUE
- FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
- DO 230 J=1,3
- BETA(J)=FAC*BETA(J)
- 230 CONTINUE
- DO 250 I3=IBEG(ISYS+1),NFIN
- IMO=I3
- 240 IMO=K(IMO,3)
- IF(MSTP(128).LE.0) THEN
- IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
- IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
- & THEN
- CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
- IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
- IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
- ENDIF
- ELSE
- IF(IMO.EQ.IMV) THEN
- CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
- IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
- IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
- ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
- GOTO 240
- ENDIF
- ENDIF
- 250 CONTINUE
- ENDIF
- 260 CONTINUE
-
-C...End of loop over showering systems
- 270 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYVETO
-C...Interface to UPVETO, which allows user to veto event generation
-C...on the parton level, after parton showers but before multiple
-C...interactions, beam remnants and hadronization is added.
-
- SUBROUTINE PYVETO(IVETO)
-
-C...All real arithmetic in double precision.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
-C...Three Pythia functions return integers, so need declaring.
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...PYTHIA commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYJETS/,/PYPARS/,/PYINT1/
-C...HEPEVT commonblock.
- PARAMETER (NMXHEP=4000)
- COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
- DOUBLE PRECISION PHEP,VHEP
- SAVE /HEPEVT/
-C...Local array.
- DIMENSION IRESO(100)
-
-C...Define longitudinal boost from initiator rest frame to cm frame.
- IF(MINT(35).EQ.3) THEN
-C...The last frame is different depending upon old and new shower
- GAMMA=1D0
- GABEZ=0D0
- ELSE
- GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
- GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
- ENDIF
-
-C... Reset counters.
- NEVHEP=0
- NHEP=0
- NRESO=0
-
-C...Oth pass: identify beam and incoming partons
- DO 140 I=MINT(83)+1,MINT(83)+6
- ISTORE=0
-C IF(K(I,2).EQ.94.OR.K(I,2).EQ.0) THEN
- IF(K(I,2).EQ.94) THEN
-
- ELSE
- ISTORE=1
- NHEP=NHEP+1
- II=NHEP
- NRESO=NRESO+1
- IRESO(NRESO)=I
- IMOTH=K(I,3)
- ENDIF
- IF(ISTORE.EQ.1) THEN
-C...Copy parton info, boosting momenta along z axis to cm frame.
- ISTHEP(II)=2
- IDHEP(II)=K(I,2)
- PHEP(1,II)=P(I,1)
- PHEP(2,II)=P(I,2)
- IF(II.GT.2) THEN
- PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
- PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
- ELSE
- PHEP(3,II)=P(I,3)
- PHEP(4,II)=P(I,4)
- ENDIF
- PHEP(5,II)=P(I,5)
-C...Store one mother. Rest of history and vertex info zeroed.
- JMOHEP(1,II)=IMOTH
- JMOHEP(2,II)=0
- JDAHEP(1,II)=0
- JDAHEP(2,II)=0
- VHEP(1,II)=0D0
- VHEP(2,II)=0D0
- VHEP(3,II)=0D0
- VHEP(4,II)=0D0
- ENDIF
- 140 CONTINUE
-
-C...First pass: identify final locations of resonances
-C...and of their daughters before showering.
- DO 150 I=MINT(84)+3,N
- ISTORE=0
- IMOTH=0
-
-C...Skip shower CM frame documentation lines.
- IF(K(I,2).EQ.94) THEN
-
-C... Store a new intermediate product, when mother in documentation.
- ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
- & K(I,3).LE.MINT(84)) THEN
- ISTORE=1
- NHEP=NHEP+1
- II=NHEP
- NRESO=NRESO+1
- IRESO(NRESO)=I
- IMOTH=K(K(I,3),3)
-
-C... Store a new intermediate product, when mother in main section.
- ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
- & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
- ISTORE=1
- NHEP=NHEP+1
- II=NHEP
- NRESO=NRESO+1
- IRESO(NRESO)=I
- IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3))
- ENDIF
-
- IF(ISTORE.EQ.1) THEN
-C...Copy parton info, boosting momenta along z axis to cm frame.
- ISTHEP(II)=2
- IDHEP(II)=K(I,2)
- PHEP(1,II)=P(I,1)
- PHEP(2,II)=P(I,2)
- PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
- PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
- PHEP(5,II)=P(I,5)
-C...Store one mother. Rest of history and vertex info zeroed.
- JMOHEP(1,II)=IMOTH
- JMOHEP(2,II)=0
- JDAHEP(1,II)=I
- JDAHEP(2,II)=0
- VHEP(1,II)=0D0
- VHEP(2,II)=0D0
- VHEP(3,II)=0D0
- VHEP(4,II)=0D0
- ENDIF
- 150 CONTINUE
-
-C...Second pass: identify current set of "final" partons.
- DO 200 I=MINT(84)+3,N
- ISTORE=0
- IMOTH=0
-
-C...Store a final parton.
- IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
- ISTORE=1
- NHEP=NHEP+1
- II=NHEP
-C..Trace it back through shower, to check if from documented particle.
- IHIST=I
- ISAVE=IHIST
- 160 CONTINUE
- IF(IHIST.GT.MINT(84)) THEN
- IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
- DO 170 IRI=1,NRESO
- IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
- 170 CONTINUE
- ISAVE=IHIST
- IHIST=K(IHIST,3)
- IF(IMOTH.EQ.0) GOTO 160
- ELSEIF(IHIST.LE.4) THEN
- IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
- ISTORE=0
- NHEP=NHEP-1
- ELSE
- IMOTH=IHIST
- ENDIF
- ENDIF
- ENDIF
-
- IF(ISTORE.EQ.1) THEN
-C...Copy parton info, boosting momenta along z axis to cm frame.
- ISTHEP(II)=1
- IDHEP(II)=K(I,2)
- PHEP(1,II)=P(I,1)
- PHEP(2,II)=P(I,2)
- PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
- PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
- PHEP(5,II)=P(I,5)
-C...Store one mother. Rest of history and vertex info zeroed.
- JMOHEP(1,II)=IMOTH
- JMOHEP(2,II)=0
- JDAHEP(1,II)=0
- JDAHEP(2,II)=0
- VHEP(1,II)=0D0
- VHEP(2,II)=0D0
- VHEP(3,II)=0D0
- VHEP(4,II)=0D0
- ENDIF
- 200 CONTINUE
-
-C...Call user-written routine to decide whether to keep events.
- CALL UPVETO(IVETO)
-
- RETURN
- END
-C*********************************************************************
-
-C...PYRESD
-C...Allows resonances to decay (including parton showers for hadronic
-C...channels).
-
- SUBROUTINE PYRESD(IRES)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Parameter statement for maximum size of showers.
- PARAMETER (MAXNUR=1000)
-C...Commonblocks.
- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYCTAG/NCT,MCT(4000,2)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
- &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/
-C...Local arrays and complex and character variables.
- DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
- &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
- &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
- &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
- &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(3),ITRI(3),IOCT(3)
- COMPLEX FGK,HA(6,6),HC(6,6)
- REAL TIR,UIR
- CHARACTER CODE*9,MASS*9
-
-C...The F, Xi and Xj functions of Gunion and Kunszt
-C...(Phys. Rev. D33, 665, plus errata from the authors).
- FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
- &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
- DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
- &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
- DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
- &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
- &2D0*(D34/D56+D56/D34))
-
-C...Some general constants.
- XW=PARU(102)
- XWV=XW
- IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
- XW1=1D0-XW
- SQMZ=PMAS(23,1)**2
-
- GMMZ=PMAS(23,1)*PMAS(23,2)
- SQMW=PMAS(24,1)**2
- GMMW=PMAS(24,1)*PMAS(24,2)
- SH=VINT(44)
-
-C...Boost and rotate to rest frame of incoming partons,
-C...to get proper amount of smearing of decay angles.
- IBST=0
- IF(IRES.EQ.0) THEN
- IBST=1
- ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4)
- BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN
- BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN
- BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN
- CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
- PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
- CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
- THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
- CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
- ENDIF
-
-C...Reset original resonance configuration.
- DO 100 JT=1,8
- IREF(1,JT)=0
- 100 CONTINUE
-
-C...Define initial one, two or three objects for subprocess.
- IHDEC=0
- IF(IRES.EQ.0) THEN
- ISUB=MINT(1)
- IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
- IREF(1,1)=MINT(84)+2+ISET(ISUB)
- IREF(1,4)=MINT(83)+6+ISET(ISUB)
- JTMAX=1
- ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
- IREF(1,1)=MINT(84)+1+ISET(ISUB)
- IREF(1,2)=MINT(84)+2+ISET(ISUB)
- IREF(1,4)=MINT(83)+5+ISET(ISUB)
- IREF(1,5)=MINT(83)+6+ISET(ISUB)
- JTMAX=2
- ELSEIF(ISET(ISUB).EQ.5) THEN
- IREF(1,1)=MINT(84)+3
- IREF(1,2)=MINT(84)+4
- IREF(1,3)=MINT(84)+5
- IREF(1,4)=MINT(83)+7
- IREF(1,5)=MINT(83)+8
- IREF(1,6)=MINT(83)+9
- JTMAX=3
- ENDIF
-
-C...Define original resonance for odd cases.
- ELSE
- ISUB=0
- IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
- & IHDEC=1
- IF(IHDEC.EQ.1) ISUB=3
- IREF(1,1)=IRES
- IREF(1,4)=K(IRES,3)
- IRESTM=IRES
- IF(IREF(1,4).GT.MINT(84)) THEN
- 110 ITMPMO=IREF(1,4)
- IF(K(ITMPMO,2).EQ.94) THEN
- IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
- IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
- ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
- IRESTM=ITMPMO
-C...Explicitly check that reference particle exists, otherwise stop recursion
- IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
- IREF(1,4)=K(ITMPMO,3)
- GOTO 110
- ENDIF
- ENDIF
- ENDIF
- IF(IREF(1,4).GT.MINT(84)) THEN
- EMATCH=1D10
- IREF14=IREF(1,4)
- DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
- IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
- & EMATCH) THEN
- IREF(1,4)=II
- EMATCH=ABS(P(II,4)-P(IREF14,4))
- ENDIF
- 120 CONTINUE
- ENDIF
- JTMAX=1
- ENDIF
-
-C...Check if initial resonance has been moved (in resonance + jet).
- DO 140 JT=1,3
- IF(IREF(1,JT).GT.0) THEN
- IF(K(IREF(1,JT),1).GT.10) THEN
- KFA=IABS(K(IREF(1,JT),2))
- IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
- KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
- KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
- IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
- IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
- ENDIF
- IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
- IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
- ENDIF
- DO 130 I=IREF(1,JT)+1,N
- IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
- & I.EQ.KDA2)) THEN
- IREF(1,JT)=I
- KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
- KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
- IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
- IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
- ENDIF
- IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
- IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
- ENDIF
- ENDIF
- 130 CONTINUE
- ELSE
- KDA=MOD(K(IREF(1,JT),4),MSTU(5))
- IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
- ENDIF
- ENDIF
- ENDIF
- 140 CONTINUE
-
-C...Set decay vertex for initial resonances
- DO 160 JT=1,JTMAX
- DO 150 I=1,4
- V(IREF(1,JT),I)=0D0
- 150 CONTINUE
- 160 CONTINUE
-
-C...Loop over decay history.
- NP=1
- IP=0
- 170 IP=IP+1
- NINH=0
- JTMAX=2
- IF(IREF(IP,2).EQ.0) JTMAX=1
- IF(IREF(IP,3).NE.0) JTMAX=3
- IT4=0
- NSAV=N
-
-C...Check for Higgs which appears as decay product of user-process.
- IF(ISUB.EQ.0) THEN
- IHDEC=0
- IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
- & .EQ.36) IHDEC=1
- IF(IHDEC.EQ.1) ISUB=3
- ENDIF
-
-C...Start treatment of one, two or three resonances in parallel.
- 180 N=NSAV
- DO 340 JT=1,JTMAX
- ID=IREF(IP,JT)
- KDCY(JT)=0
- KFL1(JT)=0
- KFL2(JT)=0
- KFL3(JT)=0
- KEQL(JT)=0
- NSD(JT)=ID
- ITJUNC(JT)=0
-
-C...Check whether particle can/is allowed to decay.
- IF(ID.EQ.0) GOTO 330
- KFA=IABS(K(ID,2))
- KCA=PYCOMP(KFA)
- IF(MWID(KCA).EQ.0) GOTO 330
- IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
- IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
- & KFA.EQ.18) IT4=IT4+1
- K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
- K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
-
-C...Choose lifetime and determine decay vertex.
- IF(K(ID,1).EQ.5) THEN
- V(ID,5)=0D0
- ELSEIF(K(ID,1).NE.4) THEN
- V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
- ENDIF
- DO 190 J=1,4
- VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
- 190 CONTINUE
-
-C...Determine whether decay allowed or not.
- MOUT=0
- IF(MSTJ(22).EQ.2) THEN
- IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
- ELSEIF(MSTJ(22).EQ.3) THEN
- IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
- ELSEIF(MSTJ(22).EQ.4) THEN
- IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
- IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
- ENDIF
- IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
- K(ID,1)=4
- GOTO 330
- ENDIF
-
-C...Info for selection of decay channel: sign, pairings.
- IF(KCHG(KCA,3).EQ.0) THEN
- IPM=2
- ELSE
- IPM=(5-ISIGN(1,K(ID,2)))/2
- ENDIF
- KFB=0
- IF(JTMAX.EQ.2) THEN
- KFB=IABS(K(IREF(IP,3-JT),2))
- ELSEIF(JTMAX.EQ.3) THEN
- JT2=JT+1-3*(JT/3)
- KFB=IABS(K(IREF(IP,JT2),2))
- IF(KFB.NE.KFA) THEN
- JT2=JT+2-3*((JT+1)/3)
- KFB=IABS(K(IREF(IP,JT2),2))
- ENDIF
- ENDIF
-
-C...Select decay channel.
- IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
- & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
- CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
- WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
- IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
- IF(WDTE0S.LE.0D0) GOTO 330
- RKFL=WDTE0S*PYR(0)
- IDL=0
- 200 IDL=IDL+1
- IDC=IDL+MDCY(KCA,2)-1
- RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
- IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
- IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
-
-C...Read out flavours and colour charges of decay channel chosen.
- KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
- IF(KCQM(JT).EQ.-2) KCQM(JT)=2
- KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
- KFC1A=PYCOMP(IABS(KFL1(JT)))
- IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
- KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
- IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
- KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
- KFC2A=PYCOMP(IABS(KFL2(JT)))
- IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
- KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
- IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
- KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
- KCQ3(JT)=0
- IF(KFL3(JT).NE.0) THEN
- KFC3A=PYCOMP(IABS(KFL3(JT)))
- IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
- KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
- IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
- ENDIF
-
-C...Set/save further info on channel.
- KDCY(JT)=1
- IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
- NSD(JT)=N
- HGZ(JT,1)=VINT(111)
- HGZ(JT,2)=VINT(112)
- HGZ(JT,3)=VINT(114)
- JTZ=JT
-
-C...Select masses; to begin with assume resonances narrow.
- DO 220 I=1,3
- P(N+I,5)=0D0
- PMMN(I)=0D0
- IF(I.EQ.1) THEN
- KFLW=IABS(KFL1(JT))
- KCW=KFC1A
- ELSEIF(I.EQ.2) THEN
- KFLW=IABS(KFL2(JT))
- KCW=KFC2A
- ELSEIF(I.EQ.3) THEN
- IF(KFL3(JT).EQ.0) GOTO 220
- KFLW=IABS(KFL3(JT))
- KCW=KFC3A
- ENDIF
- P(N+I,5)=PMAS(KCW,1)
-CMRENNA++
-C...This prevents SUSY/t particles from becoming too light.
- IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
- PMMN(I)=PMAS(KCW,1)
- DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
- IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
- PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
- & PMAS(PYCOMP(KFDP(IDC,2)),1)
- IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
- & PMAS(PYCOMP(KFDP(IDC,3)),1)
- PMMN(I)=MIN(PMMN(I),PMSUM)
- ENDIF
- 210 CONTINUE
-CMRENNA--
- ELSEIF(KFLW.EQ.6) THEN
- PMMN(I)=PMAS(24,1)+PMAS(5,1)
- ENDIF
- 220 CONTINUE
-
-C...Check which two out of three are widest.
- IWID1=1
- IWID2=2
- PWID1=PMAS(KFC1A,2)
- PWID2=PMAS(KFC2A,2)
- KFLW1=IABS(KFL1(JT))
- KFLW2=IABS(KFL2(JT))
- IF(KFL3(JT).NE.0) THEN
- PWID3=PMAS(KFC3A,2)
- IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
- IWID1=3
- PWID1=PWID3
- KFLW1=IABS(KFL3(JT))
- ELSEIF(PWID3.GT.PWID2) THEN
- IWID2=3
- PWID2=PWID3
- KFLW2=IABS(KFL3(JT))
- ENDIF
- ENDIF
-
-C...If all narrow then only check that masses consistent.
- IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
- & PWID2.LT.PARP(41))) THEN
-CMRENNA++
-C....Handle near degeneracy cases.
- IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
- IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
- P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
- IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
- ENDIF
- ENDIF
-CMRENNA--
- IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
- CALL PYERRM(13,'(PYRESD:) daughter masses too large')
- MINT(51)=1
- GOTO 720
- ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
- CALL PYERRM(3,'(PYRESD:) daughter masses too large')
- MINT(51)=1
- GOTO 720
- ENDIF
-
-C...For three wide resonances select narrower of three
-C...according to BW decoupled from rest.
- ELSE
- PMTOT=P(ID,5)
- IF(KFL3(JT).NE.0) THEN
- IWID3=6-IWID1-IWID2
- KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
- & KFLW1-KFLW2
- LOOP=0
- 230 LOOP=LOOP+1
- P(N+IWID3,5)=PYMASS(KFLW3)
- IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
- PMTOT=PMTOT-P(N+IWID3,5)
- ENDIF
-C...Select other two correlated within remaining phase space.
- IF(IP.EQ.1) THEN
- CKIN45=CKIN(45)
- CKIN47=CKIN(47)
- CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
- CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
- CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
- & P(N+IWID2,5))
- CKIN(45)=CKIN45
- CKIN(47)=CKIN47
- ELSE
- CKIN(49)=PMMN(IWID1)
- CKIN(50)=PMMN(IWID2)
- CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
- & P(N+IWID2,5))
- CKIN(49)=0D0
- CKIN(50)=0D0
- ENDIF
- IF(MINT(51).EQ.1) GOTO 720
- ENDIF
-
-C...Begin fill decay products, with colour flow for coloured objects.
- MSTU10=MSTU(10)
- MSTU(10)=1
- MSTU(19)=1
-
-C...Three-body decays
- IF(KFL3(JT).NE.0) THEN
- DO 250 I=N+1,N+3
- DO 240 J=1,5
- K(I,J)=0
- V(I,J)=0D0
- 240 CONTINUE
- MCT(I,1)=0
- MCT(I,2)=0
- 250 CONTINUE
- K(N+1,1)=1
- K(N+1,2)=KFL1(JT)
- K(N+2,1)=1
- K(N+2,2)=KFL2(JT)
- K(N+3,1)=1
- K(N+3,2)=KFL3(JT)
- IDIN=ID
-
-C...Generate kinematics (default is flat)
- CALL PYTBDY(IDIN)
-
-C...Set generic colour flows whenever unambiguous,
-C...(independently of the order of the decay products)
-C...Sum up total colour content
- NANT=0
- NTRI=0
- NOCT=0
- KCQ(0)=KCQM(JT)
- KCQ(1)=KCQ1(JT)
- KCQ(2)=KCQ2(JT)
- KCQ(3)=KCQ3(JT)
- DO 255 J=0,3
- IF (KCQ(J).EQ.-1) THEN
- NANT=NANT+1
- IANT(NANT)=N+J
- ELSEIF (KCQ(J).EQ.1) THEN
- NTRI=NTRI+1
- ITRI(NTRI)=N+J
- ELSEIF (KCQ(J).EQ.2) THEN
- NOCT=NOCT+1
- IOCT(NOCT)=N+J
- ENDIF
- 255 CONTINUE
-
-C...Set color flow for generic 1 -> N processes (N arbitrary)
- IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
-C...All singlets: do nothing
-
- ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
-C...Two octets, zero triplets, n singlets:
- IF (KCQ(0).EQ.2) THEN
-C...8 -> 8 + n(1)
- K(ID,4)=K(ID,4)+IOCT(2)
- K(ID,5)=K(ID,5)+IOCT(2)
- K(IOCT(2),1)=3
- K(IOCT(2),4)=MSTU(5)*ID
- K(IOCT(2),5)=MSTU(5)*ID
- MCT(IOCT(2),1)=MCT(ID,1)
- MCT(IOCT(2),2)=MCT(ID,2)
- ELSE
-C...1 -> 8 + 8 + n(1)
- K(IOCT(1),1)=3
- K(IOCT(1),4)=MSTU(5)*IOCT(2)
- K(IOCT(1),5)=MSTU(5)*IOCT(2)
- K(IOCT(2),1)=3
- K(IOCT(2),4)=MSTU(5)*IOCT(1)
- K(IOCT(2),5)=MSTU(5)*IOCT(1)
- NCT=NCT+1
- MCT(IOCT(1),1)=NCT
- MCT(IOCT(2),2)=NCT
- NCT=NCT+1
- MCT(IOCT(2),1)=NCT
- MCT(IOCT(1),2)=NCT
- ENDIF
-
- ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
-C...Two triplets, zero octets, n singlets.
- IF (KCQ(0).EQ.1) THEN
-C...3 -> 3 + n(1)
- K(ID,4)=K(ID,4)+ITRI(2)
- K(ITRI(2),1)=3
- K(ITRI(2),4)=MSTU(5)*ID
- MCT(ITRI(2),1)=MCT(ID,1)
- ELSEIF (KCQ(0).EQ.-1) THEN
-C...3bar -> 3bar + n(1)
- K(ID,5)=K(ID,5)+IANT(2)
- K(IANT(2),1)=3
- K(IANT(2),5)=MSTU(5)*ID
- MCT(IANT(2),2)=MCT(ID,2)
- ELSE
-C...1 -> 3 + 3bar + n(1)
- K(ITRI(1),1)=3
- K(ITRI(1),4)=MSTU(5)*IANT(1)
- K(IANT(1),1)=3
- K(IANT(1),5)=MSTU(5)*ITRI(1)
- NCT=NCT+1
- MCT(ITRI(1),1)=NCT
- MCT(IANT(1),2)=NCT
- ENDIF
-
- ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
-C...Two triplets, one octet, n singlets.
- IF (KCQ(0).EQ.2) THEN
-C...8 -> 3 + 3bar + n(1)
- K(ID,4)=K(ID,4)+ITRI(1)
- K(ID,5)=K(ID,5)+IANT(1)
- K(ITRI(1),1)=3
- K(ITRI(1),4)=MSTU(5)*ID
- K(IANT(1),1)=3
- K(IANT(1),5)=MSTU(5)*ID
- MCT(ITRI(1),1)=MCT(ID,1)
- MCT(IANT(1),2)=MCT(ID,2)
- ELSEIF (KCQ(0).EQ.1) THEN
-C...3 -> 8 + 3 + n(1)
- K(ID,4)=K(ID,4)+IOCT(1)
- K(IOCT(1),1)=3
- K(IOCT(1),4)=MSTU(5)*ID
- K(IOCT(1),5)=MSTU(5)*ITRI(2)
- K(ITRI(2),1)=3
- K(ITRI(2),4)=MSTU(5)*IOCT(1)
- MCT(IOCT(1),1)=MCT(ID,1)
- NCT=NCT+1
- MCT(IOCT(1),2)=NCT
- MCT(ITRI(2),1)=NCT
- ELSEIF (KCQ(0).EQ.-1) THEN
-C...3bar -> 8 + 3bar + n(1)
- K(ID,5)=K(ID,5)+IOCT(1)
- K(IOCT(1),1)=3
- K(IOCT(1),5)=MSTU(5)*ID
- K(IOCT(1),4)=MSTU(5)*IANT(2)
- K(IANT(2),1)=3
- K(IANT(2),5)=MSTU(5)*IOCT(1)
- MCT(IOCT(1),2)=MCT(ID,2)
- NCT=NCT+1
- MCT(IOCT(1),1)=NCT
- MCT(IANT(2),2)=NCT
- ELSE
-C...1 -> 3 + 3bar + 8 + n(1)
- K(ITRI(1),1)=3
- K(ITRI(1),4)=MSTU(5)*IOCT(1)
- K(IOCT(1),1)=3
- K(IOCT(1),5)=MSTU(5)*ITRI(1)
- K(IOCT(1),4)=MSTU(5)*IANT(1)
- K(IANT(1),1)=3
- K(IANT(1),5)=MSTU(5)*IOCT(1)
- NCT=NCT+1
- MCT(ITRI(1),1)=NCT
- MCT(IOCT(1),2)=NCT
- NCT=NCT+1
- MCT(IOCT(1),1)=NCT
- MCT(IANT(1),2)=NCT
- ENDIF
-CPS-- End of generic cases
-C...(could three octets also be handled?)
-C...(could (some of) the RPV cases be made generic as well?)
-
-C...Special cases (= old treatment)
-C...Set colour flow for t -> W + b + Z.
- ELSEIF(KFA.EQ.6) THEN
- K(N+2,1)=3
- ISID=4
- IF(KCQM(JT).EQ.-1) ISID=5
- IDAU=N+2
- K(ID,ISID)=K(ID,ISID)+IDAU
- K(IDAU,ISID)=MSTU(5)*ID
-
-C...Set colour flow in three-body decays - programmed as special cases.
-
- ELSEIF(KFC2A.LE.6) THEN
- K(N+2,1)=3
- K(N+3,1)=3
- ISID=4
- IF(KFL2(JT).LT.0) ISID=5
- K(N+2,ISID)=MSTU(5)*(N+3)
- K(N+3,9-ISID)=MSTU(5)*(N+2)
-C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
- ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
- & .AND.KFL3(JT).NE.0) THEN
- KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
-C...3-body decays of squarks to colour singlets plus one quark
- IF (KQSUMA.EQ.1) THEN
-C...Find quark
- IQ=0
- IF (KCQ1(JT).NE.0) IQ=1
- IF (KCQ2(JT).NE.0) IQ=2
- IF (KCQ3(JT).NE.0) IQ=3
- ISID=4
- IF (K(N+IQ,2).LT.0) ISID=5
- K(N+IQ,1)=3
- K(ID,ISID)=K(ID,ISID)+(N+IQ)
- K(N+IQ,ISID)=MSTU(5)*ID
- ENDIF
-C...PS--
- ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
- K(N+1,1)=3
- K(N+2,1)=3
- K(N+3,1)=3
- ISID=4
- IF(KFL2(JT).LT.0) ISID=5
- K(N+1,ISID)=MSTU(5)*(N+2)
- K(N+1,9-ISID)=MSTU(5)*(N+3)
- K(N+2,ISID)=MSTU(5)*(N+1)
- K(N+3,9-ISID)=MSTU(5)*(N+1)
- ELSEIF(KFA.EQ.KSUSY1+21) THEN
- K(N+2,1)=3
- K(N+3,1)=3
- ISID=4
- IF(KFL2(JT).LT.0) ISID=5
- K(ID,ISID)=K(ID,ISID)+(N+2)
- K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
- K(N+2,ISID)=MSTU(5)*ID
- K(N+3,9-ISID)=MSTU(5)*ID
-CMRENNA--
-
- ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
- & IABS(KCQ2(JT)).EQ.1) THEN
- K(N+2,1)=3
- K(N+3,1)=3
- ISID=4
- IF(KFL2(JT).LT.0) ISID=5
- K(N+2,ISID)=MSTU(5)*(N+3)
- K(N+3,9-ISID)=MSTU(5)*(N+2)
- ENDIF
-
- NSAV=N
-
-C...Set colour flow in three-body decays with baryon number violation.
-C...Neutralino and chargino decays first.
- KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
- IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
- ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
- K(N+4,4)=ITJUNC(JT)*MSTU(5)
-C...Insert junction to keep track of colours.
- IF(KCQ1(JT).NE.0) K(N+1,1)=3
- IF(KCQ2(JT).NE.0) K(N+2,1)=3
- IF(KCQ3(JT).NE.0) K(N+3,1)=3
-C...Set special junction codes:
- K(N+4,1)=42
- K(N+4,2)=88
-
-C...Order decay products by invariant mass. (will be used in PYSTRF).
- PM12=P(N+1,4)*P(N+2,4)-P(N+1,1)*P(N+2,1)-P(N+1,2)*P(N+2,2)-
- & P(N+1,3)*P(N+2,3)
- PM13=P(N+1,4)*P(N+3,4)-P(N+1,1)*P(N+3,1)-P(N+1,2)*P(N+3,2)-
- & P(N+1,3)*P(N+3,3)
- PM23=P(N+2,4)*P(N+3,4)-P(N+2,1)*P(N+3,1)-P(N+2,2)*P(N+3,2)-
- & P(N+2,3)*P(N+3,3)
- IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
- K(N+4,4)=N+3+K(N+4,4)
- K(N+4,5)=N+1+MSTU(5)*(N+2)
- ELSEIF(PM13.LT.PM23) THEN
- K(N+4,4)=N+2+K(N+4,4)
- K(N+4,5)=N+1+MSTU(5)*(N+3)
- ELSE
- K(N+4,4)=N+1+K(N+4,4)
- K(N+4,5)=N+2+MSTU(5)*(N+3)
- ENDIF
- DO 260 J=1,5
- P(N+4,J)=0D0
- V(N+4,J)=0D0
- 260 CONTINUE
-C...Connect daughters to junction.
- DO 270 II=N+1,N+3
- K(II,4)=0
- K(II,5)=0
- K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
- 270 CONTINUE
-C...Particle counter should be stepped up one extra for junction.
- N=N+1
-
-C...Gluino decays.
- ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
- ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
- K(N+4,4)=ITJUNC(JT)*MSTU(5)
-C...Insert junction to keep track of colours.
- IF(KCQ1(JT).NE.0) K(N+1,1)=3
- IF(KCQ2(JT).NE.0) K(N+2,1)=3
- IF(KCQ3(JT).NE.0) K(N+3,1)=3
- K(N+4,1)=42
- K(N+4,2)=88
- DO 280 J=1,5
- P(N+4,J)=0D0
- V(N+4,J)=0D0
- 280 CONTINUE
- CTMSUM=0D0
- DO 290 II=N+1,N+3
- K(II,4)=0
- K(II,5)=0
-C...Start by connecting all daughters to junction.
- K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
-C...Only consider colour topologies with off shell resonances.
- RMQ1=PMAS(PYCOMP(K(II,2)),1)
- RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
- RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
- IF (RMGLU-RMQ1.LT.RMRES) THEN
-C...Calculate propagators for each colour topology.
- RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
- & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
- CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
- ELSE
- CTM2(II-N)=0D0
- ENDIF
- CTMSUM=CTMSUM+CTM2(II-N)
- 290 CONTINUE
- CTMSUM=PYR(0)*CTMSUM
-C...Select colour topology J, with most off shell least likely.
- J=0
- 300 J=J+1
- CTMSUM=CTMSUM-CTM2(J)
- IF (CTMSUM.GT.0D0) GOTO 300
-C...The lucky winner gets its colour (anti-colour) directly from gluino.
- K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
- K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
-C...The other gluino colour is connected to junction
- K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
- & MSTU(5)
- K(N+4,4)=K(N+4,4)+ID
-C...Lastly, connect junction to remaining daughters.
- K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
-C...Particle counter should be stepped up one extra for junction.
- N=N+1
- ENDIF
-
-C...Update particle counter.
- N=N+3
-
-C...2) Everything else two-body decay.
- ELSE
- CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
- MCT(N-1,1)=0
- MCT(N-1,2)=0
- MCT(N,1)=0
- MCT(N,2)=0
-C...First set colour flow as if mother colour singlet.
- IF(KCQ1(JT).NE.0) THEN
- K(N-1,1)=3
- IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
- IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
- ENDIF
- IF(KCQ2(JT).NE.0) THEN
- K(N,1)=3
- IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
- IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
- ENDIF
-C...Then redirect colour flow if mother (anti)triplet.
- IF(KCQM(JT).EQ.0) THEN
- ELSEIF(KCQM(JT).NE.2) THEN
- ISID=4
- IF(KCQM(JT).EQ.-1) ISID=5
- IDAU=N-1
- IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
- K(ID,ISID)=K(ID,ISID)+IDAU
- K(IDAU,ISID)=MSTU(5)*ID
-C...Then redirect colour flow if mother octet.
- ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
- IDAU=N-1
- IF(KCQ1(JT).EQ.0) IDAU=N
- K(ID,4)=K(ID,4)+IDAU
- K(ID,5)=K(ID,5)+IDAU
- K(IDAU,4)=MSTU(5)*ID
- K(IDAU,5)=MSTU(5)*ID
- ELSE
- ISID=4
- IF(KCQ1(JT).EQ.-1) ISID=5
- IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
- K(ID,ISID)=K(ID,ISID)+(N-1)
- K(ID,9-ISID)=K(ID,9-ISID)+N
- K(N-1,ISID)=MSTU(5)*ID
- K(N,9-ISID)=MSTU(5)*ID
- ENDIF
-
-C...Insert junction
- IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
- N=N+1
-C...~q* mother: type 3 junction. ~q mother: type 4.
- ITJUNC(JT)=(7+KCQM(JT))/2
-C...Specify junction KF and set colour flow from junction
- K(N,1)=42
- K(N,2)=88
- K(N,3)=ID
-C...Junction type encoded together with mother:
- K(N,4)=ID+ITJUNC(JT)*MSTU(5)
- K(N,5)=N-1+MSTU(5)*(N-2)
-C...Zero P and V for junction (V filled later)
- DO 310 J=1,5
- P(N,J)=0D0
- V(N,J)=0D0
- 310 CONTINUE
-C...Set colour flow from mother to junction
- K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
-C...Set colour flow from daughters to junction
- DO 320 II=N-2,N-1
- K(II,4) = 0
- K(II,5) = 0
-C...(Anti-)colour mother is junction.
- K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
- 320 CONTINUE
- ENDIF
- ENDIF
-
-C...End loop over resonances for daughter flavour and mass selection.
- MSTU(10)=MSTU10
- 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
- & NINH=NINH+1
- IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
- & KFL1(JT).EQ.0) THEN
- WRITE(CODE,'(I9)') K(ID,2)
- WRITE(MASS,'(F9.3)') P(ID,5)
- CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
- & CODE//' with mass'//MASS)
- MINT(51)=1
- GOTO 720
- ENDIF
- 340 CONTINUE
-
-C...Check for allowed combinations. Skip if no decays.
- IF(JTMAX.EQ.1) THEN
- IF(KDCY(1).EQ.0) GOTO 710
- ELSEIF(JTMAX.EQ.2) THEN
- IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
- IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
- IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
- ELSEIF(JTMAX.EQ.3) THEN
- IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
- IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
- IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
- IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
- IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
- IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
- IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
- ENDIF
-
-C...Special case: matrix element option for Z0 decay to quarks.
- IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
- &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
-
-C...Check consistency of MSTJ options set.
- IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
- CALL PYERRM(6,
- & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
- MSTJ(110)=1
- ENDIF
- IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
- CALL PYERRM(6,
- & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
-
- MSTJ(111)=0
- ENDIF
-
-C...Select alpha_strong behaviour.
- MST111=MSTU(111)
- PAR112=PARU(112)
- MSTU(111)=MSTJ(108)
- IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
- & MSTU(111)=1
- PARU(112)=PARJ(121)
- IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
-
-C...Find axial fraction in total cross section for scalar gluon model.
- PARJ(171)=0D0
- IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
- & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
- POLL=1D0-PARJ(131)*PARJ(132)
- SFF=1D0/(16D0*XW*XW1)
- SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
- & (PARJ(123)*PARJ(124))**2)
- SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
- VE=4D0*XW-1D0
- HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
- HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
- & (PARJ(132)-PARJ(131)))
- KFLC=IABS(KFL1(1))
- PMQ=PYMASS(KFLC)
- QF=KCHG(KFLC,1)/3D0
- VQ=1D0
- IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
- & 1D0-(2D0*PMQ/P(ID,5))**2))
- VF=SIGN(1D0,QF)-4D0*QF*XW
- RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
- & VF**2*HF1W)+VQ**3*HF1W
- IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
- ENDIF
-
-C...Choice of jet configuration.
- CALL PYXJET(P(ID,5),NJET,CUT)
- KFLC=IABS(KFL1(1))
- KFLN=21
- IF(NJET.EQ.4) THEN
- CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
- ELSEIF(NJET.EQ.3) THEN
- CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
- ELSE
- MSTJ(120)=1
- ENDIF
-
-C...Fill jet configuration; return if incorrect kinematics.
- NC=N-2
- IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
- CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
- ELSEIF(NJET.EQ.2) THEN
- CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
- ELSEIF(NJET.EQ.3) THEN
- CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
- ELSEIF(KFLN.EQ.21) THEN
- CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
- & X12,X14)
- ELSE
- CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
- & X12,X14)
- ENDIF
- IF(MSTU(24).NE.0) THEN
- MINT(51)=1
- MSTU(111)=MST111
- PARU(112)=PAR112
- GOTO 720
- ENDIF
-
-C...Angular orientation according to matrix element.
- IF(MSTJ(106).EQ.1) THEN
- CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
- IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
- CTHE(1)=COS(THEZ)
- CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
- CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
- ENDIF
-
-C...Boost partons to Z0 rest frame.
- CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
- & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
-
-C...Mark decayed resonance and add documentation lines,
- K(ID,1)=K(ID,1)+10
- IDOC=MINT(83)+MINT(4)
- DO 360 I=NC+1,N
- I1=MINT(83)+MINT(4)+1
- K(I,3)=I1
- IF(MSTP(128).GE.1) K(I,3)=ID
- IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
- MINT(4)=MINT(4)+1
- K(I1,1)=21
- K(I1,2)=K(I,2)
- K(I1,3)=IREF(IP,4)
- DO 350 J=1,5
- P(I1,J)=P(I,J)
- 350 CONTINUE
- ENDIF
- 360 CONTINUE
-
-C...Generate parton shower.
- IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
- if(parj(200).ne.1.) CALL PYSHOW(N-1,N,P(ID,5))
- if(parj(200).eq.1.) CALL PYSHOWQ(N-1,N,P(ID,5))
- ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
- NPART=2
- IPART(1)=N-1
- IPART(2)=N
- PTPART(1)=0.5D0*P(ID,5)
- PTPART(2)=PTPART(1)
- NCT=NCT+1
- IF(K(N-1,2).GT.0) THEN
- MCT(N-1,1)=NCT
- MCT(N,2)=NCT
- ELSE
- MCT(N-1,2)=NCT
- MCT(N,1)=NCT
- ENDIF
- CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
- ENDIF
-
-C... End special case for Z0: skip ahead.
- MSTU(111)=MST111
- PARU(112)=PAR112
- GOTO 700
- ENDIF
-
-C...Order incoming partons and outgoing resonances.
- IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
- &NINH.EQ.0) THEN
- ILIN(1)=MINT(84)+1
- IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
- IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
- & ILIN(1)=2*MINT(84)+3-ILIN(1)
- ILIN(2)=2*MINT(84)+3-ILIN(1)
- IMIN=1
- IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
- & .EQ.36) IMIN=3
- IMAX=2
- IORD=1
- IF(K(IREF(IP,1),2).EQ.23) IORD=2
- IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
- IAKIPD=IABS(K(IREF(IP,IORD),2))
- IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
- IF(KDCY(IORD).EQ.0) IORD=3-IORD
-
-C...Order decay products of resonances.
- DO 370 JT=IORD,3-IORD,3-2*IORD
- IF(KDCY(JT).EQ.0) THEN
- ILIN(IMAX+1)=NSD(JT)
- IMAX=IMAX+1
- ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
- ILIN(IMAX+1)=N+2*JT-1
- ILIN(IMAX+2)=N+2*JT
- IMAX=IMAX+2
- K(N+2*JT-1,2)=K(NSD(JT)+1,2)
- K(N+2*JT,2)=K(NSD(JT)+2,2)
- ELSE
- ILIN(IMAX+1)=N+2*JT
-
- ILIN(IMAX+2)=N+2*JT-1
- IMAX=IMAX+2
- K(N+2*JT-1,2)=K(NSD(JT)+1,2)
- K(N+2*JT,2)=K(NSD(JT)+2,2)
- ENDIF
- 370 CONTINUE
-
-C...Find charge, isospin, left- and righthanded couplings.
- DO 390 I=IMIN,IMAX
- DO 380 J=1,4
- COUP(I,J)=0D0
- 380 CONTINUE
- KFA=IABS(K(ILIN(I),2))
- IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
- COUP(I,1)=KCHG(KFA,1)/3D0
- COUP(I,2)=(-1)**MOD(KFA,2)
- COUP(I,4)=-2D0*COUP(I,1)*XWV
- COUP(I,3)=COUP(I,2)+COUP(I,4)
- 390 CONTINUE
-
-C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
- IF(ISUB.EQ.22) THEN
- DO 420 I=3,5,2
- I1=IORD
- IF(I.EQ.5) I1=3-IORD
- DO 410 J1=1,2
- DO 400 J2=1,2
- CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
- & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
- & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
- & COUP(I,J2+2)**2
- 400 CONTINUE
- 410 CONTINUE
- 420 CONTINUE
- COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
- & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
- COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
- & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
-
- IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
- ENDIF
- ENDIF
-
-C...Select angular orientation type - Z'/W' only.
- MZPWP=0
- IF(ISUB.EQ.141) THEN
- IF(PYR(0).LT.PARU(130)) MZPWP=1
- IF(IP.EQ.2) THEN
- IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
- IAKIR=IABS(K(IREF(2,2),2))
- IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
- IF(IAKIR.LE.20) MZPWP=2
- ENDIF
- IF(IP.GE.3) MZPWP=2
- ELSEIF(ISUB.EQ.142) THEN
- IF(PYR(0).LT.PARU(136)) MZPWP=1
- IF(IP.EQ.2) THEN
- IAKIR=IABS(K(IREF(2,2),2))
- IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
- IF(IAKIR.LE.20) MZPWP=2
- ENDIF
- IF(IP.GE.3) MZPWP=2
- ENDIF
-
-C...Select random angles (begin of weighting procedure).
- 430 DO 440 JT=1,JTMAX
- IF(KDCY(JT).EQ.0) GOTO 440
- IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
- CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
- IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
- PHI(JT)=VINT(24)
- ELSE
- CTHE(JT)=2D0*PYR(0)-1D0
- PHI(JT)=PARU(2)*PYR(0)
- ENDIF
- 440 CONTINUE
-
- IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
-C...Construct massless four-vectors.
- DO 460 I=N+1,N+4
- K(I,1)=1
- DO 450 J=1,5
- P(I,J)=0D0
- V(I,J)=0D0
- 450 CONTINUE
- 460 CONTINUE
- DO 470 JT=1,JTMAX
- IF(KDCY(JT).EQ.0) GOTO 470
- ID=IREF(IP,JT)
- P(N+2*JT-1,3)=0.5D0*P(ID,5)
- P(N+2*JT-1,4)=0.5D0*P(ID,5)
- P(N+2*JT,3)=-0.5D0*P(ID,5)
- P(N+2*JT,4)=0.5D0*P(ID,5)
- CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
- & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
- 470 CONTINUE
-
-C...Store incoming and outgoing momenta, with random rotation to
-C...avoid accidental zeroes in HA expressions.
- IF(ISUB.NE.0) THEN
- DO 490 I=IMIN,IMAX
- K(N+4+I,1)=1
- P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
- & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
- P(N+4+I,5)=P(ILIN(I),5)
- DO 480 J=1,3
- P(N+4+I,J)=P(ILIN(I),J)
- 480 CONTINUE
- 490 CONTINUE
- 500 THERR=ACOS(2D0*PYR(0)-1D0)
- PHIRR=PARU(2)*PYR(0)
- CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
- DO 520 I=IMIN,IMAX
- IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
- & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
- DO 510 J=1,4
- PK(I,J)=P(N+4+I,J)
- 510 CONTINUE
- 520 CONTINUE
- ENDIF
-
-C...Calculate internal products.
- IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
- & ISUB.EQ.142) THEN
- DO 540 I1=IMIN,IMAX-1
- DO 530 I2=I1+1,IMAX
- HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
- & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
- & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
- & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
- & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
- & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
- HC(I1,I2)=CONJG(HA(I1,I2))
- IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
- IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
- HA(I2,I1)=-HA(I1,I2)
- HC(I2,I1)=-HC(I1,I2)
- 530 CONTINUE
- 540 CONTINUE
- ENDIF
-
-C...Calculate four-products.
- IF(ISUB.NE.0) THEN
- DO 560 I=1,2
- DO 550 J=1,4
- PK(I,J)=-PK(I,J)
- 550 CONTINUE
- 560 CONTINUE
- DO 580 I1=IMIN,IMAX-1
- DO 570 I2=I1+1,IMAX
- PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
- & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
- PKK(I2,I1)=PKK(I1,I2)
- 570 CONTINUE
- 580 CONTINUE
- ENDIF
- ENDIF
-
- KFAGM=IABS(IREF(IP,7))
- IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
-C...Isotropic decay selected by user.
- WT=1D0
- WTMAX=1D0
-
- ELSEIF(JTMAX.EQ.3) THEN
-C...Isotropic decay when three mother particles.
- WT=1D0
- WTMAX=1D0
-
- ELSEIF(IT4.GE.1) THEN
-C... Isotropic decay t -> b + W etc for 4th generation q and l.
- WT=1D0
- WTMAX=1D0
-
- ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
- & IREF(IP,7).EQ.36) THEN
-C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
-C...CP-odd case added by Kari Ertresvag Myklevoll.
-C...Now also with mixed Higgs CP-states
- ETA=PARP(25)
- IF(IP.EQ.1) WTMAX=SH**2
- IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
- KFA=IABS(K(IREF(IP,1),2))
- KFT=IABS(K(IREF(IP,2),2))
-
- IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
- & MSTP(25).GE.3) THEN
-C...For mixed CP states need epsilon product.
- P10=PK(3,4)
- P20=PK(4,4)
- P30=PK(5,4)
- P40=PK(6,4)
- P11=PK(3,1)
- P21=PK(4,1)
- P31=PK(5,1)
- P41=PK(6,1)
- P12=PK(3,2)
- P22=PK(4,2)
- P32=PK(5,2)
- P42=PK(6,2)
- P13=PK(3,3)
- P23=PK(4,3)
- P33=PK(5,3)
- P43=PK(6,3)
- EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
- & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
- & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
- & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
- & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
- & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
- & P22*P30*P41+P13*P22*P31*P40
-C...For mixed CP states need gauge boson masses.
- XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
- & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
- XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
- & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
- XMV=PMAS(KFA,1)
- ENDIF
-
-C...Z decay
- IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
- KFLF1A=IABS(KFL1(1))
- EF1=KCHG(KFLF1A,1)/3D0
- AF1=SIGN(1D0,EF1+0.1D0)
- VF1=AF1-4D0*EF1*XWV
- KFLF2A=IABS(KFL1(2))
- EF2=KCHG(KFLF2A,1)/3D0
- AF2=SIGN(1D0,EF2+0.1D0)
- VF2=AF2-4D0*EF2*XWV
- VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
- IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
- & THEN
-C...CP-even decay
- WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
- & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
- ELSEIF(MSTP(25).LE.2) THEN
-C...CP-odd decay
- WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
- & -2*PKK(3,4)*PKK(5,6)
- & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
- & (PKK(3,4)*PKK(5,6))
- & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
- & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
- ELSE
-C...Mixed CP states.
- WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
- & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
- & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
- & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
- & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
- & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
- & +PKK(3,4)*PKK(5,6)
- & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
- & +VA12AS*PKK(3,4)*PKK(5,6)
- & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
- & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
- & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
- & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
- ENDIF
-
-C...W decay
- ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
- IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
- & THEN
-C...CP-even decay
- WT=16D0*PKK(3,5)*PKK(4,6)
- ELSEIF(MSTP(25).LE.2) THEN
-C...CP-odd decay
- WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
- & -2*PKK(3,4)*PKK(5,6)
- & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
- & (PKK(3,4)*PKK(5,6))
- & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
- & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
- ELSE
-C...Mixed CP states.
- WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
- & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
- & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
- & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
- & +PKK(3,4)*PKK(5,6)
- & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
- & +PKK(3,4)*PKK(5,6)
- & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
- & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
- & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
- & +(2D0*ETA*XMA*XMB/XMV**2)**2)
- ENDIF
-
-C...No angular correlations in other Higgs decays.
- ELSE
- WT=WTMAX
- ENDIF
-
- ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
- & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
- & THEN
-C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
- I1=IREF(IP,8)
- IF(MOD(KFAGM,2).EQ.0) THEN
- I2=N+1
- I3=N+2
- ELSE
- I2=N+2
- I3=N+1
- ENDIF
- I4=IREF(IP,2)
- WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
- & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
- & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
- WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
-
- ELSEIF(ISUB.EQ.1) THEN
-C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
- EI=KCHG(IABS(MINT(15)),1)/3D0
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*XWV
- EF=KCHG(IABS(KFL1(1)),1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
-
- VF=AF-4D0*EF*XWV
- RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
- WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
- & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
- WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
- & (VI**2+AI**2)*VINT(114)*VF**2)
- WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
- & 4D0*VI*AI*VINT(114)*VF*AF)
- WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
- & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
- WTMAX=2D0*(WT1+ABS(WT3))
-
- ELSEIF(ISUB.EQ.2) THEN
-C...Angular weight for W+/- -> 2 quarks/leptons.
- RM3=PMAS(IABS(KFL1(1)),1)**2/SH
- RM4=PMAS(IABS(KFL2(1)),1)**2/SH
- BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
- WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
- WTMAX=4D0
-
- ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
-C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
-C...-> gluon/gamma + 2 quarks/leptons.
- CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
- & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
- & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
- CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
- & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
- & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
- CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
- & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
- & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
- CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
- & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
- & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
- WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
- & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
- WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
- & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
-
- ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
-C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
-C...-> gluon/gamma + 2 quarks/leptons.
- WT=PKK(1,3)**2+PKK(2,4)**2
- WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
-
- ELSEIF(ISUB.EQ.22) THEN
-C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
- S34=P(IREF(IP,IORD),5)**2
- S56=P(IREF(IP,3-IORD),5)**2
- TI=PKK(1,3)+PKK(1,4)+S34
- UI=PKK(1,5)+PKK(1,6)+S56
- TIR=REAL(TI)
- UIR=REAL(UI)
- FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
- FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
- FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
- FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
- FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
- FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
- FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
- FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
-
- WT=
- & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
- & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
- & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
- & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
- WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
- & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
- & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
- & 1D0/UI**2))
-
- ELSEIF(ISUB.EQ.23) THEN
-C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
- D34=P(IREF(IP,IORD),5)**2
- D56=P(IREF(IP,3-IORD),5)**2
- DT=PKK(1,3)+PKK(1,4)+D34
- DU=PKK(1,5)+PKK(1,6)+D56
- FACBW=1D0/((SH-SQMW)**2+GMMW**2)
- CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
- CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
- FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
-
- & REAL(CBWZ)*FGK(1,2,5,6,3,4))
- FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
- & REAL(CBWZ)*FGK(1,2,6,5,3,4))
- WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
- WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
- & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
-
- ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
-C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
-C...(or H0, or A0).
- WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
- & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
- & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
- WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
- & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
-
- ELSEIF(ISUB.EQ.25) THEN
-C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
- POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
- POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
- D34=P(IREF(IP,IORD),5)**2
- D56=P(IREF(IP,3-IORD),5)**2
- DT=PKK(1,3)+PKK(1,4)+D34
- DU=PKK(1,5)+PKK(1,6)+D56
- FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
- CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
- CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
- CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
- CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
- FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
- & REAL(CBWW)*FGK(1,2,5,6,3,4))
- FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
- IF(MSTP(50).LE.0) THEN
- WT=FGK135**2+(CCWW*FGK253)**2
- WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
- & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
- & DJGK(DT,DU)))
- ELSE
- WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
- WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
- & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
- & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
- ENDIF
-
- ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
-C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
-C...(or H0, or A0).
- WT=PKK(1,3)*PKK(2,4)
- WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
-
- ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
-C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
-C...-> f + 2 quarks/leptons.
- CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
- & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
- & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
- CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
- & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
- & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
- CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
- & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
- & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
- CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
- & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
- & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
- IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
- & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
- IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
- & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
- WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
- & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
-
- ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
-C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
- IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
- IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
- WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
-
- ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
- & ISUB.EQ.77) THEN
-C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
- WT=16D0*PKK(3,5)*PKK(4,6)
- WTMAX=SH**2
-
- ELSEIF(ISUB.EQ.110) THEN
-C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
- WT=1D0
- WTMAX=1D0
-
- ELSEIF(ISUB.EQ.141) THEN
- IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
-C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
-C...Couplings of incoming flavour.
- KFAI=IABS(MINT(15))
- EI=KCHG(KFAI,1)/3D0
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*XWV
- KFAIC=1
- IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
- IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
- IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
- IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
- VPI=PARU(119+2*KFAIC)
- API=PARU(120+2*KFAIC)
- ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
- VPI=PARJ(178+2*KFAIC)
- API=PARJ(179+2*KFAIC)
- ELSE
- VPI=PARJ(186+2*KFAIC)
- API=PARJ(187+2*KFAIC)
- ENDIF
-C...Couplings of final flavour.
- KFAF=IABS(KFL1(1))
- EF=KCHG(KFAF,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- KFAFC=1
- IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
- IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
- IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
- IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
- VPF=PARU(119+2*KFAFC)
- APF=PARU(120+2*KFAFC)
- ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
- VPF=PARJ(178+2*KFAFC)
- APF=PARJ(179+2*KFAFC)
- ELSE
- VPF=PARJ(186+2*KFAFC)
- APF=PARJ(187+2*KFAFC)
- ENDIF
-C...Asymmetry and weight.
- ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
- & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
- & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
- & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
- & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
- & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
- & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
- WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
- WTMAX=2D0+ABS(ASYM)
- ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
-C...Angular weight for f + fbar -> Z' -> W+ + W-.
- RM1=P(NSD(1)+1,5)**2/SH
- RM2=P(NSD(1)+2,5)**2/SH
- CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
- & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
- CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
- & (RM2-RM1)**2)
- WT=CFLAT+CCOS2*CTHE(1)**2
- WTMAX=CFLAT+MAX(0D0,CCOS2)
- ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
- & IABS(KFL1(1)).EQ.37)) THEN
-C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
- WT=1D0-CTHE(1)**2
- WTMAX=1D0
- ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
-C...Angular weight for f + fbar -> Z' -> Z0 + h0.
- RM1=P(NSD(1)+1,5)**2/SH
- RM2=P(NSD(1)+2,5)**2/SH
- FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
- WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
- WTMAX=1D0+FLAM2/(8D0*RM1)
- ELSEIF(MZPWP.EQ.0) THEN
-C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
-C...(W:s like if intermediate Z).
- D34=P(IREF(IP,IORD),5)**2
- D56=P(IREF(IP,3-IORD),5)**2
- DT=PKK(1,3)+PKK(1,4)+D34
- DU=PKK(1,5)+PKK(1,6)+D56
- FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
- FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
- WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
- WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
- & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
- ELSEIF(MZPWP.EQ.1) THEN
-C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
-C...(W:s approximately longitudinal, like if intermediate H).
- WT=16D0*PKK(3,5)*PKK(4,6)
- WTMAX=SH**2
- ELSE
-C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
-C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
- WT=1D0
- WTMAX=1D0
- ENDIF
-
- ELSEIF(ISUB.EQ.142) THEN
- IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
-C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
- KFAI=IABS(MINT(15))
- KFAIC=1
- IF(KFAI.GT.10) KFAIC=2
- VI=PARU(129+2*KFAIC)
- AI=PARU(130+2*KFAIC)
- KFAF=IABS(KFL1(1))
- KFAFC=1
- IF(KFAF.GT.10) KFAFC=2
- VF=PARU(129+2*KFAFC)
- AF=PARU(130+2*KFAFC)
- ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
- WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
- WTMAX=2D0+ABS(ASYM)
- ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
-C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
- RM1=P(NSD(1)+1,5)**2/SH
- RM2=P(NSD(1)+2,5)**2/SH
- CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
- & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
- CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
- & (RM2-RM1)**2)
- WT=CFLAT+CCOS2*CTHE(1)**2
- WTMAX=CFLAT+MAX(0D0,CCOS2)
- ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
-C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
- RM1=P(NSD(1)+1,5)**2/SH
- RM2=P(NSD(1)+2,5)**2/SH
- FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
- WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
- WTMAX=1D0+FLAM2/(8D0*RM1)
- ELSEIF(MZPWP.EQ.0) THEN
-C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
-C...(W/Z like if intermediate W).
- D34=P(IREF(IP,IORD),5)**2
- D56=P(IREF(IP,3-IORD),5)**2
- DT=PKK(1,3)+PKK(1,4)+D34
- DU=PKK(1,5)+PKK(1,6)+D56
- FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
- FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
- WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
- WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
- & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
- ELSEIF(MZPWP.EQ.1) THEN
-C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
-C...(W/Z approximately longitudinal, like if intermediate H).
- WT=16D0*PKK(3,5)*PKK(4,6)
- WTMAX=SH**2
- ELSE
-C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
-C...t + bbar -> t + W + bbar.
- WT=1D0
- WTMAX=1D0
- ENDIF
-
- ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
- & THEN
-C...Isotropic decay of leptoquarks (assumed spin 0).
- WT=1D0
- WTMAX=1D0
-
- ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
-C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
- SIDE=1D0
- IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
- IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
- WT=1D0+SIDE*CTHE(1)
- WTMAX=2D0
- ELSEIF(IP.EQ.1) THEN
-
- RM1=P(NSD(1)+1,5)**2/SH
- WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
- WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
- ELSE
-C...W/Z decay assumed isotropic, since not known.
- WT=1D0
- WTMAX=1D0
- ENDIF
-
- ELSEIF(ISUB.EQ.149) THEN
-C...Isotropic decay of techni-eta.
- WT=1D0
- WTMAX=1D0
-
- ELSEIF(ISUB.EQ.191) THEN
- IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
-C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
-C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
- WT=1D0-CTHE(1)**2
- WTMAX=1D0
- ELSEIF(IP.EQ.1) THEN
-C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
- CTHESG=CTHE(1)*ISIGN(1,MINT(15))
- XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
- BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
- BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
- KFAI=IABS(MINT(15))
- EI=KCHG(KFAI,1)/3D0
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*XWV
- VALI=0.5D0*(VI+AI)
- VARI=0.5D0*(VI-AI)
- ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
- ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
- KFAF=IABS(KFL1(1))
- EF=KCHG(KFAF,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- VALF=0.5D0*(VF+AF)
- VARF=0.5D0*(VF-AF)
- ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
- ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
- ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
- AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
- WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
- WTMAX=4D0*MAX(ASAME,AFLIP)
- ELSE
-C...Isotropic decay of W/pi_tc produced in rho_tc decay.
- WT=1D0
- WTMAX=1D0
- ENDIF
-
- ELSEIF(ISUB.EQ.192) THEN
- IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
-C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
-C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
- WT=1D0-CTHE(1)**2
- WTMAX=1D0
- ELSEIF(IP.EQ.1) THEN
-C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
- CTHESG=CTHE(1)*ISIGN(1,MINT(15))
- WT=(1D0+CTHESG)**2
- WTMAX=4D0
- ELSE
-C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
- WT=1D0
- WTMAX=1D0
- ENDIF
-
- ELSEIF(ISUB.EQ.193) THEN
- IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
-C...Angular weight for f + fbar -> omega_tc0 ->
-C...gamma pi_tc0 or Z0 pi_tc0.
- WT=1D0+CTHE(1)**2
- WTMAX=2D0
- ELSEIF(IP.EQ.1) THEN
-C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
- CTHESG=CTHE(1)*ISIGN(1,MINT(15))
- BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
- BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
- KFAI=IABS(MINT(15))
- EI=KCHG(KFAI,1)/3D0
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*XWV
- VALI=0.5D0*(VI+AI)
- VARI=0.5D0*(VI-AI)
- BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
- BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
- KFAF=IABS(KFL1(1))
- EF=KCHG(KFAF,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- VALF=0.5D0*(VF+AF)
- VARF=0.5D0*(VF-AF)
- BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
- BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
- BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
- BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
- WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
- WTMAX=4D0*MAX(BSAME,BFLIP)
- ELSE
-C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
- WT=1D0
- WTMAX=1D0
- ENDIF
-
- ELSEIF(ISUB.EQ.353) THEN
-C...Angular weight for Z_R0 -> 2 quarks/leptons.
- EI=KCHG(IABS(MINT(15)),1)/3D0
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*XWV
- EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
- WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
- WT2=RMF*(VI**2+AI**2)*VF**2
- WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
- WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
- & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
- WTMAX=2D0*(WT1+ABS(WT3))
-
- ELSEIF(ISUB.EQ.354) THEN
-C...Angular weight for W_R+/- -> 2 quarks/leptons.
- RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
- RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
- BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
- WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
- WTMAX=4D0
-
- ELSEIF(ISUB.EQ.391) THEN
-C...Angular weight for f + fbar -> G* -> f + fbar
- IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
- WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
- WTMAX=2D0
-C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
-C...implemented by M.-C. Lemaire
- ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
- & IABS(KFL1(1)).EQ.22)) THEN
- WT=1D0-CTHE(1)**4
- WTMAX=1D0
-C...Other G* decays not yet implemented angular distributions.
- ELSE
- WT=1D0
- WTMAX=1D0
- ENDIF
-
- ELSEIF(ISUB.EQ.392) THEN
-C...Angular weight for g + g -> G* -> f + fbar
- IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
- WT=1D0-CTHE(1)**4
- WTMAX=1D0
-C...Angular weight for g + g -> G* -> gamma +gamma or g + g
-C...implemented by M.-C. Lemaire
- ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
- & IABS(KFL1(1)).EQ.22)) THEN
- WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
- WTMAX=8D0
-C...Other G* decays not yet implemented angular distributions.
- ELSE
- WT=1D0
- WTMAX=1D0
- ENDIF
-
-C...Obtain correct angular distribution by rejection techniques.
- ELSE
- WT=1D0
- WTMAX=1D0
- ENDIF
- IF(WT.LT.PYR(0)*WTMAX) GOTO 430
-
-C...Construct massive four-vectors using angles chosen.
- 590 DO 690 JT=1,JTMAX
- IF(KDCY(JT).EQ.0) GOTO 690
- ID=IREF(IP,JT)
- DO 600 J=1,5
- DPMO(J)=P(ID,J)
- 600 CONTINUE
- DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
-CMRENNA++
- IF(KFL3(JT).EQ.0) THEN
- CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
- & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
- N0=NSD(JT)+2
- ELSE
- CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
- & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
- N0=NSD(JT)+3
- ENDIF
-
- DO 610 J=1,4
- VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
- 610 CONTINUE
-C...Fill in position of decay vertex.
- DO 630 I=NSD(JT)+1,N0
- DO 620 J=1,4
- V(I,J)=VDCY(J)
- 620 CONTINUE
- V(I,5)=0D0
-
- 630 CONTINUE
-CMRENNA--
-
-C...Mark decayed resonances; trace history.
- K(ID,1)=K(ID,1)+10
- KFA=IABS(K(ID,2))
- KCA=PYCOMP(KFA)
- IF(KCQM(JT).NE.0) THEN
-C...Do not kill colour flow through coloured resonance!
- ELSE
- K(ID,4)=NSD(JT)+1
- K(ID,5)=NSD(JT)+2
-C...If 3-body or 2-body with junction:
- IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
-C...If 3-body with junction:
- IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
- ENDIF
-
-C...Add documentation lines.
- ISUBRG=MAX(1,MIN(500,MINT(1)))
- IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
- IDOC=MINT(83)+MINT(4)
-CMRENNA+++
- IHI=NSD(JT)+2
- IF(KFL3(JT).NE.0) IHI=IHI+1
- DO 650 I=NSD(JT)+1,IHI
-CMRENNA---
- I1=MINT(83)+MINT(4)+1
- K(I,3)=I1
- IF(MSTP(128).GE.1) K(I,3)=ID
- IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
- MINT(4)=MINT(4)+1
- K(I1,1)=21
- K(I1,2)=K(I,2)
- K(I1,3)=IREF(IP,JT+3)
- DO 640 J=1,5
- P(I1,J)=P(I,J)
- 640 CONTINUE
- ENDIF
- 650 CONTINUE
- ELSE
- K(NSD(JT)+1,3)=ID
- K(NSD(JT)+2,3)=ID
-C...If 3-body or 2-body with junction:
- IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
-C...If 3-body with junction:
- IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
- ENDIF
-
-C...Do showering of two or three objects.
- NSHBEF=N
- IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
- IF(KFL3(JT).EQ.0) THEN
- if(parj(200).ne.1.) CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
- if(parj(200).eq.1.) CALL PYSHOWQ(NSD(JT)+1,NSD(JT)+2,P(ID,5))
- ELSE
- if(parj(200).ne.1.) CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
- if(parj(200).eq.1.) CALL PYSHOWQ(NSD(JT)+1,-3,P(ID,5))
- ENDIF
-
-c...For pT-ordered shower need set up first, especially colour tags.
-C...(Need to set up colour tags even if MSTP(71) = 0)
- ELSEIF(MINT(35).GE.2) THEN
- NPART=2
- IF(KFL3(JT).NE.0) NPART=3
- IPART(1)=NSD(JT)+1
- IPART(2)=NSD(JT)+2
- IPART(3)=NSD(JT)+3
- PTPART(1)=0.5D0*P(ID,5)
- PTPART(2)=PTPART(1)
- PTPART(3)=PTPART(1)
- IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
- MOTHER=K(NSD(JT)+1,4)/MSTU(5)
- IF(MOTHER.LE.NSD(JT)) THEN
- MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
- ELSE
- NCT=NCT+1
- MCT(NSD(JT)+1,1)=NCT
- MCT(MOTHER,2)=NCT
- ENDIF
- ENDIF
- IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
- MOTHER=K(NSD(JT)+1,5)/MSTU(5)
- IF(MOTHER.LE.NSD(JT)) THEN
- MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
- ELSE
- NCT=NCT+1
- MCT(NSD(JT)+1,2)=NCT
- MCT(MOTHER,1)=NCT
- ENDIF
- ENDIF
- IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
- & KCQ2(JT).EQ.2)) THEN
- MOTHER=K(NSD(JT)+2,4)/MSTU(5)
- IF(MOTHER.LE.NSD(JT)) THEN
- MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
- ELSE
- NCT=NCT+1
- MCT(NSD(JT)+2,1)=NCT
- MCT(MOTHER,2)=NCT
- ENDIF
- ENDIF
- IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
- & KCQ2(JT).EQ.2)) THEN
- MOTHER=K(NSD(JT)+2,5)/MSTU(5)
- IF(MOTHER.LE.NSD(JT)) THEN
- MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
- ELSE
- NCT=NCT+1
- MCT(NSD(JT)+2,2)=NCT
- MCT(MOTHER,1)=NCT
- ENDIF
- ENDIF
- IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
- & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
- MOTHER=K(NSD(JT)+3,4)/MSTU(5)
- MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
- ENDIF
- IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
- & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
- MOTHER=K(NSD(JT)+3,5)/MSTU(5)
- MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
- ENDIF
- IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
- ENDIF
- NSHAFT=N
- IF(JT.EQ.1) NAFT1=N
-
-C...Check if decay products moved by shower.
- NSD1=NSD(JT)+1
- NSD2=NSD(JT)+2
- NSD3=NSD(JT)+3
- IF(NSHAFT.GT.NSHBEF) THEN
- IF(K(NSD1,1).GT.10) THEN
- DO 660 I=NSHBEF+1,NSHAFT
- IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
- 660 CONTINUE
- ENDIF
- IF(K(NSD2,1).GT.10) THEN
- DO 670 I=NSHBEF+1,NSHAFT
- IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
- & I.NE.NSD1) NSD2=I
- 670 CONTINUE
- ENDIF
- IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
- DO 680 I=NSHBEF+1,NSHAFT
- IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
- & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
- 680 CONTINUE
- ENDIF
- ENDIF
-
-C...Store decay products for further treatment.
- NP=NP+1
- IREF(NP,1)=NSD1
- IREF(NP,2)=NSD2
- IREF(NP,3)=0
- IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
- IREF(NP,4)=IDOC+1
- IREF(NP,5)=IDOC+2
- IREF(NP,6)=0
- IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
- IREF(NP,7)=K(IREF(IP,JT),2)
- IREF(NP,8)=IREF(IP,JT)
- 690 CONTINUE
-
-
-C...Fill information for 2 -> 1 -> 2.
- 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
- MINT(7)=MINT(83)+6+2*ISET(ISUB)
- MINT(8)=MINT(83)+7+2*ISET(ISUB)
- MINT(25)=KFL1(1)
- MINT(26)=KFL2(1)
- VINT(23)=CTHE(1)
- RM3=P(N-1,5)**2/SH
- RM4=P(N,5)**2/SH
- BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
- VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
- VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
- VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
- VINT(47)=SQRT(VINT(48))
- ENDIF
-
-C...Possibility of colour rearrangement in W+W- events.
- IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
- IAKF1=IABS(KFL1(1))
- IAKF2=IABS(KFL1(2))
- IAKF3=IABS(KFL2(1))
- IAKF4=IABS(KFL2(2))
- IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
- & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
- & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
- IF(MINT(51).NE.0) RETURN
- ENDIF
-
-C...Loop back if needed.
- 710 IF(IP.LT.NP) GOTO 170
-
-C...Boost back to standard frame.
- 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
- &BEZIN)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYMULT
-C...Initializes treatment of multiple interactions, selects kinematics
-C...of hardest interaction if low-pT physics included in run, and
-C...generates all non-hardest interactions.
-
- SUBROUTINE PYMULT(MMUL)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
- &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
-C...Local arrays and saved variables.
- DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
- SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
- &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
- &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
-
-C...Initialization of multiple interaction treatment.
- IF(MMUL.EQ.1) THEN
- IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
- ISUB=96
- MINT(1)=96
- VINT(63)=0D0
- VINT(64)=0D0
- VINT(143)=1D0
- VINT(144)=1D0
-
-C...Loop over phase space points: xT2 choice in 20 bins.
- 100 SIGSUM=0D0
- DO 120 IXT2=1,20
- NMUL(IXT2)=MSTP(83)
- SIGM(IXT2)=0D0
- DO 110 ITRY=1,MSTP(83)
- RSCA=0.05D0*((21-IXT2)-PYR(0))
- XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
- XT2=MAX(0.01D0*VINT(149),XT2)
- VINT(25)=XT2
-
-C...Choose tau and y*. Calculate cos(theta-hat).
- IF(PYR(0).LE.COEF(ISUB,1)) THEN
- TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
- TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
- ELSE
- TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
- ENDIF
- VINT(21)=TAU
- CALL PYKLIM(2)
- RYST=PYR(0)
- MYST=1
- IF(RYST.GT.COEF(ISUB,8)) MYST=2
- IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
- CALL PYKMAP(2,MYST,PYR(0))
- VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
-
-C...Calculate differential cross-section.
- VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
- CALL PYSIGH(NCHN,SIGS)
- SIGM(IXT2)=SIGM(IXT2)+SIGS
- 110 CONTINUE
- SIGSUM=SIGSUM+SIGM(IXT2)
- 120 CONTINUE
- SIGSUM=SIGSUM/(20D0*MSTP(83))
-
-C...Reject result if sigma(parton-parton) is smaller than hadronic one.
- IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
- IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
- & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
- PARP(82)=0.9D0*PARP(82)
- VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
- & VINT(2)
- GOTO 100
- ENDIF
- IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
- & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
-
-C...Start iteration to find k factor.
- YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
- P83A=(1D0-PARP(83))**2
- P83B=2D0*PARP(83)*(1D0-PARP(83))
- P83C=PARP(83)**2
- CQ2I=1D0/PARP(84)**2
- CQ2R=2D0/(1D0+PARP(84)**2)
- SO=0.5D0
- XI=0D0
- YI=0D0
- XF=0D0
- YF=0D0
- XK=0.5D0
- IIT=0
- 130 IF(IIT.EQ.0) THEN
- XK=2D0*XK
- ELSEIF(IIT.EQ.1) THEN
- XK=0.5D0*XK
- ELSE
- XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
- ENDIF
-
-C...Evaluate overlap integrals. Find where to divide the b range.
- IF(MSTP(82).EQ.2) THEN
- SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
- SOP=SP/PARU(1)
- ELSE
- IF(MSTP(82).EQ.3) THEN
- DELTAB=0.02D0
- ELSEIF(MSTP(82).EQ.4) THEN
- DELTAB=MIN(0.01D0,0.05D0*PARP(84))
- ELSE
- POWIP=MAX(0.4D0,PARP(83))
- RPWIP=2D0/POWIP-1D0
- DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
- SO=0D0
- ENDIF
- SP=0D0
- SOP=0D0
- BSP=0D0
- SOHIGH=0D0
- IBDIV=0
- B=-0.5D0*DELTAB
- 140 B=B+DELTAB
- IF(MSTP(82).EQ.3) THEN
- OV=EXP(-B**2)/PARU(2)
- ELSEIF(MSTP(82).EQ.4) THEN
- OV=(P83A*EXP(-MIN(50D0,B**2))+
- & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
- & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
- ELSE
- OV=EXP(-B**POWIP)/PARU(2)
- SO=SO+PARU(2)*B*DELTAB*OV
- ENDIF
- IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
- PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
- SP=SP+PARU(2)*B*DELTAB*PACC
- SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
- BSP=BSP+B*PARU(2)*B*DELTAB*PACC
- IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
- IBDIV=1
- BDIV=B+0.5D0*DELTAB
- ENDIF
- IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
- ENDIF
- YK=PARU(1)*XK*SO/SP
-
-C...Continue iteration until convergence.
- IF(YK.LT.YKE) THEN
- XI=XK
- YI=YK
- IF(IIT.EQ.1) IIT=2
- ELSE
- XF=XK
- YF=YK
- IF(IIT.EQ.0) IIT=1
- ENDIF
- IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
-
-C...Store some results for subsequent use.
- BAVG=BSP/SP
- VINT(145)=SIGSUM
- VINT(146)=SOP/SO
- VINT(147)=SOP/SP
- VNT145=VINT(145)
- VNT146=VINT(146)
- VNT147=VINT(147)
-C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
- PIK=(VNT146/VNT147)*YKE
-
-C...Find relative weight for low and high impact parameter.
- PLOWB=PARU(1)*BDIV**2
- IF(MSTP(82).EQ.3) THEN
- PHIGHB=PIK*0.5*EXP(-BDIV**2)
- ELSEIF(MSTP(82).EQ.4) THEN
- S4A=P83A*EXP(-BDIV**2)
- S4B=P83B*EXP(-BDIV**2*CQ2R)
- S4C=P83C*EXP(-BDIV**2*CQ2I)
- PHIGHB=PIK*0.5*(S4A+S4B+S4C)
- ELSEIF(PARP(83).GE.1.999D0) THEN
- PHIGHB=PIK*SOHIGH
- B2RPDV=BDIV**POWIP
- ELSE
- PHIGHB=PIK*SOHIGH
- B2RPDV=BDIV**POWIP
- B2RPMX=MAX(2D0*RPWIP,B2RPDV)
- ENDIF
- PALLB=PLOWB+PHIGHB
-
-C...Initialize iteration in xT2 for hardest interaction.
- ELSEIF(MMUL.EQ.2) THEN
- VINT(145)=VNT145
- VINT(146)=VNT146
- VINT(147)=VNT147
- IF(MSTP(82).LE.0) THEN
- ELSEIF(MSTP(82).EQ.1) THEN
- XT2=1D0
- SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
- & VINT(317)/(VINT(318)*VINT(320))
- XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
- ELSEIF(MSTP(82).EQ.2) THEN
- XT2=1D0
- XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
- & VINT(149)*(1D0+VINT(149))
- ELSE
- XC2=4D0*CKIN(3)**2/VINT(2)
- IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
- ENDIF
-
-C...Select impact parameter for hardest interaction.
- IF(MSTP(82).LE.2) RETURN
- 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
-C...Treatment in low b region.
- MINT(39)=1
- B=BDIV*SQRT(PYR(0))
- IF(MSTP(82).EQ.3) THEN
- OV=EXP(-B**2)/PARU(2)
- ELSEIF(MSTP(82).EQ.4) THEN
- OV=(P83A*EXP(-MIN(50D0,B**2))+
- & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
- & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
- ELSE
- OV=EXP(-B**POWIP)/PARU(2)
- ENDIF
- VINT(148)=OV/VNT147
- PACC=1D0-EXP(-MIN(50D0,PIK*OV))
- XT2=1D0
- XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
- & VINT(149)*(1D0+VINT(149))
- ELSE
-C...Treatment in high b region.
- MINT(39)=2
- IF(MSTP(82).EQ.3) THEN
- B=SQRT(BDIV**2-LOG(PYR(0)))
- OV=EXP(-B**2)/PARU(2)
- ELSEIF(MSTP(82).EQ.4) THEN
- S4RNDM=PYR(0)*(S4A+S4B+S4C)
- IF(S4RNDM.LT.S4A) THEN
- B=SQRT(BDIV**2-LOG(PYR(0)))
- ELSEIF(S4RNDM.LT.S4A+S4B) THEN
- B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
- ELSE
- B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
- ENDIF
- OV=(P83A*EXP(-MIN(50D0,B**2))+
- & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
- & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
- ELSEIF(PARP(83).GE.1.999D0) THEN
- 144 B2RPW=B2RPDV-LOG(PYR(0))
- ACCIP=(B2RPW/B2RPDV)**RPWIP
- IF(ACCIP.LT.PYR(0)) GOTO 144
- OV=EXP(-B2RPW)/PARU(2)
- B=B2RPW**(1D0/POWIP)
- ELSE
- 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
- ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
- IF(ACCIP.LT.PYR(0)) GOTO 146
- OV=EXP(-B2RPW)/PARU(2)
- B=B2RPW**(1D0/POWIP)
- ENDIF
- VINT(148)=OV/VNT147
- PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
- ENDIF
- IF(PACC.LT.PYR(0)) GOTO 142
- VINT(139)=B/BAVG
-
- ELSEIF(MMUL.EQ.3) THEN
-C...Low-pT or multiple interactions (first semihard interaction):
-C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
-C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
- ISUB=MINT(1)
- VINT(145)=VNT145
- VINT(146)=VNT146
- VINT(147)=VNT147
- IF(MSTP(82).LE.0) THEN
- XT2=0D0
- ELSEIF(MSTP(82).EQ.1) THEN
- XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
-C...Use with "Sudakov" for low b values when impact parameter dependence.
- ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
- IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
- & VINT(149)))).GT.PYR(0)) XT2=1D0
- IF(XT2.GE.1D0) THEN
- XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
- & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
- & VINT(149)
- ELSE
- XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
- & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
- & VINT(149)
- ENDIF
- XT2=MAX(0.01D0*VINT(149),XT2)
-C...Use without "Sudakov" for high b values when impact parameter dep.
- ELSE
- XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
- & PYR(0)*(1D0-XC2))-VINT(149)
- XT2=MAX(0.01D0*VINT(149),XT2)
- ENDIF
- VINT(25)=XT2
-
-C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
- IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
- IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
- IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
- ISUB=95
- MINT(1)=ISUB
- VINT(21)=0.01D0*VINT(149)
- VINT(22)=0D0
- VINT(23)=0D0
- VINT(25)=0.01D0*VINT(149)
-
- ELSE
-C...Multiple interactions (first semihard interaction).
-C...Choose tau and y*. Calculate cos(theta-hat).
- IF(PYR(0).LE.COEF(ISUB,1)) THEN
- TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
- TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
- ELSE
- TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
- ENDIF
- VINT(21)=TAU
- CALL PYKLIM(2)
- RYST=PYR(0)
- MYST=1
- IF(RYST.GT.COEF(ISUB,8)) MYST=2
- IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
- CALL PYKMAP(2,MYST,PYR(0))
- VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
- ENDIF
- VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
-
-C...Store results of cross-section calculation.
- ELSEIF(MMUL.EQ.4) THEN
- ISUB=MINT(1)
- VINT(145)=VNT145
- VINT(146)=VNT146
- VINT(147)=VNT147
- XTS=VINT(25)
- IF(ISET(ISUB).EQ.1) XTS=VINT(21)
- IF(ISET(ISUB).EQ.2)
- & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
- IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
- RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
- & (XTS+VINT(149))))
- IRBIN=INT(1D0+20D0*RBIN)
- IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
- NMUL(IRBIN)=NMUL(IRBIN)+1
- SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
- ENDIF
-
-C...Choose impact parameter if not already done.
- ELSEIF(MMUL.EQ.5) THEN
- ISUB=MINT(1)
- VINT(145)=VNT145
- VINT(146)=VNT146
- VINT(147)=VNT147
- 150 IF(MINT(39).GT.0) THEN
- ELSEIF(MSTP(82).EQ.3) THEN
- EXPB2=PYR(0)
- B2=-LOG(PYR(0))
- VINT(148)=EXPB2/(PARU(2)*VNT147)
- VINT(139)=SQRT(B2)/BAVG
- ELSEIF(MSTP(82).EQ.4) THEN
- RTYPE=PYR(0)
- IF(RTYPE.LT.P83A) THEN
- B2=-LOG(PYR(0))
- ELSEIF(RTYPE.LT.P83A+P83B) THEN
- B2=-LOG(PYR(0))/CQ2R
- ELSE
- B2=-LOG(PYR(0))/CQ2I
- ENDIF
- VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
- & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
- & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
- VINT(139)=SQRT(B2)/BAVG
- ELSEIF(PARP(83).GE.1.999D0) THEN
- POWIP=MAX(2D0,PARP(83))
- RPWIP=2D0/POWIP-1D0
- PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
- 160 IF(PYR(0).LT.PROB1) THEN
- B2RPW=PYR(0)**(0.5D0*POWIP)
- ACCIP=EXP(-B2RPW)
- ELSE
- B2RPW=1D0-LOG(PYR(0))
- ACCIP=B2RPW**RPWIP
- ENDIF
- IF(ACCIP.LT.PYR(0)) GOTO 160
- VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
- VINT(139)=B2RPW**(1D0/POWIP)/BAVG
- ELSE
- POWIP=MAX(0.4D0,PARP(83))
- RPWIP=2D0/POWIP-1D0
- PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
- 170 IF(PYR(0).LT.PROB1) THEN
- B2RPW=2D0*RPWIP*PYR(0)
- ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
- ELSE
- B2RPW=2D0*(RPWIP-LOG(PYR(0)))
- ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
- ENDIF
- IF(ACCIP.LT .PYR(0)) GOTO 170
- VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
- VINT(139)=B2RPW**(1D0/POWIP)/BAVG
- ENDIF
-
-C...Multiple interactions (variable impact parameter) : reject with
-C...probability exp(-overlap*cross-section above pT/normalization).
-C...Does not apply to low-b region, where "Sudakov" already included.
- VINT(150)=1D0
- IF(MINT(39).NE.1) THEN
- RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
- SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
- DO 180 IBIN=IRBIN+1,20
- RNCOR=RNCOR+NMUL(IBIN)
- SIGCOR=SIGCOR+SIGM(IBIN)
- 180 CONTINUE
- SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
- IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
- VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
- & SIGABV/MAX(1D-10,SIGT(0,0,5))))
- ENDIF
- IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
- & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
- & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
- IF(VINT(150).LT.PYR(0)) GOTO 150
- VINT(150)=1D0
- ENDIF
-
-C...Generate additional multiple semihard interactions.
- ELSEIF(MMUL.EQ.6) THEN
- ISUBSV=MINT(1)
- VINT(145)=VNT145
- VINT(146)=VNT146
- VINT(147)=VNT147
- DO 190 J=11,80
- VINTSV(J)=VINT(J)
- 190 CONTINUE
- ISUB=96
- MINT(1)=96
- VINT(151)=0D0
- VINT(152)=0D0
-
-C...Reconstruct strings in hard scattering.
- NMAX=MINT(84)+4
- IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
- IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
- NSTR=0
- DO 210 I=MINT(84)+1,NMAX
- KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
- IF(KCS.EQ.0) GOTO 210
- DO 200 J=1,4
- IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
- IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
- IF(J.LE.2) THEN
- IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
- ELSE
- IST=MOD(K(I,J+1),MSTU(5))
- ENDIF
- IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
- IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
- NSTR=NSTR+1
- IF(J.EQ.1.OR.J.EQ.4) THEN
- KSTR(NSTR,1)=I
- KSTR(NSTR,2)=IST
- ELSE
- KSTR(NSTR,1)=IST
- KSTR(NSTR,2)=I
- ENDIF
- 200 CONTINUE
- 210 CONTINUE
-
-C...Set up starting values for iteration in xT2.
- XT2=4D0*VINT(62)/VINT(2)
- IF(MSTP(82).LE.1) THEN
- SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
- & VINT(317)/(VINT(318)*VINT(320))
- XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
- ELSE
- XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
- & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
- ENDIF
- VINT(63)=0D0
- VINT(64)=0D0
- VINT(143)=1D0-VINT(141)
- VINT(144)=1D0-VINT(142)
-
-C...Iterate downwards in xT2.
- 220 IF(MSTP(82).LE.1) THEN
- XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
- IF(XT2.LT.VINT(149)) GOTO 270
- ELSE
- IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
- XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
- & LOG(PYR(0)))-VINT(149)
- IF(XT2.LE.0D0) GOTO 270
- XT2=MAX(0.01D0*VINT(149),XT2)
- ENDIF
- VINT(25)=XT2
-
-C...Choose tau and y*. Calculate cos(theta-hat).
- IF(PYR(0).LE.COEF(ISUB,1)) THEN
- TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
- TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
- ELSE
- TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
- ENDIF
- VINT(21)=TAU
- CALL PYKLIM(2)
- RYST=PYR(0)
- MYST=1
- IF(RYST.GT.COEF(ISUB,8)) MYST=2
- IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
- CALL PYKMAP(2,MYST,PYR(0))
- VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
-
-C...Check that x not used up. Accept or reject kinematical variables.
- X1M=SQRT(TAU)*EXP(VINT(22))
- X2M=SQRT(TAU)*EXP(-VINT(22))
- IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
- VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
- CALL PYSIGH(NCHN,SIGS)
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
- IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
-
-C...Reset K, P and V vectors. Select some variables.
- DO 240 I=N+1,N+2
- DO 230 J=1,5
- K(I,J)=0
- P(I,J)=0D0
- V(I,J)=0D0
- 230 CONTINUE
- 240 CONTINUE
- RFLAV=PYR(0)
- PT=0.5D0*VINT(1)*SQRT(XT2)
- PHI=PARU(2)*PYR(0)
- CTH=VINT(23)
-
-C...Add first parton to event record.
- K(N+1,1)=3
- K(N+1,2)=21
- IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
- & 1+INT((2D0+PARJ(2))*PYR(0))
- P(N+1,1)=PT*COS(PHI)
- P(N+1,2)=PT*SIN(PHI)
- P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
- P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
- P(N+1,5)=0D0
-
-C...Add second parton to event record.
- K(N+2,1)=3
- K(N+2,2)=21
- IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
- P(N+2,1)=-P(N+1,1)
- P(N+2,2)=-P(N+1,2)
- P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
- P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
- P(N+2,5)=0D0
-
- IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
-C....Choose relevant string pieces to place gluons on.
- DO 260 I=N+1,N+2
- DMIN=1D8
- DO 250 ISTR=1,NSTR
- I1=KSTR(ISTR,1)
- I2=KSTR(ISTR,2)
- DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
- & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
- & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
- & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
- IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
- DMIN=DIST
- IST1=I1
- IST2=I2
- ISTM=ISTR
- ENDIF
- 250 CONTINUE
-
-C....Colour flow adjustments, new string pieces.
- IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
- & MOD(K(IST1,4),MSTU(5))
- IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
- & MSTU(5)*(K(IST1,5)/MSTU(5))+I
- K(I,5)=MSTU(5)*IST1
- K(I,4)=MSTU(5)*IST2
- IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
- & MOD(K(IST2,5),MSTU(5))
- IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
- & MSTU(5)*(K(IST2,4)/MSTU(5))+I
- KSTR(ISTM,2)=I
- KSTR(NSTR+1,1)=I
- KSTR(NSTR+1,2)=IST2
- NSTR=NSTR+1
- 260 CONTINUE
-
-C...String drawing and colour flow for gluon loop.
- ELSEIF(K(N+1,2).EQ.21) THEN
- K(N+1,4)=MSTU(5)*(N+2)
- K(N+1,5)=MSTU(5)*(N+2)
- K(N+2,4)=MSTU(5)*(N+1)
- K(N+2,5)=MSTU(5)*(N+1)
- KSTR(NSTR+1,1)=N+1
- KSTR(NSTR+1,2)=N+2
- KSTR(NSTR+2,1)=N+2
- KSTR(NSTR+2,2)=N+1
- NSTR=NSTR+2
-
-C...String drawing and colour flow for qqbar pair.
- ELSE
- K(N+1,4)=MSTU(5)*(N+2)
- K(N+2,5)=MSTU(5)*(N+1)
- KSTR(NSTR+1,1)=N+1
- KSTR(NSTR+1,2)=N+2
- NSTR=NSTR+1
- ENDIF
-
-C...Global statistics.
- MINT(351)=MINT(351)+1
- VINT(351)=VINT(351)+PT
- IF (MINT(351).EQ.1) VINT(356)=PT
-
-C...Update remaining energy; iterate.
- N=N+2
- IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
- CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
- MINT(51)=1
- RETURN
- ENDIF
- MINT(31)=MINT(31)+1
- VINT(151)=VINT(151)+VINT(41)
- VINT(152)=VINT(152)+VINT(42)
- VINT(143)=VINT(143)-VINT(41)
- VINT(144)=VINT(144)-VINT(42)
-C...Allow FSR for UE
- IF(MSTP(152).EQ.1) then
- if(parj(200).ne.1.) CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
- if(parj(200).eq.1.) CALL PYSHOWQ(N-1,N,SQRT(PARP(71))*PT)
- endif
- IF(MINT(31).LT.240) GOTO 220
- 270 CONTINUE
- MINT(1)=ISUBSV
- DO 280 J=11,80
- VINT(J)=VINTSV(J)
- 280 CONTINUE
- ENDIF
-
-C...Format statements for printout.
- 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
- &'actions for MSTP(82) =',I2,' ******')
- 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
- &D9.2,' mb: rejected')
- 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
- &D9.2,' mb: accepted')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYREMN
-C...Adds on target remnants (one or two from each side) and
-C...includes primordial kT for hadron beams.
-
- SUBROUTINE PYREMN(IPU1,IPU2)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
-C...Local arrays.
- DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
- &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
-
-C...Find event type and remaining energy.
- ISUB=MINT(1)
- NS=N
- IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
- VINT(143)=1D0-VINT(141)
- VINT(144)=1D0-VINT(142)
- ENDIF
-
-C...Define initial partons.
- NTRY=0
- 100 NTRY=NTRY+1
- DO 130 JT=1,2
- I=MINT(83)+JT+2
- IF(JT.EQ.1) IPU=IPU1
- IF(JT.EQ.2) IPU=IPU2
- K(I,1)=21
- K(I,2)=K(IPU,2)
- K(I,3)=I-2
- PMS(JT)=0D0
- VINT(156+JT)=0D0
- VINT(158+JT)=0D0
- IF(MINT(47).EQ.1) THEN
- DO 110 J=1,5
- P(I,J)=P(I-2,J)
- 110 CONTINUE
- ELSEIF(ISUB.EQ.95) THEN
- K(I,2)=21
- ELSE
- P(I,5)=P(IPU,5)
-
-C...No primordial kT, or chosen according to truncated Gaussian or
-C...exponential, or (for photon) predetermined or power law.
- 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
- IF(MSTP(91).LE.0) THEN
- PT=0D0
- ELSEIF(MSTP(91).EQ.1) THEN
- PT=PARP(91)*SQRT(-LOG(PYR(0)))
- ELSE
- RPT1=PYR(0)
- RPT2=PYR(0)
- PT=-PARP(92)*LOG(RPT1*RPT2)
- ENDIF
- IF(PT.GT.PARP(93)) GOTO 120
- ELSEIF(MINT(106+JT).EQ.3) THEN
- PTA=SQRT(VINT(282+JT))
- PTB=0D0
- IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
- PTB=PARP(99)*SQRT(-LOG(PYR(0)))
- ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
- RPT1=PYR(0)
- RPT2=PYR(0)
- PTB=-PARP(99)*LOG(RPT1*RPT2)
- ENDIF
- IF(PTB.GT.PARP(100)) GOTO 120
- PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
- PT=PT*0.8D0**MINT(57)
- IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
- ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
- IF(MSTP(93).LE.0) THEN
- PT=0D0
- ELSEIF(MSTP(93).EQ.1) THEN
- PT=PARP(99)*SQRT(-LOG(PYR(0)))
- ELSEIF(MSTP(93).EQ.2) THEN
- RPT1=PYR(0)
- RPT2=PYR(0)
- PT=-PARP(99)*LOG(RPT1*RPT2)
- ELSEIF(MSTP(93).EQ.3) THEN
- HA=PARP(99)**2
- HB=PARP(100)**2
- PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
- ELSE
- HA=PARP(99)**2
- HB=PARP(100)**2
- IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
- PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
- ENDIF
- IF(PT.GT.PARP(100)) GOTO 120
- ELSE
- PT=0D0
- ENDIF
- VINT(156+JT)=PT
- PHI=PARU(2)*PYR(0)
- P(I,1)=PT*COS(PHI)
- P(I,2)=PT*SIN(PHI)
- PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
- ENDIF
- 130 CONTINUE
- IF(MINT(47).EQ.1) RETURN
-
-C...Kinematics construction for initial partons.
- I1=MINT(83)+3
- I2=MINT(83)+4
- IF(ISUB.EQ.95) THEN
- SHS=0D0
- SHR=0D0
- ELSE
- SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
- & (P(I1,2)+P(I2,2))**2
- SHR=SQRT(MAX(0D0,SHS))
- IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
- P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
- P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
- P(I2,4)=SHR-P(I1,4)
- P(I2,3)=-P(I1,3)
-
-C...Transform partons to overall CM-frame.
- ROBO(3)=(P(I1,1)+P(I2,1))/SHR
- ROBO(4)=(P(I1,2)+P(I2,2))/SHR
- CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
- ROBO(2)=PYANGL(P(I1,1),P(I1,2))
- CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
- ROBO(1)=PYANGL(P(I1,3),P(I1,1))
- CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
- CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
- CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
- ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
- CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
- ENDIF
-
-C...Optionally fix up x and Q2 definitions for leptoproduction.
- IDISXQ=0
- IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
- &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
- IF(IDISXQ.EQ.1) THEN
-
-C...Find where incoming and outgoing leptons/partons are sitting.
- LESD=1
- IF(MINT(42).EQ.1) LESD=2
- LPIN=MINT(83)+3-LESD
- LEIN=MINT(84)+LESD
- LQIN=MINT(84)+3-LESD
- LEOUT=MINT(84)+2+LESD
- LQOUT=MINT(84)+5-LESD
- IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
- IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
- LSCMS=0
- DO 140 I=MINT(84)+5,N
- IF(K(I,2).EQ.94) THEN
- LSCMS=I
- LEOUT=I+LESD
- LQOUT=I+3-LESD
- ENDIF
- 140 CONTINUE
- LQBG=IPU1
- IF(LESD.EQ.1) LQBG=IPU2
-
-C...Calculate actual and wanted momentum transfer.
- XNOM=VINT(43-LESD)
- Q2NOM=-VINT(45)
- HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
- & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
- & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
- HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
- FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
- P(N+1,1)=FAC*P(LEOUT,1)
- P(N+1,2)=FAC*P(LEOUT,2)
- P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
- & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
- P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
- & P(N+1,3)**2)
- DO 150 J=1,4
- QOLD(J)=P(LEIN,J)-P(LEOUT,J)
- QNEW(J)=P(LEIN,J)-P(N+1,J)
- 150 CONTINUE
-
-C...Boost outgoing electron and daughters.
- IF(LSCMS.EQ.0) THEN
- DO 160 J=1,4
- P(LEOUT,J)=P(N+1,J)
- 160 CONTINUE
- ELSE
- DO 170 J=1,3
- P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
- 170 CONTINUE
- PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
- DO 180 J=1,3
- DBE(J)=PINV*P(N+2,J)
- 180 CONTINUE
- DO 200 I=LSCMS+1,N
- IORIG=I
- 190 IORIG=K(IORIG,3)
- IF(IORIG.GT.LEOUT) GOTO 190
- IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
- & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
- 200 CONTINUE
- ENDIF
-
-C...Copy shower initiator and all outgoing partons.
- NCOP=N+1
- K(NCOP,3)=LQBG
- DO 210 J=1,5
- P(NCOP,J)=P(LQBG,J)
- 210 CONTINUE
- DO 240 I=MINT(84)+1,N
- ICOP=0
- IF(K(I,1).GT.10) GOTO 240
- IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
- ICOP=I
- ELSE
- IORIG=I
- 220 IORIG=K(IORIG,3)
- IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
- ICOP=IORIG
- ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
- GOTO 220
- ENDIF
- ENDIF
- IF(ICOP.NE.0) THEN
- NCOP=NCOP+1
- K(NCOP,3)=I
- DO 230 J=1,5
- P(NCOP,J)=P(I,J)
- 230 CONTINUE
- ENDIF
- 240 CONTINUE
-
-C...Calculate relative rescaling factors.
- SLC=3-2*LESD
- PLCSUM=0D0
- DO 250 I=N+2,NCOP
- PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
- 250 CONTINUE
- DO 260 I=N+2,NCOP
- V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
- 260 CONTINUE
-
-C...Transfer extra three-momentum of current.
- DO 280 I=N+2,NCOP
- DO 270 J=1,3
- P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
- 270 CONTINUE
- P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
- 280 CONTINUE
-
-C...Iterate change of initiator momentum to get energy right.
- ITER=0
- 290 ITER=ITER+1
- PEEX=-P(N+1,4)-QNEW(4)
- PEMV=-P(N+1,3)/P(N+1,4)
- DO 300 I=N+2,NCOP
- PEEX=PEEX+P(I,4)
- PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
- 300 CONTINUE
- IF(ABS(PEMV).LT.1D-10) THEN
- MINT(51)=1
- MINT(57)=MINT(57)+1
- RETURN
- ENDIF
- PZCH=-PEEX/PEMV
- P(N+1,3)=P(N+1,3)+PZCH
- P(N+1,4)=SQRT(P(N+1,5)**2+P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
- DO 310 I=N+2,NCOP
- P(I,3)=P(I,3)+V(I,1)*PZCH
- P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
- 310 CONTINUE
- IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
-
-C...Modify momenta in event record.
- HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
- & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
- IF(ABS(HBE).GE.1D0) THEN
- MINT(51)=1
- MINT(57)=MINT(57)+1
- RETURN
- ENDIF
- I=MINT(83)+5-LESD
- CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
- DO 330 I=N+1,NCOP
- ICOP=K(I,3)
- DO 320 J=1,4
- P(ICOP,J)=P(I,J)
- 320 CONTINUE
- 330 CONTINUE
- ENDIF
-
-C...Check minimum invariant mass of remnant system(s).
- PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
- PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
- PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
- PMIN(0)=SQRT(PMS(0))
- DO 340 JT=1,2
- PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
- PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
- PMIN(JT)=0D0
- IF(MINT(44+JT).EQ.1) GOTO 340
- MINT(105)=MINT(102+JT)
- MINT(109)=MINT(106+JT)
- CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
- IF(MINT(51).NE.0) THEN
- MINT(57)=MINT(57)+1
- RETURN
- ENDIF
- IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
- IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
- IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
- PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
- & P(MINT(83)+JT+2,2)**2)
- 340 CONTINUE
- IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
- &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
- &PSYS(2,4))) THEN
- MINT(51)=1
- MINT(57)=MINT(57)+1
- RETURN
- ENDIF
-
-C...Loop over two remnants; skip if none there.
- I=NS
- DO 410 JT=1,2
- ISN(JT)=0
- IF(MINT(44+JT).EQ.1) GOTO 410
- IF(JT.EQ.1) IPU=IPU1
- IF(JT.EQ.2) IPU=IPU2
-
-C...Store first remnant parton.
- I=I+1
- IS(JT)=I
- ISN(JT)=1
- DO 350 J=1,5
- K(I,J)=0
- P(I,J)=0D0
- V(I,J)=0D0
- 350 CONTINUE
- K(I,1)=1
- K(I,2)=KFLSP(JT)
- K(I,3)=MINT(83)+JT
- P(I,5)=PYMASS(K(I,2))
-
-C...First parton colour connections and kinematics.
- KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
- IF(KCOL.EQ.2) THEN
- K(I,1)=3
- K(I,4)=MSTU(5)*IPU+IPU
- K(I,5)=MSTU(5)*IPU+IPU
- K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
- K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
- ELSEIF(KCOL.NE.0) THEN
- K(I,1)=3
- KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
- K(I,KFLS+3)=IPU
- K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
- ENDIF
- IF(KFLCH(JT).EQ.0) THEN
- P(I,1)=-P(MINT(83)+JT+2,1)
- P(I,2)=-P(MINT(83)+JT+2,2)
- PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
- PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
- P(I,3)=PSYS(JT,3)
- P(I,4)=PSYS(JT,4)
-
-C...When extra remnant parton or hadron: store extra remnant.
- ELSE
- I=I+1
- ISN(JT)=2
- DO 360 J=1,5
- K(I,J)=0
- P(I,J)=0D0
- V(I,J)=0D0
- 360 CONTINUE
- K(I,1)=1
- K(I,2)=KFLCH(JT)
- K(I,3)=MINT(83)+JT
- P(I,5)=PYMASS(K(I,2))
-
-C...Find parton colour connections of extra remnant.
- KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
- IF(KCOL.EQ.2) THEN
- K(I,1)=3
- K(I,4)=MSTU(5)*IPU+IPU
- K(I,5)=MSTU(5)*IPU+IPU
- K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
- K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
- ELSEIF(KCOL.NE.0) THEN
- K(I,1)=3
- KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
- K(I,KFLS+3)=IPU
- K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
- ENDIF
-
-C...Relative transverse momentum when two remnants.
- LOOP=0
- 370 LOOP=LOOP+1
- CALL PYPTDI(1,P(I-1,1),P(I-1,2))
- IF(IABS(MINT(10+JT)).LT.20) THEN
- P(I-1,1)=0D0
- P(I-1,2)=0D0
- ELSE
- P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
- P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
- ENDIF
- PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
- P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
- P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
- PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
-
-C...Meson or baryon; photon as meson. For splitup below.
- IMB=1
- IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
-
-C***Relative distribution for electron into two electrons. Temporary!
- IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
- & THEN
- CHI(JT)=PYR(0)
-
-C...Relative distribution of electron energy into electron plus parton.
- ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
- XHRD=VINT(140+JT)
- XE=VINT(154+JT)
- CHI(JT)=(XE-XHRD)/(1D0-XHRD)
-
-C...Relative distribution of energy for particle into two jets.
- ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
- CHIK=PARP(92+2*IMB)
- IF(MSTP(92).LE.1) THEN
- IF(IMB.EQ.1) CHI(JT)=PYR(0)
- IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
- ELSEIF(MSTP(92).EQ.2) THEN
- CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
- ELSEIF(MSTP(92).EQ.3) THEN
- CUT=2D0*0.3D0/VINT(1)
- 380 CHI(JT)=PYR(0)**2
- IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
- & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
- ELSEIF(MSTP(92).EQ.4) THEN
- CUT=2D0*0.3D0/VINT(1)
- CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
- 390 CHIR=CUT*CUTR**PYR(0)
- CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
- IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
- ELSE
- CUT=2D0*0.3D0/VINT(1)
- CUTA=CUT**(1D0-PARP(98))
- CUTB=(1D0+CUT)**(1D0-PARP(98))
- 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
- IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
- & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
- ENDIF
-
-C...Relative distribution of energy for particle into jet plus particle.
- ELSE
- IF(MSTP(94).LE.1) THEN
- IF(IMB.EQ.1) CHI(JT)=PYR(0)
- IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
- IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
- ELSEIF(MSTP(94).EQ.2) THEN
- CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
- IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
- ELSEIF(MSTP(94).EQ.3) THEN
- CALL PYZDIS(1,0,PMS(JT+4),ZZ)
- CHI(JT)=ZZ
- ELSE
- CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
- CHI(JT)=ZZ
- ENDIF
- ENDIF
-
-C...Construct total transverse mass; reject if too large.
- CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
- PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
- IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
- IF(LOOP.LT.100) THEN
- GOTO 370
- ELSE
- MINT(51)=1
- MINT(57)=MINT(57)+1
- RETURN
- ENDIF
- ENDIF
- PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
- VINT(158+JT)=CHI(JT)
-
-C...Subdivide longitudinal momentum according to value selected above.
- PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
- P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
- P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
- P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
- P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
- ENDIF
- 410 CONTINUE
- N=I
-
-C...Check if longitudinal boosts needed - if so pick two systems.
- PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
- &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
- IF(PDEV.LE.1D-6*VINT(1)) RETURN
- IF(ISN(1).EQ.0) THEN
- IR=0
- IL=2
- ELSEIF(ISN(2).EQ.0) THEN
- IR=1
- IL=0
- ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
- IR=1
- IL=2
- ELSEIF(VINT(143).GT.0.2D0) THEN
- IR=1
- IL=0
- ELSEIF(VINT(144).GT.0.2D0) THEN
- IR=0
- IL=2
- ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
- IR=1
- IL=0
- ELSE
- IR=0
- IL=2
- ENDIF
- IG=3-IR-IL
-
-C...E+-pL wanted for system to be modified.
- IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
- PPB=VINT(1)
- PNB=VINT(1)
- ELSE
- PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
- PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
- ENDIF
-
-C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
- IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
- PPB=PPB-(PSYS(0,4)+PSYS(0,3))
- PNB=PNB-(PSYS(0,4)-PSYS(0,3))
- DO 420 J=1,4
- PSYS(0,J)=0D0
- 420 CONTINUE
- DO 450 I=MINT(84)+1,NS
- IF(K(I,1).GT.10) GOTO 450
- INCL=0
- IORIG=I
- 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
- IORIG=K(IORIG,3)
- IF(IORIG.GT.LPIN) GOTO 430
- IF(INCL.EQ.0) GOTO 450
- DO 440 J=1,4
- PSYS(0,J)=PSYS(0,J)+P(I,J)
- 440 CONTINUE
- 450 CONTINUE
- PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
- PPB=PPB+(PSYS(0,4)+PSYS(0,3))
- PNB=PNB+(PSYS(0,4)-PSYS(0,3))
- ENDIF
-
-C...Construct longitudinal boosts.
- DPMTB=PPB*PNB
- DPMTR=PMS(IR)
- DPMTL=PMS(IL)
- DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
- IF(DSQLAM.LE.1D-6*DPMTB) THEN
- MINT(51)=1
- MINT(57)=MINT(57)+1
- RETURN
- ENDIF
- DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
- DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
- &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
- DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
- &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
- DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
- DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
-
-C...Perform longitudinal boosts.
- IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
- P(IS(1),3)=0D0
- P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
- ELSEIF(IR.EQ.1) THEN
- CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
- ELSEIF(IDISXQ.EQ.1) THEN
- DO 470 I=I1,NS
- INCL=0
- IORIG=I
- 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
- IORIG=K(IORIG,3)
- IF(IORIG.GT.LPIN) GOTO 460
- IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
- 470 CONTINUE
- ELSE
- CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
- ENDIF
- IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
- P(IS(2),3)=0D0
- P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
- ELSEIF(IL.EQ.2) THEN
- CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
- ELSEIF(IDISXQ.EQ.1) THEN
- DO 490 I=I1,NS
- INCL=0
- IORIG=I
- 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
- IORIG=K(IORIG,3)
- IF(IORIG.GT.LPIN) GOTO 480
- IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
- 490 CONTINUE
- ELSE
- CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
- ENDIF
-
-C...Final check that energy-momentum conservation worked.
- PESUM=0D0
- PZSUM=0D0
- DO 500 I=MINT(84)+1,N
- IF(K(I,1).GT.10) GOTO 500
- PESUM=PESUM+P(I,4)
- PZSUM=PZSUM+P(I,3)
- 500 CONTINUE
- PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
- IF(PDEV.GT.1D-4*VINT(1)) THEN
- MINT(51)=1
- MINT(57)=MINT(57)+1
- RETURN
- ENDIF
-
-C...Calculate rotation and boost from overall CM frame to
-C...hadronic CM frame in leptoproduction.
- MINT(91)=0
- IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
- MINT(91)=1
- LESD=1
- IF(MINT(42).EQ.1) LESD=2
- LPIN=MINT(83)+3-LESD
-
-C...Sum upp momenta of everything not lepton or photon to define boost.
- DO 510 J=1,4
- PSUM(J)=0D0
- 510 CONTINUE
- DO 530 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
- IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
- IF(K(I,2).EQ.22) GOTO 530
- DO 520 J=1,4
- PSUM(J)=PSUM(J)+P(I,J)
- 520 CONTINUE
- 530 CONTINUE
- VINT(223)=-PSUM(1)/PSUM(4)
- VINT(224)=-PSUM(2)/PSUM(4)
- VINT(225)=-PSUM(3)/PSUM(4)
-
-C...Boost incoming hadron to hadronic CM frame to determine rotations.
- K(N+1,1)=1
- DO 540 J=1,5
- P(N+1,J)=P(LPIN,J)
- V(N+1,J)=V(LPIN,J)
- 540 CONTINUE
- CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
- VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
- CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
- IF(LESD.EQ.2) THEN
- VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
- ELSE
- VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
- ENDIF
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYMIGN
-C...Initializes treatment of new multiple interactions scenario,
-C...selects kinematics of hardest interaction if low-pT physics
-C...included in run, and generates all non-hardest interactions.
-
- SUBROUTINE PYMIGN(MMUL)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
- EXTERNAL PYALPS
- DOUBLE PRECISION PYALPS
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
- COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
- & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
- & XMI(2,240),PT2MI(240),IMISEP(0:240)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
- &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
-C...Local arrays and saved variables.
- DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
- &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
- SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
- &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
- &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
-
-C...Initialization of multiple interaction treatment.
- IF(MMUL.EQ.1) THEN
- IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
- ISUB=96
- MINT(1)=96
- VINT(63)=0D0
- VINT(64)=0D0
- VINT(143)=1D0
- VINT(144)=1D0
-
-C...Loop over phase space points: xT2 choice in 20 bins.
- 100 SIGSUM=0D0
- DO 120 IXT2=1,20
- NMUL(IXT2)=MSTP(83)
- SIGM(IXT2)=0D0
- DO 110 ITRY=1,MSTP(83)
- RSCA=0.05D0*((21-IXT2)-PYR(0))
- XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
- XT2=MAX(0.01D0*VINT(149),XT2)
- VINT(25)=XT2
-
-C...Choose tau and y*. Calculate cos(theta-hat).
- IF(PYR(0).LE.COEF(ISUB,1)) THEN
- TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
- TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
- ELSE
- TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
- ENDIF
- VINT(21)=TAU
- CALL PYKLIM(2)
- RYST=PYR(0)
- MYST=1
- IF(RYST.GT.COEF(ISUB,8)) MYST=2
- IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
- CALL PYKMAP(2,MYST,PYR(0))
- VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
-
-C...Calculate differential cross-section.
- VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
- CALL PYSIGH(NCHN,SIGS)
- SIGM(IXT2)=SIGM(IXT2)+SIGS
- 110 CONTINUE
- SIGSUM=SIGSUM+SIGM(IXT2)
- 120 CONTINUE
- SIGSUM=SIGSUM/(20D0*MSTP(83))
-
-C...Reject result if sigma(parton-parton) is smaller than hadronic one.
- IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
- IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
- & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
- PARP(82)=0.9D0*PARP(82)
- VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
- & VINT(2)
- GOTO 100
- ENDIF
- IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
- & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
-
-C...Start iteration to find k factor.
- YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
- P83A=(1D0-PARP(83))**2
- P83B=2D0*PARP(83)*(1D0-PARP(83))
- P83C=PARP(83)**2
- CQ2I=1D0/PARP(84)**2
- CQ2R=2D0/(1D0+PARP(84)**2)
- SO=0.5D0
- XI=0D0
- YI=0D0
- XF=0D0
- YF=0D0
- XK=0.5D0
- IIT=0
- 130 IF(IIT.EQ.0) THEN
- XK=2D0*XK
- ELSEIF(IIT.EQ.1) THEN
- XK=0.5D0*XK
- ELSE
- XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
- ENDIF
-
-C...Evaluate overlap integrals. Find where to divide the b range.
- IF(MSTP(82).EQ.2) THEN
- SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
- SOP=SP/PARU(1)
- ELSE
- IF(MSTP(82).EQ.3) THEN
- DELTAB=0.02D0
- ELSEIF(MSTP(82).EQ.4) THEN
- DELTAB=MIN(0.01D0,0.05D0*PARP(84))
- ELSE
- POWIP=MAX(0.4D0,PARP(83))
- RPWIP=2D0/POWIP-1D0
- DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
- SO=0D0
- ENDIF
- SP=0D0
- SOP=0D0
- BSP=0D0
- SOHIGH=0D0
- IBDIV=0
- B=-0.5D0*DELTAB
- 140 B=B+DELTAB
- IF(MSTP(82).EQ.3) THEN
- OV=EXP(-B**2)/PARU(2)
- ELSEIF(MSTP(82).EQ.4) THEN
- OV=(P83A*EXP(-MIN(50D0,B**2))+
- & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
- & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
- ELSE
- OV=EXP(-B**POWIP)/PARU(2)
- SO=SO+PARU(2)*B*DELTAB*OV
- ENDIF
- IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
- PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
- SP=SP+PARU(2)*B*DELTAB*PACC
- SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
- BSP=BSP+B*PARU(2)*B*DELTAB*PACC
- IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
- IBDIV=1
- BDIV=B+0.5D0*DELTAB
- ENDIF
- IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
- ENDIF
- YK=PARU(1)*XK*SO/SP
-
-C...Continue iteration until convergence.
- IF(YK.LT.YKE) THEN
- XI=XK
- YI=YK
- IF(IIT.EQ.1) IIT=2
- ELSE
- XF=XK
- YF=YK
- IF(IIT.EQ.0) IIT=1
- ENDIF
- IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
-
-C...Store some results for subsequent use.
- BAVG=BSP/SP
- VINT(145)=SIGSUM
- VINT(146)=SOP/SO
- VINT(147)=SOP/SP
- VNT145=VINT(145)
- VNT146=VINT(146)
- VNT147=VINT(147)
-C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
- PIK=(VNT146/VNT147)*YKE
-
-C...Find relative weight for low and high impact parameter..
- PLOWB=PARU(1)*BDIV**2
- IF(MSTP(82).EQ.3) THEN
- PHIGHB=PIK*0.5*EXP(-BDIV**2)
- ELSEIF(MSTP(82).EQ.4) THEN
- S4A=P83A*EXP(-BDIV**2)
- S4B=P83B*EXP(-BDIV**2*CQ2R)
- S4C=P83C*EXP(-BDIV**2*CQ2I)
- PHIGHB=PIK*0.5*(S4A+S4B+S4C)
- ELSEIF(PARP(83).GE.1.999D0) THEN
- PHIGHB=PIK*SOHIGH
- B2RPDV=BDIV**POWIP
- ELSE
- PHIGHB=PIK*SOHIGH
- B2RPDV=BDIV**POWIP
- B2RPMX=MAX(2D0*RPWIP,B2RPDV)
- ENDIF
- PALLB=PLOWB+PHIGHB
-
-C...Initialize iteration in xT2 for hardest interaction.
- ELSEIF(MMUL.EQ.2) THEN
- VINT(145)=VNT145
- VINT(146)=VNT146
- VINT(147)=VNT147
- IF(MSTP(82).LE.0) THEN
- ELSEIF(MSTP(82).EQ.1) THEN
- XT2=1D0
- SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
- & VINT(317)/(VINT(318)*VINT(320))
- XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
- ELSEIF(MSTP(82).EQ.2) THEN
- XT2=1D0
- XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
- & VINT(149)*(1D0+VINT(149))
- ELSE
- XC2=4D0*CKIN(3)**2/VINT(2)
- IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
- ENDIF
-
-C...Select impact parameter for hardest interaction.
- IF(MSTP(82).LE.2) RETURN
- 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
-C...Treatment in low b region.
- MINT(39)=1
- B=BDIV*SQRT(PYR(0))
- IF(MSTP(82).EQ.3) THEN
- OV=EXP(-B**2)/PARU(2)
- ELSEIF(MSTP(82).EQ.4) THEN
- OV=(P83A*EXP(-MIN(50D0,B**2))+
- & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
- & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
- ELSE
- OV=EXP(-B**POWIP)/PARU(2)
- ENDIF
- VINT(148)=OV/VNT147
- PACC=1D0-EXP(-MIN(50D0,PIK*OV))
- XT2=1D0
- XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
- & VINT(149)*(1D0+VINT(149))
- ELSE
-C...Treatment in high b region.
- MINT(39)=2
- IF(MSTP(82).EQ.3) THEN
- B=SQRT(BDIV**2-LOG(PYR(0)))
- OV=EXP(-B**2)/PARU(2)
- ELSEIF(MSTP(82).EQ.4) THEN
- S4RNDM=PYR(0)*(S4A+S4B+S4C)
- IF(S4RNDM.LT.S4A) THEN
- B=SQRT(BDIV**2-LOG(PYR(0)))
- ELSEIF(S4RNDM.LT.S4A+S4B) THEN
- B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
- ELSE
- B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
- ENDIF
- OV=(P83A*EXP(-MIN(50D0,B**2))+
- & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
- & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
- ELSEIF(PARP(83).GE.1.999D0) THEN
- 144 B2RPW=B2RPDV-LOG(PYR(0))
- ACCIP=(B2RPW/B2RPDV)**RPWIP
- IF(ACCIP.LT.PYR(0)) GOTO 144
- OV=EXP(-B2RPW)/PARU(2)
- B=B2RPW**(1D0/POWIP)
- ELSE
- 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
- ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
- IF(ACCIP.LT.PYR(0)) GOTO 146
- OV=EXP(-B2RPW)/PARU(2)
- B=B2RPW**(1D0/POWIP)
- ENDIF
- VINT(148)=OV/VNT147
- PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
- ENDIF
- IF(PACC.LT.PYR(0)) GOTO 142
- VINT(139)=B/BAVG
-
- ELSEIF(MMUL.EQ.3) THEN
-C...Low-pT or multiple interactions (first semihard interaction):
-C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
-C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
- ISUB=MINT(1)
- VINT(145)=VNT145
- VINT(146)=VNT146
- VINT(147)=VNT147
- IF(MSTP(82).LE.0) THEN
- XT2=0D0
- ELSEIF(MSTP(82).EQ.1) THEN
- XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
-C...Use with "Sudakov" for low b values when impact parameter dependence.
- ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
- IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
- & VINT(149)))).GT.PYR(0)) XT2=1D0
- IF(XT2.GE.1D0) THEN
- XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
- & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
- & VINT(149)
- ELSE
- XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
- & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
- & VINT(149)
- ENDIF
- XT2=MAX(0.01D0*VINT(149),XT2)
-C...Use without "Sudakov" for high b values when impact parameter dep.
- ELSE
- XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
- & PYR(0)*(1D0-XC2))-VINT(149)
- XT2=MAX(0.01D0*VINT(149),XT2)
- ENDIF
- VINT(25)=XT2
-
-C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
- IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
- IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
- IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
- ISUB=95
- MINT(1)=ISUB
- VINT(21)=1D-12*VINT(149)
- VINT(22)=0D0
- VINT(23)=0D0
- VINT(25)=1D-12*VINT(149)
-
- ELSE
-C...Multiple interactions (first semihard interaction).
-C...Choose tau and y*. Calculate cos(theta-hat).
- IF(PYR(0).LE.COEF(ISUB,1)) THEN
- TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
- TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
- ELSE
- TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
- ENDIF
- VINT(21)=TAU
- CALL PYKLIM(2)
- RYST=PYR(0)
- MYST=1
- IF(RYST.GT.COEF(ISUB,8)) MYST=2
- IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
- CALL PYKMAP(2,MYST,PYR(0))
- VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
- ENDIF
- VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
-
-C...Store results of cross-section calculation.
- ELSEIF(MMUL.EQ.4) THEN
- ISUB=MINT(1)
- VINT(145)=VNT145
- VINT(146)=VNT146
- VINT(147)=VNT147
- XTS=VINT(25)
- IF(ISET(ISUB).EQ.1) XTS=VINT(21)
- IF(ISET(ISUB).EQ.2)
- & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
- IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
- RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
- & (XTS+VINT(149))))
- IRBIN=INT(1D0+20D0*RBIN)
- IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
- NMUL(IRBIN)=NMUL(IRBIN)+1
- SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
- ENDIF
-
-C...Choose impact parameter if not already done.
- ELSEIF(MMUL.EQ.5) THEN
- ISUB=MINT(1)
- VINT(145)=VNT145
- VINT(146)=VNT146
- VINT(147)=VNT147
- 150 IF(MINT(39).GT.0) THEN
- ELSEIF(MSTP(82).EQ.3) THEN
- EXPB2=PYR(0)
- B2=-LOG(PYR(0))
- VINT(148)=EXPB2/(PARU(2)*VNT147)
- VINT(139)=SQRT(B2)/BAVG
- ELSEIF(MSTP(82).EQ.4) THEN
- RTYPE=PYR(0)
- IF(RTYPE.LT.P83A) THEN
- B2=-LOG(PYR(0))
- ELSEIF(RTYPE.LT.P83A+P83B) THEN
- B2=-LOG(PYR(0))/CQ2R
- ELSE
- B2=-LOG(PYR(0))/CQ2I
- ENDIF
- VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
- & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
- & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
- VINT(139)=SQRT(B2)/BAVG
- ELSEIF(PARP(83).GE.1.999D0) THEN
- POWIP=MAX(2D0,PARP(83))
- RPWIP=2D0/POWIP-1D0
- PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
- 160 IF(PYR(0).LT.PROB1) THEN
- B2RPW=PYR(0)**(0.5D0*POWIP)
- ACCIP=EXP(-B2RPW)
- ELSE
- B2RPW=1D0-LOG(PYR(0))
- ACCIP=B2RPW**RPWIP
- ENDIF
- IF(ACCIP.LT.PYR(0)) GOTO 160
- VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
- VINT(139)=B2RPW**(1D0/POWIP)/BAVG
- ELSE
- POWIP=MAX(0.4D0,PARP(83))
- RPWIP=2D0/POWIP-1D0
- PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
- 170 IF(PYR(0).LT.PROB1) THEN
- B2RPW=2D0*RPWIP*PYR(0)
- ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
- ELSE
- B2RPW=2D0*(RPWIP-LOG(PYR(0)))
- ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
- ENDIF
- IF(ACCIP.LT .PYR(0)) GOTO 170
- VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
- VINT(139)=B2RPW**(1D0/POWIP)/BAVG
- ENDIF
-
-C...Multiple interactions (variable impact parameter) : reject with
-C...probability exp(-overlap*cross-section above pT/normalization).
-C...Does not apply to low-b region, where "Sudakov" already included.
- VINT(150)=1D0
- IF(MINT(39).NE.1) THEN
- RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
- SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
- DO 180 IBIN=IRBIN+1,20
- RNCOR=RNCOR+NMUL(IBIN)
- SIGCOR=SIGCOR+SIGM(IBIN)
- 180 CONTINUE
- SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
- IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
- VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
- & SIGABV/MAX(1D-10,SIGT(0,0,5))))
- ENDIF
- IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
- & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
- & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
- IF(VINT(150).LT.PYR(0)) GOTO 150
- VINT(150)=1D0
- ENDIF
-
-C...Generate additional multiple semihard interactions.
- ELSEIF(MMUL.EQ.6) THEN
-
-C...Save data for hardest initeraction, to be restored.
- ISUBSV=MINT(1)
- VINT(145)=VNT145
- VINT(146)=VNT146
- VINT(147)=VNT147
- M13SV=MINT(13)
- M14SV=MINT(14)
- M15SV=MINT(15)
- M16SV=MINT(16)
- M21SV=MINT(21)
- M22SV=MINT(22)
- DO 190 J=11,80
- VINTSV(J)=VINT(J)
- 190 CONTINUE
- V141SV=VINT(141)
- V142SV=VINT(142)
-
-C...Store data on hardest interaction.
- XMI(1,1)=VINT(141)
- XMI(2,1)=VINT(142)
- PT2MI(1)=VINT(54)
- IMISEP(0)=MINT(84)
- IMISEP(1)=N
-
-C...Change process to generate; sum of x values so far.
- ISUB=96
- MINT(1)=96
- VINT(143)=1D0-VINT(141)
- VINT(144)=1D0-VINT(142)
- VINT(151)=0D0
- VINT(152)=0D0
-
-C...Initialize factors for PDF reshaping.
- DO 230 JS=1,2
- KFBEAM=MINT(10+JS)
- KFABM=IABS(KFBEAM)
- KFSBM=ISIGN(1,KFBEAM)
-
-C...Zero flavour content of incoming beam particle.
- KFIVAL(JS,1)=0
- KFIVAL(JS,2)=0
- KFIVAL(JS,3)=0
-C...Flavour content of baryon.
- IF(KFABM.GT.1000) THEN
- KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
- KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
- KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
-C...Flavour content of pi+-, K+-.
- ELSEIF(KFABM.EQ.211) THEN
- KFIVAL(JS,1)=KFSBM*2
- KFIVAL(JS,2)=-KFSBM
- ELSEIF(KFABM.EQ.321) THEN
- KFIVAL(JS,1)=-KFSBM*3
- KFIVAL(JS,2)=KFSBM*2
-C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
- ENDIF
-
-C...Zero initial valence and companion content.
- DO 200 IFL=-6,6
- NVC(JS,IFL)=0
- 200 CONTINUE
-
-C...Initiate listing of all incoming partons from two sides.
- NMI(JS)=0
- DO 210 I=MINT(84)+1,N
- IF(K(I,3).EQ.MINT(83)+2+JS) THEN
- IMI(JS,1,1)=I
- IMI(JS,1,2)=0
- ENDIF
- 210 CONTINUE
-
-C...Decide whether quarks in hard scattering were valence or sea.
- IFL=K(IMI(JS,1,1),2)
- IF (IABS(IFL).GT.6) GOTO 230
-
-C...Get PDFs at X and Q2 of the parton shower initiator for the
-C...hard scattering.
- X=VINT(140+JS)
- IF(MSTP(61).GE.1) THEN
- Q2=PARP(62)**2
- ELSE
- Q2=VINT(54)
- ENDIF
-C...Note: XPSVC = x*pdf.
- MINT(30)=JS
- CALL PYPDFU(KFBEAM,X,Q2,XPQ)
- SEA=XPSVC(IFL,-1)
- VAL=XPSVC(IFL,0)
-
-C...Decide (Extra factor x cancels in the division).
- RVCS=PYR(0)*(SEA+VAL)
- IVNOW=1
- 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
-C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
- IVNOW=0
- IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
- IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
- IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
- IF(KFIVAL(JS,1).EQ.0) THEN
- IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
- IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
- IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
- & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
- ENDIF
- IF(IVNOW.EQ.0) GOTO 220
-C...Mark valence.
- IMI(JS,1,2)=0
-C...Sets valence content of gamma, pi0, K0S, K0L if not done.
- IF(KFIVAL(JS,1).EQ.0) THEN
- IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
- KFIVAL(JS,1)=IFL
- KFIVAL(JS,2)=-IFL
- ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
- KFIVAL(JS,1)=IFL
- IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
- IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
- ENDIF
- ENDIF
-
-C...If sea, add opposite sign companion parton. Store X and I.
- ELSE
- NVC(JS,-IFL)=NVC(JS,-IFL)+1
- XASSOC(JS,-IFL,NVC(JS,-IFL))=X
-C...Set pointer to companion
- IMI(JS,1,2)=-NVC(JS,-IFL)
- ENDIF
- 230 CONTINUE
-
-C...Update counter number of multiple interactions.
- NMI(1)=1
- NMI(2)=1
-
-C...Set up starting values for iteration in xT2.
- IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
- & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
- & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
- & ISUBSV.NE.96)) THEN
- XT2=(1D0-VINT(141))*(1D0-VINT(142))
- ELSE
- XT2=VINT(25)
- IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
- IF(ISET(ISUBSV).EQ.2)
- & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
- IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
- ENDIF
- IF(MSTP(82).LE.1) THEN
- SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
- & VINT(317)/(VINT(318)*VINT(320))
- XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
- ELSE
- XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
- & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
- ENDIF
- VINT(63)=0D0
- VINT(64)=0D0
-
-C...Iterate downwards in xT2.
- 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
- XT2=0D0
- GOTO 440
- ELSEIF(MSTP(82).LE.1) THEN
- XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
- IF(XT2.LT.VINT(149)) GOTO 440
- ELSE
- IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
- XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
- & LOG(PYR(0)))-VINT(149)
- IF(XT2.LE.0D0) GOTO 440
- XT2=MAX(0.01D0*VINT(149),XT2)
- ENDIF
- VINT(25)=XT2
-
-C...Choose tau and y*. Calculate cos(theta-hat).
- IF(PYR(0).LE.COEF(ISUB,1)) THEN
- TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
- TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
- ELSE
- TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
- ENDIF
- VINT(21)=TAU
-C...New: require shat > 1.
- IF(TAU*VINT(2).LT.1D0) GOTO 240
- CALL PYKLIM(2)
- RYST=PYR(0)
- MYST=1
- IF(RYST.GT.COEF(ISUB,8)) MYST=2
- IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
- CALL PYKMAP(2,MYST,PYR(0))
- VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
-
-C...Check that x not used up. Accept or reject kinematical variables.
- X1M=SQRT(TAU)*EXP(VINT(22))
- X2M=SQRT(TAU)*EXP(-VINT(22))
- IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
- VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
- CALL PYSIGH(NCHN,SIGS)
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
- IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
- IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
-
-C...Reset K, P and V vectors.
- DO 260 I=N+1,N+4
- DO 250 J=1,5
- K(I,J)=0
- P(I,J)=0D0
- V(I,J)=0D0
- 250 CONTINUE
- 260 CONTINUE
- PT=0.5D0*VINT(1)*SQRT(XT2)
-
-C...Choose flavour of reacting partons (and subprocess).
- RSIGS=SIGS*PYR(0)
- DO 270 ICHN=1,NCHN
- KFL1=ISIG(ICHN,1)
- KFL2=ISIG(ICHN,2)
- ICONMI=ISIG(ICHN,3)
- RSIGS=RSIGS-SIGH(ICHN)
- IF(RSIGS.LE.0D0) GOTO 280
- 270 CONTINUE
-
-C...Reassign to appropriate process codes.
- 280 ISUBMI=ICONMI/10
- ICONMI=MOD(ICONMI,10)
-
-C...Choose new quark flavour for annihilation graphs
- IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
- SH=TAU*VINT(2)
- CALL PYWIDT(21,SH,WDTP,WDTE)
- 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
- DO 300 I=1,MDCY(21,3)
- KFLF=KFDP(I+MDCY(21,2)-1,1)
- RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
- IF(RKFL.LE.0D0) GOTO 310
- 300 CONTINUE
- 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
- IF(KFLF.GE.4) GOTO 290
- ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
- KFLF=4
- ICONMI=ICONMI-2
- ELSEIF(ISUBMI.EQ.53) THEN
- KFLF=5
- ICONMI=ICONMI-4
- ENDIF
- ENDIF
-
-C...Final state flavours and colour flow: default values
- JS=1
- KFL3=KFL1
- KFL4=KFL2
- KCC=20
- KCS=ISIGN(1,KFL1)
-
- IF(ISUBMI.EQ.11) THEN
-C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
- KCC=ICONMI
- IF(KFL1*KFL2.LT.0) KCC=KCC+2
-
- ELSEIF(ISUBMI.EQ.12) THEN
-C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
- KFL3=ISIGN(KFLF,KFL1)
- KFL4=-KFL3
- KCC=4
-
- ELSEIF(ISUBMI.EQ.13) THEN
-C...f + fbar -> g + g; th arbitrary
- KFL3=21
- KFL4=21
- KCC=ICONMI+4
-
- ELSEIF(ISUBMI.EQ.28) THEN
-C...f + g -> f + g; th = (p(f)-p(f))**2
- IF(KFL1.EQ.21) JS=2
- KCC=ICONMI+6
- IF(KFL1.EQ.21) KCC=KCC+2
- IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
- IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
-
- ELSEIF(ISUBMI.EQ.53) THEN
-C...g + g -> f + fbar; th arbitrary
- KCS=(-1)**INT(1.5D0+PYR(0))
- KFL3=ISIGN(KFLF,KCS)
- KFL4=-KFL3
- KCC=ICONMI+10
-
- ELSEIF(ISUBMI.EQ.68) THEN
-C...g + g -> g + g; th arbitrary
- KCC=ICONMI+12
- KCS=(-1)**INT(1.5D0+PYR(0))
- ENDIF
-
-C...Store flavours of scattering.
- MINT(13)=KFL1
- MINT(14)=KFL2
- MINT(15)=KFL1
- MINT(16)=KFL2
- MINT(21)=KFL3
- MINT(22)=KFL4
-
-C...Set flavours and mothers of scattering partons.
- K(N+1,1)=14
- K(N+2,1)=14
- K(N+3,1)=3
- K(N+4,1)=3
- K(N+1,2)=KFL1
- K(N+2,2)=KFL2
- K(N+3,2)=KFL3
- K(N+4,2)=KFL4
- K(N+1,3)=MINT(83)+1
- K(N+2,3)=MINT(83)+2
- K(N+3,3)=N+1
- K(N+4,3)=N+2
-
-C...Store colour connection indices.
- DO 320 J=1,2
- JC=J
- IF(KCS.EQ.-1) JC=3-J
- IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
- IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
- IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
- IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
- 320 CONTINUE
-
-C...Store incoming and outgoing partons in their CM-frame.
- SHR=SQRT(TAU)*VINT(1)
- P(N+1,3)=0.5D0*SHR
- P(N+1,4)=0.5D0*SHR
- P(N+2,3)=-0.5D0*SHR
- P(N+2,4)=0.5D0*SHR
- P(N+3,5)=PYMASS(K(N+3,2))
- P(N+4,5)=PYMASS(K(N+4,2))
- IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
- P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
- P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
- P(N+4,4)=SHR-P(N+3,4)
- P(N+4,3)=-P(N+3,3)
-
-C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
- PHI=PARU(2)*PYR(0)
- CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
-
-C...Set up default values before showers.
- MINT(31)=MINT(31)+1
- IPU1=N+1
- IPU2=N+2
- IPU3=N+3
- IPU4=N+4
- VINT(141)=VINT(41)
- VINT(142)=VINT(42)
- N=N+4
-
-C...Showering of initial state partons (optional).
-C...Note: no showering of final state partons here; it comes later.
- IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
- MINT(51)=0
- ALAMSV=PARJ(81)
- PARJ(81)=PARP(72)
- NSAV=N
- DO 340 I=1,4
- DO 330 J=1,5
- KSAV(I,J)=K(N-4+I,J)
- PSAV(I,J)=P(N-4+I,J)
- 330 CONTINUE
- 340 CONTINUE
- CALL PYSSPA(IPU1,IPU2)
- PARJ(81)=ALAMSV
-C...If shower failed then restore to situation before shower.
- IF(MINT(51).GE.1) THEN
- N=NSAV
- DO 360 I=1,4
- DO 350 J=1,5
- K(N-4+I,J)=KSAV(I,J)
- P(N-4+I,J)=PSAV(I,J)
- 350 CONTINUE
- 360 CONTINUE
- IPU1=N-3
- IPU2=N-2
- VINT(141)=VINT(41)
- VINT(142)=VINT(42)
- ENDIF
- ENDIF
-
-C...Keep track of loose colour ends and information on scattering.
- 370 IMI(1,MINT(31),1)=IPU1
- IMI(2,MINT(31),1)=IPU2
- IMI(1,MINT(31),2)=0
- IMI(2,MINT(31),2)=0
- XMI(1,MINT(31))=VINT(141)
- XMI(2,MINT(31))=VINT(142)
- PT2MI(MINT(31))=VINT(54)
- IMISEP(MINT(31))=N
-
-C...Decide whether quarks in last scattering were valence, companion or
-C...sea.
- DO 430 JS=1,2
- KFBEAM=MINT(10+JS)
- KFSBM=ISIGN(1,MINT(10+JS))
- IFL=K(IMI(JS,MINT(31),1),2)
- IMI(JS,MINT(31),2)=0
- IF (IABS(IFL).GT.6) GOTO 430
-
-C...Get PDFs at X and Q2 of the parton shower initiator for the
-C...last scattering. At this point VINT(143:144) do not yet
-C...include the scattered x values VINT(141:142).
- X=VINT(140+JS)/VINT(142+JS)
- IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
- Q2=PARP(62)**2
- ELSE
- Q2=VINT(54)
- ENDIF
-C...Note: XPSVC = x*pdf.
- MINT(30)=JS
- CALL PYPDFU(KFBEAM,X,Q2,XPQ)
- SEA=XPSVC(IFL,-1)
- VAL=XPSVC(IFL,0)
- CMP=0D0
- DO 380 IVC=1,NVC(JS,IFL)
- CMP=CMP+XPSVC(IFL,IVC)
- 380 CONTINUE
-
-C...Decide (Extra factor x cancels in the dvision).
- RVCS=PYR(0)*(SEA+VAL+CMP)
- IVNOW=1
- 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
-C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
- IVNOW=0
- IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
- IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
- IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
- IF(KFIVAL(JS,1).EQ.0) THEN
- IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
- IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
- IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
- & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
- ELSE
- DO 400 I1=1,NMI(JS)
- IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
- & IVNOW=IVNOW-1
- 400 CONTINUE
- ENDIF
- IF(IVNOW.EQ.0) GOTO 390
-C...Mark valence.
- IMI(JS,MINT(31),2)=0
-C...Sets valence content of gamma, pi0, K0S, K0L if not done.
- IF(KFIVAL(JS,1).EQ.0) THEN
- IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
- KFIVAL(JS,1)=IFL
- KFIVAL(JS,2)=-IFL
- ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
- KFIVAL(JS,1)=IFL
- IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
- IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
- ENDIF
- ENDIF
-
- ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
-C...If sea, add opposite sign companion parton. Store X and I.
- NVC(JS,-IFL)=NVC(JS,-IFL)+1
- XASSOC(JS,-IFL,NVC(JS,-IFL))=X
-C...Set pointer to companion
- IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
- ELSE
-C...If companion, decide which one.
- CMPSUM=VAL+SEA
- ISEL=0
- 410 ISEL=ISEL+1
- CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
- IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
-C...Find original sea (anti-)quark:
- IASSOC=0
- DO 420 I1=1,NMI(JS)
- IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
- IF (-IMI(JS,I1,2).EQ.ISEL) THEN
- IMI(JS,MINT(31),2)=IMI(JS,I1,1)
- IMI(JS,I1,2)=IMI(JS,MINT(31),1)
- ENDIF
- 420 CONTINUE
-C...Change X to what associated companion had, so that the correct
-C...amount of momentum can be subtracted from the companion sum below.
- X=XASSOC(JS,IFL,ISEL)
-C...Mark companion read.
- XASSOC(JS,IFL,ISEL)=0D0
- ENDIF
- 430 CONTINUE
-
-C...Global statistics.
- MINT(351)=MINT(351)+1
- VINT(351)=VINT(351)+PT
- IF (MINT(351).EQ.1) VINT(356)=PT
-
-C...Update remaining energy and other counters.
- IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
- CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
- MINT(51)=1
- RETURN
- ENDIF
- NMI(1)=NMI(1)+1
- NMI(2)=NMI(2)+1
- VINT(151)=VINT(151)+VINT(41)
- VINT(152)=VINT(152)+VINT(42)
- VINT(143)=VINT(143)-VINT(141)
- VINT(144)=VINT(144)-VINT(142)
-
-C...Iterate, with more interactions allowed.
- IF(MINT(31).LT.240) GOTO 240
- 440 CONTINUE
-
-C...Restore saved quantities for hardest interaction.
- MINT(1)=ISUBSV
- MINT(13)=M13SV
- MINT(14)=M14SV
- MINT(15)=M15SV
- MINT(16)=M16SV
- MINT(21)=M21SV
- MINT(22)=M22SV
- DO 450 J=11,80
- VINT(J)=VINTSV(J)
- 450 CONTINUE
- VINT(141)=V141SV
- VINT(142)=V142SV
-
- ENDIF
-
-C...Format statements for printout.
- 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
- &'actions for MSTP(82) =',I2,' ******')
- 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
- &D9.2,' mb: rejected')
- 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
- &D9.2,' mb: accepted')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYMIHK
-C...Finds left-behind remnant flavour content and hooks up
-C...the colour flow between the hard scattering and remnants
-
- SUBROUTINE PYMIHK
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...The event record
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
-C...Parameters
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
-C...The common block of dangling ends
- COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
- & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
- & XMI(2,240),PT2MI(240),IMISEP(0:240)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
-C...Local variables
- PARAMETER (NERSIZ=4000)
- COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
- & ,MACCPT
- COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
- SAVE /PYCBLS/,/PYCTAG/
- DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
- & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
- DATA NERRPR/0/
- SAVE NERRPR
- FOUR(I,J)=P(I,4)*P(J,4)-P(I,3)*P(J,3)-P(I,2)*P(J,2)-P(I,1)*P(J,1)
-
-C...Set up error checkers
- IBOOST=0
-
-C...Initialize colour arrays: MCO (Original) and MCT (New)
- DO 110 I=MINT(84)+1,NERSIZ
- DO 100 JC=1,2
- MCT(I,JC)=0
- MCO(I,JC)=0
- 100 CONTINUE
-C...Also zero colour tracing information, if existed.
- IF (I.LE.N) THEN
- K(I,4)=MOD(K(I,4),MSTU(5)**2)
- K(I,5)=MOD(K(I,5),MSTU(5)**2)
- ENDIF
- 110 CONTINUE
-
-C...Initialize colour tag collapse arrays:
-C...JCCO (Original) and JCCN (New).
- DO 130 MG=MINT(84)+1,NERSIZ
- DO 120 JC=1,2
- JCCO(MG,JC)=0
- JCCN(MG,JC)=0
- 120 CONTINUE
- 130 CONTINUE
-
-C...Zero gluon insertion array
- DO 150 IM=1,1000
- DO 140 J=1,3
- INSR(IM,J)=0
- 140 CONTINUE
- 150 CONTINUE
-
-C...Compute hard scattering system rapidities
- IF (MSTP(89).EQ.1) THEN
- DO 160 IM=1,240
- IF (IM.LE.MINT(31)) THEN
- YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
- ELSE
-C...Set (unsigned) rapidity = 100 for beam remnant systems.
- YMI(IM)=100D0
- ENDIF
- 160 CONTINUE
- ENDIF
-
-C...Treat each side separately
- DO 290 JS=1,2
-
-C...Initialize side.
- NG(JS)=0
- JV=0
- KFS=ISIGN(1,MINT(10+JS))
-
-C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
- IF(KFIVAL(JS,1).EQ.0) THEN
- IF(MINT(10+JS).EQ.111) THEN
- KFIVAL(JS,1)=INT(1.5D0+PYR(0))
- KFIVAL(JS,2)=-KFIVAL(JS,1)
- ELSEIF(MINT(10+JS).EQ.22) THEN
- PYRKF=PYR(0)
- KFIVAL(JS,1)=1
- IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
- IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
- IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
- KFIVAL(JS,2)=-KFIVAL(JS,1)
- ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
- IF(PYR(0).GT.0.5D0) THEN
- KFIVAL(JS,1)=1
- KFIVAL(JS,2)=-3
- ELSE
- KFIVAL(JS,1)=3
- KFIVAL(JS,2)=-1
- ENDIF
- ENDIF
- ENDIF
-
-C...Initialize beam remnant sea and valence content flavour by flavour.
- NVSUM(JS)=0
- NBRTOT(JS)=0
- DO 210 JFA=1,6
-C...Count up original number of JFA valence quarks and antiquarks.
- NVALQ=0
- NVALQB=0
- NSEA=0
- DO 170 J=1,3
- IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
- IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
- 170 CONTINUE
- NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
-C...Subtract kicked out valence and determine sea from flavour cons.
- DO 180 IM=1,NMI(JS)
- IFL = K(IMI(JS,IM,1),2)
- IFA = IABS(IFL)
- IFS = ISIGN(1,IFL)
- IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
-C...Subtract K.O. valence quark from remainder.
- NVALQ=NVALQ-1
- JV=NVSUM(JS)-NVALQ-NVALQB
- IV(JS,JV)=IMI(JS,IM,1)
- ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
-C...Subtract K.O. valence antiquark from remainder.
- NVALQB=NVALQB-1
- JV=NVSUM(JS)-NVALQ-NVALQB
- IV(JS,JV)=IMI(JS,IM,1)
- ELSEIF (IFA.EQ.JFA) THEN
-C...Outside sea without companion: add opposite sea flavour inside.
- IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
- ENDIF
- 180 CONTINUE
-C...Check if space left in PYJETS for additional BR flavours
- NFLSUM=IABS(NSEA)+NVALQ+NVALQB
- NBRTOT(JS)=NBRTOT(JS)+NFLSUM
- IF (N+NFLSUM+1.GT.MSTU(4)) THEN
- CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
- MINT(51)=1
- RETURN
- ENDIF
-C...Add required val+sea content to beam remnant.
- IF (NFLSUM.GT.0) THEN
- DO 200 IA=1,NFLSUM
-C...Insert beam remnant quark as p.t. symbolic parton in ER.
- N=N+1
- DO 190 IX=1,5
- K(N,IX)=0
- P(N,IX)=0D0
- V(N,IX)=0D0
- 190 CONTINUE
- K(N,1)=3
- K(N,2)=ISIGN(JFA,NSEA)
- IF (IA.LE.NVALQ) K(N,2)=JFA
- IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
- K(N,3)=MINT(83)+JS
-C...Also update NMI, IMI, and IV arrays.
- NMI(JS)=NMI(JS)+1
- IMI(JS,NMI(JS),1)=N
- IMI(JS,NMI(JS),2)=-1
- IF (IA.LE.NVALQ+NVALQB) THEN
- IMI(JS,NMI(JS),2)=0
- JV=JV+1
- IV(JS,JV)=IMI(JS,NMI(JS),1)
- ENDIF
- 200 CONTINUE
- ENDIF
- 210 CONTINUE
-
- IM=0
- 220 IM=IM+1
- IF (IM.LE.NMI(JS)) THEN
- IF (K(IMI(JS,IM,1),2).EQ.21) THEN
- NG(JS)=NG(JS)+1
-C...Add fictitious parent gluons for companion pairs.
- ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
-C...Randomly assign companions to sea quarks which have none.
- IF (IMI(JS,IM,2).LT.0) THEN
- IMC=PYR(0)*NMI(JS)
- 230 IMC=MOD(IMC,NMI(JS))+1
- IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
- IF (IMI(JS,IMC,2).GE.0) GOTO 230
- IMI(JS, IM,2) = IMI(JS,IMC,1)
- IMI(JS,IMC,2) = IMI(JS, IM,1)
- ENDIF
-C...Add fictitious parent gluon
- N=N+1
- DO 240 IX=1,5
- K(N,IX)=0
- P(N,IX)=0D0
- V(N,IX)=0D0
- 240 CONTINUE
- K(N,1)=14
- K(N,2)=21
- K(N,3)=MINT(83)+JS
-C...Set gluon (anti-)colour daughter pointers
- K(N,4)=IMI(JS, IM,1)
- K(N,5)=IMI(JS, IM,2)
-C...Set quark (anti-)colour parent pointers
- K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
- K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
-C...Add gluon to IMI
- NMI(JS)=NMI(JS)+1
- IMI(JS,NMI(JS),1)=N
- IMI(JS,NMI(JS),2)=0
- ENDIF
- GOTO 220
- ENDIF
-
-C...If incoming (anti-)baryon, insert inside (anti-)junction.
-C...Set up initial v-v-j-v configuration. Otherwise set up
-C...mesonic v-vbar configuration
- IF (IABS(MINT(10+JS)).GT.1000) THEN
-C...Determine junction type (1: B=1 2: B=-1)
- ITJUNC(JS) = (3-KFS)/2
-C...Insert junction.
- N=N+1
- DO 250 IX=1,5
- K(N,IX)=0
- P(N,IX)=0D0
- V(N,IX)=0D0
- 250 CONTINUE
-C...Set special junction codes:
- K(N,1)=42
- K(N,2)=88
-C...Set parent to side.
- K(N,3)=MINT(83)+JS
- K(N,4)=ITJUNC(JS)*MSTU(5)
- K(N,5)=0
-C...Connect valence quarks to junction.
- MOUT(JS)=0
- MANTI=ITJUNC(JS)-1
-C...Set (anti)colour mother = junction.
- DO 260 JV=1,3
- K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
- & +MSTU(5)*N
-C...Keep track of partons adjacent to junction:
- JST(JS,JV)=IV(JS,JV)
- 260 CONTINUE
- ELSE
-C...Mesons: set up initial q-qbar topology
- ITJUNC(JS)=0
- IF (K(IV(JS,1),2).GT.0) THEN
- IQ=IV(JS,1)
- IQBAR=IV(JS,2)
- ELSE
- IQ=IV(JS,2)
- IQBAR=IV(JS,1)
- ENDIF
- IV(JS,3)=0
- JST(JS,1)=IQ
- JST(JS,2)=IQBAR
- JST(JS,3)=0
- K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
- K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
-C...Special for mesons. Insert gluon if BR empty.
- IF (NBRTOT(JS).EQ.0) THEN
- N=N+1
- DO 270 IX=1,5
- K(N,IX)=0
- P(N,IX)=0D0
- V(N,IX)=0D0
- 270 CONTINUE
- K(N,1)=3
- K(N,2)=21
- K(N,3)=MINT(83)+JS
- K(N,4)=0
- K(N,5)=0
- NBRTOT(JS)=1
- NG(JS)=NG(JS)+1
-C...Add gluon to IMI
- NMI(JS)=NMI(JS)+1
- IMI(JS,NMI(JS),1)=N
- IMI(JS,NMI(JS),2)=0
- ENDIF
- MOUT(JS)=0
- ENDIF
-
-C...Count up number of valence quarks outside BR.
- DO 280 JV=1,3
- IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
- & MOUT(JS)=MOUT(JS)+1
- 280 CONTINUE
-
- 290 CONTINUE
-
-C...Now both sides have been prepared in an initial vvjv (baryonic) or
-C...v(g)vbar (mesonic) configuration.
-
-C...Create colour line tags starting from initiators.
- NCT=0
- DO 320 IM=1,MINT(31)
-C...Consider each side in turn.
- DO 310 JS=1,2
- I1=IMI(JS,IM,1)
- I2=IMI(3-JS,IM,1)
- DO 300 JCS=4,5
- IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
- & GOTO 300
- IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
-
- KCS=JCS
- CALL PYCTTR(I1,KCS,I2)
- IF(MINT(51).NE.0) RETURN
-
- 300 CONTINUE
- 310 CONTINUE
- 320 CONTINUE
-
- DO 340 JS=1,2
-C...Create colour tags for beam remnant partons.
- DO 330 IM=MINT(31)+1,NMI(JS)
- IP=IMI(JS,IM,1)
- IF (K(IP,2).NE.21) THEN
- JC=(3-ISIGN(1,K(IP,2)))/2
- IF (MCT(IP,JC).EQ.0) THEN
- NCT=NCT+1
- MCT(IP,JC)=NCT
- ENDIF
- ELSE
-C...Gluons
- ICD=K(IP,4)
- IAD=K(IP,5)
- IF (ICD.NE.0) THEN
-C...Fictituous gluons just inherit from their quark daughters.
- ICC=MCT(ICD,1)
- IAC=MCT(IAD,2)
- ELSE
-C...Real beam remnant gluons get their own colours
- ICC=NCT+1
- IAC=NCT+2
- NCT=NCT+2
- ENDIF
- MCT(IP,1)=ICC
- MCT(IP,2)=IAC
- ENDIF
- 330 CONTINUE
- 340 CONTINUE
-
-C...Create colour tags for colour lines which are detached from the
-C...initial state.
-
- DO 360 MQGST=1,2
- DO 350 I=MINT(84)+1,N
-
-C...Look for coloured string endpoint, or (later) leftover gluon.
- IF (K(I,1).NE.3) GOTO 350
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0) GOTO 350
- KQ=KCHG(KC,2)
- IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
-
-C...Pick up loose string end with no previous tag.
- KCS=4
- IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
- IF(MCT(I,KCS-3).NE.0) GOTO 350
-
- CALL PYCTTR(I,KCS,I)
- IF(MINT(51).NE.0) RETURN
-
- 350 CONTINUE
- 360 CONTINUE
-
-C...Store original colour tags
- DO 370 I=MINT(84)+1,N
- MCO(I,1)=MCT(I,1)
- MCO(I,2)=MCT(I,2)
- 370 CONTINUE
-
-C...Iteratively add gluons to already existing string pieces, enforcing
-C...various possible orderings, and rejecting insertions that would give
-C...rise to singlet gluons.
-C...<kappa tau> normalization.
- RM0=1.5D0
- MRETRY=0
- PARP80=PARP(80)
-
-C...Set up simplified kinematics.
-C...Boost hard interaction systems.
- IBOOST=IBOOST+1
- DO 380 IM=1,MINT(31)
- BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
- CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
- 380 CONTINUE
-C...Assign preliminary beam remnant momenta.
- DO 390 I=MINT(53)+1,N
- JS=K(I,3)
- P(I,1)=0D0
- P(I,2)=0D0
- IF (K(I,2).NE.88) THEN
- P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
- P(I,3)=P(I,4)
- IF (JS.EQ.2) P(I,3)=-P(I,3)
- ELSE
-C...Junctions are wildcards for the present.
- P(I,4)=0D0
- P(I,3)=0D0
- ENDIF
- 390 CONTINUE
-
-C...Reset colour processing information.
- 400 DO 410 I=MINT(84)+1,N
- K(I,4)=MOD(K(I,4),MSTU(5)**2)
- K(I,5)=MOD(K(I,5),MSTU(5)**2)
- 410 CONTINUE
-
- NCC=0
- DO 430 JS=1,2
-C...If meson, without gluon in BR, collapse q-qbar colour tags:
- IF (ITJUNC(JS).EQ.0) THEN
- JC1=MCT(JST(JS,1),1)
- JC2=MCT(JST(JS,2),2)
- NCC=NCC+1
- JCCO(NCC,1)=MAX(JC1,JC2)
- JCCO(NCC,2)=MIN(JC1,JC2)
-C...Collapse colour tags in event record
- DO 420 I=MINT(84)+1,N
- IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
- IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
- 420 CONTINUE
- ENDIF
- 430 CONTINUE
-
- 440 JS=1
- IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
- IF (NG(JS).GT.0) THEN
- NOPT=0
- RLOPT=1D9
-C...Start at random gluon (optimizes speed for random attachments)
- NMGL=0
- IMGL=PYR(0)*NMI(JS)+1
- 450 IMGL=MOD(IMGL,NMI(JS))+1
- NMGL=NMGL+1
-C...Only loop through NMI once (with upper limit to save time)
- IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
- IGL = IMI(JS,IMGL,1)
-C...If not gluon or if already connected, try next.
- IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
- & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
-C...Now loop through all possible insertions of this gluon.
- NMP1=0
- IMP1=PYR(0)*NMI(JS)+1
- 460 IMP1=MOD(IMP1,NMI(JS))+1
- NMP1=NMP1+1
- IF (IMP1.EQ.IMGL) GOTO 460
-C...Only loop through NMI once (with upper limit to save time).
- IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
- IP1 = IMI(JS,IMP1,1)
-C...Try both colour mother and colour anti-mother.
-C...Randomly select which one to try first.
- NANTI=0
- MANTI=PYR(0)*2
- 470 MANTI=MOD(MANTI+1,2)
- NANTI=NANTI+1
- IF (NANTI.LE.2) THEN
- IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
-C...Reject if no appropriate mother (or if mother is fictitious
-C...parent gluon.)
- IF (IP2.LE.0) GOTO 470
- IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
-C...Also reject if this link has already been tried.
- IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
- IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
-C...Set flag to indicate that this link has now been tried for this
-C...gluon. IP2 may be junction, which has several mothers.
- K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
- IF (K(IP2,2).NE.88) THEN
- K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
- ENDIF
-
-C...JCG1: Original colour tag of gluon on IP1 side
-C...JCG2: Original colour tag of gluon on IP2 side
-C...JCP1: Original colour tag of IP1 on gluon side
-C...JCP2: Original colour tag of IP2 on gluon side.
- JCG1=MCO(IGL,2-MANTI)
- JCG2=MCO(IGL,1+MANTI)
- JCP1=MCO(IP1,1+MANTI)
- JCP2=MCO(IP2,2-MANTI)
-
- CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
-C...Reject gluon attachments that give rise to singlet gluons.
- IF (MACCPT.EQ.0) GOTO 470
-
-C...Update colours
- JCG1=MCT(IGL,2-MANTI)
- JCG2=MCT(IGL,1+MANTI)
- JCP1=MCT(IP1,1+MANTI)
- JCP2=MCT(IP2,2-MANTI)
-
-C...Select whether to accept this insertion
- IF (MSTP(89).EQ.0) THEN
-C...Random insertions: no measure.
- RL=1D0
-C...For random ordering, we want to suppress beam remnant breakups
-C...already at this point.
- IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
- & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
- NMP1=0
- NMGL=0
- GOTO 470
- ENDIF
- ELSEIF (MSTP(89).EQ.1) THEN
-C...Rapidity ordering:
-C...YGL = Rapidity of gluon.
- YGL=YMI(IMGL)
-C...If fictitious gluon
- IF (YGL.EQ.100D0) THEN
- YGL=(3-2*JS)*100D0
- IDA1=MOD(K(IGL,4),MSTU(5))
- IDA2=MOD(K(IGL,5),MSTU(5))
- DO 480 IMT=1,NMI(JS)
-C...Select (arbitrarily) the most central daughter.
- IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
- & THEN
- IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
- ENDIF
- 480 CONTINUE
- ENDIF
-C...YP1 = Rapidity IP1
- YP1=YMI(IMP1)
-C...If fictitious gluon
- IF (YP1.EQ.100D0) THEN
- YP1=(3-2*JS)*YP1
- IDA1=MOD(K(IP1,4),MSTU(5))
- IDA2=MOD(K(IP1,5),MSTU(5))
- DO 490 IMT=1,NMI(JS)
-C...Select (arbitrarily) the most central daughter.
- IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
- & THEN
- IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
- ENDIF
- 490 CONTINUE
- ENDIF
-C...YP2 = Rapidity of mother system
- IF (K(IP2,2).NE.88) THEN
- DO 500 IMT=1,NMI(JS)
- IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
- 500 CONTINUE
-C...If fictitious gluon
- IF (YP2.EQ.100D0) THEN
- YP2=(3-2*JS)*YP2
- IDA1=MOD(K(IP2,4),MSTU(5))
- IDA2=MOD(K(IP2,5),MSTU(5))
- DO 510 IMT=1,NMI(JS)
-C...Select (arbitrarily) the most central daughter.
- IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
- & ) THEN
- IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
- ENDIF
- 510 CONTINUE
- ENDIF
-C...Assign (arbitrarily) 100D0 to junction also
- ELSE
- YP2=(3-2*JS)*100D0
- ENDIF
- RL=ABS(YGL-YP1)+ABS(YGL-YP2)
- ELSEIF (MSTP(89).EQ.2) THEN
-C...Lambda ordering:
-C...Compute lambda measure for this insertion.
- RL=1D0
- DO 520 IST=1,6
- ISTR(IST)=0
- 520 CONTINUE
-C...If IP2 is junction, not caught below.
- IF (JCP2.EQ.0) THEN
- ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
-C...Anti-junction is colour endpoint et vv., always on JCG2.
- ISTR(5-ITJU)=IP2
- ENDIF
- DO 530 I=MINT(84)+1,N
- IF (K(I,1).LT.10) THEN
-C...The new string pieces
- IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
- IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
- IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
- IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
- ENDIF
- 530 CONTINUE
-C...Also identify junctions as string endpoints.
- DO 540 I=MINT(84)+1,N
- ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
- IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
-C...Find partons adjacent to junctions.
- IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
- & .EQ.0) ISTR(2) = ICMO
- IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
- & .EQ.0) ISTR(1) = IAMO
- IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
- & .EQ.0) ISTR(4) = ICMO
- IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
- & .EQ.0) ISTR(3) = IAMO
- 540 CONTINUE
-C...The old string piece
- ISTR(5)=ISTR(1+2*MANTI)
- ISTR(6)=ISTR(4-2*MANTI)
- RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
- & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
- RL=LOG(RL)
- ENDIF
-C...Allow some breadth to speed things up.
- IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
- NOPT=NOPT+1
- ELSEIF (RL.GT.RLOPT) THEN
- GOTO 470
- ELSE
- NOPT=1
- RLOPT=RL
- ENDIF
-C...INSR(NOPT,1)=Gluon colour mother
-C...INSR(NOPT,2)=Gluon
-C...INSR(NOPT,3)=Gluon anticolour mother
- IF (NOPT.GT.1000) GOTO 470
- INSR(NOPT,1+2*MANTI)=IP2
- INSR(NOPT,2)=IGL
- INSR(NOPT,3-2*MANTI)=IP1
- IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
- ENDIF
- IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
- ENDIF
-C...Reset link test information.
- DO 550 I=MINT(84)+1,N
- K(I,4)=MOD(K(I,4),MSTU(5)**2)
- K(I,5)=MOD(K(I,5),MSTU(5)**2)
- 550 CONTINUE
- IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
- ENDIF
-C...Now we have a list of best gluon insertions, none of which cause
-C...singlets to arise. If list is empty, try again a few times. Note:
-C...this should never happen if we have a meson with a gluon inserted
-C...in the beam remnant, since that breaks up the colour line.
- IF (NOPT.EQ.0) THEN
-C...Abandon BR-g-BR suppression for retries. This is not serious, it
-C...just means we happened to start with trying a bad sequence.
- PARP80=1D0
- IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
- & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
- MRETRY=MRETRY+1
- DO 590 JS=1,2
- IF (ITJUNC(JS).NE.0) THEN
- JST(JS,1)=IV(JS,1)
- JST(JS,2)=IV(JS,2)
- JST(JS,3)=IV(JS,3)
-C...Reset valence quark parent pointers
- DO 560 I=MINT(53)+1,N
- IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
- 560 CONTINUE
- MANTI=ITJUNC(JS)-1
-C...Set (anti)colour mother = junction.
- DO 570 JV=1,3
- K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
- & +MSTU(5)*IJU
- 570 CONTINUE
- ELSE
-C...Same for mesons. JST unchanged, so needn't be restored.
- IQ=JST(JS,1)
- IQBAR=JST(JS,2)
- K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
- K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
- ENDIF
-C...Also reset gluon parent pointers.
- NG(JS)=0
- DO 580 IM=1,NMI(JS)
- I=IMI(JS,IM,1)
- IF (K(I,2).EQ.21) THEN
- K(I,4)=MOD(K(I,4),MSTU(5))
- K(I,5)=MOD(K(I,5),MSTU(5))
- NG(JS)=NG(JS)+1
- ENDIF
- 580 CONTINUE
- 590 CONTINUE
-C...Reset colour tags
- DO 600 I=MINT(84)+1,N
- MCT(I,1)=MCO(I,1)
- MCT(I,2)=MCO(I,2)
- 600 CONTINUE
- GOTO 400
- ELSE
- IF(NERRPR.LT.5) THEN
- NERRPR=NERRPR+1
- CALL PYLIST(4)
- CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
- WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
- ENDIF
-C...Kill event and start another.
- MINT(51)=1
- RETURN
- ENDIF
- ELSE
-C...Select between insertions, suppressing insertions wholly in the BR.
- IIN=PYR(0)*NOPT+1
- 610 IIN=MOD(IIN,NOPT)+1
- IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
- & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
- ENDIF
-
-C...Now we know which gluon to insert where. Colour tags in JCCO and
-C...colour connection information should be updated, NG(JS) should be
-C...counted down, and a new loop performed if there are still gluons
-C...left on any side.
- ICM=INSR(IIN,1)
- IACM=INSR(IIN,3)
- IGL=INSR(IIN,2)
-C...JCG : Original gluon colour tag
-C...JCAG: Original gluon anticolour tag.
-C...JCM : Original anticolour tag of gluon colour mother
-C...JACM: Original colour tag of gluon anticolour mother
- JCG=MCO(IGL,1)
- JCM=MCO(ICM,2)
- JACG=MCO(IGL,2)
- JACM=MCO(IACM,1)
-
- CALL PYMIHG(JACM,JACG,JCM,JCG)
- IF (MACCPT.EQ.0) THEN
- IF(NERRPR.LT.5) THEN
- NERRPR=NERRPR+1
- CALL PYLIST(4)
- CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
- WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
- ENDIF
-C...Kill event and start another.
- MINT(51)=1
- RETURN
- ELSE
-C...If everything went fine, store new JCCN in JCCO.
- NCC=NCC+1
- DO 620 ICC=1,NCC
- JCCO(ICC,1)=JCCN(ICC,1)
- JCCO(ICC,2)=JCCN(ICC,2)
- 620 CONTINUE
- ENDIF
-
-C...One gluon attached is counted as equivalent to one end outside.
- MOUT(JS)=1
-C...Set IGL colour mother = ICM.
- K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
-C...Set ICM anticolour mother = IGL colour.
- IF (K(ICM,2).NE.88) THEN
- K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
- ELSE
-C...If ICM is junction, just update JST array for now.
- DO 630 MSJ=1,3
- IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
- 630 CONTINUE
- ENDIF
-C...Set IGL anticolour mother = IACM.
- K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
-C...Set IACM anticolour mother = IGL anticolour.
- IF (K(IACM,2).NE.88) THEN
- K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
- ELSE
-C...If IACM is junction, just update JST array for now.
- DO 640 MSJ=1,3
- IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
- 640 CONTINUE
- ENDIF
-C...Count down # unconnected gluons.
- NG(JS)=NG(JS)-1
- ENDIF
- IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
-
- DO 840 JS=1,2
-C...Collapse fictitious gluons.
- DO 670 IGL=MINT(53)+1,N
- IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
- & K(IGL,1).EQ.14) THEN
- ICM=K(IGL,4)/MSTU(5)
- IAM=K(IGL,5)/MSTU(5)
- ICD=MOD(K(IGL,4),MSTU(5))
- IAD=MOD(K(IGL,5),MSTU(5))
-C...Set gluon daughters pointing to gluon mothers
- K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
- K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
-C...Set gluon mothers pointing to gluon daughters.
- IF (K(ICM,2).NE.88) THEN
- K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
- ELSE
-C...Special case: mother=junction. Just update JST array for now.
- DO 650 MSJ=1,3
- IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
- 650 CONTINUE
- ENDIF
- IF (K(IAM,2).NE.88) THEN
- K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
- ELSE
- DO 660 MSJ=1,3
- IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
- 660 CONTINUE
- ENDIF
- ENDIF
- 670 CONTINUE
-
-C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
- IM=NMI(JS)+1
- 680 IM=IM-1
- IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
- IF (IM.GT.MINT(31)) THEN
- NMI(JS)=NMI(JS)-1
- DO 690 IMR=IM,NMI(JS)
- IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
- IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
- 690 CONTINUE
- GOTO 680
- ENDIF
-
-C...Finally, connect junction.
- IF (ITJUNC(JS).NE.0) THEN
- DO 700 I=MINT(53)+1,N
- IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
- 700 CONTINUE
-C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
- NBRJQ =0
- NBRVQ =0
- DO 720 MSJ=1,3
- IDQ(MSJ)=0
-C...Find jq with no glue inbetween inside beam remnant.
- IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
- & THEN
- NBRJQ=NBRJQ+1
-C...Set IDQ = -I if q non-valence and = +I if q valence.
- IDQ(NBRJQ)=-JST(JS,MSJ)
- DO 710 JV=1,3
- IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
- IDQ(NBRJQ)=JST(JS,MSJ)
- NBRVQ=NBRVQ+1
- ENDIF
- 710 CONTINUE
- ENDIF
- I12=MOD(MSJ+1,2)
- I45=5
- IF (MSJ.EQ.3) I45=4
- K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
- 720 CONTINUE
-
-C...Check if diquark can be formed.
- IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
- & .GE.1)) THEN
-C...If there is less than 2 valence quarks connected to junction
-C...and MSTP(88)>1, use random non-valence quarks to fill up.
- IF (NBRVQ.LE.1) THEN
- NDIQ=NBRVQ
- 730 JFLIP=NBRJQ*PYR(0)+1
- IF (IDQ(JFLIP).LT.0) THEN
- IDQ(JFLIP)=-IDQ(JFLIP)
- NDIQ=NDIQ+1
- ENDIF
- IF (NDIQ.LE.1) GOTO 730
- ENDIF
-C...Place selected quarks first in IDQ, ordered in flavour.
- DO 740 JDQ=1,3
- IF (IDQ(JDQ).LE.0) THEN
- ITEMP1 = IDQ(JDQ)
- IDQ(JDQ)= IDQ(3)
- IDQ(3) = -ITEMP1
- IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
- ITEMP1 = IDQ(1)
- IDQ(1) = IDQ(2)
- IDQ(2) = ITEMP1
- ENDIF
- ENDIF
- 740 CONTINUE
-C...Choose diquark spin.
- IF (NBRVQ.EQ.2) THEN
-C...If the selected quarks are both valence, we may use SU(6) rules
-C...to figure out which spin the diquark has, by a subdivision of the
-C...original beam hadron into the selected diquark system plus a kicked
-C...out quark, IKO.
- JKO=6
- DO 760 JDQ=1,2
- DO 750 JV=1,3
- IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
- 750 CONTINUE
- 760 CONTINUE
- IKO=IV(JS,JKO)
- CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
- ELSE
-C...If one or more of the selected quarks are not valence, we cannot use
-C...SU(6) subdivisions of the original beam hadron. Instead, with the
-C...flavours of the diquark already selected, we assume for now
-C...50:50 spin-1:spin-0 (where spin-0 possible).
- KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
- IS=3
- IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
- & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
- KFDQ=KFDQ+ISIGN(IS,KFDQ)
- ENDIF
-
-C...Collapse diquark-j-quark system to baryon, if allowed and possible.
-C...Note: third quark can per definition not also be valence,
-C...therefore we can only do this if we are allowed to use sea quarks.
- 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
- NTRY=0
- 780 NTRY=NTRY+1
- CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
- IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
- GOTO 780
- ELSEIF(NTRY.GT.100) THEN
-C...If no baryon can be found, give up and form diquark.
- IDQ(3)=0
- GOTO 770
- ELSE
-C...Replace junction by baryon.
- K(IJU,1)=1
- K(IJU,2)=KFBAR
- K(IJU,3)=MINT(83)+JS
- K(IJU,4)=0
- K(IJU,5)=0
- P(IJU,5)=PYMASS(KFBAR)
- DO 790 MSJ=1,3
-C...Prepare removal of participating quarks from ER.
- K(JST(JS,MSJ),1)=-1
- 790 CONTINUE
- ENDIF
- ELSE
-C...If collapse to baryon not possible or not allowed, replace junction
-C...by diquark. This way, collapsed gluons that were pointing at the
-C...junction will now point (correctly) at diquark.
- MANTI=ITJUNC(JS)-1
- K(IJU,1)=3
- K(IJU,2)=KFDQ
- K(IJU,3)=MINT(83)+JS
- K(IJU,4)=0
- K(IJU,5)=0
- DO 800 MSJ=1,3
- IP=JST(JS,MSJ)
- IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
- K(IJU,4+MANTI)=0
- K(IJU,5-MANTI)=IP*MSTU(5)
- K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
- & MSTU(5)*IJU
- MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
- ELSE
-C...Prepare removal of participating quarks from ER.
- K(IP,1)=-1
- ENDIF
- 800 CONTINUE
- ENDIF
-
-C...Update so ER pointers to collapsed quarks
-C...now go to collapsed object.
- DO 820 I=MINT(84)+1,N
- IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
- & .K(I,1).GT.0) THEN
- DO 810 ISID=4,5
- IMO=K(I,ISID)/MSTU(5)
- IDA=MOD(K(I,ISID),MSTU(5))
- IF (IMO.GT.0) THEN
- IF (K(IMO,1).EQ.-1) IMO=IJU
- ENDIF
- IF (IDA.GT.0) THEN
- IF (K(IDA,1).EQ.-1) IDA=IJU
- ENDIF
- K(I,ISID)=IDA+MSTU(5)*IMO
- 810 CONTINUE
- ENDIF
- 820 CONTINUE
- ENDIF
- ENDIF
-
-C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
-C...(this only happens for baryons, where we want to force the gluon
-C...to sit next to the junction. Mesons handled above.)
- IF (NBRTOT(JS).EQ.0) THEN
- N=N+1
- DO 830 IX=1,5
- K(N,IX)=0
- P(N,IX)=0D0
- V(N,IX)=0D0
- 830 CONTINUE
- IGL=N
- K(IGL,1)=3
- K(IGL,2)=21
- K(IGL,3)=MINT(83)+JS
- IF (ITJUNC(JS).NE.0) THEN
-C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
- JLEG=PYR(0)*NVSUM(JS)+1
- I1=JST(JS,JLEG)
- JST(JS,JLEG)=IGL
- JCT=MCT(I1,ITJUNC(JS))
- MCT(IGL,3-ITJUNC(JS))=JCT
- NCT=NCT+1
- MCT(IGL,ITJUNC(JS))=NCT
- MANTI=ITJUNC(JS)-1
- ELSE
-C...Meson. Should not happen.
- CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
- IF(NERRPR.LT.5) THEN
- WRITE(MSTU(11),*) 'This should not have been possible!'
- CALL PYLIST(4)
- NERRPR=NERRPR+1
- ENDIF
- MINT(51)=1
- RETURN
- ENDIF
- I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
- K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
- K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
- K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
- IF (K(I2,2).NE.88) THEN
- K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
- ELSE
- IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
- K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
- ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
- K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
- ELSE
- K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
- ENDIF
- ENDIF
- ENDIF
- 840 CONTINUE
-
-C...Remove collapsed quarks and junctions from ER and update IMI.
- CALL PYEDIT(11)
-
-C...Also update beam remnant part of IMI.
- NMI(1)=MINT(31)
- NMI(2)=MINT(31)
- DO 850 I=MINT(53)+1,N
- IF (K(I,1).LE.0) GOTO 850
-C...Restore BR quark/diquark/baryon pointers in IMI.
- IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
- JS=K(I,3)-MINT(83)
- NMI(JS)=NMI(JS)+1
- IMI(JS,NMI(JS),1)=I
- IMI(JS,NMI(JS),2)=0
- ENDIF
- 850 CONTINUE
-
-C...Restore companion information from collapsed gluons.
- DO 870 I=MINT(53)+1,N
- IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
- JS=K(I,3)-MINT(83)
- JCD=MOD(K(I,4),MSTU(5))
- JAD=MOD(K(I,5),MSTU(5))
- DO 860 IM=1,NMI(JS)
- IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
- IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
- 860 CONTINUE
- IMI(JS,IMC,2)=IMI(JS,IMA,1)
- IMI(JS,IMA,2)=IMI(JS,IMC,1)
- ENDIF
- 870 CONTINUE
-
-C...Renumber colour lines (since some have disappeared)
- JCT=0
- JCD=0
- 880 JCT=JCT+1
- MFOUND=0
- I=MINT(84)
- 890 I=I+1
- IF (I.EQ.N+1) THEN
- IF (MFOUND.EQ.0) JCD=JCD+1
- ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
- MCT(I,1)=JCT-JCD
- MFOUND=1
- ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
- MCT(I,2)=JCT-JCD
- MFOUND=1
- ENDIF
- IF (I.LE.N) GOTO 890
- IF (JCT.LT.NCT) GOTO 880
- NCT=JCT-JCD
-
-C...Reset hard interaction subsystems to their CM frames.
- IF (IBOOST.EQ.1) THEN
- DO 900 IM=1,MINT(31)
- BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
- CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
- 900 CONTINUE
-C...Zero beam remnant longitudinal momenta and energies
- DO 910 I=MINT(53)+1,N
- P(I,3)=0D0
- P(I,4)=0D0
- 910 CONTINUE
- ELSE
- CALL PYERRM(9
- & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
-C...Kill event and start another.
- MINT(51)=1
- RETURN
- ENDIF
-
- 9999 RETURN
- END
-C*********************************************************************
-
-C...PYCTTR
-C...Adapted from PYPREP.
-C...Assigns LHA1 colour tags to coloured partons based on
-C...K(I,4) and K(I,5) colour connection record.
-C...KCS negative signifies that a previous tracing should be continued.
-C...(in case the tag to be continued is empty, the routine exits)
-C...Starts at I and ends at I or IEND.
-C...Special considerations for systems with junctions.
-
- SUBROUTINE PYCTTR(I,KCS,IEND)
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYINT1/MINT(400),VINT(400)
-C...The common block of colour tags.
- COMMON/PYCTAG/NCT,MCT(4000,2)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
- DATA NERRPR/0/
- SAVE NERRPR
-
-C...Skip if parton not existing or does not have KCS
- IF (K(I,1).LE.0) GOTO 120
- KC=PYCOMP(K(I,2))
- IF (KC.EQ.0) GOTO 120
- KQ=KCHG(KC,2)
- IF (KQ.EQ.0) GOTO 120
- IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
- & GOTO 120
-
- IF (KCS.GT.0) THEN
- NCT=NCT+1
-C...Set colour tag of first parton.
- MCT(I,KCS-3)=NCT
- NCS=NCT
- ELSE
- KCS=-KCS
- NCS=MCT(I,KCS-3)
- IF (NCS.EQ.0) GOTO 120
- ENDIF
-
- IA=I
- NSTP=0
- 100 NSTP=NSTP+1
- IF(NSTP.GT.4*N) THEN
- CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
- GOTO 120
- ENDIF
-
-C...Finished if reached final-state triplet.
- IF(K(IA,1).EQ.3) THEN
- IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
- ENDIF
-
-C...Also finished if reached junction.
- IF(K(IA,1).EQ.42) THEN
- GOTO 120
- ENDIF
-
-C...GOTO next parton in colour space.
- 110 IB=IA
-C...If IB's KCS daughter not traced and exists, goto KCS daughter.
- IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
- & .NE.0) THEN
- IA=MOD(K(IB,KCS),MSTU(5))
- K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
- MREV=0
- ELSE
-C...If KCS mother traced or KCS mother nonexistent, switch colour.
- IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
- & MSTU(5)).EQ.0) THEN
- KCS=9-KCS
- NCT=NCT+1
- NCS=NCT
-C...Assign new colour tag on other side of old parton.
- MCT(IB,KCS-3)=NCT
- ENDIF
-C...Goto (new) KCS mother, set mother traced tag
- IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
- K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
- MREV=1
- ENDIF
- IF(IA.LE.0.OR.IA.GT.N) THEN
- CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
- IF(NERRPR.LT.5) THEN
- write(*,*) 'began at ',I
- write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS,
- & ' NCS=',NCS,' MREV=',MREV
- CALL PYLIST(4)
- NERRPR=NERRPR+1
- ENDIF
- MINT(51)=1
- RETURN
- ENDIF
- IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
- & MSTU(5)).EQ.IB) THEN
- IF(MREV.EQ.1) KCS=9-KCS
- IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
-C...Set KSC mother traced tag for IA
- K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
- ELSE
- IF(MREV.EQ.0) KCS=9-KCS
- IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
-C...Set KCS daughter traced tag for IA
- K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
- ENDIF
-C...Assign new colour tag
- MCT(IA,KCS-3)=NCS
- IF(IA.NE.I.AND.IA.NE.IEND) GOTO 100
-
- 120 RETURN
- END
-
-*********************************************************************
-
-C...PYMIHG
-C...Collapse JCP1 and connecting tags to JCG1.
-C...Collapse JCP2 and connecting tags to JCG2.
-
- SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...The event record
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
-C...Parameters
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYJETS/,/PYINT1/
-C...Local variables
- COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
- COMMON /PYCTAG/NCT,MCT(4000,2)
- SAVE /PYCBLS/,/PYCTAG/
-
-C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
-C...in temporary tag collapse array JCCN. Only break up one connection.
- MACCPT=1
- MCLPS=0
- DO 100 ICC=1,NCC
- JCCN(ICC,1)=JCCO(ICC,1)
- JCCN(ICC,2)=JCCO(ICC,2)
-C...If there was a mother, it was previously connected to JCP1.
-C...Should be changed to JCP2.
- IF (MCLPS.EQ.0) THEN
- IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
- & ,JCP2)) THEN
- JCCN(ICC,1)=MAX(JCG2,JCP2)
- JCCN(ICC,2)=MIN(JCG2,JCP2)
- MCLPS=1
- ENDIF
- ENDIF
- 100 CONTINUE
-C...Also collapse colours on JCP1 side of JCG1
- IF (JCP1.NE.0) THEN
- JCCN(NCC+1,1)=MAX(JCP1,JCG1)
- JCCN(NCC+1,2)=MIN(JCP1,JCG1)
- ELSE
- JCCN(NCC+1,1)=MAX(JCP2,JCG2)
- JCCN(NCC+1,2)=MIN(JCP2,JCG2)
- ENDIF
-
-C...Initialize event record colour tag array MCT array to MCO.
- DO 110 I=MINT(84)+1,N
- MCT(I,1)=MCO(I,1)
- MCT(I,2)=MCO(I,2)
- 110 CONTINUE
-
-C...Collapse tags:
-C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
-C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
-C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
-C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
- DO 160 IS=1,4
-C...Skip if junction.
- IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
-C...Define starting point in tag space.
-C...JCA = previous tag
-C...JCO = present tag
-C...JCN = new tag
- IF (MOD(IS,2).EQ.1) THEN
- JCO=JCP1
- JCN=JCG1
- JCALL=JCG1
- ELSEIF (MOD(IS,2).EQ.0) THEN
- JCO=JCP2
- JCN=JCG2
- JCALL=JCG2
- ENDIF
- ITRACE=0
- 120 ITRACE=ITRACE+1
- IF (ITRACE.GT.1000) THEN
-C...NB: Proper error message should be defined here.
- CALL PYERRM(14
- & ,'(PYMIHG:) Inf loop when collapsing colours.')
- MINT(57)=MINT(57)+1
- MINT(51)=1
- RETURN
- ENDIF
-C...Collapse all JCN tags to JCALL
- DO 130 I=MINT(84)+1,N
- IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
- IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
- 130 CONTINUE
-C...IS = 1,2: first step forward. IS = 3,4: first step backward.
- IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
- JCA=JCN
- JCN=JCO
- ELSE
- JCA=JCO
- JCO=JCN
- ENDIF
-C...If possible, step from JCO to new tag JCN not equal to JCA.
- DO 140 ICC=1,NCC+1
- IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
- & JCCN(ICC,2)
- IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
- & JCCN(ICC,1)
- 140 CONTINUE
-C...Iterate if new colour was arrived at, but don't go in circles.
- IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
-C...Change all JCN tags in MCO to JCALL in MCT.
- DO 150 I=MINT(84)+1,N
- IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
- IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
-C...If gluon and colour tag = anticolour tag (and not = 0) try again.
- IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
- & .NE.0) MACCPT=0
- 150 CONTINUE
- 160 CONTINUE
-
- DO 200 JCL=NCT,1,-1
- JCA=0
- JCN=JCL
- 170 JCO=JCN
- DO 180 ICC=1,NCC+1
- IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
- & =JCCN(ICC,2)
- IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
- & =JCCN(ICC,1)
- 180 CONTINUE
-C...Overpaint all JCN with JCL
- IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
- DO 190 I=MINT(84)+1,N
- IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
- IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
-C...If gluon and colour tag = anticolour tag (and not = 0) try again.
- IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
- & .NE.0) MACCPT=0
- 190 CONTINUE
- JCA=JCO
- GOTO 170
- ENDIF
- 200 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYMIRM
-C...Picks primordial kT and shares longitudinal momentum among
-C...beam remnants.
-
- SUBROUTINE PYMIRM
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...The event record
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
-C...Parameters
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
-C...The common block of colour tags.
- COMMON/PYCTAG/NCT,MCT(4000,2)
-C...The common block of dangling ends
- COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
- & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
- & XMI(2,240),PT2MI(240),IMISEP(0:240)
- SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
-C...Local variables
- DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
-C...W(I,J)| J=0 | 1 | 2 |
-C... I=0 | Wrem**2 | W+ | W- |
-C... 1 | W1**2 | W1+ | W1- |
-C... 2 | W2**2 | W2+ | W2- |
-C...4-product
- FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
-C...Tentative parametrization of <kT> as a function of Q.
- SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
-C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
-C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
- GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
-C...Lambda kinematic function.
- FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
-
-C...Beginning and end of beam remnant partons
- NOUT=MINT(53)
- ISUB=MINT(1)
-
-C...Loopback point if kinematic choices gives impossible configuration.
- NTRY=0
- 100 NTRY=NTRY+1
-
-C...Assign kT values on each side separately.
- DO 180 JS=1,2
-
-C...First zero all kT on this side. Skip if no kT to generate.
- DO 110 IM=1,NMI(JS)
- P(IMI(JS,IM,1),1)=0D0
- P(IMI(JS,IM,1),2)=0D0
- 110 CONTINUE
- IF(MSTP(91).LE.0) GOTO 180
-
-C...Now assign kT to each (non-collapsed) parton in IMI.
- DO 170 IM=1,NMI(JS)
- I=IMI(JS,IM,1)
-C...Select kT according to truncated gaussian or 1/kt6 tails.
-C...For first interaction, either use rms width = PARP(91) or fitted.
- IF (IM.EQ.1) THEN
- SIGMA=PARP(91)
- IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
- Q=SQRT(PT2MI(IM))
- SIGMA=SIGPT(Q)
- ENDIF
- ELSE
-C...For subsequent interactions and BR partons use fragmentation width.
- SIGMA=PARJ(21)
- ENDIF
- PHI=PARU(2)*PYR(0)
- PT=0D0
- IF(NTRY.LE.100) THEN
- 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
- PT=GETPT(Q,SIGMA)
- PTX=PT*COS(PHI)
- PTY=PT*SIN(PHI)
- ELSEIF (MSTP(91).EQ.2) THEN
- CALL PYERRM(11,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
- & 'available, using MSTP(91)=1.')
- CALL PYGIVE('MSTP(91)=1')
- GOTO 111
- ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
-C...Use distribution with kt**6 tails, rms width = PARP(91).
- EPS=SQRT(3D0/2D0)*SIGMA
-C...Generate PTX and PTY separately, each propto 1/KT**6
- DO 119 IXY=1,2
-C...Decide which interval to try
- 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
- IF (PYR(0).LT.P12) THEN
-C...Use flat approx with accept/reject up to EPS.
- PT=PYR(0)*EPS
- WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
- IF (PYR(0).GT.WT) GOTO 112
- ELSE
-C...Above EPS, use 1/kt**6 approx with accept/reject.
- PT=EPS/(PYR(0)**(1D0/5D0))
- WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
- IF (PYR(0).GT.WT) GOTO 112
- ENDIF
- MSIGN=1
- IF (PYR(0).GT.0.5D0) MSIGN=-1
- IF (IXY.EQ.1) PTX=MSIGN*PT
- IF (IXY.EQ.2) PTY=MSIGN*PT
- 119 CONTINUE
- ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
- PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
- PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
- ENDIF
-C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
- PT=SQRT(PTX**2+PTY**2)
- WT=1D0
- IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
- IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
- PTX=PTX*WT
- PTY=PTY*WT
- PT=SQRT(PTX**2+PTY**2)
- ENDIF
-
- P(I,1)=P(I,1)+PTX
- P(I,2)=P(I,2)+PTY
-
-C...Compensation kicks, with varying degree of local anticorrelations.
- MCORR=MSTP(90)
- IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
- PTCX=-PTX/(NMI(JS)-1)
- PTCY=-PTY/(NMI(JS)-1)
- IF(ISUB.EQ.95) THEN
- PTCX=-PTX/(NMI(JS)-2)
- PTCY=-PTY/(NMI(JS)-2)
- ENDIF
- DO 120 IMC=1,NMI(JS)
- IF (IMC.EQ.IM) GOTO 120
- IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
- P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
- P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
- 120 CONTINUE
- ELSEIF (MCORR.GE.1) THEN
- DO 140 MSID=4,5
- NNXT(MSID-3)=0
-C...Count up # of neighbours on either side
- IMO=I
- 130 IMO=K(IMO,MSID)/MSTU(5)
- IF (IMO.EQ.0) GOTO 140
- NNXT(MSID-3)=NNXT(MSID-3)+1
-C...Stop at quarks and junctions
- IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
- 140 CONTINUE
-C...How should compensation be shared when unequal numbers on the
-C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
- NSUM=NNXT(1)+NNXT(2)
- T1=0
- DO 160 MSID=4,5
-C...Total momentum to be compensated on this side
- IF (NNXT(MSID-3).EQ.0) GOTO 160
- PTCX=-(NNXT(MSID-3)*PTX)/NSUM
- PTCY=-(NNXT(MSID-3)*PTY)/NSUM
-C...RS: compensation supression factor as we go out from parton I.
-C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
-C...since (for now) MSTP(90) provides enough variability.
- RS=0.5D0
- FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
- IMO=I
- 150 IDA=IMO
- IMO=K(IMO,MSID)/MSTU(5)
- IF (IMO.EQ.0) GOTO 160
- FAC=FAC*RS
- IF (K(IMO,2).NE.88) THEN
- P(IMO,1)=P(IMO,1)+FAC*PTCX
- P(IMO,2)=P(IMO,2)+FAC*PTCY
- IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
-C...If we reach junction, divide out the kT that would have been
-C...assigned to the junction on each of its other legs.
- ELSE
- L1=MOD(K(IMO,4),MSTU(5))
- L2=K(IMO,5)/MSTU(5)
- L3=MOD(K(IMO,5),MSTU(5))
- P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
- P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
- P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
- P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
- P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
- P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
- P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
- P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
- ENDIF
-
- 160 CONTINUE
- ENDIF
- 170 CONTINUE
-C...End assignment of kT values to initiators and remnants.
- 180 CONTINUE
-
-C...Check kinematics constraints for non-BR partons.
- DO 190 IM=1,MINT(31)
- SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
- PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
- PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
- PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
- & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
- IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
- IF(NTRY.GE.100) THEN
-C...Kill this event and start another.
- CALL PYERRM(11,
- & '(PYMIRM:) No consistent (x,kT) sets found')
- MINT(51)=1
- RETURN
- ENDIF
- GOTO 100
- ENDIF
- 190 CONTINUE
-
-C...Calculate W+ and W- available for combined remnant system.
- W(0,1)=VINT(1)
- W(0,2)=VINT(1)
- DO 200 IM=1,MINT(31)
- PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
- & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
- ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
- W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
- W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
- 200 CONTINUE
-C...Also store Wrem**2 = W+ * W-
- W(0,0)=W(0,1)*W(0,2)
-
- IF (W(0,0).LT.0D0.AND.NTRY.LE.100) THEN
- IF(NTRY.GE.100) THEN
-C...Kill this event and start another.
- CALL PYERRM(11,
- & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
- MINT(51)=1
- RETURN
- ENDIF
- GOTO 100
- ENDIF
-
-C...Assign unscaled x values to partons/hadrons in each of the
-C...beam remnants and calculate unscaled W+ and W- from them.
- NTRYX=0
- 210 NTRYX=NTRYX+1
- DO 280 JS=1,2
- W(JS,1)=0D0
- W(JS,2)=0D0
- DO 270 IM=MINT(31)+1,NMI(JS)
- I=IMI(JS,IM,1)
- KF=K(I,2)
- KFA=IABS(KF)
- ICOMP=IMI(JS,IM,2)
-
-C...Skip collapsed gluons and junctions. Reset.
- IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
- IF (KFA.EQ.88) GOTO 270
- X=0D0
- IVALQ(1)=0
- IVALQ(2)=0
- ICOMQ(1)=0
- ICOMQ(2)=0
-
-C...If gluon then only beam remnant, so takes all.
- IF(KFA.EQ.21) THEN
- X=1D0
-C...If valence quark then use parametrized valence distribution.
- ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
- IVALQ(1)=KF
-C...If companion quark then derive from companion x.
- ELSEIF(KFA.LE.6) THEN
- ICOMQ(1)=ICOMP
-C...If valence diquark then use two parametrized valence distributions.
- ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
- & ICOMP.EQ.0) THEN
- IVALQ(1)=ISIGN(KFA/1000,KF)
- IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
-C...If valence+sea diquark then combine valence + companion choices.
- ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
- & ICOMP.LT.MSTU(5)) THEN
- IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
- IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
- ELSE
- IVALQ(1)=ISIGN(KFA/1000,KF)
- ENDIF
- ICOMQ(1)=ICOMP
-C...Extra code: workaround for diquark made out of two sea
-C...quarks, but where not (yet) ICOMP > MSTU(5).
- DO 220 IM1=1,MINT(31)
- IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
- ICOMQ(2)=IMI(JS,IM1,1)
- IVALQ(1)=0
- ENDIF
- 220 CONTINUE
-C...If sea diquark then sum of two derived from companion x.
- ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
- ICOMQ(1)=MOD(ICOMP,MSTU(5))
- ICOMQ(2)=ICOMP/MSTU(5)
-C...If meson or baryon then use fragmentation function.
-C...Somewhat arbitrary split into old and new flavour, but OK normally.
- ELSE
- KFL3=MOD(KFA/10,10)
- IF(MOD(KFA/1000,10).EQ.0) THEN
- KFL1=MOD(KFA/100,10)
- ELSE
- KFL1=MOD(KFA,10000)-10*KFL3-1
- IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
- & MOD(KFA,10).EQ.2) KFL1=KFL1+2
- ENDIF
- PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
- CALL PYZDIS(KFL1,KFL3,PR,X)
- ENDIF
-
- DO 260 IQ=1,2
-C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
-C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
-C...In other baryons combine u and d from proton appropriately.
- IF(IVALQ(IQ).NE.0) THEN
- NVAL=0
- IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
- IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
- IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
-C...Meson.
- IF(KFIVAL(JS,3).EQ.0) THEN
- MDU=0
-C...Baryon with three identical quarks: mix u and d forms.
- ELSEIF(NVAL.EQ.3) THEN
- MDU=INT(PYR(0)+5D0/3D0)
-C...Baryon, one of two identical quarks: u form.
- ELSEIF(NVAL.EQ.2) THEN
- MDU=2
-C...Baryon with two identical quarks, but not the one picked: d form.
- ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
- & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
- MDU=1
-C...Baryon with three nonidentical quarks: mix u and d forms.
- ELSE
- MDU=INT(PYR(0)+5D0/3D0)
- ENDIF
- XPOW=0.8D0
- IF(MDU.EQ.1) XPOW=3.5D0
- IF(MDU.EQ.2) XPOW=2D0
- 230 XX=PYR(0)**2
- IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
- X=X+XX
- ENDIF
-
-C...Calculation of x of companion quark.
- IF(ICOMQ(IQ).NE.0) THEN
- XCOMP=1D-4
- DO 240 IM1=1,MINT(31)
- IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
- 240 CONTINUE
- NPOW=MAX(0,MIN(4,MSTP(87)))
- 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
- CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
- & (XCOMP**2+XX**2)/(XCOMP+XX)**2
- IF(CORR.LT.PYR(0)) GOTO 250
- X=X+XX
- ENDIF
- 260 CONTINUE
-
-C...Optionally enchance x of composite systems (e.g. diquarks)
- IF (KFA.GT.100) X=PARP(79)*X
-
-C...Store x. Also calculate light cone energies of each system.
- XMI(JS,IM)=X
- W(JS,JS)=W(JS,JS)+X
- W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
- 270 CONTINUE
- W(JS,JS)=W(JS,JS)*W(0,JS)
- W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
- W(JS,0)=W(JS,1)*W(JS,2)
- 280 CONTINUE
-
-C...Check W1 W2 < Wrem (can be done before rescaling, since W
-C...insensitive to global rescalings of the BR x values).
- IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
- & THEN
- GOTO 210
- ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
- GOTO 100
- ELSEIF (NTRYX.GT.100) THEN
- CALL PYERRM(11,'(PYMIRM:) No consistent (x,kT) sets found')
- MINT(57)=MINT(57)+1
- MINT(51)=1
- RETURN
- ENDIF
-
-C...Compute x rescaling factors
- COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
- R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
- R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
-
- IF (R1.LT.0.OR.R2.LT.0) THEN
- CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
- MINT(57)=MINT(57)+1
- MINT(51)=1
- ENDIF
-
-C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
- W(1,1)=W(1,1)*R1
- W(1,2)=W(1,2)/R1
- W(2,1)=W(2,1)/R2
- W(2,2)=W(2,2)*R2
-
-C...Rescale BR x values.
- DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
- XMI(1,IM)=XMI(1,IM)*R1
- XMI(2,IM)=XMI(2,IM)*R2
- 290 CONTINUE
-
-C...Now we have a consistent set of x and kT values.
-C...First set up the initiators and their daughters correctly.
- DO 300 IM=1,MINT(31)
- I1=IMI(1,IM,1)
- I2=IMI(2,IM,1)
- ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
- & (P(I1,2)+P(I2,2))**2
- PT12=P(I1,1)**2+P(I1,2)**2
- PT22=P(I2,1)**2+P(I2,2)**2
-C...p_z
- P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
- P(I2,3)=-P(I1,3)
-C...Energies (masses should be zero at this stage)
- P(I1,4)=SQRT(PT12+P(I1,3)**2)
- P(I2,4)=SQRT(PT22+P(I2,3)**2)
-
-C...Transverse 12 system initiator velocity:
- VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
- VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
-C...Boost to overall initiator system rest frame
- CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
- CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
-
-C...Compute phi,theta coordinates of I1 and rotate z axis.
- PHI=PYANGL(P(I1,1),P(I1,2))
- THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
- IMIN=IMISEP(IM-1)+1
-C...(include documentation lines if MI = 1)
- IF (IM.EQ.1) IMIN=MINT(83)+5
- IMAX=IMISEP(IM)
-C...Rotate entire system in phi
- CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
-C...Only rotate 12 system in theta
- CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
- CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
-
-C...Now boost entire system back to LAB
- VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
- CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
- CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
-
- 300 CONTINUE
-
-
-C...For the beam remnant partons/hadrons, we only need to set pz and E.
- DO 320 JS=1,2
- DO 310 IM=MINT(31)+1,NMI(JS)
- I=IMI(JS,IM,1)
-C...Skip collapsed gluons and junctions.
- IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
- IF (KFA.EQ.88) GOTO 310
- RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
- P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
- P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
- IF (JS.EQ.2) P(I,3)=-P(I,3)
- 310 CONTINUE
- 320 CONTINUE
-
-
-C...Documentation lines
- DO 340 JS=1,2
- IN=MINT(83)+JS+2
- IO=IMI(JS,1,1)
- K(IN,1)=21
- K(IN,2)=K(IO,2)
- K(IN,3)=MINT(83)+JS
- K(IN,4)=0
- K(IN,5)=0
- DO 330 J=1,5
- P(IN,J)=P(IO,J)
- V(IN,J)=V(IO,J)
- 330 CONTINUE
- MCT(IN,1)=MCT(IO,1)
- MCT(IN,2)=MCT(IO,2)
- 340 CONTINUE
-
-C...Final state colour reconnections.
- IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
-
-C...Number of colour tags for which a recoupling will be tried.
- NTOT=NCT
-C...Number of recouplings to try
- MINT(34)=0
- NRECP=0
- NITER=0
- 350 NRECP=MINT(34)
- NITER=NITER+1
- IITER=0
- 360 IITER=IITER+1
- IF (IITER.LE.PARP(78)*NTOT) THEN
-C...Select two colour tags at random
-C...NB: jj strings do not have colour tags assigned to them,
-C...thus they are as yet not affected by anything done here.
- JCT=PYR(0)*NCT+1
- KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
- IJ1=0
- IJ2=0
- IK1=0
- IK2=0
-C...Find final state partons with this (anti)colour
- DO 370 I=MINT(84)+1,N
- IF (K(I,1).EQ.3) THEN
- IF (MCT(I,1).EQ.JCT) IJ1=I
- IF (MCT(I,2).EQ.JCT) IJ2=I
- IF (MCT(I,1).EQ.KCT) IK1=I
- IF (MCT(I,2).EQ.KCT) IK2=I
- ENDIF
- 370 CONTINUE
-C...Only consider recouplings not involving junctions for now.
- IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
-
- RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
- RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
- IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
- MCT(IJ2,2)=KCT
- MCT(IK2,2)=JCT
-C...Count up number of reconnections
- MINT(34)=MINT(34)+1
- ENDIF
- IF (MINT(34).LE.1000) THEN
- GOTO 360
- ELSE
- CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
- GOTO 380
- ENDIF
- ENDIF
- IF (NRECP.LT.MINT(34)) GOTO 350
-
-C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
- 380 MINT(33)=1
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYFSCR
-C...Performs colour annealing.
-C...MSTP(95) : CR Type
-C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
-C... = 2 : Type I(no gg loops); hadron-hadron only
-C... = 3 : Type I(no gg loops); all beams
-C... = 4 : Type II(gg loops) ; hadron-hadron only
-C... = 5 : Type II(gg loops) ; all beams
-C... = 6 : Type S ; hadron-hadron only
-C... = 7 : Type S ; all beams
-C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
-C...Type S is driven by starting only from free triplets, not octets.
-C...A string piece remains unchanged with probability
-C... PKEEP = (1-PARP(78))**N
-C...This scaling corresponds to each string piece having to go through
-C...N other ones, each with probability PARP(78) for reconnection, where
-C...N is here chosen simply as the number of multiple interactions,
-C...for a rough scaling with the general level of activity.
-
- SUBROUTINE PYFSCR(IP)
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYINT1/MINT(400),VINT(400)
-C...The common block of colour tags.
- COMMON/PYCTAG/NCT,MCT(4000,2)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
- &/PYPARS/
-C...MCN: Temporary storage of new colour tags
- DOUBLE PRECISION MCN(4000,2)
-
-C...Function to give four-product.
- FOUR(I,J)=P(I,4)*P(J,4)
- & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
-
-C...Check valid range of MSTP(95), local copy
- IF (MSTP(95).LE.1.OR.MSTP(95).GE.8) RETURN
- MSTP95=MOD(MSTP(95),10)
-C...Set whether CR allowed inside resonance systems or not
-C...(not implemented yet)
-C MRESCR=1
-C IF (MSTP(95).GE.10) MRESCR=0
-
-C...Check whether colour tags already defined
- IF (MINT(33).EQ.0) THEN
-C...Erase any existing colour tags for this event
- DO 100 I=1,N
- MCT(I,1)=0
- MCT(I,2)=0
- 100 CONTINUE
-C...Create colour tags for this event
- DO 120 I=1,N
- IF (K(I,1).EQ.3) THEN
- DO 110 KCS=4,5
- KCSIN=KCS
- IF (MCT(I,KCSIN-3).EQ.0) THEN
- CALL PYCTTR(I,KCSIN,I)
- ENDIF
- 110 CONTINUE
- ENDIF
- 120 CONTINUE
-C...Instruct PYPREP to use colour tags
- MINT(33)=1
- ENDIF
-
-C...For MSTP(95) even, only apply to hadron-hadron
- IF (MOD(MSTP(95),2).EQ.0) THEN
- KA1=IABS(MINT(11))
- KA2=IABS(MINT(12))
- IF (KA1.LT.100.OR.KA2.LT.100) GOTO 9999
- ENDIF
-
-C...Initialize new tag array (but do not delete old yet)
- LCT=NCT
- DO 130 I=MAX(1,IP),N
- MCN(I,1)=0
- MCN(I,2)=0
- 130 CONTINUE
-
-C...For each final-state dipole, check whether string should be
-C...preserved.
- DO 150 ICT=1,NCT
- IC=0
- IA=0
- DO 140 I=MAX(1,IP),N
- IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
- IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
- 140 CONTINUE
- IF (IC.NE.0.AND.IA.NE.0) THEN
-C...Chiefly consider large strings.
- PKEEP=(1D0-PARP(78))**MINT(31)
- IF (PYR(0).LE.PKEEP) THEN
- LCT=LCT+1
- MCN(IC,1)=LCT
- MCN(IA,2)=LCT
- ENDIF
- ENDIF
- 150 CONTINUE
-
-C...Loop over event record, starting from IP
-C...(Ignore junctions for now.)
- NLOOP=0
- 160 NLOOP=NLOOP+1
- MCIMAX=0
- MCJMAX=0
- RLMAX=0D0
- ILMAX=0
- JLMAX=0
- DO 230 I=MAX(1,IP),N
- IF (K(I,1).NE.3) GOTO 230
-C...Check colour charge
- MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
- IF (MCI.EQ.0) GOTO 230
-C...For Seattle algorithm, only start from partons with one dangling
-C...colour tag
- IF (MSTP(95).EQ.6.OR.MSTP(95).EQ.7) THEN
- IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) GOTO 230
- ENDIF
-C... Find optimal partner
- JLOPT=0
- MCJOPT=0
- MBROPT=0
- MGGOPT=0
- RLOPT=1D19
-C...Loop over I colour/anticolour, check whether already connected
- 170 DO 220 ICL=1,2
- IF (MCN(I,ICL).NE.0) GOTO 220
- IF (ICL.EQ.1.AND.MCI.EQ.-1) GOTO 220
- IF (ICL.EQ.2.AND.MCI.EQ.1) GOTO 220
-C...Check whether this is a dangling colour tag (ie to junction!)
- IFOUND=0
- DO 180 J=MAX(1,IP),N
- IF (K(J,1).EQ.3.AND.MCT(J,3-ICL).EQ.MCT(I,ICL)) IFOUND=1
- 180 CONTINUE
- IF (IFOUND.EQ.0) GOTO 220
- DO 210 J=MAX(1,IP),N
- IF (K(J,1).NE.3.OR.I.EQ.J) GOTO 210
-C...Do not make direct connections between partons in same Beam Remnant
- MBRSTR=0
- IF (K(I,3).LE.2.AND.K(J,3).LE.2.AND.K(I,3).EQ.K(J,3))
- & MBRSTR=1
-C...Check colour charge
- MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
- IF (MCJ.EQ.0.OR.(MCJ.EQ.MCI.AND.MCI.NE.2)) GOTO 210
-C...Check for gluon loops
- MGGSTR=0
- IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
- ICLA=3-ICL
- IF (MCN(I,ICLA).EQ.MCN(J,ICL).AND.MSTP(95).LE.3.AND.
- & MCN(I,ICLA).NE.0) MGGSTR=1
- ENDIF
-C...Loop over J colour/anticolour, check whether already connected
- DO 200 JCL=1,2
- IF (MCN(J,JCL).NE.0) GOTO 200
- IF (JCL.EQ.ICL) GOTO 200
- IF (JCL.EQ.1.AND.MCJ.EQ.-1) GOTO 200
- IF (JCL.EQ.2.AND.MCJ.EQ.1) GOTO 200
-C...Check whether this is a dangling colour tag (ie to junction!)
- IFOUND=0
- DO 190 J2=MAX(1,IP),N
- IF (K(J2,1).EQ.3.AND.MCT(J2,3-JCL).EQ.MCT(J,JCL))
- & IFOUND=1
- 190 CONTINUE
- IF (IFOUND.EQ.0) GOTO 200
-C...Save connection with smallest lambda measure
-C...If best so far was a BR string and this is not, also save.
-C...If best so far was a gg string and this is not, also save.
- RL=FOUR(I,J)
- IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
- & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
- & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
- RLOPT=RL
- JLOPT=J
- ICOPT=ICL
- JCOPT=JCL
- MCJOPT=MCJ
- MBROPT=MBRSTR
- MGGOPT=MGGSTR
- ENDIF
- 200 CONTINUE
- 210 CONTINUE
- 220 CONTINUE
- IF (JLOPT.NE.0) THEN
-C...Save pair with largest RLOPT so far
- IF (RLOPT.GE.RLMAX) THEN
- RLMAX=RLOPT
- ILMAX=I
- JLMAX=JLOPT
- ICMAX=ICOPT
- JCMAX=JCOPT
- MCJMAX=MCJOPT
- MCIMAX=MCI
- ENDIF
- ENDIF
- 230 CONTINUE
-C...Save and iterate
- IF (ILMAX.GT.0) THEN
- LCT=LCT+1
- MCN(ILMAX,ICMAX)=LCT
- MCN(JLMAX,JCMAX)=LCT
- IF (NLOOP.LE.2*(N-IP)) THEN
- GOTO 160
- ELSE
- CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
- CALL PYSTOP(11)
- ENDIF
- ELSE
-C...Save and exit. First check for leftover gluon(s)
- DO 260 I=MAX(1,IP),N
-C...Check colour charge
- MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
- IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
- IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
-C...Decide where to put left-over gluon (minimal insertion)
- ILMAX=0
- RLMAX=1D19
- DO 250 KCT=NCT+1,LCT
- DO 240 IT=MAX(1,IP),N
- IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
- IF (MCN(IT,1).EQ.KCT) IC=IT
- IF (MCN(IT,2).EQ.KCT) IA=IT
- 240 CONTINUE
- RL=FOUR(IC,I)*FOUR(IA,I)
- IF (RL.LT.RLMAX) THEN
- RLMAX=RL
- ICMAX=IC
- IAMAX=IA
- ENDIF
- 250 CONTINUE
- LCT=LCT+1
- MCN(I,1)=MCN(ICMAX,1)
- MCN(I,2)=LCT
- MCN(ICMAX,1)=LCT
- ENDIF
- 260 CONTINUE
- DO 270 I=MAX(1,IP),N
-C...Do not erase parton shower colour history
- IF (K(I,1).NE.3) GOTO 270
-C...Check colour charge
- MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
- IF (MCI.EQ.0) GOTO 270
- IF (MCN(I,1).NE.0) MCT(I,1)=MCN(I,1)
- IF (MCN(I,2).NE.0) MCT(I,2)=MCN(I,2)
- 270 CONTINUE
- ENDIF
-
- 9999 RETURN
- END
-
-C*********************************************************************
-
-C...PYDIFF
-C...Handles diffractive and elastic scattering.
-
- SUBROUTINE PYDIFF
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
-
-C...Reset K, P and V vectors. Store incoming particles.
- DO 110 JT=1,MSTP(126)+10
- I=MINT(83)+JT
- DO 100 J=1,5
- K(I,J)=0
- P(I,J)=0D0
- V(I,J)=0D0
- 100 CONTINUE
- 110 CONTINUE
- N=MINT(84)
- MINT(3)=0
- MINT(21)=0
- MINT(22)=0
- MINT(23)=0
- MINT(24)=0
- MINT(4)=4
- DO 130 JT=1,2
- I=MINT(83)+JT
- K(I,1)=21
- K(I,2)=MINT(10+JT)
- DO 120 J=1,5
- P(I,J)=VINT(285+5*JT+J)
- 120 CONTINUE
- 130 CONTINUE
- MINT(6)=2
-
-C...Subprocess; kinematics.
- SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
- PZ=SQRT(SQLAM)/(2D0*VINT(1))
- DO 200 JT=1,2
- I=MINT(83)+JT
- PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
- KFH=MINT(102+JT)
-
-C...Elastically scattered particle. (Except elastic GVMD states.)
- IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
- & MINT(106+JT).NE.3)) THEN
- N=N+1
- K(N,1)=1
- K(N,2)=KFH
- K(N,3)=I+2
- P(N,3)=PZ*(-1)**(JT+1)
- P(N,4)=PE
- P(N,5)=SQRT(VINT(62+JT))
-
-C...Decay rho from elastic scattering of gamma with sin**2(theta)
-C...distribution of decay products (in rho rest frame).
- IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
- NSAV=N
- DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
- P(N,3)=0D0
- P(N,4)=P(N,5)
- CALL PYDECY(NSAV)
- IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
- PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
- CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
- THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
- CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
- 140 CTHE=2D0*PYR(0)-1D0
- IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
- CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
- ENDIF
- CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
- ENDIF
-
-C...Diffracted particle: low-mass system to two particles.
- ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
- N=N+2
- K(N-1,1)=1
- K(N,1)=1
- K(N-1,3)=I+2
- K(N,3)=I+2
- PMMAS=SQRT(VINT(62+JT))
- NTRY=0
- 150 NTRY=NTRY+1
- IF(NTRY.LT.20) THEN
- MINT(105)=MINT(102+JT)
- MINT(109)=MINT(106+JT)
- CALL PYSPLI(KFH,21,KFL1,KFL2)
- CALL PYKFDI(KFL1,0,KFL3,KF1)
- IF(KF1.EQ.0) GOTO 150
- CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
- IF(KF2.EQ.0) GOTO 150
- ELSE
- KF1=KFH
- KF2=111
- ENDIF
- PM1=PYMASS(KF1)
- PM2=PYMASS(KF2)
- IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
- K(N-1,2)=KF1
- K(N,2)=KF2
- P(N-1,5)=PM1
- P(N,5)=PM2
- PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
- & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
- P(N-1,3)=PZP
- P(N,3)=-PZP
- P(N-1,4)=SQRT(PM1**2+PZP**2)
- P(N,4)=SQRT(PM2**2+PZP**2)
- CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
- & 0D0,0D0,0D0)
- DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
- CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
-
-C...Diffracted particle: valence quark kicked out.
- ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
- & PARP(101))) THEN
- N=N+2
- K(N-1,1)=2
- K(N,1)=1
- K(N-1,3)=I+2
- K(N,3)=I+2
- MINT(105)=MINT(102+JT)
- MINT(109)=MINT(106+JT)
- CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
- P(N-1,5)=PYMASS(K(N-1,2))
- P(N,5)=PYMASS(K(N,2))
- SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
- & 4D0*P(N-1,5)**2*P(N,5)**2
- P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
- & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
- P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
- P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
- P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
-
-C...Diffracted particle: gluon kicked out.
- ELSE
- N=N+3
- K(N-2,1)=2
- K(N-1,1)=2
- K(N,1)=1
- K(N-2,3)=I+2
- K(N-1,3)=I+2
- K(N,3)=I+2
- MINT(105)=MINT(102+JT)
- MINT(109)=MINT(106+JT)
- CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
- K(N-1,2)=21
- P(N-2,5)=PYMASS(K(N-2,2))
- P(N-1,5)=0D0
- P(N,5)=PYMASS(K(N,2))
-C...Energy distribution for particle into two jets.
- 160 IMB=1
- IF(MOD(KFH/1000,10).NE.0) IMB=2
- CHIK=PARP(92+2*IMB)
- IF(MSTP(92).LE.1) THEN
- IF(IMB.EQ.1) CHI=PYR(0)
- IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
- ELSEIF(MSTP(92).EQ.2) THEN
- CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
- ELSEIF(MSTP(92).EQ.3) THEN
- CUT=2D0*0.3D0/VINT(1)
- 170 CHI=PYR(0)**2
- IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
- & PYR(0)) GOTO 170
- ELSEIF(MSTP(92).EQ.4) THEN
- CUT=2D0*0.3D0/VINT(1)
- CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
- 180 CHIR=CUT*CUTR**PYR(0)
- CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
- IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
- ELSE
- CUT=2D0*0.3D0/VINT(1)
- CUTA=CUT**(1D0-PARP(98))
- CUTB=(1D0+CUT)**(1D0-PARP(98))
- 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
- IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
- & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
- ENDIF
- IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
- & VINT(62+JT)) GOTO 160
- SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
- PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
- & (2D0*VINT(62+JT))
- PEI=SQRT(PZI**2+SQM)
- PQQP=(1D0-CHI)*(PEI+PZI)
- P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
- P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
- P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
- P(N-1,3)=P(N-1,4)*(-1)**JT
- P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
- P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
- ENDIF
-
-C...Documentation lines.
- K(I+2,1)=21
- IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
- IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
- & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
- K(I+2,3)=I
- P(I+2,3)=PZ*(-1)**(JT+1)
- P(I+2,4)=PE
- P(I+2,5)=SQRT(VINT(62+JT))
- 200 CONTINUE
-
-C...Rotate outgoing partons/particles using cos(theta).
- IF(VINT(23).LT.0.9D0) THEN
- CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
- ELSE
- CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYDISG
-C...Set up a DIS process as gamma* + f -> f, with beam remnant
-C...and showering added consecutively. Photon flux by the PYGAGA
-C...routine (if at all).
-
- SUBROUTINE PYDISG
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
-C...Local arrays.
- DIMENSION PMS(4)
-
-C...Choice of subprocess, number of documentation lines
- IDOC=7
- MINT(3)=IDOC-6
- MINT(4)=IDOC
- IPU1=MINT(84)+1
- IPU2=MINT(84)+2
- IPU3=MINT(84)+3
- ISIDE=1
- IF(MINT(107).EQ.4) ISIDE=2
-
-C...Reset K, P and V vectors. Store incoming particles
- DO 110 JT=1,MSTP(126)+20
- I=MINT(83)+JT
- DO 100 J=1,5
- K(I,J)=0
- P(I,J)=0D0
- V(I,J)=0D0
- 100 CONTINUE
- 110 CONTINUE
- DO 130 JT=1,2
- I=MINT(83)+JT
- K(I,1)=21
- K(I,2)=MINT(10+JT)
- DO 120 J=1,5
- P(I,J)=VINT(285+5*JT+J)
- 120 CONTINUE
- 130 CONTINUE
- MINT(6)=2
-
-C...Store incoming partons in hadronic CM-frame
- DO 140 JT=1,2
- I=MINT(84)+JT
- K(I,1)=14
- K(I,2)=MINT(14+JT)
- K(I,3)=MINT(83)+2+JT
- 140 CONTINUE
- IF(MINT(15).EQ.22) THEN
- P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
- P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
- P(MINT(84)+1,5)=-SQRT(VINT(307))
- P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
- P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
- KFRES=MINT(16)
- ISIDE=2
- ELSE
- P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
- P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
- P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
- P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
- P(MINT(84)+1,5)=-SQRT(VINT(308))
- KFRES=MINT(15)
- ISIDE=1
- ENDIF
- SIDESG=(-1D0)**(ISIDE-1)
-
-C...Copy incoming partons to documentation lines.
- DO 170 JT=1,2
- I1=MINT(83)+4+JT
- I2=MINT(84)+JT
- K(I1,1)=21
- K(I1,2)=K(I2,2)
- K(I1,3)=I1-2
- DO 150 J=1,5
- P(I1,J)=P(I2,J)
- 150 CONTINUE
-
-C...Second copy for partons before ISR shower, since no such.
- I1=MINT(83)+2+JT
- K(I1,1)=21
- K(I1,2)=K(I2,2)
- K(I1,3)=I1-2
- DO 160 J=1,5
- P(I1,J)=P(I2,J)
- 160 CONTINUE
- 170 CONTINUE
-
-C...Define initial partons.
- NTRY=0
- 180 NTRY=NTRY+1
- IF(NTRY.GT.100) THEN
- MINT(51)=1
- RETURN
- ENDIF
-
-C...Scattered quark in hadronic CM frame.
- I=MINT(83)+7
- K(IPU3,1)=3
- K(IPU3,2)=KFRES
- K(IPU3,3)=I
- P(IPU3,5)=PYMASS(KFRES)
- P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
- P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
- P(IPU3,5)=0D0
- K(I,1)=21
- K(I,2)=KFRES
- K(I,3)=MINT(83)+4+ISIDE
- P(I,3)=P(IPU3,3)
- P(I,4)=P(IPU3,4)
- P(I,5)=P(IPU3,5)
- N=IPU3
- MINT(21)=KFRES
- MINT(22)=0
-
-C...No primordial kT, or chosen according to truncated Gaussian or
-C...exponential, or (for photon) predetermined or power law.
- 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
- IF(MSTP(91).LE.0) THEN
- PT=0D0
- ELSEIF(MSTP(91).EQ.1) THEN
- PT=PARP(91)*SQRT(-LOG(PYR(0)))
- ELSE
- RPT1=PYR(0)
- RPT2=PYR(0)
- PT=-PARP(92)*LOG(RPT1*RPT2)
- ENDIF
- IF(PT.GT.PARP(93)) GOTO 190
- ELSEIF(MINT(106+ISIDE).EQ.3) THEN
- PTA=SQRT(VINT(282+ISIDE))
- PTB=0D0
- IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
- PTB=PARP(99)*SQRT(-LOG(PYR(0)))
- ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
- RPT1=PYR(0)
- RPT2=PYR(0)
- PTB=-PARP(99)*LOG(RPT1*RPT2)
- ENDIF
- IF(PTB.GT.PARP(100)) GOTO 190
- PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
- IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
- ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
- IF(MSTP(93).LE.0) THEN
- PT=0D0
- ELSEIF(MSTP(93).EQ.1) THEN
- PT=PARP(99)*SQRT(-LOG(PYR(0)))
- ELSEIF(MSTP(93).EQ.2) THEN
- RPT1=PYR(0)
- RPT2=PYR(0)
- PT=-PARP(99)*LOG(RPT1*RPT2)
- ELSEIF(MSTP(93).EQ.3) THEN
- HA=PARP(99)**2
- HB=PARP(100)**2
- PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
- ELSE
- HA=PARP(99)**2
- HB=PARP(100)**2
- IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
- PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
- ENDIF
- IF(PT.GT.PARP(100)) GOTO 190
- ELSE
- PT=0D0
- ENDIF
- VINT(156+ISIDE)=PT
- PHI=PARU(2)*PYR(0)
- P(IPU3,1)=PT*COS(PHI)
- P(IPU3,2)=PT*SIN(PHI)
- P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
- PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
- PCP=P(IPU3,4)+ABS(P(IPU3,3))
-
-C...Find one or two beam remnants.
- MINT(105)=MINT(102+ISIDE)
- MINT(109)=MINT(106+ISIDE)
- CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
- IF(MINT(51).NE.0) THEN
- MINT(51)=0
- GOTO 180
- ENDIF
-
-C...Store first remnant parton, with colour info and kinematics.
- I=N+1
- K(I,1)=1
- K(I,2)=KFLSP
- K(I,3)=MINT(83)+ISIDE
- P(I,5)=PYMASS(K(I,2))
- KCOL=KCHG(PYCOMP(KFLSP),2)
- IF(KCOL.NE.0) THEN
- K(I,1)=3
- KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
- K(I,KFLS+3)=MSTU(5)*IPU3
- K(IPU3,6-KFLS)=MSTU(5)*I
- ICOLR=I
- ENDIF
- IF(KFLCH.EQ.0) THEN
- P(I,1)=-P(IPU3,1)
- P(I,2)=-P(IPU3,2)
- PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
- P(I,3)=-P(IPU3,3)
- P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
- PRP=P(I,4)+ABS(P(I,3))
-
-C...When extra remnant parton or hadron: store extra remnant.
- ELSE
- I=I+1
- K(I,1)=1
- K(I,2)=KFLCH
- K(I,3)=MINT(83)+ISIDE
- P(I,5)=PYMASS(K(I,2))
- KCOL=KCHG(PYCOMP(KFLCH),2)
- IF(KCOL.NE.0) THEN
- K(I,1)=3
- KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
- K(I,KFLS+3)=MSTU(5)*IPU3
- K(IPU3,6-KFLS)=MSTU(5)*I
- ICOLR=I
- ENDIF
-
-C...Relative transverse momentum when two remnants.
- LOOP=0
- 200 LOOP=LOOP+1
- CALL PYPTDI(1,P(I-1,1),P(I-1,2))
- P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
- P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
- PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
- P(I,1)=-P(IPU3,1)-P(I-1,1)
- P(I,2)=-P(IPU3,2)-P(I-1,2)
- PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
-
-C...Relative distribution of energy for particle into jet plus particle.
- IMB=1
- IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
- IF(MSTP(94).LE.1) THEN
- IF(IMB.EQ.1) CHI=PYR(0)
- IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
- IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
- ELSEIF(MSTP(94).EQ.2) THEN
- CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
- IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
- ELSEIF(MSTP(94).EQ.3) THEN
- CALL PYZDIS(1,0,PMS(4),ZZ)
- CHI=ZZ
- ELSE
- CALL PYZDIS(1000,0,PMS(4),ZZ)
- CHI=ZZ
- ENDIF
-
-C...Construct total transverse mass; reject if too large.
- CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
- PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
- IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
- IF(LOOP.LT.10) GOTO 200
- GOTO 180
- ENDIF
- VINT(158+ISIDE)=CHI
-
-C...Subdivide longitudinal momentum according to value selected above.
- PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
- PW1=(1D0-CHI)*PRP
- P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
- P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
- PW2=CHI*PRP
- P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
- P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
- ENDIF
- N=I
-
-C...Boost current and remnant systems to correct frame.
- IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
- DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
- DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
- &(2D0*VINT(1)*PCP)
- DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
- &(2D0*VINT(1)*PRP)
- DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
- DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
- CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
- CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
-
-C...Let current quark shower; recoil but no showering by colour partner.
- QMAX=2D0*SQRT(VINT(309-ISIDE))
- MSTJ48=MSTJ(48)
- MSTJ(48)=1
- PARJ86=PARJ(86)
- PARJ(86)=0D0
- IF(MSTP(71).EQ.1) then
- if(parj(200).ne.1.) CALL PYSHOW(IPU3,ICOLR,QMAX)
- if(parj(200).eq.1.) CALL PYSHOWQ(IPU3,ICOLR,QMAX)
- endif
- MSTJ(48)=MSTJ48
- PARJ(86)=PARJ86
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYDOCU
-C...Handles the documentation of the process in MSTI and PARI,
-C...and also computes cross-sections based on accumulated statistics.
-
- SUBROUTINE PYDOCU
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
- &/PYINT5/
-
-C...Calculate Monte Carlo estimates of cross-sections.
- ISUB=MINT(1)
- IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
- NGEN(0,3)=NGEN(0,3)+1
- XSEC(0,3)=0D0
- DO 100 I=1,500
- IF(I.EQ.96.OR.I.EQ.97) THEN
- XSEC(I,3)=0D0
- ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
- & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
- XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
- & DBLE(NGEN(96,2)))
- ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
- XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
- & DBLE(NGEN(96,2)))
- ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
- XSEC(I,3)=0D0
- ELSEIF(NGEN(I,2).EQ.0) THEN
- XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
- & DBLE(NGEN(0,2)))
- ELSE
- XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
- & DBLE(NGEN(I,2)))
- ENDIF
- XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
- 100 CONTINUE
-
-C...Rescale to known low-pT cross-section for standard QCD processes.
- IF(MSUB(95).EQ.1) THEN
- XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
- & XSEC(68,3)+XSEC(95,3)
- XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
- IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
- FAC=XSECW/XSECH
- XSEC(11,3)=FAC*XSEC(11,3)
- XSEC(12,3)=FAC*XSEC(12,3)
- XSEC(13,3)=FAC*XSEC(13,3)
- XSEC(28,3)=FAC*XSEC(28,3)
- XSEC(53,3)=FAC*XSEC(53,3)
- XSEC(68,3)=FAC*XSEC(68,3)
- XSEC(95,3)=FAC*XSEC(95,3)
- XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
- ENDIF
- ENDIF
-
-C...Save information for gamma-p and gamma-gamma.
- IF(MINT(121).GT.1) THEN
- IGA=MINT(122)
- CALL PYSAVE(2,IGA)
- CALL PYSAVE(5,0)
- ENDIF
-
-C...Reset information on hard interaction.
- DO 110 J=1,200
- MSTI(J)=0
- PARI(J)=0D0
- 110 CONTINUE
-
-C...Copy integer valued information from MINT into MSTI.
- DO 120 J=1,32
- MSTI(J)=MINT(J)
- 120 CONTINUE
- IF(MINT(121).GT.1) MSTI(9)=MINT(122)
-
-C...Store cross-section variables in PARI.
- PARI(1)=XSEC(0,3)
- PARI(2)=XSEC(0,3)/MINT(5)
- PARI(7)=VINT(97)
- PARI(9)=VINT(99)
- PARI(10)=VINT(100)
- VINT(98)=VINT(98)+VINT(100)
- IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
-
-C...Store kinematics variables in PARI.
- PARI(11)=VINT(1)
- PARI(12)=VINT(2)
- IF(ISUB.NE.95) THEN
- DO 130 J=13,26
- PARI(J)=VINT(30+J)
- 130 CONTINUE
- PARI(29)=VINT(39)
- PARI(30)=VINT(40)
- PARI(31)=VINT(141)
- PARI(32)=VINT(142)
- PARI(33)=VINT(41)
- PARI(34)=VINT(42)
- PARI(35)=PARI(33)-PARI(34)
- PARI(36)=VINT(21)
- PARI(37)=VINT(22)
- PARI(38)=VINT(26)
- PARI(39)=VINT(157)
- PARI(40)=VINT(158)
- PARI(41)=VINT(23)
- PARI(42)=2D0*VINT(47)/VINT(1)
- ENDIF
-
-C...Store information on scattered partons in PARI.
- IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
- DO 140 IS=7,8
- I=MINT(IS)
- PARI(36+IS)=P(I,3)/VINT(1)
- PARI(38+IS)=P(I,4)/VINT(1)
- PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
- PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
- & SQRT(PR),1D20)),P(I,3))
- PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
- PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
- & SQRT(PR),1D20)),P(I,3))
- PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
- PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
- PARI(48+IS)=PYANGL(P(I,1),P(I,2))
- 140 CONTINUE
- ENDIF
-
-C...Store sum up transverse and longitudinal momenta.
- PARI(65)=2D0*PARI(17)
- IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
- DO 150 I=MSTP(126)+1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
- PT=SQRT(P(I,1)**2+P(I,2)**2)
- PARI(69)=PARI(69)+PT
- IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
- IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
- 150 CONTINUE
- PARI(67)=PARI(68)
- PARI(71)=VINT(151)
- PARI(72)=VINT(152)
- PARI(73)=VINT(151)
- PARI(74)=VINT(152)
- ELSE
- PARI(66)=PARI(65)
- PARI(69)=PARI(65)
- ENDIF
-
-C...Store various other pieces of information into PARI.
- PARI(61)=VINT(148)
- PARI(75)=VINT(155)
- PARI(76)=VINT(156)
- PARI(77)=VINT(159)
- PARI(78)=VINT(160)
- PARI(81)=VINT(138)
-
-C...Store information on lepton -> lepton + gamma in PYGAGA.
- MSTI(71)=MINT(141)
- MSTI(72)=MINT(142)
- PARI(101)=VINT(301)
- PARI(102)=VINT(302)
- DO 160 I=103,114
- PARI(I)=VINT(I+202)
- 160 CONTINUE
-
-C...Set information for PYTABU.
- IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
- MSTU(161)=MINT(21)
- MSTU(162)=0
- ELSEIF(ISET(ISUB).EQ.5) THEN
- MSTU(161)=MINT(23)
- MSTU(162)=0
- ELSE
- MSTU(161)=MINT(21)
- MSTU(162)=MINT(22)
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYFRAM
-C...Performs transformations between different coordinate frames.
-
- SUBROUTINE PYFRAM(IFRAME)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYDAT1/,/PYPARS/,/PYINT1/
-
-C...Check that transformation can and should be done.
- IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
- &MINT(91).EQ.1)) THEN
- IF(IFRAME.EQ.MINT(6)) RETURN
- ELSE
- WRITE(MSTU(11),5000) IFRAME,MINT(6)
- RETURN
- ENDIF
-
- IF(MINT(6).EQ.1) THEN
-C...Transform from fixed target or user specified frame to
-C...overall CM frame.
- CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
- CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
- CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
- ELSEIF(MINT(6).EQ.3) THEN
-C...Transform from hadronic CM frame in DIS to overall CM frame.
- CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
- & -VINT(225))
- ENDIF
-
- IF(IFRAME.EQ.1) THEN
-C...Transform from overall CM frame to fixed target or user specified
-C...frame.
- CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
- ELSEIF(IFRAME.EQ.3) THEN
-C...Transform from overall CM frame to hadronic CM frame in DIS.
- CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
- CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
- CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
- ENDIF
-
-C...Set information about new frame.
- MINT(6)=IFRAME
- MSTI(6)=IFRAME
-
- 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
- &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
- &1X,I5)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYWIDT
-C...Calculates full and partial widths of resonances.
-
- SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
- &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/
-C...Local arrays and saved variables.
- COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
- DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
- &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
- SAVE MOFSV,WIDWSV,WID2SV
- DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
-
-C...Compressed code and sign; mass.
- KFLA=IABS(KFLR)
- KFLS=ISIGN(1,KFLR)
- KC=PYCOMP(KFLA)
- SHR=SQRT(SH)
- PMR=PMAS(KC,1)
-
-C...Reset width information.
- DO 110 I=0,MDCY(KC,3)
- WDTP(I)=0D0
- DO 100 J=0,5
- WDTE(I,J)=0D0
- 100 CONTINUE
- 110 CONTINUE
-
-C...Allow for fudge factor to rescale resonance width.
- FUDGE=1D0
- IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
- &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
- IF(MSTP(110).EQ.KFLA) THEN
- FUDGE=PARP(110)
- ELSEIF(MSTP(110).EQ.-1) THEN
- IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
- ELSEIF(MSTP(110).EQ.-2) THEN
- FUDGE=PARP(110)
- ENDIF
- ENDIF
-
-C...Not to be treated as a resonance: return.
- IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
- &KFLA.NE.22) THEN
- WDTP(0)=1D0
- WDTE(0,0)=1D0
- MINT(61)=0
- MINT(62)=0
- MINT(63)=0
- RETURN
-
-C...Treatment as a resonance based on tabulated branching ratios.
- ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
-C...Loop over possible decay channels; skip irrelevant ones.
- DO 120 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 120
-
-C...Read out decay products and nominal masses.
- KFD1=KFDP(IDC,1)
- KFC1=PYCOMP(KFD1)
- IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
- PM1=PMAS(KFC1,1)
- KFD2=KFDP(IDC,2)
- KFC2=PYCOMP(KFD2)
- IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
- PM2=PMAS(KFC2,1)
- KFD3=KFDP(IDC,3)
- PM3=0D0
- IF(KFD3.NE.0) THEN
- KFC3=PYCOMP(KFD3)
- IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
- PM3=PMAS(KFC3,1)
- ENDIF
-
-C...Naive partial width and alternative threshold factors.
- WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
- IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
- & PM1+PM2+PM3.GE.SHR) THEN
- WDTP(I)=0D0
- ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
- WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
- & 4D0*PM1**2*PM2**2))/SH
- ELSEIF(MDME(IDC,2).EQ.52) THEN
- PMA=MAX(PM1,PM2,PM3)
- PMC=MIN(PM1,PM2,PM3)
- PMB=PM1+PM2+PM3-PMA-PMC
- PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
- PMAN=PMA**2/SH
- PMBN=PMB**2/SH
- PMCN=PMC**2/SH
- PMBCN=PMBC**2/SH
- WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
- & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
- & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
- & ((SHR-PMA)**2-(PMB+PMC)**2)*
- & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
- & ((1D0-PMBCN)*PMBCN*SH)
- ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
- WDTP(I)=WDTP(I)*SQRT(
- & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
- & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
- ELSEIF(MDME(IDC,2).EQ.53) THEN
- PMA=MAX(PM1,PM2,PM3)
- PMC=MIN(PM1,PM2,PM3)
- PMB=PM1+PM2+PM3-PMA-PMC
- PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
- PMAN=PMA**2/SH
- PMBN=PMB**2/SH
- PMCN=PMC**2/SH
- PMBCN=PMBC**2/SH
- FACACT=SQRT(MAX(0D0,
- & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
- & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
- & ((SHR-PMA)**2-(PMB+PMC)**2)*
- & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
- & ((1D0-PMBCN)*PMBCN*SH)
- PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
- PMAN=PMA**2/PMR**2
- PMBN=PMB**2/PMR**2
- PMCN=PMC**2/PMR**2
- PMBCN=PMBC**2/PMR**2
- FACNOM=SQRT(MAX(0D0,
- & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
- & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
- & ((PMR-PMA)**2-(PMB+PMC)**2)*
- & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
- & ((1D0-PMBCN)*PMBCN*PMR**2)
- WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
-
-C...Calculate secondary width (at most two identical/opposite).
- WID2=1D0
- IF(MDME(IDC,1).GT.0) THEN
- IF(KFD2.EQ.KFD1) THEN
- IF(KCHG(KFC1,3).EQ.0) THEN
- WID2=WIDS(KFC1,1)
- ELSEIF(KFD1.GT.0) THEN
- WID2=WIDS(KFC1,4)
- ELSE
- WID2=WIDS(KFC1,5)
- ENDIF
- IF(KFD3.GT.0) THEN
- WID2=WID2*WIDS(KFC3,2)
- ELSEIF(KFD3.LT.0) THEN
- WID2=WID2*WIDS(KFC3,3)
- ENDIF
- ELSEIF(KFD2.EQ.-KFD1) THEN
- WID2=WIDS(KFC1,1)
- IF(KFD3.GT.0) THEN
- WID2=WID2*WIDS(KFC3,2)
- ELSEIF(KFD3.LT.0) THEN
- WID2=WID2*WIDS(KFC3,3)
- ENDIF
- ELSEIF(KFD3.EQ.KFD1) THEN
- IF(KCHG(KFC1,3).EQ.0) THEN
- WID2=WIDS(KFC1,1)
- ELSEIF(KFD1.GT.0) THEN
- WID2=WIDS(KFC1,4)
- ELSE
- WID2=WIDS(KFC1,5)
- ENDIF
- IF(KFD2.GT.0) THEN
- WID2=WID2*WIDS(KFC2,2)
- ELSEIF(KFD2.LT.0) THEN
- WID2=WID2*WIDS(KFC2,3)
- ENDIF
- ELSEIF(KFD3.EQ.-KFD1) THEN
- WID2=WIDS(KFC1,1)
- IF(KFD2.GT.0) THEN
- WID2=WID2*WIDS(KFC2,2)
- ELSEIF(KFD2.LT.0) THEN
- WID2=WID2*WIDS(KFC2,3)
- ENDIF
- ELSEIF(KFD3.EQ.KFD2) THEN
- IF(KCHG(KFC2,3).EQ.0) THEN
- WID2=WIDS(KFC2,1)
- ELSEIF(KFD2.GT.0) THEN
- WID2=WIDS(KFC2,4)
- ELSE
- WID2=WIDS(KFC2,5)
- ENDIF
- IF(KFD1.GT.0) THEN
- WID2=WID2*WIDS(KFC1,2)
- ELSEIF(KFD1.LT.0) THEN
- WID2=WID2*WIDS(KFC1,3)
- ENDIF
- ELSEIF(KFD3.EQ.-KFD2) THEN
- WID2=WIDS(KFC2,1)
- IF(KFD1.GT.0) THEN
- WID2=WID2*WIDS(KFC1,2)
- ELSEIF(KFD1.LT.0) THEN
- WID2=WID2*WIDS(KFC1,3)
- ENDIF
- ELSE
- IF(KFD1.GT.0) THEN
- WID2=WIDS(KFC1,2)
- ELSE
- WID2=WIDS(KFC1,3)
- ENDIF
- IF(KFD2.GT.0) THEN
- WID2=WID2*WIDS(KFC2,2)
- ELSE
- WID2=WID2*WIDS(KFC2,3)
- ENDIF
- IF(KFD3.GT.0) THEN
- WID2=WID2*WIDS(KFC3,2)
- ELSEIF(KFD3.LT.0) THEN
- WID2=WID2*WIDS(KFC3,3)
- ENDIF
- ENDIF
-
-C...Store effective widths according to case.
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 120 CONTINUE
-C...Return.
- MINT(61)=0
- MINT(62)=0
- MINT(63)=0
- RETURN
- ENDIF
-
-C...Here begins detailed dynamical calculation of resonance widths.
-C...Shared treatment of Higgs states.
- KFHIGG=25
- IHIGG=1
- IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
- KFHIGG=KFLA
- IHIGG=KFLA-33
- ENDIF
-
-C...Common electroweak and strong constants.
- XW=PARU(102)
- XWV=XW
- IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
- XW1=1D0-XW
- AEM=PYALEM(SH)
- IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
- AS=PYALPS(SH)
- RADC=1D0+AS/PARU(1)
-
- IF(KFLA.EQ.6) THEN
-C...t quark.
- FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
- RADCT=1D0-2.5D0*AS/PARU(1)
- DO 140 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 140
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
- WID2=1D0
- IF(I.GE.4.AND.I.LE.7) THEN
-C...t -> W + q; including approximate QCD correction factor.
- WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
- & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
- IF(KFLR.GT.0) THEN
- WID2=WIDS(24,2)
- IF(I.EQ.7) WID2=WID2*WIDS(7,2)
- ELSE
- WID2=WIDS(24,3)
- IF(I.EQ.7) WID2=WID2*WIDS(7,3)
- ENDIF
- ELSEIF(I.EQ.9) THEN
-C...t -> H + b.
- RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
- WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
- & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
- & 4D0*SQRT(RM2R*RM2))
- WID2=WIDS(37,2)
- IF(KFLR.LT.0) WID2=WIDS(37,3)
-CMRENNA++
- ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
-C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
- BETA=ATAN(RMSS(5))
- SINB=SIN(BETA)
- TANW=SQRT(PARU(102)/(1D0-PARU(102)))
- ET=KCHG(6,1)/3D0
- T3L=SIGN(0.5D0,ET)
- KFC1=PYCOMP(KFDP(IDC,1))
- KFC2=PYCOMP(KFDP(IDC,2))
- PMNCHI=PMAS(KFC1,1)
- PMSTOP=PMAS(KFC2,1)
- IF(SHR.GT.PMNCHI+PMSTOP) THEN
- IZ=I-9
- DO 130 IK=1,4
- ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
- 130 CONTINUE
- AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
- AR=-ET*ZMIXC(IZ,1)*TANW
- BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
- BR=AL
- FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
- FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
- PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
- & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
- WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
- & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
- & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
- IF(KFLR.GT.0) THEN
- WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
- ELSE
- WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
- ENDIF
- ENDIF
- ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
-C...t -> ~g + ~t
- KFC1=PYCOMP(KFDP(IDC,1))
- KFC2=PYCOMP(KFDP(IDC,2))
- PMNCHI=PMAS(KFC1,1)
- PMSTOP=PMAS(KFC2,1)
- IF(SHR.GT.PMNCHI+PMSTOP) THEN
- RL=SFMIX(6,1)
- RR=-SFMIX(6,2)
- PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
- & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
- WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
- & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
- IF(KFLR.GT.0) THEN
- WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
- ELSE
- WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
- ENDIF
- ENDIF
- ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
-C...t -> ~gravitino + ~t
- XMP2=RMSS(29)**2
- KFC1=PYCOMP(KFDP(IDC,1))
- XMGR2=PMAS(KFC1,1)**2
- WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
- KFC2=PYCOMP(KFDP(IDC,2))
- WID2=WIDS(KFC2,2)
- IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
-CMRENNA--
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 140 CONTINUE
-
- ELSEIF(KFLA.EQ.7) THEN
-C...b' quark.
- FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
- DO 150 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 150
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
- WID2=1D0
- IF(I.GE.4.AND.I.LE.7) THEN
-C...b' -> W + q.
- WDTP(I)=FAC*VCKM(I-3,4)*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
- & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
- IF(KFLR.GT.0) THEN
- WID2=WIDS(24,3)
- IF(I.EQ.6) WID2=WID2*WIDS(6,2)
- IF(I.EQ.7) WID2=WID2*WIDS(8,2)
- ELSE
- WID2=WIDS(24,2)
- IF(I.EQ.6) WID2=WID2*WIDS(6,3)
- IF(I.EQ.7) WID2=WID2*WIDS(8,3)
- ENDIF
- WID2=WIDS(24,3)
- IF(KFLR.LT.0) WID2=WIDS(24,2)
- ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
-C...b' -> H + q.
- WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
- & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
- IF(KFLR.GT.0) THEN
- WID2=WIDS(37,3)
- IF(I.EQ.10) WID2=WID2*WIDS(6,2)
- ELSE
- WID2=WIDS(37,2)
- IF(I.EQ.10) WID2=WID2*WIDS(6,3)
- ENDIF
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 150 CONTINUE
-
- ELSEIF(KFLA.EQ.8) THEN
-C...t' quark.
- FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
- DO 160 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 160
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
- WID2=1D0
- IF(I.GE.4.AND.I.LE.7) THEN
-C...t' -> W + q.
- WDTP(I)=FAC*VCKM(4,I-3)*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
- & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
- IF(KFLR.GT.0) THEN
- WID2=WIDS(24,2)
- IF(I.EQ.7) WID2=WID2*WIDS(7,2)
- ELSE
- WID2=WIDS(24,3)
- IF(I.EQ.7) WID2=WID2*WIDS(7,3)
- ENDIF
- ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
-C...t' -> H + q.
- WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
- & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
- IF(KFLR.GT.0) THEN
- WID2=WIDS(37,2)
- IF(I.EQ.10) WID2=WID2*WIDS(7,2)
- ELSE
- WID2=WIDS(37,3)
- IF(I.EQ.10) WID2=WID2*WIDS(7,3)
- ENDIF
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 160 CONTINUE
-
- ELSEIF(KFLA.EQ.17) THEN
-C...tau' lepton.
- FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
- DO 170 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 170
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
- WID2=1D0
- IF(I.EQ.3) THEN
-C...tau' -> W + nu'_tau.
- WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
- & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
- IF(KFLR.GT.0) THEN
- WID2=WIDS(24,3)
- WID2=WID2*WIDS(18,2)
- ELSE
- WID2=WIDS(24,2)
- WID2=WID2*WIDS(18,3)
- ENDIF
- ELSEIF(I.EQ.5) THEN
-C...tau' -> H + nu'_tau.
- WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
- & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
- IF(KFLR.GT.0) THEN
- WID2=WIDS(37,3)
- WID2=WID2*WIDS(18,2)
- ELSE
- WID2=WIDS(37,2)
- WID2=WID2*WIDS(18,3)
- ENDIF
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 170 CONTINUE
-
- ELSEIF(KFLA.EQ.18) THEN
-C...nu'_tau neutrino.
- FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
- DO 180 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 180
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
- WID2=1D0
- IF(I.EQ.2) THEN
-C...nu'_tau -> W + tau'.
- WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
- & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
- IF(KFLR.GT.0) THEN
- WID2=WIDS(24,2)
- WID2=WID2*WIDS(17,2)
- ELSE
- WID2=WIDS(24,3)
- WID2=WID2*WIDS(17,3)
- ENDIF
- ELSEIF(I.EQ.3) THEN
-C...nu'_tau -> H + tau'.
- WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
- & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
- IF(KFLR.GT.0) THEN
- WID2=WIDS(37,2)
- WID2=WID2*WIDS(17,2)
- ELSE
- WID2=WIDS(37,3)
- WID2=WID2*WIDS(17,3)
- ENDIF
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 180 CONTINUE
-
- ELSEIF(KFLA.EQ.21) THEN
-C...QCD:
-C***Note that widths are not given in dimensional quantities here.
- DO 190 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 190
- RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
- WID2=1D0
- IF(I.LE.8) THEN
-C...QCD -> q + qbar
- WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
- IF(I.EQ.6) WID2=WIDS(6,1)
- IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 190 CONTINUE
-
- ELSEIF(KFLA.EQ.22) THEN
-C...QED photon.
-C***Note that widths are not given in dimensional quantities here.
- DO 200 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 200
- RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
- WID2=1D0
- IF(I.LE.8) THEN
-C...QED -> q + qbar.
- EF=KCHG(I,1)/3D0
- FCOF=3D0*RADC
- IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
- WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
- IF(I.EQ.6) WID2=WIDS(6,1)
- IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
- ELSEIF(I.LE.12) THEN
-C...QED -> l+ + l-.
- EF=KCHG(9+2*(I-8),1)/3D0
- WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
- IF(I.EQ.12) WID2=WIDS(17,1)
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 200 CONTINUE
-
- ELSEIF(KFLA.EQ.23) THEN
-C...Z0:
- ICASE=1
- XWC=1D0/(16D0*XW*XW1)
- FAC=(AEM*XWC/3D0)*SHR
- 210 CONTINUE
- IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
- VINT(111)=0D0
- VINT(112)=0D0
- VINT(114)=0D0
- ENDIF
- IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
- KFI=IABS(MINT(15))
- IF(KFI.GT.20) KFI=IABS(MINT(16))
- EI=KCHG(KFI,1)/3D0
- AI=SIGN(1D0,EI)
- VI=AI-4D0*EI*XWV
- SQMZ=PMAS(23,1)**2
- HZ=SHR*WDTP(0)
- IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
- IF(MSTP(43).EQ.3) VINT(112)=
- & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
- IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
- & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
- ENDIF
- DO 220 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 220
- RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
- WID2=1D0
- IF(I.LE.8) THEN
-C...Z0 -> q + qbar
- EF=KCHG(I,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- FCOF=3D0*RADC
- IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
- IF(I.EQ.6) WID2=WIDS(6,1)
- IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
- ELSEIF(I.LE.16) THEN
-C...Z0 -> l+ + l-, nu + nubar
- EF=KCHG(I+2,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- FCOF=1D0
- IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
- ENDIF
- BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
- IF(ICASE.EQ.1) THEN
- WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
- & BE34
- ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
- WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
- & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
- & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
- ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
- FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
- FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
- FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
- ENDIF
- IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
- IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
- & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
- & WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
- IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
- & VINT(111)+FGGF*WID2
- IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
- IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
- & VINT(114)+FZZF*WID2
- ENDIF
- ENDIF
- 220 CONTINUE
- IF(MINT(61).GE.1) ICASE=3-ICASE
- IF(ICASE.EQ.2) GOTO 210
-
- ELSEIF(KFLA.EQ.24) THEN
-C...W+/-:
- FAC=(AEM/(24D0*XW))*SHR
- DO 230 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 230
- RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
- WID2=1D0
- IF(I.LE.16) THEN
-C...W+/- -> q + qbar'
- FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
- IF(KFLR.GT.0) THEN
- IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
- IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
- IF(I.GE.13) WID2=WID2*WIDS(7,3)
- ELSE
- IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
- IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
- IF(I.GE.13) WID2=WID2*WIDS(7,2)
- ENDIF
- ELSEIF(I.LE.20) THEN
-C...W+/- -> l+/- + nu
- FCOF=1D0
- IF(KFLR.GT.0) THEN
- IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
- ELSE
- IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
- ENDIF
- ENDIF
- WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 230 CONTINUE
-
- ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
-C...h0 (or H0, or A0):
- SHFS=SH
- FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
- DO 270 I=1,MDCY(KFHIGG,3)
- IDC=I+MDCY(KFHIGG,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 270
- KFC1=PYCOMP(KFDP(IDC,1))
- KFC2=PYCOMP(KFDP(IDC,2))
- RM1=PMAS(KFC1,1)**2/SH
- RM2=PMAS(KFC2,1)**2/SH
- IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
- & GOTO 270
- WID2=1D0
-
- IF(I.LE.8) THEN
-C...h0 -> q + qbar
- WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
- & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
-C...A0 behaves like beta, ho and H0 like beta**3.
- IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
- IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
- IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
- IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
- WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
- IF(IHIGG.NE.3) THEN
- WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
- & PARU(151+10*IHIGG))**2
- ENDIF
- ENDIF
- ENDIF
- IF(I.EQ.6) WID2=WIDS(6,1)
- IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
- ELSEIF(I.LE.12) THEN
-C...h0 -> l+ + l-
- WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
-C...A0 behaves like beta, ho and H0 like beta**3.
- IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
- & PARU(153+10*IHIGG)**2
- IF(I.EQ.12) WID2=WIDS(17,1)
-
- ELSEIF(I.EQ.13) THEN
-C...h0 -> g + g; quark loop contribution only
- ETARE=0D0
- ETAIM=0D0
- DO 240 J=1,2*MSTP(1)
- EPS=(2D0*PMAS(J,1))**2/SH
-C...Loop integral; function of eps=4m^2/shat; different for A0.
- IF(EPS.LE.1D0) THEN
- IF(EPS.GT.1D-4) THEN
- ROOT=SQRT(1D0-EPS)
- RLN=LOG((1D0+ROOT)/(1D0-ROOT))
- ELSE
- RLN=LOG(4D0/EPS-2D0)
- ENDIF
- PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
- PHIIM=0.5D0*PARU(1)*RLN
- ELSE
- PHIRE=(ASIN(1D0/SQRT(EPS)))**2
- PHIIM=0D0
- ENDIF
- IF(IHIGG.LE.2) THEN
- ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
- ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
- ELSE
- ETAREJ=-0.5D0*EPS*PHIRE
- ETAIMJ=-0.5D0*EPS*PHIIM
- ENDIF
-C...Couplings (=1 for standard model Higgs).
- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
- IF(MOD(J,2).EQ.1) THEN
- ETAREJ=ETAREJ*PARU(151+10*IHIGG)
- ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
- ELSE
- ETAREJ=ETAREJ*PARU(152+10*IHIGG)
- ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
- ENDIF
- ENDIF
- ETARE=ETARE+ETAREJ
- ETAIM=ETAIM+ETAIMJ
- 240 CONTINUE
- ETA2=ETARE**2+ETAIM**2
- WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
-
- ELSEIF(I.EQ.14) THEN
-C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
- ETARE=0D0
- ETAIM=0D0
- JMAX=3*MSTP(1)+1
- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
- DO 250 J=1,JMAX
- IF(J.LE.2*MSTP(1)) THEN
- EJ=KCHG(J,1)/3D0
- EPS=(2D0*PMAS(J,1))**2/SH
- ELSEIF(J.LE.3*MSTP(1)) THEN
- JL=2*(J-2*MSTP(1))-1
- EJ=KCHG(10+JL,1)/3D0
- EPS=(2D0*PMAS(10+JL,1))**2/SH
- ELSEIF(J.EQ.3*MSTP(1)+1) THEN
- EPS=(2D0*PMAS(24,1))**2/SH
- ELSE
- EPS=(2D0*PMAS(37,1))**2/SH
- ENDIF
-C...Loop integral; function of eps=4m^2/shat.
- IF(EPS.LE.1D0) THEN
- IF(EPS.GT.1D-4) THEN
- ROOT=SQRT(1D0-EPS)
- RLN=LOG((1D0+ROOT)/(1D0-ROOT))
- ELSE
- RLN=LOG(4D0/EPS-2D0)
- ENDIF
- PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
- PHIIM=0.5D0*PARU(1)*RLN
- ELSE
- PHIRE=(ASIN(1D0/SQRT(EPS)))**2
- PHIIM=0D0
- ENDIF
- IF(J.LE.3*MSTP(1)) THEN
-C...Fermion loops: loop integral different for A0; charges.
- IF(IHIGG.LE.2) THEN
- PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
- PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
- ELSE
- PHIPRE=-0.5D0*EPS*PHIRE
- PHIPIM=-0.5D0*EPS*PHIIM
- ENDIF
- IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
- EJC=3D0*EJ**2
- EJH=PARU(151+10*IHIGG)
- ELSEIF(J.LE.2*MSTP(1)) THEN
- EJC=3D0*EJ**2
- EJH=PARU(152+10*IHIGG)
- ELSE
- EJC=EJ**2
- EJH=PARU(153+10*IHIGG)
- ENDIF
- IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
- ETAREJ=EJC*EJH*PHIPRE
- ETAIMJ=EJC*EJH*PHIPIM
- ELSEIF(J.EQ.3*MSTP(1)+1) THEN
-C...W loops: loop integral and charges.
- ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
- ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
- ETAREJ=ETAREJ*PARU(155+10*IHIGG)
- ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
- ENDIF
- ELSE
-C...Charged H loops: loop integral and charges.
- FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
- & PARU(158+10*IHIGG+2*(IHIGG/3))
- ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
- ETAIMJ=-EPS**2*PHIIM*FACHHH
- ENDIF
- ETARE=ETARE+ETAREJ
- ETAIM=ETAIM+ETAIMJ
- 250 CONTINUE
- ETA2=ETARE**2+ETAIM**2
- WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
-
- ELSEIF(I.EQ.15) THEN
-C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
- ETARE=0D0
- ETAIM=0D0
- JMAX=3*MSTP(1)+1
- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
- DO 260 J=1,JMAX
- IF(J.LE.2*MSTP(1)) THEN
- EJ=KCHG(J,1)/3D0
- AJ=SIGN(1D0,EJ+0.1D0)
- VJ=AJ-4D0*EJ*XWV
- EPS=(2D0*PMAS(J,1))**2/SH
- EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
- ELSEIF(J.LE.3*MSTP(1)) THEN
- JL=2*(J-2*MSTP(1))-1
- EJ=KCHG(10+JL,1)/3D0
- AJ=SIGN(1D0,EJ+0.1D0)
- VJ=AJ-4D0*EJ*XWV
- EPS=(2D0*PMAS(10+JL,1))**2/SH
- EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
- ELSE
- EPS=(2D0*PMAS(24,1))**2/SH
- EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
- ENDIF
-C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
- IF(EPS.LE.1D0) THEN
- ROOT=SQRT(1D0-EPS)
- IF(EPS.GT.1D-4) THEN
- RLN=LOG((1D0+ROOT)/(1D0-ROOT))
- ELSE
- RLN=LOG(4D0/EPS-2D0)
- ENDIF
- PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
- PHIIM=0.5D0*PARU(1)*RLN
- PSIRE=0.5D0*ROOT*RLN
- PSIIM=-0.5D0*ROOT*PARU(1)
- ELSE
- PHIRE=(ASIN(1D0/SQRT(EPS)))**2
- PHIIM=0D0
- PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
- PSIIM=0D0
- ENDIF
- IF(EPSP.LE.1D0) THEN
- ROOT=SQRT(1D0-EPSP)
- IF(EPSP.GT.1D-4) THEN
- RLN=LOG((1D0+ROOT)/(1D0-ROOT))
- ELSE
- RLN=LOG(4D0/EPSP-2D0)
- ENDIF
- PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
- PHIIMP=0.5D0*PARU(1)*RLN
- PSIREP=0.5D0*ROOT*RLN
- PSIIMP=-0.5D0*ROOT*PARU(1)
- ELSE
- PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
- PHIIMP=0D0
- PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
- PSIIMP=0D0
- ENDIF
- FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
- & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
- FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
- & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
- F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
- F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
- IF(J.LE.3*MSTP(1)) THEN
-C...Fermion loops: loop integral different for A0; charges.
- IF(IHIGG.EQ.3) FXYRE=0D0
- IF(IHIGG.EQ.3) FXYIM=0D0
- IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
- EJC=-3D0*EJ*VJ
- EJH=PARU(151+10*IHIGG)
- ELSEIF(J.LE.2*MSTP(1)) THEN
- EJC=-3D0*EJ*VJ
- EJH=PARU(152+10*IHIGG)
- ELSE
- EJC=-EJ*VJ
- EJH=PARU(153+10*IHIGG)
- ENDIF
- IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
- ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
- ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
- ELSEIF(J.EQ.3*MSTP(1)+1) THEN
-C...W loops: loop integral and charges.
- HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
- ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
- ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
- ETAREJ=ETAREJ*PARU(155+10*IHIGG)
- ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
- ENDIF
- ELSE
-C...Charged H loops: loop integral and charges.
- FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
- & PARU(158+10*IHIGG+2*(IHIGG/3))
- ETAREJ=FACHHH*FXYRE
- ETAIMJ=FACHHH*FXYIM
- ENDIF
- ETARE=ETARE+ETAREJ
- ETAIM=ETAIM+ETAIMJ
- 260 CONTINUE
- ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
- WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
- WID2=WIDS(23,2)
-
- ELSEIF(I.LE.17) THEN
-C...h0 -> Z0 + Z0, W+ + W-
- PM1=PMAS(IABS(KFDP(IDC,1)),1)
- PG1=PMAS(IABS(KFDP(IDC,1)),2)
- IF(MINT(62).GE.1) THEN
- IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
- & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
- & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
- MOFSV(IHIGG,I-15)=0
- WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
- & 1D0-4D0*RM1))
- WID2=1D0
- ELSE
- MOFSV(IHIGG,I-15)=1
- RMAS=SQRT(MAX(0D0,SH))
- CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
- & WID2)
- WIDWSV(IHIGG,I-15)=WIDW
- WID2SV(IHIGG,I-15)=WID2
- ENDIF
- ELSE
- IF(MOFSV(IHIGG,I-15).EQ.0) THEN
- WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
- & 1D0-4D0*RM1))
- WID2=1D0
- ELSE
- WIDW=WIDWSV(IHIGG,I-15)
- WID2=WID2SV(IHIGG,I-15)
- ENDIF
- ENDIF
- WDTP(I)=FAC*WIDW/(2D0*(18-I))
- IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
- & PARU(138+I+10*IHIGG)**2
- WID2=WID2*WIDS(7+I,1)
-
- ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
-C...H0 -> Z0 + h0, A0-> Z0 + h0
- WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
- & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
- IF(IHIGG.EQ.2) THEN
- WDTP(I)=WDTP(I)*PARU(179)**2
- ELSEIF(IHIGG.EQ.3) THEN
- WDTP(I)=WDTP(I)*PARU(186)**2
- ENDIF
- WID2=WIDS(23,2)*WIDS(25,2)
-
- ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
-C...H0 -> h0 + h0, A0-> h0 + h0
- WDTP(I)=FAC*0.25D0*
- & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
- IF(IHIGG.EQ.2) THEN
- WDTP(I)=WDTP(I)*PARU(176)**2
- ELSEIF(IHIGG.EQ.3) THEN
- WDTP(I)=WDTP(I)*PARU(169)**2
- ENDIF
- WID2=WIDS(25,1)
- ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
-C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
- WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
- & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
- & *PARU(195+IHIGG)**2
- IF(I.EQ.20) THEN
- WID2=WIDS(24,2)*WIDS(37,3)
- ELSEIF(I.EQ.21) THEN
- WID2=WIDS(24,3)*WIDS(37,2)
- ENDIF
-
- ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
-C...H0 -> Z0 + A0.
- WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
- & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
- WID2=WIDS(36,2)*WIDS(23,2)
-
- ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
-C...H0 -> h0 + A0.
- WDTP(I)=FAC*0.5D0*PARU(180)**2*
- & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
- WID2=WIDS(25,2)*WIDS(36,2)
-
- ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
-C...H0 -> A0 + A0
- WDTP(I)=FAC*0.25D0*PARU(177)**2*
- & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
- WID2=WIDS(36,1)
-
-CMRENNA++
- ELSE
-C...Add in SUSY decays (two-body) by rescaling by phase space factor.
- RM10=RM1*SH/PMR**2
- RM20=RM2*SH/PMR**2
- WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
- WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
- IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
- WFAC=0D0
- ELSE
- WFAC=WFAC/WFAC0
- ENDIF
- WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
-CMRENNA--
- IF(KFC2.EQ.KFC1) THEN
- WID2=WIDS(KFC1,1)
- ELSE
- KSGN1=2
- IF(KFDP(IDC,1).LT.0) KSGN1=3
- KSGN2=2
- IF(KFDP(IDC,2).LT.0) KSGN2=3
- WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
- ENDIF
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 270 CONTINUE
-
- ELSEIF(KFLA.EQ.32) THEN
-C...Z'0:
- ICASE=1
- XWC=1D0/(16D0*XW*XW1)
- FAC=(AEM*XWC/3D0)*SHR
- VINT(117)=0D0
- 280 CONTINUE
- IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
- VINT(111)=0D0
- VINT(112)=0D0
- VINT(113)=0D0
- VINT(114)=0D0
- VINT(115)=0D0
- VINT(116)=0D0
- ENDIF
- IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
- KFAI=IABS(MINT(15))
- EI=KCHG(KFAI,1)/3D0
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*XWV
- KFAIC=1
- IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
- IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
- IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
- IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
- VPI=PARU(119+2*KFAIC)
- API=PARU(120+2*KFAIC)
- ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
- VPI=PARJ(178+2*KFAIC)
- API=PARJ(179+2*KFAIC)
- ELSE
- VPI=PARJ(186+2*KFAIC)
- API=PARJ(187+2*KFAIC)
- ENDIF
- SQMZ=PMAS(23,1)**2
- HZ=SHR*VINT(117)
- SQMZP=PMAS(32,1)**2
- HZP=SHR*WDTP(0)
- IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
- & MSTP(44).EQ.7) VINT(111)=1D0
- IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
- & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
- IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
- & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
- IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
- & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
- IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
- & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
- & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
- IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
- & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
- ENDIF
- DO 290 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 290
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
- WID2=1D0
- IF(I.LE.16) THEN
- IF(I.LE.8) THEN
-C...Z'0 -> q + qbar
- EF=KCHG(I,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- IF(I.LE.2) THEN
- VPF=PARU(123-2*MOD(I,2))
- APF=PARU(124-2*MOD(I,2))
- ELSEIF(I.LE.4) THEN
- VPF=PARJ(182-2*MOD(I,2))
- APF=PARJ(183-2*MOD(I,2))
- ELSE
- VPF=PARJ(190-2*MOD(I,2))
- APF=PARJ(191-2*MOD(I,2))
- ENDIF
- FCOF=3D0*RADC
- IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
- & PYHFTH(SH,SH*RM1,1D0)
- IF(I.EQ.6) WID2=WIDS(6,1)
- IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
- ELSEIF(I.LE.16) THEN
-C...Z'0 -> l+ + l-, nu + nubar
- EF=KCHG(I+2,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- IF(I.LE.10) THEN
- VPF=PARU(127-2*MOD(I,2))
- APF=PARU(128-2*MOD(I,2))
- ELSEIF(I.LE.12) THEN
- VPF=PARJ(186-2*MOD(I,2))
- APF=PARJ(187-2*MOD(I,2))
- ELSE
- VPF=PARJ(194-2*MOD(I,2))
- APF=PARJ(195-2*MOD(I,2))
- ENDIF
- FCOF=1D0
- IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
- ENDIF
- BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
- IF(ICASE.EQ.1) THEN
- WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
- WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
- & APF**2*(1D0-4D0*RM1))*BE34
- ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
- WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
- & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
- & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
- & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
- & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
- & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
- ELSEIF(MINT(61).EQ.2) THEN
- FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
- FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
- FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
- FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
- FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
- & BE34
- FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
- & BE34
- ENDIF
- ELSEIF(I.EQ.17) THEN
-C...Z'0 -> W+ + W-
- WDTPZP=PARU(129)**2*XW1**2*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
- IF(ICASE.EQ.1) THEN
- WDTPZ=0D0
- WDTP(I)=FAC*WDTPZP
- ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
- WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
- ELSEIF(MINT(61).EQ.2) THEN
- FGGF=0D0
- FGZF=0D0
- FGZPF=0D0
- FZZF=0D0
- FZZPF=0D0
- FZPZPF=WDTPZP
- ENDIF
- WID2=WIDS(24,1)
- ELSEIF(I.EQ.18) THEN
-C...Z'0 -> H+ + H-
- CZC=2D0*(1D0-2D0*XW)
- BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
- IF(ICASE.EQ.1) THEN
- WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
- WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
- ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
- WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
- & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
- & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
- & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
- & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
- ELSEIF(MINT(61).EQ.2) THEN
- FGGF=0.25D0*BE34C
- FGZF=0.25D0*PARU(142)*CZC*BE34C
- FGZPF=0.25D0*PARU(143)*CZC*BE34C
- FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
- FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
- FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
- ENDIF
- WID2=WIDS(37,1)
- ELSEIF(I.EQ.19) THEN
-C...Z'0 -> Z0 + gamma.
- ELSEIF(I.EQ.20) THEN
-C...Z'0 -> Z0 + h0
- FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
- & (3D0*RM1+0.25D0*FLAM**2)*FLAM
- IF(ICASE.EQ.1) THEN
- WDTPZ=0D0
- WDTP(I)=FAC*WDTPZP
- ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
- WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
- ELSEIF(MINT(61).EQ.2) THEN
- FGGF=0D0
- FGZF=0D0
- FGZPF=0D0
- FZZF=0D0
- FZZPF=0D0
- FZPZPF=WDTPZP
- ENDIF
- WID2=WIDS(23,2)*WIDS(25,2)
- ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
-C...Z' -> h0 + A0 or H0 + A0.
- BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
- IF(I.EQ.21) THEN
- CZAH=PARU(186)
- CZPAH=PARU(188)
- ELSE
- CZAH=PARU(187)
- CZPAH=PARU(189)
- ENDIF
- IF(ICASE.EQ.1) THEN
- WDTPZ=CZAH**2*BE34C
- WDTP(I)=FAC*CZPAH**2*BE34C
- ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
- WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
- & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
- & VINT(116))*BE34C
- ELSEIF(MINT(61).EQ.2) THEN
- FGGF=0D0
- FGZF=0D0
- FGZPF=0D0
- FZZF=CZAH**2*BE34C
- FZZPF=CZAH*CZPAH*BE34C
- FZPZPF=CZPAH**2*BE34C
- ENDIF
- IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
- IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
- ENDIF
- IF(ICASE.EQ.1) THEN
- VINT(117)=VINT(117)+FAC*WDTPZ
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- ENDIF
- IF(MDME(IDC,1).GT.0) THEN
- IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
- & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
- & WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
- IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
- & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
- IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
- & FGZF*WID2
- IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
- & FGZPF*WID2
- IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
- & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
- IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
- & FZZPF*WID2
- IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
- & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
- ENDIF
- ENDIF
- 290 CONTINUE
- IF(MINT(61).GE.1) ICASE=3-ICASE
- IF(ICASE.EQ.2) GOTO 280
-
- ELSEIF(KFLA.EQ.34) THEN
-C...W'+/-:
- FAC=(AEM/(24D0*XW))*SHR
- DO 300 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 300
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
- WID2=1D0
- IF(I.LE.20) THEN
- IF(I.LE.16) THEN
-C...W'+/- -> q + qbar'
- FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
- & VCKM((I-1)/4+1,MOD(I-1,4)+1)
- IF(KFLR.GT.0) THEN
- IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
- IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
- IF(I.GE.13) WID2=WID2*WIDS(7,3)
- ELSE
- IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
- IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
- IF(I.GE.13) WID2=WID2*WIDS(7,2)
- ENDIF
- ELSEIF(I.LE.20) THEN
-C...W'+/- -> l+/- + nu
- FCOF=PARU(133)**2+PARU(134)**2
- IF(KFLR.GT.0) THEN
- IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
- ELSE
- IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
- ENDIF
- ENDIF
- WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- ELSEIF(I.EQ.21) THEN
-C...W'+/- -> W+/- + Z0
- WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
- IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
- IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
- ELSEIF(I.EQ.23) THEN
-C...W'+/- -> W+/- + h0
- FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
- IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
- IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 300 CONTINUE
-
- ELSEIF(KFLA.EQ.37) THEN
-C...H+/-:
-C IF(MSTP(49).EQ.0) THEN
- SHFS=SH
-C ELSE
-C SHFS=PMAS(37,1)**2
-C ENDIF
- FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
- DO 310 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 310
- KFC1=PYCOMP(KFDP(IDC,1))
- KFC2=PYCOMP(KFDP(IDC,2))
- RM1=PMAS(KFC1,1)**2/SH
- RM2=PMAS(KFC2,1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
- WID2=1D0
- IF(I.LE.4) THEN
-C...H+/- -> q + qbar'
- RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
- RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
- WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
- & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
- IF(KFLR.GT.0) THEN
- IF(I.EQ.3) WID2=WIDS(6,2)
- IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
- ELSE
- IF(I.EQ.3) WID2=WIDS(6,3)
- IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
- ENDIF
- ELSEIF(I.LE.8) THEN
-C...H+/- -> l+/- + nu
- WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
- & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
- & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
- IF(KFLR.GT.0) THEN
- IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
- ELSE
- IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
- ENDIF
- ELSEIF(I.EQ.9) THEN
-C...H+/- -> W+/- + h0.
- WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
- & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
- IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
- IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
-
-CMRENNA++
- ELSE
-C...Add in SUSY decays (two-body) by rescaling by phase space factor.
- RM10=RM1*SH/PMR**2
- RM20=RM2*SH/PMR**2
- WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
- WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
- IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
- WFAC=0D0
- ELSE
- WFAC=WFAC/WFAC0
- ENDIF
- WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
-CMRENNA--
- KSGN1=2
- IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
- KSGN2=2
- IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
- WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 310 CONTINUE
-
- ELSEIF(KFLA.EQ.41) THEN
-C...R:
- FAC=(AEM/(12D0*XW))*SHR
- DO 320 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 320
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
- WID2=1D0
- IF(I.LE.6) THEN
-C...R -> q + qbar'
- FCOF=3D0*RADC
- ELSEIF(I.LE.9) THEN
-C...R -> l+ + l'-
- FCOF=1D0
- ENDIF
- WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- IF(KFLR.GT.0) THEN
- IF(I.EQ.4) WID2=WIDS(6,3)
- IF(I.EQ.5) WID2=WIDS(7,3)
- IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
- IF(I.EQ.9) WID2=WIDS(17,3)
- ELSE
- IF(I.EQ.4) WID2=WIDS(6,2)
- IF(I.EQ.5) WID2=WIDS(7,2)
- IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
- IF(I.EQ.9) WID2=WIDS(17,2)
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 320 CONTINUE
-
- ELSEIF(KFLA.EQ.42) THEN
-C...LQ (leptoquark).
- FAC=(AEM/4D0)*PARU(151)*SHR
- DO 330 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 330
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
- WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
- WID2=1D0
- ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
- IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
- IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
- ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
- IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
- IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 330 CONTINUE
-
- ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
-C...Techni-pi0 and techni-pi0':
- FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
- DO 340 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 340
- PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
- PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
- RM1=PM1**2/SH
- RM2=PM2**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
- WID2=1D0
-C...pi_tc -> g + g
- IF(I.EQ.8) THEN
- FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
- & /(8D0*PARU(1))*SH*SHR
- IF(KFLA.EQ.KTECHN+111) THEN
- FACP=FACP*RTCM(9)
- ELSE
- FACP=FACP*RTCM(10)
- ENDIF
- WDTP(I)=FACP
- ELSE
-C...pi_tc -> f + fbar.
- FCOF=1D0
- IKA=IABS(KFDP(IDC,1))
- IF(IKA.LT.10) FCOF=3D0*RADC
- HM1=PM1
- HM2=PM2
- IF(IKA.GE.4.AND.IKA.LE.6) THEN
- FCOF=FCOF*RTCM(1+IKA)**2
- HM1=PYMRUN(KFDP(IDC,1),SH)
- HM2=PYMRUN(KFDP(IDC,2),SH)
- ELSEIF(IKA.EQ.15) THEN
- FCOF=FCOF*RTCM(8)**2
- ENDIF
- WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 340 CONTINUE
-
- ELSEIF(KFLA.EQ.KTECHN+211) THEN
-C...pi+_tc
- FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
- DO 350 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 350
- PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
- PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
- PM3=0D0
- IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
- RM1=PM1**2/SH
- RM2=PM2**2/SH
- RM3=PM3**2/SH
- IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
- WID2=1D0
-C...pi_tc -> f + f'.
- FCOF=1D0
- IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
-C...pi_tc+ -> W b b~
- IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
- FCOF=3D0*RADC
- XMT2=PMAS(6,1)**2/SH
- FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
- KFC3=PYCOMP(KFDP(IDC,3))
- CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
- CHECK = SQRT(RM1)
- T0 = (1D0-CHECK**2)*
- & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
- & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
- T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
- & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
- T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
- WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
- & +T3*LOG(CHECK))
- IF(KFLR.GT.0) THEN
- WID2=WIDS(24,2)
- ELSE
- WID2=WIDS(24,3)
- ENDIF
- ELSE
- FCOF=1D0
- IKA=IABS(KFDP(IDC,1))
- IF(IKA.LT.10) FCOF=3D0*RADC
- HM1=PM1
- HM2=PM2
- IF(I.GE.1.AND.I.LE.5) THEN
- IF(I.LE.2) THEN
- FCOF=FCOF*RTCM(5)**2
- ELSEIF(I.LE.4) THEN
- FCOF=FCOF*RTCM(6)**2
- ELSEIF(I.EQ.5) THEN
- FCOF=FCOF*RTCM(7)**2
- ENDIF
- HM1=PYMRUN(KFDP(IDC,1),SH)
- HM2=PYMRUN(KFDP(IDC,2),SH)
- ELSEIF(I.EQ.8) THEN
- FCOF=FCOF*RTCM(8)**2
- ENDIF
- WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 350 CONTINUE
-
- ELSEIF(KFLA.EQ.KTECHN+331) THEN
-C...Techni-eta.
- FAC=(SH/PARP(46)**2)*SHR
- DO 360 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 360
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
- WID2=1D0
- IF(I.LE.2) THEN
- WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
- IF(I.EQ.2) WID2=WIDS(6,1)
- ELSE
- WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 360 CONTINUE
-
- ELSEIF(KFLA.EQ.KTECHN+113) THEN
-C...Techni-rho0:
- ALPRHT=2.16D0*(3D0/ITCM(1))
- FAC=(ALPRHT/12D0)*SHR
- FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
- SQMZ=PMAS(23,1)**2
- SQMW=PMAS(24,1)**2
- SHP=SH
- CALL PYWIDX(23,SHP,WDTPP,WDTEP)
- GMMZ=SHR*WDTPP(0)
- XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
- BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
- BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
- DO 370 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 370
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
- WID2=1D0
- IF(I.EQ.1) THEN
-C...rho_tc0 -> W+ + W-.
-C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
- WDTP(I)=FAC*RTCM(3)**4*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
- & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
- & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
- & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
- WID2=WIDS(24,1)
- ELSEIF(I.EQ.2) THEN
-C...rho_tc0 -> W+ + pi_tc-.
-C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
- WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
- & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
- & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
- & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
- WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
- ELSEIF(I.EQ.3) THEN
-C...rho_tc0 -> pi_tc+ + W-.
- WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
- & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
- & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
- & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
- WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
- ELSEIF(I.EQ.4) THEN
-C...rho_tc0 -> pi_tc+ + pi_tc-.
- WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
- WID2=WIDS(PYCOMP(KTECHN+211),1)
- ELSEIF(I.EQ.5) THEN
-C...rho_tc0 -> gamma + pi_tc0
- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
- & SHR**3
- WID2=WIDS(PYCOMP(KTECHN+111),2)
- ELSEIF(I.EQ.6) THEN
-C...rho_tc0 -> gamma + pi_tc0'
- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
- WID2=WIDS(PYCOMP(KTECHN+221),2)
- ELSEIF(I.EQ.7) THEN
-C...rho_tc0 -> Z0 + pi_tc0
- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
- & XW/XW1*SHR**3
- WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
- ELSEIF(I.EQ.8) THEN
-C...rho_tc0 -> Z0 + pi_tc0'
- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
- & XW/XW1*SHR**3
- WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
- ELSEIF(I.EQ.9) THEN
-C...rho_tc0 -> gamma + Z0
- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
- WID2=WIDS(23,2)
- ELSEIF(I.EQ.10) THEN
-C...rho_tc0 -> Z0 + Z0
- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
- & SHR**3
- WID2=WIDS(23,1)
- ELSE
-C...rho_tc0 -> f + fbar.
- WID2=1D0
- IF(I.LE.18) THEN
- IA=I-10
- FCOF=3D0*RADC
- IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
- ELSE
- IA=I-6
- FCOF=1D0
- IF(IA.GE.17) WID2=WIDS(IA,1)
- ENDIF
- EI=KCHG(IA,1)/3D0
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*XWV
- VALI=0.5D0*(VI+AI)
- VARI=0.5D0*(VI-AI)
- WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
- & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
- & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
- & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 370 CONTINUE
-
- ELSEIF(KFLA.EQ.KTECHN+213) THEN
-C...Techni-rho+/-:
- ALPRHT=2.16D0*(3D0/ITCM(1))
- FAC=(ALPRHT/12D0)*SHR
- SQMZ=PMAS(23,1)**2
- SQMW=PMAS(24,1)**2
- SHP=SH
- CALL PYWIDX(24,SHP,WDTPP,WDTEP)
- GMMW=SHR*WDTPP(0)
- FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
- & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
- DO 380 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 380
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
- WID2=1D0
- PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
-c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
-c & /3D0*SHR**3
- IF(I.EQ.1) THEN
-C...rho_tc+ -> W+ + Z0.
-C......Goldstone
- WDTP(I)=FAC*RTCM(3)**4*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
- VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
- AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
-C......W_L Z_T
- WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
- & /3D0*SHR**3
- VA2=0D0
- AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
-C......W_T Z_L
- WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
- & /3D0*SHR**3
- IF(KFLR.GT.0) THEN
- WID2=WIDS(24,2)*WIDS(23,2)
- ELSE
- WID2=WIDS(24,3)*WIDS(23,2)
- ENDIF
- ELSEIF(I.EQ.2) THEN
-C...rho_tc+ -> W+ + pi_tc0.
- WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
- & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
- & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
- & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
- IF(KFLR.GT.0) THEN
- WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
- ELSE
- WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
- ENDIF
- ELSEIF(I.EQ.3) THEN
-C...rho_tc+ -> pi_tc+ + Z0.
- WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
- & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
- & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
- & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
- & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
- & SHR**3*XW/XW1
- IF(KFLR.GT.0) THEN
- WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
- ELSE
- WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
- ENDIF
- ELSEIF(I.EQ.4) THEN
-C...rho_tc+ -> pi_tc+ + pi_tc0.
- WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
- IF(KFLR.GT.0) THEN
- WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
- ELSE
- WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
- ENDIF
- ELSEIF(I.EQ.5) THEN
-C...rho_tc+ -> pi_tc+ + gamma
- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
- & SHR**3
- IF(KFLR.GT.0) THEN
- WID2=WIDS(PYCOMP(KTECHN+211),2)
- ELSE
- WID2=WIDS(PYCOMP(KTECHN+211),3)
- ENDIF
- ELSEIF(I.EQ.6) THEN
-C...rho_tc+ -> W+ + pi_tc0'
- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
- IF(KFLR.GT.0) THEN
- WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
- ELSE
- WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
- ENDIF
- ELSEIF(I.EQ.7) THEN
-C...rho_tc+ -> W+ + gamma
- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
- IF(KFLR.GT.0) THEN
- WID2=WIDS(24,2)
- ELSE
- WID2=WIDS(24,3)
- ENDIF
- ELSE
-C...rho_tc+ -> f + fbar'.
- IA=I-7
- WID2=1D0
- IF(IA.LE.16) THEN
- FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
- IF(KFLR.GT.0) THEN
- IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
- IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
- IF(IA.GE.13) WID2=WID2*WIDS(7,3)
- ELSE
- IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
- IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
- IF(IA.GE.13) WID2=WID2*WIDS(7,2)
- ENDIF
- ELSE
- FCOF=1D0
- IF(KFLR.GT.0) THEN
- IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
- ELSE
- IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
- ENDIF
- ENDIF
- WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 380 CONTINUE
-
- ELSEIF(KFLA.EQ.KTECHN+223) THEN
-C...Techni-omega:
- ALPRHT=2.16D0*(3D0/ITCM(1))
- FAC=(ALPRHT/12D0)*SHR
- FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
- SQMZ=PMAS(23,1)**2
- SHP=SH
- CALL PYWIDX(23,SHP,WDTPP,WDTEP)
- GMMZ=SHR*WDTPP(0)
- BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
- BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
- DO 390 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 390
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
- WID2=1D0
- IF(I.EQ.1) THEN
-C...omega_tc0 -> gamma + pi_tc0.
- WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
- WID2=WIDS(PYCOMP(KTECHN+111),2)
- ELSEIF(I.EQ.2) THEN
-C...omega_tc0 -> Z0 + pi_tc0
- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
- & XW/XW1*SHR**3
- WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
- ELSEIF(I.EQ.3) THEN
-C...omega_tc0 -> gamma + pi_tc0'
- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
- & SHR**3
- WID2=WIDS(PYCOMP(KTECHN+221),2)
- ELSEIF(I.EQ.4) THEN
-C...omega_tc0 -> Z0 + pi_tc0'
- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
- & XW/XW1*SHR**3
- WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
- ELSEIF(I.EQ.5) THEN
-C...omega_tc0 -> W+ + pi_tc-
- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
- & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
- WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
- ELSEIF(I.EQ.6) THEN
-C...omega_tc0 -> pi_tc+ + W-
- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
- & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
- WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
- ELSEIF(I.EQ.7) THEN
-C...omega_tc0 -> W+ + W-.
-C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
- WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
- & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
- WID2=WIDS(24,1)
- ELSEIF(I.EQ.8) THEN
-C...omega_tc0 -> pi_tc+ + pi_tc-.
- WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
- WID2=WIDS(PYCOMP(KTECHN+211),1)
-C...omega_tc0 -> gamma + Z0
- ELSEIF(I.EQ.9) THEN
- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
- WID2=WIDS(23,2)
-C...omega_tc0 -> Z0 + Z0
- ELSEIF(I.EQ.10) THEN
- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
- & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
- & /24D0/RTCM(12)**2*SHR**3
- WID2=WIDS(23,1)
- ELSE
-C...omega_tc0 -> f + fbar.
- WID2=1D0
- IF(I.LE.18) THEN
- IA=I-10
- FCOF=3D0*RADC
- IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
- ELSE
- IA=I-8
- FCOF=1D0
- IF(IA.GE.17) WID2=WIDS(IA,1)
- ENDIF
- EI=KCHG(IA,1)/3D0
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*XWV
- VALI=-0.5D0*(VI+AI)
- VARI=-0.5D0*(VI-AI)
- WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
- & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
- & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
- & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 390 CONTINUE
-
-C.....V8 -> quark anti-quark
- ELSEIF(KFLA.EQ.KTECHN+100021) THEN
- FAC=AS/6D0*SHR
- TANT3=RTCM(21)
- IF(ITCM(2).EQ.0) THEN
- IMDL=1
- ELSEIF(ITCM(2).EQ.1) THEN
- IMDL=2
- ENDIF
- DO 400 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 400
- PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
- RM1=PM1**2/SH
- IF(RM1.GT.0.25D0) GOTO 400
- WID2=1D0
- IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
- FMIX=1D0/TANT3**2
- ELSE
- FMIX=TANT3**2
- ENDIF
- WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
- IF(I.EQ.6) WID2=WIDS(6,1)
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 400 CONTINUE
-
- ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
- FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
- CLEBF=0D0
- DO 410 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 410
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
- WID2=1D0
-C...pi_tc -> g + g
- IF(I.EQ.7) THEN
- IF(KFLA.EQ.KTECHN+100111) THEN
- CLEBG=4D0/3D0
- ELSE
- CLEBG=5D0/3D0
- ENDIF
- FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
- & /(2D0*PARU(1))*SH*SHR*CLEBG
- WDTP(I)=FACP
- ELSE
-C...pi_tc -> f + fbar.
- IF(I.EQ.6) WID2=WIDS(6,1)
- FCOF=1D0
- IKA=IABS(KFDP(IDC,1))
- IF(IKA.LT.10) FCOF=3D0*RADC
- HM1=PYMRUN(KFDP(IDC,1),SH)
- WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 410 CONTINUE
-
- ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
- FAC=AS/6D0*SHR
- ALPRHT=2.16D0*(3D0/ITCM(1))
- TANT3=RTCM(21)
- SIN2T=2D0*TANT3/(TANT3**2+1D0)
- SINT3=TANT3/SQRT(TANT3**2+1D0)
- CSXPP=RTCM(22)
- RM82=RTCM(27)**2
- X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
- & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
- X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
- & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
- X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
- & SINT3**2)*2D0
- X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
- & SINT3**2)*2D0
- CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
-
- IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
- GMV8=SHR*WDTPP(0)
- RMV8=PMAS(PYCOMP(KTECHN+100021),1)
- FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
- FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
- IF(ITCM(2).EQ.0) THEN
- IMDL=1
- ELSE
- IMDL=2
- ENDIF
- DO 420 I=1,MDCY(KC,3)
- IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
- & KFLA.EQ.KTECHN+300113)) GOTO 420
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 420
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
- WID2=1D0
- IF(I.LE.6) THEN
- IF(I.EQ.6) WID2=WIDS(6,1)
- XIG=1D0
- IF(KFLA.EQ.KTECHN+200113) THEN
- XIG=0D0
- XIJ=X12
- ELSEIF(KFLA.EQ.KTECHN+300113) THEN
- XIG=0D0
- XIJ=X21
- ELSEIF(KFLA.EQ.KTECHN+100113) THEN
- XIJ=X11
- ELSE
- XIJ=X22
- ENDIF
- IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
- FMIX=1D0/TANT3/SIN2T
- ELSE
- FMIX=-TANT3/SIN2T
- ENDIF
- XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
- WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
- ELSEIF(I.EQ.7) THEN
- WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
- ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
- PSH=SHR*(1D0-RM1)/2D0
- WDTP(I)=AS/9D0*PSH**3/RM82
- IF(I.EQ.8) THEN
- WDTP(I)=2D0*WDTP(I)*CSXPP**2
- WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
- ELSE
- WDTP(I)=5D0*WDTP(I)
- WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
- ENDIF
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 420 CONTINUE
-
- ELSEIF(KFLA.EQ.KEXCIT+1) THEN
-C...d* excited quark.
- FAC=(SH/RTCM(41)**2)*SHR
- DO 430 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 430
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
- WID2=1D0
- IF(I.EQ.1) THEN
-C...d* -> g + d.
- WDTP(I)=FAC*AS*RTCM(45)**2/3D0
- WID2=1D0
- ELSEIF(I.EQ.2) THEN
-C...d* -> gamma + d.
- QF=-RTCM(43)/2D0+RTCM(44)/6D0
- WDTP(I)=FAC*AEM*QF**2/4D0
- WID2=1D0
- ELSEIF(I.EQ.3) THEN
-C...d* -> Z0 + d.
- QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
- WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
- & (1D0-RM1)**2*(2D0+RM1)
- WID2=WIDS(23,2)
- ELSEIF(I.EQ.4) THEN
-C...d* -> W- + u.
- WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
- & (1D0-RM1)**2*(2D0+RM1)
- IF(KFLR.GT.0) WID2=WIDS(24,3)
- IF(KFLR.LT.0) WID2=WIDS(24,2)
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 430 CONTINUE
-
- ELSEIF(KFLA.EQ.KEXCIT+2) THEN
-C...u* excited quark.
- FAC=(SH/RTCM(41)**2)*SHR
- DO 440 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 440
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
- WID2=1D0
- IF(I.EQ.1) THEN
-C...u* -> g + u.
- WDTP(I)=FAC*AS*RTCM(45)**2/3D0
- WID2=1D0
- ELSEIF(I.EQ.2) THEN
-C...u* -> gamma + u.
- QF=RTCM(43)/2D0+RTCM(44)/6D0
- WDTP(I)=FAC*AEM*QF**2/4D0
- WID2=1D0
- ELSEIF(I.EQ.3) THEN
-C...u* -> Z0 + u.
- QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
- WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
- & (1D0-RM1)**2*(2D0+RM1)
- WID2=WIDS(23,2)
- ELSEIF(I.EQ.4) THEN
-C...u* -> W+ + d.
- WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
- & (1D0-RM1)**2*(2D0+RM1)
- IF(KFLR.GT.0) WID2=WIDS(24,2)
- IF(KFLR.LT.0) WID2=WIDS(24,3)
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 440 CONTINUE
-
- ELSEIF(KFLA.EQ.KEXCIT+11) THEN
-C...e* excited lepton.
- FAC=(SH/RTCM(41)**2)*SHR
- DO 450 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 450
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
- WID2=1D0
- IF(I.EQ.1) THEN
-C...e* -> gamma + e.
- QF=-RTCM(43)/2D0-RTCM(44)/2D0
- WDTP(I)=FAC*AEM*QF**2/4D0
- WID2=1D0
- ELSEIF(I.EQ.2) THEN
-C...e* -> Z0 + e.
- QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
- WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
- & (1D0-RM1)**2*(2D0+RM1)
- WID2=WIDS(23,2)
- ELSEIF(I.EQ.3) THEN
-C...e* -> W- + nu.
- WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
- & (1D0-RM1)**2*(2D0+RM1)
- IF(KFLR.GT.0) WID2=WIDS(24,3)
- IF(KFLR.LT.0) WID2=WIDS(24,2)
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 450 CONTINUE
-
- ELSEIF(KFLA.EQ.KEXCIT+12) THEN
-C...nu*_e excited neutrino.
- FAC=(SH/RTCM(41)**2)*SHR
- DO 460 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 460
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
- WID2=1D0
- IF(I.EQ.1) THEN
-C...nu*_e -> Z0 + nu*_e.
- QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
- WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
- & (1D0-RM1)**2*(2D0+RM1)
- WID2=WIDS(23,2)
- ELSEIF(I.EQ.2) THEN
-C...nu*_e -> W+ + e.
- WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
- & (1D0-RM1)**2*(2D0+RM1)
- IF(KFLR.GT.0) WID2=WIDS(24,2)
- IF(KFLR.LT.0) WID2=WIDS(24,3)
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 460 CONTINUE
-
- ELSEIF(KFLA.EQ.KDIMEN+39) THEN
-C...G* (graviton resonance):
- FAC=(PARP(50)**2/PARU(1))*SHR
- DO 470 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 470
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
- WID2=1D0
- IF(I.LE.8) THEN
-C...G* -> q + qbar
- FCOF=3D0*RADC
- IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
- & PYHFTH(SH,SH*RM1,1D0)
- WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
- & (1D0+8D0*RM1/3D0)/320D0
- IF(I.EQ.6) WID2=WIDS(6,1)
- IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
- ELSEIF(I.LE.16) THEN
-C...G* -> l+ + l-, nu + nubar
- FCOF=1D0
- WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
- & (1D0+8D0*RM1/3D0)/320D0
- IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
- ELSEIF(I.EQ.17) THEN
-C...G* -> g + g.
- WDTP(I)=FAC/20D0
- ELSEIF(I.EQ.18) THEN
-C...G* -> gamma + gamma.
- WDTP(I)=FAC/160D0
- ELSEIF(I.EQ.19) THEN
-C...G* -> Z0 + Z0.
- WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
- & 14D0*RM1/3D0+4D0*RM1**2)/160D0
- WID2=WIDS(23,1)
- ELSEIF(I.EQ.20) THEN
-C...G* -> W+ + W-.
- WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
- & 14D0*RM1/3D0+4D0*RM1**2)/80D0
- WID2=WIDS(24,1)
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 470 CONTINUE
-
- ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
-C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
- PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
- FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
- DO 480 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 480
- PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
- PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
- PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
- IF(PM1+PM2+PM3.GE.SHR) GOTO 480
- WID2=1D0
- IF(I.LE.9) THEN
-C...nu_lR -> l- qbar q'
- FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
- IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
- ELSEIF(I.LE.18) THEN
-C...nu_lR -> l+ q qbar'
- FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
- IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
- ELSE
-C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
- FCOF=1D0
- WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
- ENDIF
- X=(PM1+PM2+PM3)/SHR
- FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
- Y=(SHR/PMWR)**2
- FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
- WDTP(I)=FAC*FCOF*FX*FY
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 480 CONTINUE
-
- ELSEIF(KFLA.EQ.9900023) THEN
-C...Z_R0:
- FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
- DO 490 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 490
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
- WID2=1D0
- SYMMET=1D0
- IF(I.LE.6) THEN
-C...Z_R0 -> q + qbar
- EF=KCHG(I,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
- VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
- FCOF=3D0*RADC
- IF(I.EQ.6) WID2=WIDS(6,1)
- ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
-C...Z_R0 -> l+ + l-
- AF=-(1D0-2D0*XW)
- VF=-1D0+4D0*XW
- FCOF=1D0
- ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
-C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
- AF=-2D0*XW
- VF=0D0
- FCOF=1D0
- SYMMET=0.5D0
- ELSEIF(I.LE.15) THEN
-C...Z0 -> nu_R + nu_R, assumed Majorana.
- AF=2D0*XW1
- VF=0D0
- FCOF=1D0
- WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
- SYMMET=0.5D0
- ENDIF
- WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
- & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 490 CONTINUE
-
- ELSEIF(KFLA.EQ.9900024) THEN
-C...W_R+/-:
- FAC=(AEM/(24D0*XW))*SHR
- DO 500 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 500
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
- WID2=1D0
- IF(I.LE.9) THEN
-C...W_R+/- -> q + qbar'
- FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
- IF(KFLR.GT.0) THEN
- IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
- ELSE
- IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
- ENDIF
- ELSEIF(I.LE.12) THEN
-C...W_R+/- -> l+/- + nu_R
- FCOF=1D0
- ENDIF
- WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 500 CONTINUE
-
- ELSEIF(KFLA.EQ.9900041) THEN
-C...H_L++/--:
- FAC=(1D0/(8D0*PARU(1)))*SHR
- DO 510 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 510
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
- WID2=1D0
- IF(I.LE.6) THEN
-C...H_L++/-- -> l+/- + l'+/-
- FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
- & (IABS(KFDP(IDC,2))-9)/2)**2
- IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
- ELSEIF(I.EQ.7) THEN
-C...H_L++/-- -> W_L+/- + W_L+/-
- FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
- & (3D0*RM1+0.25D0/RM1-1D0)
- WID2=WIDS(24,4+(1-KFLS)/2)
- ENDIF
- WDTP(I)=FAC*FCOF*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 510 CONTINUE
-
- ELSEIF(KFLA.EQ.9900042) THEN
-C...H_R++/--:
- FAC=(1D0/(8D0*PARU(1)))*SHR
- DO 520 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 520
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
- WID2=1D0
- IF(I.LE.6) THEN
-C...H_R++/-- -> l+/- + l'+/-
- FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
- & (IABS(KFDP(IDC,2))-9)/2)**2
- IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
- ELSEIF(I.EQ.7) THEN
-C...H_R++/-- -> W_R+/- + W_R+/-
- FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
- WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
- ENDIF
- WDTP(I)=FAC*FCOF*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 520 CONTINUE
-
- ELSEIF(KFLA.EQ.KTECHN+115) THEN
-C...Techni-a2:
-C...Need to update to alpha_rho
- ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
- FAC=(ALPRHT/12D0)*SHR
- FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
- SQMZ=PMAS(23,1)**2
- SQMW=PMAS(24,1)**2
- SHP=SH
- CALL PYWIDX(23,SHP,WDTPP,WDTEP)
- GMMZ=SHR*WDTPP(0)
- XWRHT=1D0/(4D0*XW*(1D0-XW))
- BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
- BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
- DO 530 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 530
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
- WID2=1D0
- PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- IF(I.LE.4) THEN
- FACPV=PCM**2
- FACPA=PCM**2+1.5D0*RM1
- VA2=0D0
- AA2=0D0
-C...a2_tc0 -> W+ + W-
- IF(I.EQ.1) THEN
- AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
-C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
- WID2=WIDS(24,1)
-C...a2_tc0 -> W+ + pi_tc- + c.c.
- ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
- AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
- IF(I.EQ.6) THEN
- WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
- ELSE
- WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
- ENDIF
- ELSEIF(I.EQ.4) THEN
-C...a2_tc0 -> Z0 + pi_tc0'
- VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
- WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
- ENDIF
- WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
- ELSEIF(I.GE.5.AND.I.LE.10) THEN
- FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
- FACPA=PCM**2*(1D0+RM1+RM2)
- VA2=0D0
- AA2=0D0
- IF(I.EQ.5) THEN
-C...a_T^0 -> gamma rho_T^0
- VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
- WID2=WIDS(PYCOMP(KTECHN+113),2)
- ELSEIF(I.EQ.6) THEN
-C...a_T^0 -> gamma omega_T
- VA2=1D0/RTCM(50)**4
- WID2=WIDS(PYCOMP(KTECHN+223),2)
- ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
-C...a_T^0 -> W^+- rho_T^-+
- AA2=.25D0/XW/RTCM(51)**4
- IF(I.EQ.7) THEN
- WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
- ELSE
- WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
- ENDIF
- ELSEIF(I.EQ.9) THEN
-C...a_T^0 -> Z^0 rho_T^0
- VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
- WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
- ELSEIF(I.EQ.10) THEN
-C...a_T^0 -> Z^0 omega_T
- VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
- WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
- ENDIF
- WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
- ELSE
-C...a2_tc0 -> f + fbar.
- WID2=1D0
- IF(I.LE.18) THEN
- IA=I-10
- FCOF=3D0*RADC
- IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
- ELSE
- IA=I-8
- FCOF=1D0
- IF(IA.GE.17) WID2=WIDS(IA,1)
- ENDIF
- EI=KCHG(IA,1)/3D0
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*XWV
- VALI=0.5D0*(VI+AI)
- VARI=0.5D0*(VI-AI)
- WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
- & ((VALI*BWZR)**2+(VALI*BWZI)**2+
- & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
- & (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 530 CONTINUE
-
- ELSEIF(KFLA.EQ.KTECHN+215) THEN
-C...Techni-a2+/-:
- ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
- FAC=(ALPRHT/12D0)*SHR
- SQMZ=PMAS(23,1)**2
- SQMW=PMAS(24,1)**2
- SHP=SH
- CALL PYWIDX(24,SHP,WDTPP,WDTEP)
- GMMW=SHR*WDTPP(0)
- FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
- & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
- DO 540 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 540
- RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
- WID2=1D0
- PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- IF(KFLR.GT.0) THEN
- ICHANN=2
- ELSE
- ICHANN=3
- ENDIF
- IF(I.LE.7) THEN
- AA2=0
- VA2=0
-C...a2_tc+ -> gamma + W+.
- IF(I.EQ.1) THEN
- AA2=RTCM(3)**2/RTCM(49)**2
- WID2=WIDS(24,ICHANN)
-C...a2_tc+ -> gamma + pi_tc+.
- ELSEIF(I.EQ.2) THEN
- AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
- WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
-C...a2_tc+ -> W+ + Z
- ELSEIF(I.EQ.3) THEN
- AA2=RTCM(3)**2*(1D0/4D0/XW1 +
- & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
- WID2=WIDS(24,ICHANN)*WIDS(23,2)
-C...a2_tc+ -> W+ + pi_tc0.
- ELSEIF(I.EQ.4) THEN
- AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
- WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
-C...a2_tc+ -> W+ + pi_tc'0.
- ELSEIF(I.EQ.5) THEN
- VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
- WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
-C...a2_tc+ -> Z0 + pi_tc+.
- ELSEIF(I.EQ.6) THEN
- AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
- & RTCM(49)**2
- WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
- ENDIF
- WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
- & /3D0*SHR**3
- ELSEIF(I.LE.10) THEN
- FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
- FACPA=PCM**2*(1D0+RM1+RM2)
- VA2=0D0
- AA2=0D0
-C...a2_tc+ -> gamma + rho_tc+
- IF(I.EQ.7) THEN
- VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
- WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
-C...a2_tc+ -> W+ + rho_T^0
- ELSEIF(I.EQ.8) THEN
- AA2=1D0/(4D0*XW)/RTCM(51)**4
- WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
-C...a2_tc+ -> W+ + omega_T
- ELSEIF(I.EQ.9) THEN
- VA2=.25D0/XW/RTCM(50)**4
- WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
-C...a2_tc+ -> Z^0 + rho_T^+
- ELSEIF(I.EQ.10) THEN
- VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
- AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
- WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
- ENDIF
- WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
- ELSE
-C...a2_tc+ -> f + fbar'.
- IA=I-10
- WID2=1D0
- IF(IA.LE.16) THEN
- FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
- IF(KFLR.GT.0) THEN
- IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
- IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
- IF(IA.GE.13) WID2=WID2*WIDS(7,3)
- ELSE
- IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
- IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
- IF(IA.GE.13) WID2=WID2*WIDS(7,2)
- ENDIF
- ELSE
- FCOF=1D0
- IF(KFLR.GT.0) THEN
- IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
- ELSE
- IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
- ENDIF
- ENDIF
- WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- ENDIF
- WDTP(I)=FUDGE*WDTP(I)
- WDTP(0)=WDTP(0)+WDTP(I)
- IF(MDME(IDC,1).GT.0) THEN
- WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
- WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
- WDTE(I,0)=WDTE(I,MDME(IDC,1))
- WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
- ENDIF
- 540 CONTINUE
-
- ENDIF
- MINT(61)=0
- MINT(62)=0
- MINT(63)=0
- RETURN
- END
-
-C***********************************************************************
-
-C...PYOFSH
-C...Calculates partial width and differential cross-section maxima
-C...of channels/processes not allowed on mass-shell, and selects
-C...masses in such channels/processes.
-
- SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
- &/PYINT2/,/PYINT5/
-C...Local arrays.
- DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
- &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
- &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
- &WDTE(0:400,0:5)
-
-C...Find if particles equal, maximum mass, matrix elements, etc.
- MINT(51)=0
- ISUB=MINT(1)
- KFD(1)=IABS(KFD1)
- KFD(2)=IABS(KFD2)
- MEQL=0
- IF(KFD(1).EQ.KFD(2)) MEQL=1
- MLM=0
- IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
- IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
- NOFF=44
- PMMX=PMMO
- ELSE
- NOFF=40
- PMMX=VINT(1)
- IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
- ENDIF
- MMED=0
- IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
- &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
- IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
- &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
- IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
- &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
- LOOP=1
-
-C...Find where Breit-Wigners are required, else select discrete masses.
- 100 DO 110 I=1,2
- KFCA=PYCOMP(KFD(I))
- IF(KFCA.GT.0) THEN
- PMD(I)=PMAS(KFCA,1)
- PGD(I)=PMAS(KFCA,2)
- ELSE
- PMD(I)=0D0
- PGD(I)=0D0
- ENDIF
- IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
- MBW(I)=0
- PMG(I)=PMD(I)
- RMG(I)=(PMG(I)/PMMX)**2
- ELSE
- MBW(I)=1
- ENDIF
- 110 CONTINUE
-
-C...Find allowed mass range and Breit-Wigner parameters.
- DO 120 I=1,2
- IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
- PML(I)=PARP(42)
- PMU(I)=PMMX-PARP(42)
- IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
- IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
- ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
- ILM=I
- IF(MLM.EQ.2) ILM=3-I
- PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
- IF(MBW(3-I).EQ.0) THEN
- PMU(I)=PMMX-PMD(3-I)
- ELSE
- PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
- ENDIF
- IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
- & MIN(PMU(I),CKIN(NOFF+2*ILM))
- IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
- IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
- IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
- IF(MBW(I).EQ.1) THEN
- ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
- ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
- IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
- & PGD(I)))
- ENDIF
- ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
- ILM=I
- IF(MLM.EQ.2) ILM=3-I
- PML(I)=MAX(CKIN(48+I),PARP(42))
- PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
- IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
- IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
- IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
- IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
- IF(MBW(I).EQ.1) THEN
- ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
- ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
- IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
- & PGD(I)))
- ENDIF
- ENDIF
- 120 CONTINUE
- IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
- &THEN
- CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
- MINT(51)=1
- RETURN
- ENDIF
-
-C...Calculation of partial width of resonance.
- IF(MOFSH.EQ.1) THEN
-
-C..If only one integration, pick that to be the inner.
- IF(MBW(1).EQ.0) THEN
- PM2=PMD(1)
- PMD(1)=PMD(2)
- PGD(1)=PGD(2)
- PML(1)=PML(2)
- PMU(1)=PMU(2)
- ELSEIF(MBW(2).EQ.0) THEN
- PM2=PMD(2)
- ENDIF
-
-C...Start outer loop of integration.
- IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
- ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
- ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
- NPT2=1
- XPT2(1)=1D0
- INX2(1)=0
- FMAX2=0D0
- ENDIF
- 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
- PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
- PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
- ENDIF
- RM2=(PM2/PMMX)**2
-
-C...Start inner loop of integration.
- PML1=PML(1)
- PMU1=MIN(PMU(1),PMMX-PM2)
- IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
- ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
- ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
- IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
- FUNC2=0D0
- GOTO 180
- ENDIF
- NPT1=1
- XPT1(1)=1D0
- INX1(1)=0
- FMAX1=0D0
- 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
- PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
- RM1=(PM1/PMMX)**2
-
-C...Evaluate function value - inner loop.
- FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
- IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
- & RM2**2+10D0*RM1*RM2)
- IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
- FPT1(NPT1)=FUNC1
-
-C...Go to next position in inner loop.
- IF(NPT1.EQ.1) THEN
- NPT1=NPT1+1
- XPT1(NPT1)=0D0
- INX1(NPT1)=1
- GOTO 140
- ELSEIF(NPT1.LE.8) THEN
- NPT1=NPT1+1
- IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
- ISH1=ISH1+1
- XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
- INX1(NPT1)=INX1(ISH1)
- INX1(ISH1)=NPT1
- GOTO 140
- ELSEIF(NPT1.LT.100) THEN
- ISN1=ISH1
- 150 ISH1=ISH1+1
- IF(ISH1.GT.NPT1) ISH1=2
- IF(ISH1.EQ.ISN1) GOTO 160
- DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
- IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
- NPT1=NPT1+1
- XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
- INX1(NPT1)=INX1(ISH1)
- INX1(ISH1)=NPT1
- GOTO 140
- ENDIF
-
-C...Calculate integral over inner loop.
- 160 FSUM1=0D0
- DO 170 IPT1=2,NPT1
- FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
- & (XPT1(INX1(IPT1))-XPT1(IPT1))
- 170 CONTINUE
- FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
- 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
- IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
- FPT2(NPT2)=FUNC2
-
-C...Go to next position in outer loop.
- IF(NPT2.EQ.1) THEN
- NPT2=NPT2+1
- XPT2(NPT2)=0D0
- INX2(NPT2)=1
- GOTO 130
- ELSEIF(NPT2.LE.8) THEN
- NPT2=NPT2+1
- IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
- ISH2=ISH2+1
- XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
- INX2(NPT2)=INX2(ISH2)
- INX2(ISH2)=NPT2
- GOTO 130
- ELSEIF(NPT2.LT.100) THEN
- ISN2=ISH2
- 190 ISH2=ISH2+1
- IF(ISH2.GT.NPT2) ISH2=2
- IF(ISH2.EQ.ISN2) GOTO 200
- DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
- IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
- NPT2=NPT2+1
- XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
- INX2(NPT2)=INX2(ISH2)
- INX2(ISH2)=NPT2
- GOTO 130
- ENDIF
-
-C...Calculate integral over outer loop.
- 200 FSUM2=0D0
- DO 210 IPT2=2,NPT2
- FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
- & (XPT2(INX2(IPT2))-XPT2(IPT2))
- 210 CONTINUE
- FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
- IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
- ELSE
- FSUM2=FUNC2
- ENDIF
-
-C...Save result; second integration for user-selected mass range.
- IF(LOOP.EQ.1) WIDW=FSUM2
- WID2=FSUM2
- IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
- & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
- LOOP=2
- GOTO 100
- ENDIF
- RET1=WIDW
- RET2=WID2/WIDW
-
-C...Select two decay product masses of a resonance.
- ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
- 220 DO 230 I=1,2
- IF(MBW(I).EQ.0) GOTO 230
- PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
- & (ATU(I)-ATL(I)))
- PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
- RMG(I)=(PMG(I)/PMMX)**2
- 230 CONTINUE
- IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
- & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
-
-C...Weight with matrix element (if none known, use beta factor).
- FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
- IF(MMED.EQ.1) THEN
- WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
- ELSEIF(MMED.EQ.2) THEN
- WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
- & RMG(2)**2+10D0*RMG(1)*RMG(2))
- ELSEIF(MMED.EQ.3) THEN
- WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
- ELSE
- WTBE=FLAM
- ENDIF
- IF(WTBE.LT.PYR(0)) GOTO 220
- RET1=PMG(1)
- RET2=PMG(2)
-
-C...Find suitable set of masses for initialization of 2 -> 2 processes.
- ELSEIF(MOFSH.EQ.3) THEN
- IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
- PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
- PMG(2)=PMD(2)
- ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
- PMG(1)=PMD(1)
- PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
- ELSE
- IDIV=-1
- 240 IDIV=IDIV+1
- PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
- PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
- IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
- ENDIF
- RET1=PMG(1)
- RET2=PMG(2)
-
-C...Evaluate importance of excluded tails of Breit-Wigners.
- IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
- & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
- IF(MEQL.LE.1) THEN
- VINT(80)=1D0
- DO 250 I=1,2
- IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
- & PARU(1)
- 250 CONTINUE
- ELSE
- VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
- & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
- ENDIF
- IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
- & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
- IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
- IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
-
-C...Pick one particle to be the lighter (if improves efficiency).
- ELSEIF(MOFSH.EQ.4) THEN
- IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
- & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
- 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
-
-C...Select two masses according to Breit-Wigner + flat in s + 1/s.
- DO 270 I=1,2
- IF(MBW(I).EQ.0) GOTO 270
- PMV=PMU(I)
- IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
- ATV=ATU(I)
- IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
- RBR=PYR(0)
- IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
- & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
- IF(RBR.LT.0.8D0) THEN
- PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
- PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
- ELSEIF(RBR.LT.0.9D0) THEN
- PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
- ELSEIF(RBR.LT.1.5D0) THEN
- PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
- ELSE
- PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
- & (PMV**2-PML(I)**2))))
- ENDIF
- 270 CONTINUE
- IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
- & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
- IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
- NGEN(0,1)=NGEN(0,1)+1
- NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
- GOTO 260
- ELSE
- MINT(51)=1
- RETURN
- ENDIF
- ENDIF
- RET1=PMG(1)
- RET2=PMG(2)
-
-C...Give weight for selected mass distribution.
- VINT(80)=1D0
- DO 280 I=1,2
- IF(MBW(I).EQ.0) GOTO 280
- PMV=PMU(I)
- IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
- ATV=ATU(I)
- IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
- F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
- & (PMD(I)*PGD(I))**2)/PARU(1)
- F1=1D0
- F2=1D0/PMG(I)**2
- F3=1D0/PMG(I)**4
- FI0=(ATV-ATL(I))/PARU(1)
- FI1=PMV**2-PML(I)**2
- FI2=2D0*LOG(PMV/PML(I))
- FI3=1D0/PML(I)**2-1D0/PMV**2
- IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
- & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
- VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
- & 5D0*F3/FI3))
- ELSE
- VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
- ENDIF
- VINT(80)=VINT(80)*FI0
- 280 CONTINUE
- IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
- ENDIF
-
- RETURN
- END
-
-C***********************************************************************
-
-C...PYRECO
-C...Handles the possibility of colour reconnection in W+W- events,
-C...Based on the main scenarios of the Sjostrand and Khoze study:
-C...I, II, II', intermediate and instantaneous; plus one model
-C...along the lines of the Gustafson and Hakkinen: GH.
-C...Note: also handles Z0 Z0 and W-W+ events, but notation below
-C...is as if first resonance is W+ and second W-.
-
- SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter value; number of points in MC integration.
- PARAMETER (NPT=100)
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
-C...Local arrays.
- DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
- &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
- &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
- &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
- &TMC(20),IJOIN(100)
-
-C...Functions to give four-product and to do determinants.
- FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
- DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
- &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
- &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
-
-C...Only allow fraction of recoupling for GH, intermediate and
-C...instantaneous.
- IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
- IF(PYR(0).GT.PARP(120)) RETURN
- ENDIF
- ISUB=MINT(1)
-
-C...Common part for scenarios I, II, II', and GH.
- IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
- &MSTP(115).EQ.5) THEN
-
-C...Read out frequently-used parameters.
- PI=PARU(1)
- HBAR=PARU(3)
- PMW=PMAS(24,1)
- IF(ISUB.EQ.22) PMW=PMAS(23,1)
- PGW=PMAS(24,2)
- IF(ISUB.EQ.22) PGW=PMAS(23,2)
- TFRAG=PARP(115)
- RHAD=PARP(116)
- FACT=PARP(117)
- BLOWR=PARP(118)
- BLOWT=PARP(119)
-
-C...Find range of decay products of the W's.
-C...Background: the W's are stored in IW1 and IW2.
-C...Their direct decay products in NSD1+1 through NSD1+4.
-C...Products after shower (if any) in NSD1+5 through NAFT1
-C...for first W and in NAFT1+1 through N for the second.
- IF(NAFT1.GT.NSD1+4) THEN
- NBEG(1)=NSD1+5
- NEND(1)=NAFT1
- ELSE
- NBEG(1)=NSD1+1
- NEND(1)=NSD1+2
- ENDIF
- IF(N.GT.NAFT1) THEN
- NBEG(2)=NAFT1+1
- NEND(2)=N
- ELSE
- NBEG(2)=NSD1+3
- NEND(2)=NSD1+4
- ENDIF
-
-C...Rearrange parton shower products along strings.
- NOLD=N
- CALL PYPREP(NSD1+1)
- IF(MINT(51).NE.0) RETURN
-
-C...Find partons pointing back to W+ and W-; store them with quark
-C...end of string first.
- NNP=0
- NNM=0
- ISGP=0
- ISGM=0
- DO 120 I=NOLD+1,N
- IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
- IF(IABS(K(I,2)).GE.22) GOTO 120
- IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
- IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
- NNP=NNP+1
- IF(ISGP.EQ.1) THEN
- INP(NNP)=I
- ELSE
- DO 100 I1=NNP,2,-1
- INP(I1)=INP(I1-1)
- 100 CONTINUE
- INP(1)=I
- ENDIF
- IF(K(I,1).EQ.1) ISGP=0
- ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
- IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
- NNM=NNM+1
- IF(ISGM.EQ.1) THEN
- INM(NNM)=I
- ELSE
- DO 110 I1=NNM,2,-1
- INM(I1)=INM(I1-1)
- 110 CONTINUE
- INM(1)=I
- ENDIF
- IF(K(I,1).EQ.1) ISGM=0
- ENDIF
- 120 CONTINUE
-
-C...Boost to W+W- rest frame (not strictly needed).
- DO 130 J=1,3
- BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
- 130 CONTINUE
- CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
- CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
- CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
-
-C...Select decay vertices of W+ and W-.
- TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
- & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
- TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
- & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
- GTMAX=MAX(TP,TM)
- DO 140 J=1,3
- XP(J)=TP*P(IW1,J)/P(IW1,4)
- XM(J)=TM*P(IW2,J)/P(IW2,4)
- 140 CONTINUE
-
-C...Begin scenario I specifics.
- IF(MSTP(115).EQ.1) THEN
-
-C...Reconstruct velocity and direction of W+ string pieces.
- DO 170 IIP=1,NNP-1
- IF(K(INP(IIP),2).LT.0) GOTO 170
- I1=INP(IIP)
- I2=INP(IIP+1)
- P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
- P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
- DO 150 J=1,3
- V1(J)=P(I1,J)/P1A
- V2(J)=P(I2,J)/P2A
- BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
- DIRP(IIP,J)=V1(J)-V2(J)
- 150 CONTINUE
- BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
- & BETP(IIP,3)**2)
- DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
- DO 160 J=1,3
- DIRP(IIP,J)=DIRP(IIP,J)/DIRL
- 160 CONTINUE
- 170 CONTINUE
-
-C...Reconstruct velocity and direction of W- string pieces.
- DO 200 IIM=1,NNM-1
- IF(K(INM(IIM),2).LT.0) GOTO 200
- I1=INM(IIM)
- I2=INM(IIM+1)
- P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
- P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
- DO 180 J=1,3
- V1(J)=P(I1,J)/P1A
- V2(J)=P(I2,J)/P2A
- BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
- DIRM(IIM,J)=V1(J)-V2(J)
- 180 CONTINUE
- BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
- & BETM(IIM,3)**2)
- DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
- DO 190 J=1,3
- DIRM(IIM,J)=DIRM(IIM,J)/DIRL
- 190 CONTINUE
- 200 CONTINUE
-
-C...Loop over number of space-time points.
- NACC=0
- SUM=0D0
- DO 250 IPT=1,NPT
-
-C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
- R=SQRT(-LOG(PYR(0)))
- PHI=2D0*PI*PYR(0)
- X=BLOWR*RHAD*R*COS(PHI)
- Y=BLOWR*RHAD*R*SIN(PHI)
- R=SQRT(-LOG(PYR(0)))
- PHI=2D0*PI*PYR(0)
- Z=BLOWR*RHAD*R*COS(PHI)
- T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
-
-C...Reject impossible points. Weight for sample distribution.
- IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
- WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
- & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
-
-C...Loop over W+ string pieces and find one with largest weight.
- IMAXP=0
- WTMAXP=1D-10
- XD(1)=X-XP(1)
- XD(2)=Y-XP(2)
- XD(3)=Z-XP(3)
- XD(4)=T-TP
- DO 220 IIP=1,NNP-1
- IF(K(INP(IIP),2).LT.0) GOTO 220
- BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
- BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
- DO 210 J=1,3
- XB(J)=XD(J)+BEDG*BETP(IIP,J)
- 210 CONTINUE
- XB(4)=BETP(IIP,4)*(XD(4)-BED)
- SR2=XB(1)**2+XB(2)**2+XB(3)**2
- SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
- & DIRP(IIP,3)*XB(3))**2
- WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
- & TFRAG**2)
- IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
- IF(WTP.GT.WTMAXP) THEN
- IMAXP=IIP
- WTMAXP=WTP
- ENDIF
- 220 CONTINUE
-
-C...Loop over W- string pieces and find one with largest weight.
- IMAXM=0
- WTMAXM=1D-10
- XD(1)=X-XM(1)
- XD(2)=Y-XM(2)
- XD(3)=Z-XM(3)
- XD(4)=T-TM
- DO 240 IIM=1,NNM-1
- IF(K(INM(IIM),2).LT.0) GOTO 240
- BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
- BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
- DO 230 J=1,3
- XB(J)=XD(J)+BEDG*BETM(IIM,J)
- 230 CONTINUE
- XB(4)=BETM(IIM,4)*(XD(4)-BED)
- SR2=XB(1)**2+XB(2)**2+XB(3)**2
- SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
- & DIRM(IIM,3)*XB(3))**2
- WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
- & TFRAG**2)
- IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
- IF(WTM.GT.WTMAXM) THEN
- IMAXM=IIM
- WTMAXM=WTM
- ENDIF
- 240 CONTINUE
-
-C...Result of integration.
- WT=0D0
- IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
- WT=WTMAXP*WTMAXM/WTSMP
- SUM=SUM+WT
- NACC=NACC+1
- IAP(NACC)=IMAXP
- IAM(NACC)=IMAXM
- WTA(NACC)=WT
- ENDIF
- 250 CONTINUE
- RES=BLOWR**3*BLOWT*SUM/NPT
-
-C...Decide whether to reconnect and, if so, where.
- IACC=0
- PREC=1D0-EXP(-FACT*RES)
- IF(PREC.GT.PYR(0)) THEN
- RSUM=PYR(0)*SUM
- DO 260 IA=1,NACC
- IACC=IA
- RSUM=RSUM-WTA(IA)
- IF(RSUM.LE.0D0) GOTO 270
- 260 CONTINUE
- 270 IIP=IAP(IACC)
- IIM=IAM(IACC)
- ENDIF
-
-C...Begin scenario II and II' specifics.
- ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
-
-C...Loop through all string pieces, one from W+ and one from W-.
- NCROSS=0
- TC(0)=0D0
- DO 340 IIP=1,NNP-1
- IF(K(INP(IIP),2).LT.0) GOTO 340
- I1P=INP(IIP)
- I2P=INP(IIP+1)
- DO 330 IIM=1,NNM-1
- IF(K(INM(IIM),2).LT.0) GOTO 330
- I1M=INM(IIM)
- I2M=INM(IIM+1)
-
-C...Find endpoint velocity vectors.
- DO 280 J=1,3
- V1P(J)=P(I1P,J)/P(I1P,4)
- V2P(J)=P(I2P,J)/P(I2P,4)
- V1M(J)=P(I1M,J)/P(I1M,4)
- V2M(J)=P(I2M,J)/P(I2M,4)
- 280 CONTINUE
-
-C...Define q matrix and find t.
- DO 290 J=1,3
- Q(1,J)=V2P(J)-V1P(J)
- Q(2,J)=-(V2M(J)-V1M(J))
- Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
- Q(4,J)=V1P(J)-V1M(J)
- 290 CONTINUE
- T=-DETER(1,2,3)/DETER(1,2,4)
-
-C...Find alpha and beta; i.e. coordinates of crossing point.
- S11=Q(1,1)*(T-TP)
- S12=Q(2,1)*(T-TM)
- S13=Q(3,1)+Q(4,1)*T
- S21=Q(1,2)*(T-TP)
- S22=Q(2,2)*(T-TM)
- S23=Q(3,2)+Q(4,2)*T
- DEN=S11*S22-S12*S21
- ALP=(S12*S23-S22*S13)/DEN
- BET=(S21*S13-S11*S23)/DEN
-
-C...Check if solution acceptable.
- IANSW=1
- IF(T.LT.GTMAX) IANSW=0
- IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
- IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
-
-C...Find point of crossing and check that not inconsistent.
- DO 300 J=1,3
- XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
- XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
- 300 CONTINUE
- D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
- & (XPP(3)-XMM(3))**2
- D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
- D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
- IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
-
-C...Find string eigentimes at crossing.
- IF(IANSW.EQ.1) THEN
- TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
- & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
- TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
- & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
- ELSE
- TAUP=0D0
- TAUM=0D0
- ENDIF
-
-C...Order crossings by time. End loop over crossings.
- IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
- NCROSS=NCROSS+1
- DO 310 I1=NCROSS,1,-1
- IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
- IPC(I1)=IIP
- IMC(I1)=IIM
- TC(I1)=T
- TPC(I1)=TAUP
- TMC(I1)=TAUM
- GOTO 320
- ELSE
- IPC(I1)=IPC(I1-1)
- IMC(I1)=IMC(I1-1)
- TC(I1)=TC(I1-1)
- TPC(I1)=TPC(I1-1)
- TMC(I1)=TMC(I1-1)
- ENDIF
- 310 CONTINUE
- 320 CONTINUE
- ENDIF
- 330 CONTINUE
- 340 CONTINUE
-
-C...Loop over crossings; find first (if any) acceptable one.
- IACC=0
- IF(NCROSS.GE.1) THEN
- DO 350 IC=1,NCROSS
- PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
- IF(PNFRAG.GT.PYR(0)) THEN
-C...Scenario II: only compare with fragmentation time.
- IF(MSTP(115).EQ.2) THEN
- IACC=IC
- IIP=IPC(IACC)
- IIM=IMC(IACC)
- GOTO 360
-C...Scenario II': also require that string length decreases.
- ELSE
- IIP=IPC(IC)
- IIM=IMC(IC)
- I1P=INP(IIP)
- I2P=INP(IIP+1)
- I1M=INM(IIM)
- I2M=INM(IIM+1)
- ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
- ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
- IF(ELNEW.LT.ELOLD) THEN
- IACC=IC
- IIP=IPC(IACC)
- IIM=IMC(IACC)
- GOTO 360
- ENDIF
- ENDIF
- ENDIF
- 350 CONTINUE
- 360 CONTINUE
- ENDIF
-
-C...Begin scenario GH specifics.
- ELSEIF(MSTP(115).EQ.5) THEN
-
-C...Loop through all string pieces, one from W+ and one from W-.
- IACC=0
- ELMIN=1D0
- DO 380 IIP=1,NNP-1
- IF(K(INP(IIP),2).LT.0) GOTO 380
- I1P=INP(IIP)
- I2P=INP(IIP+1)
- DO 370 IIM=1,NNM-1
- IF(K(INM(IIM),2).LT.0) GOTO 370
- I1M=INM(IIM)
- I2M=INM(IIM+1)
-
-C...Look for largest decrease of (exponent of) Lambda measure.
- ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
- ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
- ELDIF=ELNEW/MAX(1D-10,ELOLD)
- IF(ELDIF.LT.ELMIN) THEN
- IACC=IIP+IIM
- ELMIN=ELDIF
- IPC(1)=IIP
- IMC(1)=IIM
- ENDIF
- 370 CONTINUE
- 380 CONTINUE
- IIP=IPC(1)
- IIM=IMC(1)
- ENDIF
-
-C...Common for scenarios I, II, II' and GH: reconnect strings.
- IF(IACC.NE.0) THEN
- MINT(32)=1
- NJOIN=0
- DO 390 IS=1,NNP+NNM
- NJOIN=NJOIN+1
- IF(IS.LE.IIP) THEN
- I=INP(IS)
- ELSEIF(IS.LE.IIP+NNM-IIM) THEN
- I=INM(IS-IIP+IIM)
- ELSEIF(IS.LE.IIP+NNM) THEN
- I=INM(IS-IIP-NNM+IIM)
- ELSE
- I=INP(IS-NNM)
- ENDIF
- IJOIN(NJOIN)=I
- IF(K(I,2).LT.0) THEN
- CALL PYJOIN(NJOIN,IJOIN)
- NJOIN=0
- ENDIF
- 390 CONTINUE
-
-C...Restore original event record if no reconnection.
- ELSE
- DO 400 I=NSD1+1,NOLD
- IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
- K(I,4)=MOD(K(I,4),MSTU(5)**2)
- K(I,5)=MOD(K(I,5),MSTU(5)**2)
- ENDIF
- 400 CONTINUE
- DO 410 I=NOLD+1,N
- K(K(I,3),1)=3
- 410 CONTINUE
- N=NOLD
- ENDIF
-
-C...Boost back system.
- CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
- CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
- IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
- & BEWW(1),BEWW(2),BEWW(3))
-
-C...Common part for intermediate and instantaneous scenarios.
- ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
- MINT(32)=1
-
-C...Remove old shower products and reset showering ones.
- N=NSD1+4
- DO 420 I=NSD1+1,NSD1+4
- K(I,1)=3
- K(I,4)=MOD(K(I,4),MSTU(5)**2)
- K(I,5)=MOD(K(I,5),MSTU(5)**2)
- 420 CONTINUE
-
-C...Identify quark-antiquark pairs.
- IQ1=NSD1+1
- IQ2=NSD1+2
- IQ3=NSD1+3
- IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
- IQ4=2*NSD1+7-IQ3
-
-C...Reconnect strings.
- IJOIN(1)=IQ1
- IJOIN(2)=IQ4
- CALL PYJOIN(2,IJOIN)
- IJOIN(1)=IQ3
- IJOIN(2)=IQ2
- CALL PYJOIN(2,IJOIN)
-
-C...Do new parton showers in intermediate scenario.
- IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
- MSTJ50=MSTJ(50)
- MSTJ(50)=0
- if(parj(200).ne.1.) CALL PYSHOW(IQ1,IQ2,P(IW1,5))
- if(parj(200).eq.1.) CALL PYSHOWQ(IQ1,IQ2,P(IW1,5))
- if(parj(200).ne.1.) CALL PYSHOW(IQ3,IQ4,P(IW2,5))
- if(parj(200).eq.1.) CALL PYSHOWQ(IQ3,IQ4,P(IW2,5))
- MSTJ(50)=MSTJ50
-
-C...Do new parton showers in instantaneous scenario.
- ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
- PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
- & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
- PPM=SQRT(MAX(0D0,PPM2))
- if(parj(200).ne.1.) CALL PYSHOW(IQ1,IQ4,PPM)
- if(parj(200).eq.1.) CALL PYSHOWQ(IQ1,IQ4,PPM)
- PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
- & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
- PPM=SQRT(MAX(0D0,PPM2))
- if(parj(200).ne.1.) CALL PYSHOW(IQ3,IQ2,PPM)
- if(parj(200).eq.1.) CALL PYSHOWQ(IQ3,IQ2,PPM)
- ENDIF
- ENDIF
-
- RETURN
- END
-
-C***********************************************************************
-
-C...PYKLIM
-C...Checks generated variables against pre-set kinematical limits;
-C...also calculates limits on variables used in generation.
-
- SUBROUTINE PYKLIM(ILIM)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
- &/PYINT1/,/PYINT2/
-
-C...Common kinematical expressions.
- MINT(51)=0
- ISUB=MINT(1)
- ISTSB=ISET(ISUB)
- IF(ISUB.EQ.96) GOTO 100
- SQM3=VINT(63)
- SQM4=VINT(64)
- IF(ILIM.NE.0) THEN
- IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
- CKIN09=MAX(CKIN(9),CKIN(13))
- CKIN10=MIN(CKIN(10),CKIN(14))
- CKIN11=MAX(CKIN(11),CKIN(15))
- CKIN12=MIN(CKIN(12),CKIN(16))
- ELSE
- CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
- CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
- CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
- CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
- ENDIF
- ENDIF
- IF(ILIM.NE.1) THEN
- TAU=VINT(21)
- RM3=SQM3/(TAU*VINT(2))
- RM4=SQM4/(TAU*VINT(2))
- BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
- ENDIF
- PTHMIN=CKIN(3)
- IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
- &PTHMIN=MAX(CKIN(3),CKIN(5))
-
- IF(ILIM.EQ.0) THEN
-C...Check generated values of tau, y*, cos(theta-hat), and tau' against
-C...pre-set kinematical limits.
- YST=VINT(22)
- CTH=VINT(23)
- TAUP=VINT(26)
- TAUE=TAU
- IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
- X1=SQRT(TAUE)*EXP(YST)
- X2=SQRT(TAUE)*EXP(-YST)
- XF=X1-X2
- IF(MINT(47).NE.1) THEN
- IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
- IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
- IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
- IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
- ENDIF
- IF(MINT(45).NE.1) THEN
- IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
- ENDIF
- IF(MINT(46).NE.1) THEN
- IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
- ENDIF
- IF(MINT(45).EQ.2) THEN
- IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
- ENDIF
- IF(MINT(46).EQ.2) THEN
- IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
- ENDIF
- IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
- PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
- EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
- & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
- EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
- & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
- Y3=YST+0.5D0*LOG(EXPY3)
- Y4=YST+0.5D0*LOG(EXPY4)
- YLARGE=MAX(Y3,Y4)
- YSMALL=MIN(Y3,Y4)
- ETALAR=20D0
- ETASMA=-20D0
- STH=SQRT(MAX(0D0,1D0-CTH**2))
- EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
- & CTH)**2-4D0*RM3))
- EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
- & CTH)**2-4D0*RM4))
- IF(STH.GE.1D-10) THEN
- EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
- & (BE34*STH)
- EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
- & (BE34*STH)
- ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
- ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
- ETALAR=MAX(ETA3,ETA4)
- ETASMA=MIN(ETA3,ETA4)
- ENDIF
- CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
- CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
- CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
- CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
- SH=TAU*VINT(2)
- RPTS=4D0*VINT(71)**2/SH
- BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
- RM34=MAX(1D-20,2D0*RM3*RM4)
- IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
- & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
- RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
- THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
- UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
- IF(PTH.LT.PTHMIN) MINT(51)=1
- IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
- IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
- IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
- IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
- IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
- IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
- IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
- IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
- IF(THA.LT.CKIN(35)) MINT(51)=1
- IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
- IF(UHA.LT.CKIN(37)) MINT(51)=1
- IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
- ENDIF
- IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
- IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
- IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
- ENDIF
-
-C...Additional cuts on W2 (approximately) in DIS.
- IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
- XBJ=X2
- IF(IABS(MINT(12)).LT.20) XBJ=X1
- Q2BJ=THA
- W2BJ=Q2BJ*(1D0-XBJ)/XBJ
- IF(W2BJ.LT.CKIN(39)) MINT(51)=1
- IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
- ENDIF
-
- ELSEIF(ILIM.EQ.1) THEN
-C...Calculate limits on tau
-C...0) due to definition
- TAUMN0=0D0
- TAUMX0=1D0
-C...1) due to limits on subsystem mass
- TAUMN1=CKIN(1)**2/VINT(2)
- TAUMX1=1D0
- IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
-C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
- TM3=SQRT(SQM3+PTHMIN**2)
- TM4=SQRT(SQM4+PTHMIN**2)
- YDCOSH=1D0
- IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
- TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
- TAUMX2=1D0
-C...3) due to limits on pT-hat and cos(theta-hat)
- CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
- CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
- TAUMN3=0D0
- IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
- & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
- & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
- TAUMX3=1D0
- IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
- & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
- & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
-C...4) due to limits on x1 and x2
- TAUMN4=CKIN(21)*CKIN(23)
- TAUMX4=CKIN(22)*CKIN(24)
-C...5) due to limits on xF
- TAUMN5=0D0
- TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
-C...6) due to limits on that and uhat
- TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
- TAUMX6=1D0
- IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
- & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
-
-C...Net effect of all separate limits.
- VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
- VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
- IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
- VINT(11)=1D0-1D-9
- VINT(31)=1D0+1D-9
- ELSEIF(MINT(47).EQ.5) THEN
- VINT(31)=MIN(VINT(31),1D0-2D-10)
- ELSEIF(MINT(47).GE.6) THEN
- VINT(31)=MIN(VINT(31),1D0-1D-10)
- ENDIF
- IF(VINT(31).LE.VINT(11)) MINT(51)=1
-
- ELSEIF(ILIM.EQ.2) THEN
-C...Calculate limits on y*
- TAUE=TAU
- IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
- TAURT=SQRT(TAUE)
-C...0) due to kinematics
- YSTMN0=LOG(TAURT)
- YSTMX0=-YSTMN0
-C...1) due to explicit limits
- YSTMN1=CKIN(7)
- YSTMX1=CKIN(8)
-C...2) due to limits on x1
- YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
- YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
-C...3) due to limits on x2
- YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
- YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
-C...4) due to limits on xF
- YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
- YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
- YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
- YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
-C...5) due to simultaneous limits on y-large and y-small
- YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
- YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
- YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
- YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
- YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
- YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
-C...6) due to simultaneous limits on cos(theta-hat) and y-large or
-C... y-small
- CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
- RZMN=BE34*MAX(CKIN(27),-CTHLIM)
- RZMX=BE34*MIN(CKIN(28),CTHLIM)
- YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
- YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
- YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
- YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
- YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
- YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
-
-C...Net effect of all separate limits.
- VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
- VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
- IF(MINT(47).EQ.1) THEN
- VINT(12)=-1D-9
- VINT(32)=1D-9
- ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
- VINT(12)=(1D0-1D-9)*YSTMX0
- VINT(32)=(1D0+1D-9)*YSTMX0
- ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
- VINT(12)=-(1D0+1D-9)*YSTMX0
- VINT(32)=-(1D0-1D-9)*YSTMX0
- ELSEIF(MINT(47).EQ.5) THEN
- YSTEE=LOG((1D0-1D-10)/TAURT)
- VINT(12)=MAX(VINT(12),-YSTEE)
- VINT(32)=MIN(VINT(32),YSTEE)
- ENDIF
- IF(VINT(32).LE.VINT(12)) MINT(51)=1
-
- ELSEIF(ILIM.EQ.3) THEN
-C...Calculate limits on cos(theta-hat)
- YST=VINT(22)
-C...0) due to definition
- CTNMN0=-1D0
- CTNMX0=0D0
- CTPMN0=0D0
- CTPMX0=1D0
-C...1) due to explicit limits
- CTNMN1=MIN(0D0,CKIN(27))
- CTNMX1=MIN(0D0,CKIN(28))
- CTPMN1=MAX(0D0,CKIN(27))
- CTPMX1=MAX(0D0,CKIN(28))
-C...2) due to limits on pT-hat
- CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
- CTPMX2=-CTNMN2
- CTNMX2=0D0
- CTPMN2=0D0
- IF(CKIN(4).GE.0D0) THEN
- CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
- & (BE34**2*TAU*VINT(2))))
- CTPMN2=-CTNMX2
- ENDIF
-C...3) due to limits on y-large and y-small
- CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
- & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
- CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
- & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
- CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
- & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
- CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
- & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
-C...4) due to limits on that
- CTNMN4=-1D0
- CTNMX4=0D0
- CTPMN4=0D0
- CTPMX4=1D0
- SH=TAU*VINT(2)
- IF(CKIN(35).GT.0D0) THEN
- CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
- IF(CTLIM.GT.0D0) THEN
- CTPMX4=CTLIM
- ELSE
- CTPMX4=0D0
- CTNMX4=CTLIM
- ENDIF
- ENDIF
- IF(CKIN(36).GT.0D0) THEN
- CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
- IF(CTLIM.LT.0D0) THEN
- CTNMN4=CTLIM
- ELSE
- CTNMN4=0D0
- CTPMN4=CTLIM
- ENDIF
- ENDIF
-C...5) due to limits on uhat
- CTNMN5=-1D0
- CTNMX5=0D0
- CTPMN5=0D0
- CTPMX5=1D0
- IF(CKIN(37).GT.0D0) THEN
- CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
- IF(CTLIM.LT.0D0) THEN
- CTNMN5=CTLIM
- ELSE
- CTNMN5=0D0
- CTPMN5=CTLIM
- ENDIF
- ENDIF
- IF(CKIN(38).GT.0D0) THEN
- CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
- IF(CTLIM.GT.0D0) THEN
- CTPMX5=CTLIM
- ELSE
- CTPMX5=0D0
- CTNMX5=CTLIM
- ENDIF
- ENDIF
-
-C...Net effect of all separate limits.
- VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
- VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
- VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
- VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
- IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
-
- IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
- IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
-
- ELSEIF(ILIM.EQ.4) THEN
-C...Calculate limits on tau'
-C...0) due to kinematics
- TAPMN0=TAU
- IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
- PQRAT=(VINT(201)+VINT(206))/VINT(1)
- TAPMN0=(SQRT(TAU)+PQRAT)**2
- ENDIF
- TAPMX0=1D0
-C...1) due to explicit limits
- TAPMN1=CKIN(31)**2/VINT(2)
- TAPMX1=1D0
- IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
-
-C...Net effect of all separate limits.
- VINT(16)=MAX(TAPMN0,TAPMN1)
- VINT(36)=MIN(TAPMX0,TAPMX1)
- IF(MINT(47).EQ.1) THEN
- VINT(16)=1D0-1D-9
- VINT(36)=1D0+1D-9
- ELSEIF(MINT(47).EQ.5) THEN
- VINT(36)=MIN(VINT(36),1D0-2D-10)
- ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
- VINT(36)=MIN(VINT(36),1D0-1D-10)
- ENDIF
- IF(VINT(36).LE.VINT(16)) MINT(51)=1
-
- ENDIF
- RETURN
-
-C...Special case for low-pT and multiple interactions:
-C...effective kinematical limits for tau, y*, cos(theta-hat).
- 100 IF(ILIM.EQ.0) THEN
- ELSEIF(ILIM.EQ.1) THEN
- IF(MSTP(82).LE.1) THEN
- VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
- & VINT(2)
- ELSE
- VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
- ENDIF
- VINT(31)=1D0
- ELSEIF(ILIM.EQ.2) THEN
- VINT(12)=0.5D0*LOG(VINT(21))
- VINT(32)=-VINT(12)
- ELSEIF(ILIM.EQ.3) THEN
- IF(MSTP(82).LE.1) THEN
- ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
- & (VINT(21)*VINT(2))
- ELSE
- ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
- & (VINT(21)*VINT(2))
- ENDIF
- VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
- VINT(33)=0D0
- VINT(14)=0D0
- VINT(34)=-VINT(13)
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYKMAP
-C...Maps a uniform distribution into a distribution of a kinematical
-C...variable according to one of the possibilities allowed. It is
-C...assumed that kinematical limits have been set by a PYKLIM call.
-
- SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
-
-C...Convert VVAR to tau variable.
- ISUB=MINT(1)
- ISTSB=ISET(ISUB)
- IF(IVAR.EQ.1) THEN
- TAUMIN=VINT(11)
- TAUMAX=VINT(31)
- IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
- TAURE=VINT(73)
- GAMRE=VINT(74)
- ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
- TAURE=VINT(75)
- GAMRE=VINT(76)
- ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
- TAURE=VINT(77)
- GAMRE=VINT(78)
- ENDIF
- IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
- TAU=1D0
- ELSEIF(MVAR.EQ.1) THEN
- TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
- ELSEIF(MVAR.EQ.2) THEN
- TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
- ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
- RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
- TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
- ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
- AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
- ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
- TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
- ELSEIF(MINT(47).EQ.5) THEN
- AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
- ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
- TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
- ELSE
- AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
- ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
- TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
- ENDIF
- VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
-
-C...Convert VVAR to y* variable.
- ELSEIF(IVAR.EQ.2) THEN
- YSTMIN=VINT(12)
- YSTMAX=VINT(32)
- TAUE=VINT(21)
- IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
- IF(MINT(47).EQ.1) THEN
- YST=0D0
- ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
- YST=-0.5D0*LOG(TAUE)
- ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
- YST=0.5D0*LOG(TAUE)
- ELSEIF(MVAR.EQ.1) THEN
- YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
- ELSEIF(MVAR.EQ.2) THEN
- YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
- ELSEIF(MVAR.EQ.3) THEN
- AUPP=ATAN(EXP(YSTMAX))
- ALOW=ATAN(EXP(YSTMIN))
- YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
- ELSEIF(MVAR.EQ.4) THEN
- YST0=-0.5D0*LOG(TAUE)
- AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
- ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
- YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
- ELSE
- YST0=-0.5D0*LOG(TAUE)
- AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
- ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
- YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
- ENDIF
- VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
-
-C...Convert VVAR to cos(theta-hat) variable.
- ELSEIF(IVAR.EQ.3) THEN
- RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
- RSQM=1D0+RM34
- IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
- & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
- CTNMIN=VINT(13)
- CTNMAX=VINT(33)
- CTPMIN=VINT(14)
- CTPMAX=VINT(34)
- IF(MVAR.EQ.1) THEN
- ANEG=CTNMAX-CTNMIN
- APOS=CTPMAX-CTPMIN
- IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
- VCTN=VVAR*(ANEG+APOS)/ANEG
- CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
- ELSE
- VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
- CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
- ENDIF
- ELSEIF(MVAR.EQ.2) THEN
- RMNMIN=MAX(RM34,RSQM-CTNMIN)
- RMNMAX=MAX(RM34,RSQM-CTNMAX)
- RMPMIN=MAX(RM34,RSQM-CTPMIN)
- RMPMAX=MAX(RM34,RSQM-CTPMAX)
- ANEG=LOG(RMNMIN/RMNMAX)
- APOS=LOG(RMPMIN/RMPMAX)
- IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
- VCTN=VVAR*(ANEG+APOS)/ANEG
- CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
- ELSE
- VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
- CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
- ENDIF
- ELSEIF(MVAR.EQ.3) THEN
- RMNMIN=MAX(RM34,RSQM+CTNMIN)
- RMNMAX=MAX(RM34,RSQM+CTNMAX)
- RMPMIN=MAX(RM34,RSQM+CTPMIN)
- RMPMAX=MAX(RM34,RSQM+CTPMAX)
- ANEG=LOG(RMNMAX/RMNMIN)
- APOS=LOG(RMPMAX/RMPMIN)
- IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
- VCTN=VVAR*(ANEG+APOS)/ANEG
- CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
- ELSE
- VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
- CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
- ENDIF
- ELSEIF(MVAR.EQ.4) THEN
- RMNMIN=MAX(RM34,RSQM-CTNMIN)
- RMNMAX=MAX(RM34,RSQM-CTNMAX)
- RMPMIN=MAX(RM34,RSQM-CTPMIN)
- RMPMAX=MAX(RM34,RSQM-CTPMAX)
- ANEG=1D0/RMNMAX-1D0/RMNMIN
- APOS=1D0/RMPMAX-1D0/RMPMIN
- IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
- VCTN=VVAR*(ANEG+APOS)/ANEG
- CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
- ELSE
- VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
- CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
- ENDIF
- ELSEIF(MVAR.EQ.5) THEN
- RMNMIN=MAX(RM34,RSQM+CTNMIN)
- RMNMAX=MAX(RM34,RSQM+CTNMAX)
- RMPMIN=MAX(RM34,RSQM+CTPMIN)
- RMPMAX=MAX(RM34,RSQM+CTPMAX)
- ANEG=1D0/RMNMIN-1D0/RMNMAX
- APOS=1D0/RMPMIN-1D0/RMPMAX
- IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
- VCTN=VVAR*(ANEG+APOS)/ANEG
- CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
- ELSE
- VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
- CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
- ENDIF
- ENDIF
- IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
- IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
- VINT(23)=CTH
-
-C...Convert VVAR to tau' variable.
- ELSEIF(IVAR.EQ.4) THEN
- TAU=VINT(21)
- TAUPMN=VINT(16)
- TAUPMX=VINT(36)
- IF(MINT(47).EQ.1) THEN
- TAUP=1D0
- ELSEIF(MVAR.EQ.1) THEN
- TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
- ELSEIF(MVAR.EQ.2) THEN
- AUPP=(1D0-TAU/TAUPMX)**4
- ALOW=(1D0-TAU/TAUPMN)**4
- TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
- ELSEIF(MINT(47).EQ.5) THEN
- AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
- ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
- TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
- ELSE
- AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
- ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
- TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
- ENDIF
- VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
-
-C...Selection of extra variables needed in 2 -> 3 process:
-C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
-C...Since no options are available, the functions of PYKLIM
-C...and PYKMAP are joint for these choices.
- ELSEIF(IVAR.EQ.5) THEN
-
-C...Read out total energy and particle masses.
- MINT(51)=0
- MPTPK=1
- IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
- & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
- & MPTPK=2
- SHP=VINT(26)*VINT(2)
- SHPR=SQRT(SHP)
- PM1=VINT(201)
- PM2=VINT(206)
- PM3=SQRT(VINT(21))*VINT(1)
- IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
- MINT(51)=1
- RETURN
- ENDIF
- PMRS1=VINT(204)**2
- PMRS2=VINT(209)**2
-
-C...Specify coefficients of pT choice; upper and lower limits.
- IF(MPTPK.EQ.1) THEN
- HWT1=0.4D0
- HWT2=0.4D0
- ELSE
- HWT1=0.05D0
- HWT2=0.05D0
- ENDIF
- HWT3=1D0-HWT1-HWT2
- PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
- & (4D0*SHP)
- IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
- PTSMN1=CKIN(51)**2
- PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
- & (4D0*SHP)
- IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
- PTSMN2=CKIN(53)**2
-
-C...Select transverse momenta according to
-C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
- HMX=PMRS1+PTSMX1
- HMN=PMRS1+PTSMN1
- IF(HMX.LT.1.0001D0*HMN) THEN
- MINT(51)=1
- RETURN
- ENDIF
- HDE=PTSMX1-PTSMN1
- RPT=PYR(0)
- IF(RPT.LT.HWT1) THEN
- PTS1=PTSMN1+PYR(0)*HDE
- ELSEIF(RPT.LT.HWT1+HWT2) THEN
- PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
- ELSE
- PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
- ENDIF
- WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
- & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
- HMX=PMRS2+PTSMX2
- HMN=PMRS2+PTSMN2
- IF(HMX.LT.1.0001D0*HMN) THEN
- MINT(51)=1
- RETURN
- ENDIF
- HDE=PTSMX2-PTSMN2
- RPT=PYR(0)
- IF(RPT.LT.HWT1) THEN
- PTS2=PTSMN2+PYR(0)*HDE
- ELSEIF(RPT.LT.HWT1+HWT2) THEN
- PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
- ELSE
- PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
- ENDIF
- WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
- & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
-
-C...Select azimuthal angles and check pT choice.
- PHI1=PARU(2)*PYR(0)
- PHI2=PARU(2)*PYR(0)
- PHIR=PHI2-PHI1
- PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
- IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
- & CKIN(56)**2)) THEN
- MINT(51)=1
- RETURN
- ENDIF
-
-C...Calculate transverse masses and check phase space not closed.
- PMS1=PM1**2+PTS1
- PMS2=PM2**2+PTS2
- PMS3=PM3**2+PTS3
- PMT1=SQRT(PMS1)
- PMT2=SQRT(PMS2)
- PMT3=SQRT(PMS3)
- PM12=(PMT1+PMT2)**2
- IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
- MINT(51)=1
- RETURN
- ENDIF
-
-C...Select rapidity for particle 3 and check phase space not closed.
- Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
- & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
- IF(Y3MAX.LT.1D-6) THEN
- MINT(51)=1
- RETURN
- ENDIF
- Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
- PZ3=PMT3*SINH(Y3)
- PE3=PMT3*COSH(Y3)
-
-C...Find momentum transfers in two mirror solutions (in 1-2 frame).
- PZ12=-PZ3
- PE12=SHPR-PE3
- PMS12=PE12**2-PZ12**2
- SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
- IF(SQL12.LT.1D-6*SHP) THEN
- MINT(51)=1
- RETURN
- ENDIF
- PMM1=PMS12+PMS1-PMS2
- PMM2=PMS12+PMS2-PMS1
- TFAC=-SHPR/(2D0*PMS12)
- T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
- T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
- T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
- T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
-
-C...Construct relative mirror weights and make choice.
- IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
- WTPU=1D0
- WTNU=1D0
- ELSE
- WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
- WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
- ENDIF
- WTP=WTPU/(WTPU+WTNU)
- WTN=WTNU/(WTPU+WTNU)
- EPS=1D0
- IF(WTN.GT.PYR(0)) EPS=-1D0
-
-C...Store result of variable choice and associated weights.
- VINT(202)=PTS1
- VINT(207)=PTS2
- VINT(203)=PHI1
- VINT(208)=PHI2
- VINT(205)=WTPTS1
- VINT(210)=WTPTS2
- VINT(211)=Y3
- VINT(212)=Y3MAX
- VINT(213)=EPS
- IF(EPS.GT.0D0) THEN
- VINT(214)=1D0/WTP
- VINT(215)=T1P
- VINT(216)=T2P
- ELSE
- VINT(214)=1D0/WTN
- VINT(215)=T1N
- VINT(216)=T2N
- ENDIF
- VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
- VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
- VINT(219)=0.5D0*(PMS12-PTS3)
- VINT(220)=SQL12
- ENDIF
-
- RETURN
- END
-
-C***********************************************************************
-
-C...PYSIGH
-C...Differential matrix elements for all included subprocesses
-C...Note that what is coded is (disregarding the COMFAC factor)
-C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
-C...when d(sigma-hat) is given in the zero-width limit, the delta
-C...function in tau is replaced by a (modified) Breit-Wigner:
-C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
-C...where H_res = s-hat/m_res*Gamma_res(s-hat);
-C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
-C...i.e., dimensionless quantities
-C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
-C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
-C...(2pi)^4 delta^4(P - sum p_i)
-C...COMFAC contains the factor pi/s (or equivalent) and
-C...the conversion factor from GeV^-2 to mb
-
- SUBROUTINE PYSIGH(NCHN,SIGS)
-
-C...Double precision and integer declarations
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
- COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
- &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
- &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
- &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
- COMMON/PYTCCO/COEFX(194:380,2)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
- &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
- &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYSGCM/,/PYTCCO/
-C...Local arrays and complex variables
- DIMENSION XPQ(-25:25)
-
-C...Map of processes onto which routine to call
-C...in order to evaluate cross section:
-C...0 = not implemented;
-C...1 = standard QCD (including photons);
-C...2 = heavy flavours;
-C...3 = W/Z;
-C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
-C...5 = SUSY;
-C...6 = Technicolor;
-C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
- DIMENSION MAPPR(500)
- DATA (MAPPR(I),I=1,180)/
- & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
- 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
- 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
- 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
- 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
- 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
- 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
- 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
- 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
- & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
- 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
- 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
- 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
- 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
- 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
- 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
- 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
- DATA (MAPPR(I),I=181,500)/
- 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
- 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
- & 100*5,
- & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 1 30*0,
- 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
- 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
- 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
- 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
- 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
- 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
- & 4, 4, 18*0,
- 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
- 4 20*0,
- 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
- 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
- 8 20*0/
-
-C...Reset number of channels and cross-section
- NCHN=0
- SIGS=0D0
-
-C...Read process to consider.
- ISUB=MINT(1)
- ISUBSV=ISUB
- MAP=MAPPR(ISUB)
-
-C...Read kinematical variables and limits
- ISTSB=ISET(ISUBSV)
- TAUMIN=VINT(11)
- YSTMIN=VINT(12)
- CTNMIN=VINT(13)
- CTPMIN=VINT(14)
- TAUPMN=VINT(16)
- TAU=VINT(21)
- YST=VINT(22)
- CTH=VINT(23)
- XT2=VINT(25)
- TAUP=VINT(26)
- TAUMAX=VINT(31)
- YSTMAX=VINT(32)
- CTNMAX=VINT(33)
- CTPMAX=VINT(34)
- TAUPMX=VINT(36)
-
-C...Derive kinematical quantities
- TAUE=TAU
- IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
- X(1)=SQRT(TAUE)*EXP(YST)
- X(2)=SQRT(TAUE)*EXP(-YST)
- IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
- IF(X(1).GT.1D0-1D-7) RETURN
- ELSEIF(MINT(45).EQ.3) THEN
- X(1)=MIN(1D0-1.1D-10,X(1))
- ENDIF
- IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
- IF(X(2).GT.1D0-1D-7) RETURN
- ELSEIF(MINT(46).EQ.3) THEN
- X(2)=MIN(1D0-1.1D-10,X(2))
- ENDIF
- SH=MAX(1D0,TAU*VINT(2))
- SQM3=VINT(63)
- SQM4=VINT(64)
- RM3=SQM3/SH
- RM4=SQM4/SH
- BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
- RPTS=4D0*VINT(71)**2/SH
- BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
- RM34=MAX(1D-20,2D0*RM3*RM4)
- RSQM=1D0+RM34
- IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
- &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
- RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
- IF(ISTSB.EQ.0) THEN
- TH=VINT(45)
- UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
- SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
- ELSE
-C...Kinematics with incoming masses tricky: now depends on how
-C...subprocess has been set up w.r.t. order of incoming partons.
- RM1=0D0
- IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
- RM2=0D0
- IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
- IF(ISUB.EQ.35) THEN
- RM2=MIN(RM1,RM2)
- RM1=0D0
- ENDIF
- BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
- TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
- & BE12*BE34*CTH)
- UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
- & BE12*BE34*CTH)
- SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
- ENDIF
- SHR=SQRT(SH)
- SH2=SH**2
- TH2=TH**2
- UH2=UH**2
-
-C...Choice of Q2 scale for hard process (e.g. alpha_s).
- IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
- Q2=SH
- ELSEIF(ISTSB.EQ.8) THEN
- IF(MINT(107).EQ.4) Q2=VINT(307)
- IF(MINT(108).EQ.4) Q2=VINT(308)
- ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
- Q2IN1=0D0
- IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
- Q2IN2=0D0
- IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
- IF(MSTP(32).EQ.1) THEN
- Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
- ELSEIF(MSTP(32).EQ.2) THEN
- Q2=SQPTH+0.5D0*(SQM3+SQM4)
- ELSEIF(MSTP(32).EQ.3) THEN
- Q2=MIN(-TH,-UH)
- ELSEIF(MSTP(32).EQ.4) THEN
- Q2=SH
- ELSEIF(MSTP(32).EQ.5) THEN
- Q2=-TH
- ELSEIF(MSTP(32).EQ.6) THEN
- XSF1=X(1)
- IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
- XSF2=X(2)
- IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
- Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
- & (SQPTH+0.5D0*(SQM3+SQM4))
- ELSEIF(MSTP(32).EQ.7) THEN
- Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
- ELSEIF(MSTP(32).EQ.8) THEN
- Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
- ELSEIF(MSTP(32).EQ.9) THEN
- Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
- ELSEIF(MSTP(32).EQ.10) THEN
- Q2=VINT(2)
-C..Begin JA 040914
- ELSEIF(MSTP(32).EQ.11) THEN
- Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
- ELSEIF(MSTP(32).EQ.12) THEN
- Q2=PARP(193)
-C..End JA
- ELSEIF(MSTP(32).EQ.13) THEN
- Q2=SQPTH
- ENDIF
- IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
- IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
- & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
- ENDIF
-
-C...Choice of Q2 scale for parton densities.
- Q2SF=Q2
-C..Begin JA 040914
- IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
- & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
- & Q2=PARP(194)
-C..End JA
- IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
- Q2SF=PMAS(23,1)**2
- IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
- & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
- IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
- IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
- & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
- Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
- IF(MSTP(39).EQ.2) Q2SF=
- & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
- IF(MSTP(39).EQ.3) Q2SF=SH
- IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
- IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
-C..Begin JA 040914
- IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
- IF(MSTP(39).EQ.7) Q2SF=
- & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
- IF(MSTP(39).EQ.8) Q2SF=PARP(193)
-C..End JA
- ENDIF
- ENDIF
- IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
-
- Q2PS=Q2SF
- Q2SF=Q2SF*PARP(34)
- IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
- IF(MSTP(69).GE.2) Q2SF=VINT(2)
-
-C...Identify to which class(es) subprocess belongs
- ISMECR=0
- ISQCD=0
- ISJETS=0
- IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
- & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
- & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
- & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
- IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
- & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
- IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
- IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
- IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
- IF (ISTSB.EQ.9) ISQCD=1
- IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
- & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
- & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
- & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
- & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
- & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
- & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
- & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
-C...WBF is special case of ISJETS
- IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
- & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
- & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
- & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
- & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
- & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
- & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
- & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
- & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
-C...Some processes with photons also belong here.
- IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
- & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
- & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
- & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
- & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
- & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
-
-C...Choice of Q2 scale for parton-shower activity.
- IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
- &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
- XBJ=X(2)
- IF(MINT(43).EQ.3) XBJ=X(1)
- IF(MSTP(22).EQ.1) THEN
- Q2PS=-TH
- ELSEIF(MSTP(22).EQ.2) THEN
- Q2PS=((1D0-XBJ)/XBJ)*(-TH)
- ELSEIF(MSTP(22).EQ.3) THEN
- Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
- ELSE
- Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
- ENDIF
- ENDIF
-C...For multiple interactions, start from scale defined above
-C...For all other QCD or "+jets"-type events, start shower from pThard.
- IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
- IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
-C...Max shower scale = s for ME corrected processes.
-C...(pT-ordering: max pT2 is s/4)
- Q2PS=VINT(2)
- IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
- ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
-C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
-C...(pT-ordering: max pT2 is s/4)
- Q2PS=VINT(2)
- IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
- ENDIF
- IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
-
-C...Elastic and diffractive events not associated with scales so set 0.
- IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
- Q2SF=0D0
- Q2PS=0D0
- ENDIF
-
-C...Store derived kinematical quantities
- VINT(41)=X(1)
- VINT(42)=X(2)
- VINT(44)=SH
- VINT(43)=SQRT(SH)
- VINT(45)=TH
- VINT(46)=UH
- IF(ISTSB.NE.8) VINT(48)=SQPTH
- IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
- VINT(50)=TAUP*VINT(2)
- VINT(49)=SQRT(MAX(0D0,VINT(50)))
- VINT(52)=Q2
- VINT(51)=SQRT(Q2)
- VINT(54)=Q2SF
- VINT(53)=SQRT(Q2SF)
- VINT(56)=Q2PS
- VINT(55)=SQRT(Q2PS)
-
-C...Set starting scale for multiple interactions
- IF (ISUBSV.EQ.95) THEN
- XT2GMX=0D0
- ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
- & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
- & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
- & ISUBSV.NE.96)) THEN
-C...All accessible phase space allowed.
- XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
- ELSE
-C...Scale of hard process sets limit.
-C...2 -> 1. Limit is tau = x1*x2.
-C...2 -> 2. Limit is XT2 for hard process + FS masses.
-C...2 -> n > 2. Limit is tau' = tau of outer process.
- XT2GMX=VINT(25)
- IF(ISTSB.EQ.1) XT2GMX=VINT(21)
- IF(ISTSB.EQ.2)
- & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
- IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
- ENDIF
- VINT(62)=0.25D0*XT2GMX*VINT(2)
- VINT(61)=SQRT(MAX(0D0,VINT(62)))
-
-C...Calculate parton distributions
- IF(ISTSB.LE.0) GOTO 160
- IF(MINT(47).GE.2) THEN
- DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
- XSF=X(I)
- IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
- IF(ISUB.EQ.99) THEN
- IF(MINT(140+I).EQ.0) THEN
- XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
- ELSE
- XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
- ENDIF
- VINT(40+I)=XSF
- Q2SF=VINT(309-I)
- ENDIF
- MINT(105)=MINT(102+I)
- MINT(109)=MINT(106+I)
- VINT(120)=VINT(2+I)
-C.... ALICE
-C.... Store side in MINT(124)
- MINT(124)=I
-C....
- IF(MSTP(57).LE.1) THEN
- CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
- ELSE
- CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
- ENDIF
-C...Safety margin against heavy flavour very close to threshold,
-C...e.g. caused by mismatch in c and b masses.
- IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
- XPQ(4)=0D0
- XPQ(-4)=0D0
- ENDIF
- IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
- XPQ(5)=0D0
- XPQ(-5)=0D0
- ENDIF
- DO 100 KFL=-25,25
- XSFX(I,KFL)=XPQ(KFL)
- 100 CONTINUE
- 110 CONTINUE
- ENDIF
-
-C...Calculate alpha_em, alpha_strong and K-factor
- XW=PARU(102)
- XWV=XW
- IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
- &1D0-(PMAS(24,1)/PMAS(23,1))**2
- XW1=1D0-XW
- XWC=1D0/(16D0*XW*XW1)
- AEM=PYALEM(Q2)
- IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
- IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
- FACK=1D0
- FACA=1D0
- IF(MSTP(33).EQ.1) THEN
- FACK=PARP(31)
- ELSEIF(MSTP(33).EQ.2) THEN
- FACK=PARP(31)
- FACA=PARP(32)/PARP(31)
- ELSEIF(MSTP(33).EQ.3) THEN
- Q2AS=PARP(33)*Q2
- IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
- & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
- AS=PYALPS(Q2AS)
- ENDIF
- VINT(138)=1D0
- VINT(57)=AEM
- VINT(58)=AS
-
-C...Set flags for allowed reacting partons/leptons
- DO 140 I=1,2
- DO 120 J=-25,25
- KFAC(I,J)=0
- 120 CONTINUE
- IF(MINT(44+I).EQ.1) THEN
- KFAC(I,MINT(10+I))=1
- ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
- KFAC(I,MINT(10+I))=1
- KFAC(I,22)=1
- KFAC(I,24)=1
- KFAC(I,-24)=1
- ELSE
- DO 130 J=-25,25
- KFAC(I,J)=KFIN(I,J)
- IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
- IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
- 130 CONTINUE
- ENDIF
- 140 CONTINUE
-
-C...Lower and upper limit for fermion flavour loops
- MMIN1=0
- MMAX1=0
- MMIN2=0
- MMAX2=0
- DO 150 J=-20,20
- IF(KFAC(1,-J).EQ.1) MMIN1=-J
- IF(KFAC(1,J).EQ.1) MMAX1=J
- IF(KFAC(2,-J).EQ.1) MMIN2=-J
- IF(KFAC(2,J).EQ.1) MMAX2=J
- 150 CONTINUE
- MMINA=MIN(MMIN1,MMIN2)
- MMAXA=MAX(MMAX1,MMAX2)
-
-C...Common resonance mass and width combinations
- SQMZ=PMAS(23,1)**2
- SQMW=PMAS(24,1)**2
- GMMZ=PMAS(23,1)*PMAS(23,2)
- GMMW=PMAS(24,1)*PMAS(24,2)
-
-C...Polarization factors...implemented so far for W+W-(25)
- POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
- POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
- POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
- POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
-
-C...Phase space integral in tau
- COMFAC=PARU(1)*PARU(5)/VINT(2)
- IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
- IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
- &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
- ATAU1=LOG(TAUMAX/TAUMIN)
- ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
- H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
- IF(MINT(72).GE.1) THEN
- TAUR1=VINT(73)
- GAMR1=VINT(74)
- ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
- ATAU3=ATAUD/TAUR1
- IF(ATAUD.GT.1D-10) H1=H1+
- & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
- ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
- ATAU4=ATAUD/GAMR1
- IF(ATAUD.GT.1D-10) H1=H1+
- & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
- ENDIF
- IF(MINT(72).GE.2) THEN
- TAUR2=VINT(75)
- GAMR2=VINT(76)
- ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
- ATAU5=ATAUD/TAUR2
- IF(ATAUD.GT.1D-10) H1=H1+
- & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
- ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
- ATAU6=ATAUD/GAMR2
- IF(ATAUD.GT.1D-10) H1=H1+
- & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
- ENDIF
- IF(MINT(72).EQ.3) THEN
- TAUR3=VINT(77)
- GAMR3=VINT(78)
- ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
- ATAU50=ATAUD/TAUR3
- IF(ATAUD.GT.1D-10) H1=H1+
- & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
- ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
- ATAU60=ATAUD/GAMR3
- IF(ATAUD.GT.1D-10) H1=H1+
- & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
- ENDIF
- IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
- ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
- IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
- & MAX(2D-10,1D0-TAU)
- ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
- ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
- IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
- & MAX(1D-10,1D0-TAU)
- ENDIF
- COMFAC=COMFAC*ATAU1/(TAU*H1)
- ENDIF
-
-C...Phase space integral in y*
- IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
- &THEN
- AYST0=YSTMAX-YSTMIN
- IF(AYST0.LT.1D-10) THEN
- COMFAC=0D0
- ELSE
- AYST1=0.5D0*(YSTMAX-YSTMIN)**2
- AYST2=AYST1
- AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
- H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
- & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
- & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
- IF(MINT(45).EQ.3) THEN
- YST0=-0.5D0*LOG(TAUE)
- AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
- & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
- IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
- & MAX(1D-10,1D0-EXP(YST-YST0))
- ENDIF
- IF(MINT(46).EQ.3) THEN
- YST0=-0.5D0*LOG(TAUE)
- AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
- & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
- IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
- & MAX(1D-10,1D0-EXP(-YST-YST0))
- ENDIF
- COMFAC=COMFAC*AYST0/H2
- ENDIF
- ENDIF
-
-C...2 -> 1 processes: reduction in angular part of phase space integral
-C...for case of decaying resonance
- ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
- IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
- IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
- IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
- & KFPR(ISUB,1).EQ.39) THEN
- COMFAC=COMFAC*0.5D0*ACTH0
- ELSE
- COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
- & CTPMAX**3-CTPMIN**3)
- ENDIF
- ENDIF
-
-C...2 -> 2 processes: angular part of phase space integral
- ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
- ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
- & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
- ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
- & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
- ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
- & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
- ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
- & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
- H3=COEF(ISUBSV,13)+
- & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
- & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
- & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
- & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
- COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
-
-C...2 -> 2 processes: take into account final state Breit-Wigners
- COMFAC=COMFAC*VINT(80)
- ENDIF
-
-C...2 -> 3, 4 processes: phace space integral in tau'
- IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
- ATAUP1=LOG(TAUPMX/TAUPMN)
- ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
- H4=COEF(ISUBSV,18)+
- & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
- IF(MINT(47).EQ.5) THEN
- ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
- H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
- ELSEIF(MINT(47).GE.6) THEN
- ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
- H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
- ENDIF
- COMFAC=COMFAC*ATAUP1/H4
- ENDIF
-
-C...2 -> 3, 4 processes: effective W/Z parton distributions
- IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
- IF(1D0-TAU/TAUP.GT.1D-4) THEN
- FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
- ELSE
- FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
- ENDIF
- COMFAC=COMFAC*FZW
- ENDIF
-
-C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
- IF(ISTSB.EQ.5) THEN
- COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
- & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
- ENDIF
-
-C...Phase space integral for low-pT and multiple interactions
- IF(ISTSB.EQ.9) THEN
- COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
- ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
- ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
- H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
- COMFAC=COMFAC*ATAU1/H1
- AYST0=YSTMAX-YSTMIN
- AYST1=0.5D0*(YSTMAX-YSTMIN)**2
- AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
- H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
- & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
- & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
- COMFAC=COMFAC*AYST0/H2
- IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
-C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
-C...introduced to make cross-section finite for xT2 -> 0
- IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
- & (1D0+VINT(149)))
- ENDIF
-
-C...Real gamma + gamma: include factor 2 when different nature
- 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
- &MSTP(14).LE.10) COMFAC=2D0*COMFAC
-
-C...Extra factors to include the effects of
-C...longitudinal resolved photons (but not direct or DIS ones).
- DO 170 ISDE=1,2
- IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
- & MINT(106+ISDE).LE.3) THEN
- VINT(314+ISDE)=1D0
- XY=PARP(166+ISDE)
- IF(MSTP(16).EQ.0) THEN
- IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
- & XY=VINT(304+ISDE)
- ELSE
- IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
- & XY=VINT(308+ISDE)
- ENDIF
- Q2GA=VINT(306+ISDE)
- IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
- & Q2GA.GT.0D0) THEN
- REDUCE=0D0
- IF(MSTP(17).EQ.1) THEN
- REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
- ELSEIF(MSTP(17).EQ.2) THEN
- REDUCE=4D0*Q2GA/(Q2+Q2GA)
- ELSEIF(MSTP(17).EQ.3) THEN
- PMVIRT=PMAS(PYCOMP(113),1)
- REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
- ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
- PMVIRT=PMAS(PYCOMP(113),1)
- REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
- ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
- PMVIRT=PMAS(PYCOMP(113),1)
- REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
- ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
- PMVSMN=4D0*PARP(15)**2
- PMVSMX=4D0*VINT(154)**2
- REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
- REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
- & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
- REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
- ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
- PMVIRT=PMAS(PYCOMP(113),1)
- REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
- ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
- PMVIRT=PMAS(PYCOMP(113),1)
- REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
- ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
- PMVSMN=4D0*PARP(15)**2
- PMVSMX=4D0*VINT(154)**2
- REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
- REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
- REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
- ENDIF
- BEAMAS=PYMASS(11)
- IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
- FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
- & (1D0-2D0*BEAMAS**2/Q2GA))
- VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
- ENDIF
- ELSE
- VINT(314+ISDE)=1D0
- ENDIF
- COMFAC=COMFAC*VINT(314+ISDE)
- 170 CONTINUE
-
-C...Evaluate cross sections - done in separate routines by kind
-C...of physics, to keep PYSIGH of sensible size.
- IF(MAP.EQ.1) THEN
-C...Standard QCD (including photons).
- CALL PYSGQC(NCHN,SIGS)
- ELSEIF(MAP.EQ.2) THEN
-C...Heavy flavours.
- CALL PYSGHF(NCHN,SIGS)
- ELSEIF(MAP.EQ.3) THEN
-C...W/Z.
- CALL PYSGWZ(NCHN,SIGS)
- ELSEIF(MAP.EQ.4) THEN
-C...Higgs (2 doublets; including longitudinal W/Z scattering).
- CALL PYSGHG(NCHN,SIGS)
- ELSEIF(MAP.EQ.5) THEN
-C...SUSY.
- CALL PYSGSU(NCHN,SIGS)
- ELSEIF(MAP.EQ.6) THEN
-C...Technicolor.
- CALL PYSGTC(NCHN,SIGS)
- ELSEIF(MAP.EQ.7) THEN
-C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
- CALL PYSGEX(NCHN,SIGS)
- ENDIF
-
-C...Multiply with parton distributions
- IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
- DO 180 ICHN=1,NCHN
- IF(MINT(45).GE.2) THEN
- KFL1=ISIG(ICHN,1)
- SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
- ENDIF
- IF(MINT(46).GE.2) THEN
- KFL2=ISIG(ICHN,2)
- SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
- ENDIF
- SIGS=SIGS+SIGH(ICHN)
- 180 CONTINUE
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSGQC
-C...Subprocess cross sections for QCD processes,
-C...including photons.
-C...Auxiliary to PYSIGH.
-
- SUBROUTINE PYSGQC(NCHN,SIGS)
-
-C...Double precision and integer declarations
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
- COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
- &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
- &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
- &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
- &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
-C...Local arrays
- DIMENSION WDTP(0:400),WDTE(0:400,0:5)
-
-C...Differential cross section expressions.
-
- IF(ISUB.LE.20) THEN
- IF(ISUB.EQ.10) THEN
-C...f + f' -> f + f' (gamma/Z/W exchange)
- FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
- FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
- FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
- FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
- DO 110 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
- IA=IABS(I)
- DO 100 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
- JA=IABS(J)
-C...Electroweak couplings
- EI=KCHG(IA,1)*ISIGN(1,I)/3D0
- AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
- VI=AI-4D0*EI*XWV
- EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
- AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
- VJ=AJ-4D0*EJ*XWV
- EPSIJ=ISIGN(1,I*J)
-C...gamma/Z exchange, only gamma exchange, or only Z exchange
- IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
- IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
- FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
- & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
- & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
- & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
- ELSEIF(MSTP(21).EQ.2) THEN
- FACNCF=FACGGF*EI**2*EJ**2
- ELSE
- FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
- & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
- ENDIF
-C...Extrafactor 2 for only one incoming neutrino spin state.
- IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
- IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACNCF
- ENDIF
-C...W exchange
- IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
- FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
- IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
- IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
- IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACCCF
- ENDIF
- 100 CONTINUE
- 110 CONTINUE
-
- ELSEIF(ISUB.EQ.11) THEN
-C...f + f' -> f + f' (g exchange)
- FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
- FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
- & MSTP(34)*2D0/3D0*UH2/(SH*TH))
- FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
- & MSTP(34)*2D0/3D0*SH2/(TH*UH))
- DO 130 I=MMIN1,MMAX1
- IA=IABS(I)
- IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
- DO 120 J=MMIN2,MMAX2
- JA=IABS(J)
- IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ1
- IF(I.EQ.-J) SIGH(NCHN)=FACQQB
- IF(I.EQ.J) THEN
- SIGH(NCHN)=0.5D0*SIGH(NCHN)
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=2
- SIGH(NCHN)=0.5D0*FACQQ2
- ENDIF
- 120 CONTINUE
- 130 CONTINUE
-
- ELSEIF(ISUB.EQ.12) THEN
-C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
- CALL PYWIDT(21,SH,WDTP,WDTE)
- FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
- & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- DO 140 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQB
- 140 CONTINUE
-
- ELSEIF(ISUB.EQ.13) THEN
-C...f + fbar -> g + g (q + qbar -> g + g only)
- FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
- & UH2/SH2)
- FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
- & TH2/SH2)
- DO 150 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=0.5D0*FACGG1
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=2
- SIGH(NCHN)=0.5D0*FACGG2
- 150 CONTINUE
-
- ELSEIF(ISUB.EQ.14) THEN
-C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
- FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
- DO 160 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
- EI=KCHG(IABS(I),1)/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACGG*EI**2
- 160 CONTINUE
-
- ELSEIF(ISUB.EQ.18) THEN
-C...f + fbar -> gamma + gamma
- FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
- DO 170 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
- EI=KCHG(IABS(I),1)/3D0
- FCOI=1D0
- IF(IABS(I).LE.10) FCOI=FACA/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
- 170 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.40) THEN
- IF(ISUB.EQ.28) THEN
-C...f + g -> f + g (q + g -> q + g only)
- FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
- & UH/SH)*FACA
- FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
- & SH/UH)
- DO 190 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
- DO 180 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQG1
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQG2
- 180 CONTINUE
- 190 CONTINUE
-
- ELSEIF(ISUB.EQ.29) THEN
-C...f + g -> f + gamma (q + g -> q + gamma only)
- FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
- DO 210 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
- EI=KCHG(IABS(I),1)/3D0
- FACGQ=FGQ*EI**2
- DO 200 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACGQ
- 200 CONTINUE
- 210 CONTINUE
-
- ELSEIF(ISUB.EQ.33) THEN
-C...f + gamma -> f + g (q + gamma -> q + g only)
- FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
- DO 230 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
- EI=KCHG(IABS(I),1)/3D0
- FACGQ=FGQ*EI**2
- DO 220 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
- IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACGQ
- 220 CONTINUE
- 230 CONTINUE
-
- ELSEIF(ISUB.EQ.34) THEN
-C...f + gamma -> f + gamma
- FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
- DO 250 I=MMINA,MMAXA
- IF(I.EQ.0) GOTO 250
- EI=KCHG(IABS(I),1)/3D0
- FACGQ=FGQ*EI**4
- DO 240 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
- IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACGQ
- 240 CONTINUE
- 250 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.80) THEN
- IF(ISUB.EQ.53) THEN
-C...g + g -> f + fbar (g + g -> q + qbar only)
- IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
- IDC0=MDCY(21,2)-1
-C...Begin by d, u, s flavours.
- FLAVWT=0D0
- IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
- & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
- IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
- & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
- IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
- & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
- FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
- & UH2/SH2)*FLAVWT*FACA
- FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
- & TH2/SH2)*FLAVWT*FACA
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ1
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQQ2
-C...Next c and b flavours: modified that and uhat for fixed
-C...cos(theta-hat).
- DO 260 IFL=4,5
- SQMAVG=PMAS(IFL,1)**2
- IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
- BE34=SQRT(1D0-4D0*SQMAVG/SH)
- THQ=-0.5D0*SH*(1D0-BE34*CTH)
- UHQ=-0.5D0*SH*(1D0+BE34*CTH)
- THUHQ=THQ*UHQ-SQMAVG*SH
- IF(MSTP(34).EQ.0) THEN
- FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
- FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
- ELSE
- FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
- & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
- FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
- & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
- ENDIF
- FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
- FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1+2*(IFL-3)
- SIGH(NCHN)=FACQQ1
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=2+2*(IFL-3)
- SIGH(NCHN)=FACQQ2
- ENDIF
- 260 CONTINUE
- 270 CONTINUE
-
- ELSEIF(ISUB.EQ.54) THEN
-C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
- CALL PYWIDT(21,SH,WDTP,WDTE)
- WDTESU=0D0
- DO 280 I=1,MIN(8,MDCY(21,3))
- EF=KCHG(I,1)/3D0
- WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
- & WDTE(I,4))
- 280 CONTINUE
- FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
- IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ
- ENDIF
- IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=22
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ
- ENDIF
-
- ELSEIF(ISUB.EQ.58) THEN
-C...gamma + gamma -> f + fbar
- CALL PYWIDT(22,SH,WDTP,WDTE)
- WDTESU=0D0
- DO 290 I=1,MIN(12,MDCY(22,3))
- IF(I.LE.8) EF= KCHG(I,1)/3D0
- IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
- WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
- & WDTE(I,4))
- 290 CONTINUE
- FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
- IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=22
- ISIG(NCHN,2)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACFF
- ENDIF
-
- ELSEIF(ISUB.EQ.68) THEN
-C...g + g -> g + g
- IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
- FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
- & TH2/SH2)*FACA
- FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
- & SH2/UH2)*FACA
- FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
- & UH2/TH2)
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=0.5D0*FACGG1
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=0.5D0*FACGG2
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=3
- SIGH(NCHN)=0.5D0*FACGG3
- 300 CONTINUE
-
- ELSEIF(ISUB.EQ.80) THEN
-C...q + gamma -> q' + pi+/-
- FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
- ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
- Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
- DELSH=UH*SQRT(ASSH*Q2FPSH)
- ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
- Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
- DELUH=SH*SQRT(ASUH*Q2FPUH)
- DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
- IF(I.EQ.0) GOTO 320
- EI=KCHG(IABS(I),1)/3D0
- EJ=SIGN(1D0-ABS(EI),EI)
- DO 310 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
- IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
- 310 CONTINUE
- 320 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.100) THEN
- IF(ISUB.EQ.91) THEN
-C...Elastic scattering
- SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
-
- ELSEIF(ISUB.EQ.92) THEN
-C...Single diffractive scattering (first side, i.e. XB)
- SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
-
- ELSEIF(ISUB.EQ.93) THEN
-C...Single diffractive scattering (second side, i.e. AX)
- SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
-
- ELSEIF(ISUB.EQ.94) THEN
-C...Double diffractive scattering
- SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
-
- ELSEIF(ISUB.EQ.95) THEN
-C...Low-pT scattering
- SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
-
- ELSEIF(ISUB.EQ.96) THEN
-C...Multiple interactions: sum of QCD processes
- CALL PYWIDT(21,SH,WDTP,WDTE)
-
-C...q + q' -> q + q'
- FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
- FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
- & MSTP(34)*2D0/3D0*UH2/(SH*TH))
- FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
- FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
- RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
- DO 340 I=-5,5
- IF(I.EQ.0) GOTO 340
- DO 330 J=-5,5
- IF(J.EQ.0) GOTO 330
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=111
- SIGH(NCHN)=FACQQ1
- IF(I.EQ.-J) SIGH(NCHN)=FACQQB
- IF(I.EQ.J) THEN
- SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=112
- SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
- ENDIF
- 330 CONTINUE
- 340 CONTINUE
-
-C...q + qbar -> q' + qbar' or g + g
- FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
- & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
- FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
- & UH2/SH2)
- FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
- & TH2/SH2)
- DO 350 I=-5,5
- IF(I.EQ.0) GOTO 350
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=121
- SIGH(NCHN)=FACQQB
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=131
- SIGH(NCHN)=0.5D0*FACGG1
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=132
- SIGH(NCHN)=0.5D0*FACGG2
- 350 CONTINUE
-
-C...q + g -> q + g
- FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
- & UH/SH)*FACA
- FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
- & SH/UH)
- DO 370 I=-5,5
- IF(I.EQ.0) GOTO 370
- DO 360 ISDE=1,2
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=281
- SIGH(NCHN)=FACQG1
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=282
- SIGH(NCHN)=FACQG2
- 360 CONTINUE
- 370 CONTINUE
-
-C...g + g -> q + qbar (only d, u, s)
- IDC0=MDCY(21,2)-1
- FLAVWT=0D0
- IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
- & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
- IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
- & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
- IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
- & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
- FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
- & UH2/SH2)*FLAVWT*FACA
- FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
- & TH2/SH2)*FLAVWT*FACA
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=531
- SIGH(NCHN)=FACQQ1
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=532
- SIGH(NCHN)=FACQQ2
-
-C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
-C...cos(theta-hat)
- DO 380 IFL=4,5
- SQMAVG=PMAS(IFL,1)**2
- IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
- BE34=SQRT(1D0-4D0*SQMAVG/SH)
- THQ=-0.5D0*SH*(1D0-BE34*CTH)
- UHQ=-0.5D0*SH*(1D0+BE34*CTH)
- THUHQ=THQ*UHQ-SQMAVG*SH
- IF(MSTP(34).EQ.0) THEN
- FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
- FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
- ELSE
- FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
- & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
- FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
- & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
- ENDIF
- FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
- FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=531+2*(IFL-3)
- SIGH(NCHN)=FACQQ1
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=532+2*(IFL-3)
- SIGH(NCHN)=FACQQ2
- ENDIF
- 380 CONTINUE
-
-C...g + g -> g + g
- FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
- & 2D0*TH/SH+TH2/SH2)*FACA
- FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
- & 2D0*SH/UH+SH2/UH2)*FACA
- FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
- & 2D0*UH/TH+UH2/TH2)
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=681
- SIGH(NCHN)=0.5D0*FACGG1
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=682
- SIGH(NCHN)=0.5D0*FACGG2
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=683
- SIGH(NCHN)=0.5D0*FACGG3
-
- ELSEIF(ISUB.EQ.99) THEN
-C...f + gamma* -> f.
- IF(MINT(107).EQ.4) THEN
- Q2GA=VINT(307)
- P2GA=VINT(308)
- ISDE=2
- ELSE
- Q2GA=VINT(308)
- P2GA=VINT(307)
- ISDE=1
- ENDIF
- COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
- PM2RHO=PMAS(PYCOMP(113),1)**2
- IF(MSTP(19).EQ.0) THEN
- COMFAC=COMFAC/Q2GA
- ELSEIF(MSTP(19).EQ.1) THEN
- COMFAC=COMFAC/(Q2GA+PM2RHO)
- ELSEIF(MSTP(19).EQ.2) THEN
- COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
- ELSE
- COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
- W2GA=VINT(2)
- IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
- RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
- & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
- XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
- ELSE
- RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
- & Q2GA**0.57D0)
- XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
- ENDIF
- COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
- IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
- ENDIF
- DO 390 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
- IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
- EI=KCHG(IABS(I),1)/3D0
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=COMFAC*EI**2
- 390 CONTINUE
- ENDIF
-
- ELSE
- IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
-C...g + g -> gamma + gamma or g + g -> g + gamma
- A0STUR=0D0
- A0STUI=0D0
- A0TSUR=0D0
- A0TSUI=0D0
- A0UTSR=0D0
- A0UTSI=0D0
- A1STUR=0D0
- A1STUI=0D0
- A2STUR=0D0
- A2STUI=0D0
- ALST=LOG(-SH/TH)
- ALSU=LOG(-SH/UH)
- ALTU=LOG(TH/UH)
- IMAX=2*MSTP(1)
- IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
- DO 400 I=1,IMAX
- EI=KCHG(IABS(I),1)/3D0
- EIWT=EI**2
- IF(ISUB.EQ.115) EIWT=EI
- SQMQ=PMAS(I,1)**2
- EPSS=4D0*SQMQ/SH
- EPST=4D0*SQMQ/TH
- EPSU=4D0*SQMQ/UH
- IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
- B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
- & PARU(1)**2)
- B0STUI=0D0
- B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
- B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
- B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
- B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
- B1STUR=-1D0
- B1STUI=0D0
- B2STUR=-1D0
- B2STUI=0D0
- ELSE
- CALL PYWAUX(1,EPSS,W1SR,W1SI)
- CALL PYWAUX(1,EPST,W1TR,W1TI)
- CALL PYWAUX(1,EPSU,W1UR,W1UI)
- CALL PYWAUX(2,EPSS,W2SR,W2SI)
- CALL PYWAUX(2,EPST,W2TR,W2TI)
- CALL PYWAUX(2,EPSU,W2UR,W2UI)
- CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
- CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
- CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
- CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
- CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
- CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
- B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
- & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
- & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
- & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
- & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
- & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
- B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
- & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
- & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
- & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
- & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
- & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
- B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
- & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
- & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
- & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
- & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
- & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
- B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
- & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
- & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
- & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
- & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
- & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
- B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
- & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
- & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
- & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
- & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
- & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
- B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
- & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
- & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
- & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
- & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
- & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
- B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
- & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
- & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
- & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
- B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
- & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
- & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
- & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
- B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
- & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
- & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
- B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
- & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
- & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
- ENDIF
- A0STUR=A0STUR+EIWT*B0STUR
- A0STUI=A0STUI+EIWT*B0STUI
- A0TSUR=A0TSUR+EIWT*B0TSUR
- A0TSUI=A0TSUI+EIWT*B0TSUI
- A0UTSR=A0UTSR+EIWT*B0UTSR
- A0UTSI=A0UTSI+EIWT*B0UTSI
- A1STUR=A1STUR+EIWT*B1STUR
- A1STUI=A1STUI+EIWT*B1STUI
- A2STUR=A2STUR+EIWT*B2STUR
- A2STUI=A2STUI+EIWT*B2STUI
- 400 CONTINUE
- ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
- & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
- FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
- FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
- IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
- IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
- 410 CONTINUE
-
- ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
-C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
- PH=0D0
- IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
- & PH=VINT(3)**2
- IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
- & PH=VINT(4)**2
- IF(ISUB.EQ.131) THEN
- FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
- & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
- ELSE
- FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
- ENDIF
- DO 430 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
- EI=KCHG(IABS(I),1)/3D0
- FACGQ=FGQ*EI**2
- DO 420 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
- IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACGQ
- 420 CONTINUE
- 430 CONTINUE
-
- ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
-C...f + gamma*_(T,L) -> f + gamma
- PH=0D0
- IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
- & PH=VINT(3)**2
- IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
- & PH=VINT(4)**2
- IF(ISUB.EQ.133) THEN
- FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
- & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
- ELSE
- FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
- ENDIF
- DO 450 I=MMINA,MMAXA
- IF(I.EQ.0) GOTO 450
- EI=KCHG(IABS(I),1)/3D0
- FACGQ=FGQ*EI**4
- DO 440 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
- IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACGQ
- 440 CONTINUE
- 450 CONTINUE
-
- ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
-C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
- PH=0D0
- IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
- & PH=VINT(3)**2
- IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
- & PH=VINT(4)**2
- CALL PYWIDT(21,SH,WDTP,WDTE)
- WDTESU=0D0
- DO 460 I=1,MIN(8,MDCY(21,3))
- EF=KCHG(I,1)/3D0
- WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
- & WDTE(I,4))
- 460 CONTINUE
- IF(ISUB.EQ.135) THEN
- FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
- & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
- ELSE
- FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
- ENDIF
- IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ
- ENDIF
- IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=22
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ
- ENDIF
-
- ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
-C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
- PH1=0D0
- IF(VINT(3).LT.0D0) PH1=VINT(3)**2
- PH2=0D0
- IF(VINT(4).LT.0D0) PH2=VINT(4)**2
- CALL PYWIDT(22,SH,WDTP,WDTE)
- WDTESU=0D0
- DO 470 I=1,MIN(12,MDCY(22,3))
- IF(I.LE.8) EF= KCHG(I,1)/3D0
- IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
- WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
- & WDTE(I,4))
- 470 CONTINUE
- DLAMB2=(TH+UH)**2-4D0*PH1*PH2
- IF(ISUB.EQ.137) THEN
- FPARAM=-SH*(TH+UH)/DLAMB2
- FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
- & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
- & 2D0*PH1*PH2*FPARAM**2)
- ELSEIF(ISUB.EQ.138) THEN
- FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
- & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
- & 2D0*PH1**2*(TH-UH)**2)
- ELSEIF(ISUB.EQ.139) THEN
- FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
- & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
- & 2D0*PH2**2*(TH-UH)**2)
- ELSE
- FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
- & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
- ENDIF
- IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=22
- ISIG(NCHN,2)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACFF
- ENDIF
-
- ENDIF
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSGHF
-C...Subprocess cross sections for heavy flavour production,
-C...open and closed.
-C...Auxiliary to PYSIGH.
-
- SUBROUTINE PYSGHF(NCHN,SIGS)
-
-C...Double precision and integer declarations
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
- &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
- &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
- &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
- SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
- &/PYINT4/,/PYSGCM/
-C...Local arrays
- DIMENSION WDTP(0:400),WDTE(0:400,0:5)
-
-C...Determine where are charmonium/bottomonium wave function parameters.
- IONIUM=140
- IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
-
-C...Convert bottomonium process into equivalent charmonium ones.
- IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
-
-C...Differential cross section expressions.
-
- IF(ISUB.LE.100) THEN
- IF(ISUB.EQ.81) THEN
-C...q + qbar -> Q + Qbar
- SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
- THQ=-0.5D0*SH*(1D0-BE34*CTH)
- UHQ=-0.5D0*SH*(1D0+BE34*CTH)
- FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
- & 2D0*SQMAVG/SH)
- IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
- WID2=1D0
- IF(MINT(55).EQ.6) WID2=WIDS(6,1)
- IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
- FACQQB=FACQQB*WID2
- DO 100 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQB
- 100 CONTINUE
-
- ELSEIF(ISUB.EQ.82) THEN
-C...g + g -> Q + Qbar
- SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
- THQ=-0.5D0*SH*(1D0-BE34*CTH)
- UHQ=-0.5D0*SH*(1D0+BE34*CTH)
- THUHQ=THQ*UHQ-SQMAVG*SH
- IF(MSTP(34).EQ.0) THEN
- FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
- FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
- ELSE
- FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
- & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
- FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
- & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
- ENDIF
- FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
- FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
- IF(MSTP(35).GE.1) THEN
- FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
- FACQQ1=FACQQ1*FATRE
- FACQQ2=FACQQ2*FATRE
- ENDIF
- WID2=1D0
- IF(MINT(55).EQ.6) WID2=WIDS(6,1)
- IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
- FACQQ1=FACQQ1*WID2
- FACQQ2=FACQQ2*WID2
- IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ1
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQQ2
- 110 CONTINUE
-
- ELSEIF(ISUB.EQ.83) THEN
-C...f + q -> f' + Q
- FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
- FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
- DO 130 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
- DO 120 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
- IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
- IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
- IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
- & THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
- & (IABS(I)+1)/2)*VINT(180+J)
- IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
- & (MINT(55)+1)/2)*VINT(180+J)
- WID2=1D0
- IF(I.GT.0) THEN
- IF(MINT(55).EQ.6) WID2=WIDS(6,2)
- IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
- & WIDS(MINT(55),2)
- ELSE
- IF(MINT(55).EQ.6) WID2=WIDS(6,3)
- IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
- & WIDS(MINT(55),3)
- ENDIF
- IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
- IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
- ENDIF
- IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
- & THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=2
- IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
- & (IABS(J)+1)/2)*VINT(180+I)
- IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
- & (MINT(55)+1)/2)*VINT(180+I)
- IF(J.GT.0) THEN
- IF(MINT(55).EQ.6) WID2=WIDS(6,2)
- IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
- & WIDS(MINT(55),2)
- ELSE
- IF(MINT(55).EQ.6) WID2=WIDS(6,3)
- IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
- & WIDS(MINT(55),3)
- ENDIF
- IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
- IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
- ENDIF
- 120 CONTINUE
- 130 CONTINUE
-
- ELSEIF(ISUB.EQ.84) THEN
-C...g + gamma -> Q + Qbar
- SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
- THQ=-0.5D0*SH*(1D0-BE34*CTH)
- UHQ=-0.5D0*SH*(1D0+BE34*CTH)
- FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
- & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
- & (THQ*UHQ)
- IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
- WID2=1D0
- IF(MINT(55).EQ.6) WID2=WIDS(6,1)
- IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
- FACQQ=FACQQ*WID2
- IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ
- ENDIF
- IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=22
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ
- ENDIF
-
- ELSEIF(ISUB.EQ.85) THEN
-C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
- SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
- THQ=-0.5D0*SH*(1D0-BE34*CTH)
- UHQ=-0.5D0*SH*(1D0+BE34*CTH)
- FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
- & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
- & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
- & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
- IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
- IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
- & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
- WID2=1D0
- IF(MINT(56).EQ.6) WID2=WIDS(6,1)
- IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
- IF(MINT(56).EQ.17) WID2=WIDS(17,1)
- FACFF=FACFF*WID2
- IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=22
- ISIG(NCHN,2)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACFF
- ENDIF
-
- ELSEIF(ISUB.EQ.86) THEN
-C...g + g -> J/Psi + g
- FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
- & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
- & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
- IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG
- ENDIF
-
- ELSEIF(ISUB.EQ.87) THEN
-C...g + g -> chi_0c + g
- PGTW=(SH*TH+TH*UH+UH*SH)/SH2
- QGTW=(SH*TH*UH)/SH**3
- RGTW=SQM3/SH
- FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
- & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
- & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
- & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
- & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
- & (QGTW*(QGTW-RGTW*PGTW)**4)
- IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG
- ENDIF
-
- ELSEIF(ISUB.EQ.88) THEN
-C...g + g -> chi_1c + g
- PGTW=(SH*TH+TH*UH+UH*SH)/SH2
- QGTW=(SH*TH*UH)/SH**3
- RGTW=SQM3/SH
- FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
- & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
- & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
- & (QGTW-RGTW*PGTW)**4
- IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG
- ENDIF
-
- ELSEIF(ISUB.EQ.89) THEN
-C...g + g -> chi_2c + g
- PGTW=(SH*TH+TH*UH+UH*SH)/SH2
- QGTW=(SH*TH*UH)/SH**3
- RGTW=SQM3/SH
- FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
- & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
- & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
- & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
- & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
- & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
- IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG
- ENDIF
- ENDIF
-
- ELSEIF(ISUB.LE.200) THEN
- IF(ISUB.EQ.104) THEN
-C...g + g -> chi_c0.
- KC=PYCOMP(10441)
- FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
- & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
- IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
- IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACBW
- ENDIF
-
- ELSEIF(ISUB.EQ.105) THEN
-C...g + g -> chi_c2.
- KC=PYCOMP(445)
- FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
- & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
- IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
- IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACBW
- ENDIF
-
- ELSEIF(ISUB.EQ.106) THEN
-C...g + g -> J/Psi + gamma.
- EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
- FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
- & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
- & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
- IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG
- ENDIF
-
- ELSEIF(ISUB.EQ.107) THEN
-C...g + gamma -> J/Psi + g.
- EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
- FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
- & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
- & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
- IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG
- ENDIF
- IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=22
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG
- ENDIF
-
- ELSEIF(ISUB.EQ.108) THEN
-C...gamma + gamma -> J/Psi + gamma.
- EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
- FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
- & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
- & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
- IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=22
- ISIG(NCHN,2)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG
- ENDIF
- ENDIF
-
-C...QUARKONIA+++
-C...Additional code by Stefan Wolf
- ELSE
-
-C...Common code for quarkonium production.
- SHTH=SH+TH
- THUH=TH+UH
- UHSH=UH+SH
- SHTH2=SHTH**2
- THUH2=THUH**2
- UHSH2=UHSH**2
- IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
- & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
- SQMQQ=SQM3
- ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
- & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
- SQMQQ=SQM4
- ENDIF
- SQMQQR=SQRT(SQMQQ)
- IF(MSTP(145).EQ.1) THEN
- IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
- & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
- AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
- BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
- ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
- ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
- BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
- BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
- ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
- & ISUB.GE.437) THEN
- AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
- BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
- ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
- ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
- BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
- BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
- ENDIF
- AQ2=AQ**2
- BQ2=BQ**2
- SMQQ2=SQMQQ*VINT(2)
-C...Polarisation frames
- IF(MSTP(146).EQ.1) THEN
-C...Recoil frame
- POLH1=SQRT(AQ2-SMQQ2)
- POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
- AZ=-SQMQQR/POLH1
- BZ=0D0
- AX=AQ*BQ/(POLH1*POLH2)
- BX=-POLH1/POLH2
- ELSEIF(MSTP(146).EQ.2) THEN
-C...Gottfried Jackson frame
- POLH1=AQ+BQ
- POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
- AZ=SQMQQR/POLH1
- BZ=AZ
- AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
- BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
- ELSEIF(MSTP(146).EQ.3) THEN
-C...Target frame
- POLH1=AQ-BQ
- POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
- AZ=-SQMQQR/POLH1
- BZ=-AZ
- AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
- BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
- ELSEIF(MSTP(146).EQ.4) THEN
-C...Collins Soper frame
- POLH1=AQ2-BQ2
- POLH2=SQRT(VINT(2)*POLH1)
- AZ=-BQ/POLH2
- BZ=AQ/POLH2
- AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
- BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
- ENDIF
-C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
- EL1K10=AZ*ATILK1+BZ*BTILK1
- EL1K20=AZ*ATILK2+BZ*BTILK2
- EL2K10=EL1K10
- EL2K20=EL1K20
- EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
- EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
- EL2K11=EL1K11
- EL2K21=EL1K21
- ENDIF
-
- IF(ISUB.EQ.421) THEN
-C...g + g -> QQ~[3S11] + g
- IF(MSTP(145).EQ.0) THEN
-* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
-* & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
- FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
- & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
-* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
-* & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
- ELSE
- FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
- AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
- BB=2D0*(SH2+TH2)
- CC=2D0*(SH2+UH2)
- DD=2D0*SH2
- IF(MSTP(147).EQ.0) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
- & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
- ELSEIF(MSTP(147).EQ.3) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
- & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
- ELSEIF(MSTP(147).EQ.4) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
- ELSEIF(MSTP(147).EQ.5) THEN
- FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
- & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
- ELSEIF(MSTP(147).EQ.6) THEN
- FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
- ENDIF
- FACQQG=COMFAC*FF*FACQQG
- ENDIF
- IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
- ENDIF
-
- ELSEIF(ISUB.EQ.422) THEN
-C...g + g -> QQ~[3S18] + g
- IF(MSTP(145).EQ.0) THEN
- FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
- & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
- & (SQMQQ*SQMQQR)*
- & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
- ELSE
- FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
- & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
- AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
- BB=2D0*(SH2+TH2)
- CC=2D0*(SH2+UH2)
- DD=2D0*SH2
- IF(MSTP(147).EQ.0) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
- & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
- ELSEIF(MSTP(147).EQ.3) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
- & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
- ELSEIF(MSTP(147).EQ.4) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
- ELSEIF(MSTP(147).EQ.5) THEN
- FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
- & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
- ELSEIF(MSTP(147).EQ.6) THEN
- FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
- ENDIF
- FACQQG=COMFAC*FF*FACQQG
- ENDIF
-C...Split total contribution into different colour flows just like
-C...in g g -> g g (recalculate kinematics for massless partons).
- THP=-0.5D0*SH*(1D0-CTH)
- UHP=-0.5D0*SH*(1D0+CTH)
- FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
- FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
- FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
- FACGGS=FACGG1+FACGG2+FACGG3
- IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=3
- SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
- ENDIF
-
- ELSEIF(ISUB.EQ.423) THEN
-C...g + g -> QQ~[1S08] + g
- IF(MSTP(145).EQ.0) THEN
-* FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
-* & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
-* & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
-* & (SHTH2*THUH2*UHSH2)
- FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
- & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
- & TH2/(SHTH2*THUH2))*
- & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
- ELSE
- FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
- & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
- & TH2/(SHTH2*THUH2))*
- & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
- IF(MSTP(147).EQ.0) THEN
- FACQQG=COMFAC*FA
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=COMFAC*2D0*FA
- ELSEIF(MSTP(147).EQ.3) THEN
- FACQQG=COMFAC*FA
- ELSEIF(MSTP(147).EQ.4) THEN
- FACQQG=COMFAC*FA
- ELSEIF(MSTP(147).EQ.5) THEN
- FACQQG=0D0
- ELSEIF(MSTP(147).EQ.6) THEN
- FACQQG=0D0
- ENDIF
- ENDIF
-C...Split total contribution into different colour flows just like
-C...in g g -> g g (recalculate kinematics for massless partons).
- THP=-0.5D0*SH*(1D0-CTH)
- UHP=-0.5D0*SH*(1D0+CTH)
- FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
- FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
- FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
- FACGGS=FACGG1+FACGG2+FACGG3
- IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=3
- SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
- ENDIF
-
- ELSEIF(ISUB.EQ.424) THEN
-C...g + g -> QQ~[3PJ8] + g
- POLY=SH2+SH*TH+TH2
- IF(MSTP(145).EQ.0) THEN
- FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
- & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
- & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
- & +7D0*TH**6)
- & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
- & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
- & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
- & +35D0*TH**8)
- & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
- & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
- & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
- & +84D0*TH**8)
- & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
- & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
- & +451D0*SH*TH**5+126D0*TH**6)
- & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
- & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
- & +171D0*SH*TH**5+42D0*TH**6)
- & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
- & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
- & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
- & +99D0*SH*TH**3+35D0*TH**4)
- & +7D0*SQMQQ**8*SHTH*POLY)/
- & (SH*TH*UH*SQMQQR*SQMQQ*
- & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
- ELSE
- FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
- & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
- AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
- & -SQMQQ*SHTH2*POLY**2*
- & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
- & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
- & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
- & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
- & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
- & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
- & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
- & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
- & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
- & +145D0*SH*TH**5+34D0*TH**6)
- & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
- & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
- & +44D0*TH**6)
- & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
- & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
- & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
- & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
- & +3D0*SQMQQ**8*SHTH*POLY)
- BB=4D0*SHTH2*POLY**3
- & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
- & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
- & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
- & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
- & +84D0*SH*TH**9+20D0*TH**10)
- & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
- & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
- & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
- & +40D0*TH**8)
- & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
- & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
- & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
- & +40D0*TH**8)
- & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
- & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
- & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
- & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
- & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
- & +4D0*TH**6)
- & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
- & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
- & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
- CC=4D0*TH2*POLY**3
- & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
- & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
- & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
- & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
- & +28D0*TH**9)
- & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
- & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
- & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
- & +394D0*SH*TH**9+84D0*TH**10)
- & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
- & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
- & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
- & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
- & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
- & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
- & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
- & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
- & +266D0*SH*TH**6+84D0*TH**7)
- & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
- & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
- & +28D0*TH**6)
- & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
- & +7D0*SH*TH**3+4*TH**4)
- & +SQMQQ**8*SH*(SH-TH)**2*TH
- DD=2D0*TH2*SHTH2*POLY**3
- & *(-SH2+2*SH*TH+2*TH2)
- & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
- & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
- & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
- & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
- & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
- & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
- & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
- & -210D0*SH*TH**8-60D0*TH**9)
- & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
- & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
- & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
- & -80D0*TH**8)
- & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
- & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
- & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
- & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
- & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
- & -30D0*SH*TH**6-24D0*TH**7)
- & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
- & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
- & -4D0*TH**6)
- & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
- IF(MSTP(147).EQ.0) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
- & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
- ELSEIF(MSTP(147).EQ.3) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
- & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
- ELSEIF(MSTP(147).EQ.4) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
- ELSEIF(MSTP(147).EQ.5) THEN
- FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
- & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
- ELSEIF(MSTP(147).EQ.6) THEN
- FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
- ENDIF
- FACQQG=COMFAC*FF*FACQQG
- ENDIF
-C...Split total contribution into different colour flows just like
-C...in g g -> g g (recalculate kinematics for massless partons).
- THP=-0.5D0*SH*(1D0-CTH)
- UHP=-0.5D0*SH*(1D0+CTH)
- FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
- FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
- FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
- FACGGS=FACGG1+FACGG2+FACGG3
- IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=3
- SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
- ENDIF
-
- ELSEIF(ISUB.EQ.425) THEN
-C...q + g -> q + QQ~[3S18]
- IF(MSTP(145).EQ.0) THEN
- FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
- & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
- & (SQMQQ*SQMQQR*SH*UH*UHSH2)
- ELSE
- FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
- & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
- AA=SHTH2+THUH2
- BB=4D0
- CC=8D0
- DD=4D0
- IF(MSTP(147).EQ.0) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
- & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
- ELSEIF(MSTP(147).EQ.3) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
- & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
- ELSEIF(MSTP(147).EQ.4) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
- ELSEIF(MSTP(147).EQ.5) THEN
- FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
- & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
- ELSEIF(MSTP(147).EQ.6) THEN
- FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
- ENDIF
- FACQQG=COMFAC*FF*FACQQG
- ENDIF
-C...Split total contribution into different colour flows just like
-C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
-C...(recalculate kinematics for massless partons).
- THP=-0.5D0*SH*(1D0-CTH)
- UHP=-0.5D0*SH*(1D0+CTH)
- FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
- FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
- FACQGS=FACQG1+FACQG2
- DO 2442 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
- DO 2441 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
- 2441 CONTINUE
- 2442 CONTINUE
-
- ELSEIF(ISUB.EQ.426) THEN
-C...q + g -> q + QQ~[1S08]
- IF(MSTP(145).EQ.0) THEN
- FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
- & (SH2+UH2)/(SQMQQR*TH*UHSH2)
- ELSE
- FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
- IF(MSTP(147).EQ.0) THEN
- FACQQG=COMFAC*FA
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=COMFAC*2D0*FA
- ELSEIF(MSTP(147).EQ.3) THEN
- FACQQG=COMFAC*FA
- ELSEIF(MSTP(147).EQ.4) THEN
- FACQQG=COMFAC*FA
- ELSEIF(MSTP(147).EQ.5) THEN
- FACQQG=0D0
- ELSEIF(MSTP(147).EQ.6) THEN
- FACQQG=0D0
- ENDIF
- ENDIF
-C...Split total contribution into different colour flows just like
-C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
-C...(recalculate kinematics for massless partons).
- THP=-0.5D0*SH*(1D0-CTH)
- UHP=-0.5D0*SH*(1D0+CTH)
- FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
- FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
- FACQGS=FACQG1+FACQG2
- DO 2444 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
- DO 2443 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
- 2443 CONTINUE
- 2444 CONTINUE
-
- ELSEIF(ISUB.EQ.427) THEN
-C...q + g -> q + QQ~[3PJ8]
- IF(MSTP(145).EQ.0) THEN
- FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
- & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
- & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
- & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
- ELSE
- FF=10D0*PARU(1)*AS**3/
- & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
- AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
- BB=8D0*(SHTH2+TH*UH)
- CC=8D0*UHSH*(SHTH+THUH)
- DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
- IF(MSTP(147).EQ.0) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
- & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
- ELSEIF(MSTP(147).EQ.3) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
- & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
- ELSEIF(MSTP(147).EQ.4) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
- ELSEIF(MSTP(147).EQ.5) THEN
- FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
- & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
- ELSEIF(MSTP(147).EQ.6) THEN
- FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
- ENDIF
- FACQQG=COMFAC*FF*FACQQG
- ENDIF
-C...Split total contribution into different colour flows just like
-C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
-C...(recalculate kinematics for massless partons).
- THP=-0.5D0*SH*(1D0-CTH)
- UHP=-0.5D0*SH*(1D0+CTH)
- FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
- FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
- FACQGS=FACQG1+FACQG2
- DO 2446 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
- DO 2445 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
- 2445 CONTINUE
- 2446 CONTINUE
-
- ELSEIF(ISUB.EQ.428) THEN
-C...q + q~ -> g + QQ~[3S18]
- IF(MSTP(145).EQ.0) THEN
- FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
- & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
- & (SQMQQ*SQMQQR*TH*UH*THUH2)
- ELSE
- FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
- & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
- AA=SHTH2+UHSH2
- BB=4D0
- CC=4D0
- DD=0D0
- IF(MSTP(147).EQ.0) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
- & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
- ELSEIF(MSTP(147).EQ.3) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
- & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
- ELSEIF(MSTP(147).EQ.4) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
- ELSEIF(MSTP(147).EQ.5) THEN
- FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
- & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
- ELSEIF(MSTP(147).EQ.6) THEN
- FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
- ENDIF
- FACQQG=COMFAC*FF*FACQQG
- ENDIF
-C...Split total contribution into different colour flows just like
-C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
-C...(recalculate kinematics for massless partons).
- THP=-0.5D0*SH*(1D0-CTH)
- UHP=-0.5D0*SH*(1D0+CTH)
- FACGG1=UH/TH-9D0/4D0*UH2/SH2
- FACGG2=TH/UH-9D0/4D0*TH2/SH2
- FACGGS=FACGG1+FACGG2
- DO 2447 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
- 2447 CONTINUE
-
- ELSEIF(ISUB.EQ.429) THEN
-C...q + q~ -> g + QQ~[1S08]
- IF(MSTP(145).EQ.0) THEN
- FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
- & (TH2+UH2)/(SQMQQR*SH*THUH2)
- ELSE
- FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
- IF(MSTP(147).EQ.0) THEN
- FACQQG=COMFAC*FA
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=COMFAC*2D0*FA
- ELSEIF(MSTP(147).EQ.3) THEN
- FACQQG=COMFAC*FA
- ELSEIF(MSTP(147).EQ.4) THEN
- FACQQG=COMFAC*FA
- ELSEIF(MSTP(147).EQ.5) THEN
- FACQQG=0D0
- ELSEIF(MSTP(147).EQ.6) THEN
- FACQQG=0D0
- ENDIF
- ENDIF
-C...Split total contribution into different colour flows just like
-C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
-C...(recalculate kinematics for massless partons).
- THP=-0.5D0*SH*(1D0-CTH)
- UHP=-0.5D0*SH*(1D0+CTH)
- FACGG1=UH/TH-9D0/4D0*UH2/SH2
- FACGG2=TH/UH-9D0/4D0*TH2/SH2
- FACGGS=FACGG1+FACGG2
- DO 2448 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
- 2448 CONTINUE
-
- ELSEIF(ISUB.EQ.430) THEN
-C...q + q~ -> g + QQ~[3PJ8]
- IF(MSTP(145).EQ.0) THEN
- FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
- & ((7D0*THUH+8D0*SH)*(TH2+UH2)
- & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
- & (SQMQQ*SQMQQR*SH*THUH2*THUH)
- ELSE
- FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
- AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
- BB=8D0*(UHSH2+SH*TH)
- CC=8D0*(SHTH2+SH*UH)
- DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
- IF(MSTP(147).EQ.0) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
- & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
- ELSEIF(MSTP(147).EQ.3) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
- & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
- ELSEIF(MSTP(147).EQ.4) THEN
- FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
- ELSEIF(MSTP(147).EQ.5) THEN
- FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
- & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
- ELSEIF(MSTP(147).EQ.6) THEN
- FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
- & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
- ENDIF
- FACQQG=COMFAC*FF*FACQQG
- ENDIF
-C...Split total contribution into different colour flows just like
-C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
-C...(recalculate kinematics for massless partons).
- THP=-0.5D0*SH*(1D0-CTH)
- UHP=-0.5D0*SH*(1D0+CTH)
- FACGG1=UH/TH-9D0/4D0*UH2/SH2
- FACGG2=TH/UH-9D0/4D0*TH2/SH2
- FACGGS=FACGG1+FACGG2
- DO 2449 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
- 2449 CONTINUE
-
- ELSEIF(ISUB.EQ.431) THEN
-C...g + g -> QQ~[3P01] + g
- PGTW=(SH*TH+TH*UH+UH*SH)/SH2
- QGTW=(SH*TH*UH)/SH**3
- RGTW=SQMQQ/SH
- IF(MSTP(145).EQ.0) THEN
- FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
- & (9D0*RGTW**2*PGTW**4*
- & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
- & -6D0*RGTW*PGTW**3*QGTW*
- & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
- & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
- & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
- & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
- ELSE
- FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
- & (9D0*RGTW**2*PGTW**4*
- & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
- & -6D0*RGTW*PGTW**3*QGTW*
- & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
- & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
- & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
- & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
- IF(MSTP(147).EQ.0) THEN
- FACQQG=COMFAC*FC1
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=COMFAC*2D0*FC1
- ELSEIF(MSTP(147).EQ.3) THEN
- FACQQG=COMFAC*FC1
- ELSEIF(MSTP(147).EQ.4) THEN
- FACQQG=COMFAC*FC1
- ELSEIF(MSTP(147).EQ.5) THEN
- FACQQG=0D0
- ELSEIF(MSTP(147).EQ.6) THEN
- FACQQG=0D0
- ENDIF
- ENDIF
- IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
- ENDIF
-
- ELSEIF(ISUB.EQ.432) THEN
-C...g + g -> QQ~[3P11] + g
- PGTW=(SH*TH+TH*UH+UH*SH)/SH2
- QGTW=(SH*TH*UH)/SH**3
- RGTW=SQMQQ/SH
- IF(MSTP(145).EQ.0) THEN
- FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
- & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
- & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
- & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
- ELSE
- FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
- C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
- & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
- & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
- & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
- C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
- & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
- & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
- C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
- & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
- & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
- C4=-4D0*THUH*(TH-UH)**2*
- & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
- & -SH2*TH*UH*(TH2+UH2))
- & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
- & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
- & +SH2*(5D0*THUH2-17D0*TH*UH)))
- IF(MSTP(147).EQ.0) THEN
- FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
- & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
- & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
- ELSEIF(MSTP(147).EQ.3) THEN
- FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
- & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
- ELSEIF(MSTP(147).EQ.4) THEN
- FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
- & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
- ELSEIF(MSTP(147).EQ.5) THEN
- FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
- & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
- ELSEIF(MSTP(147).EQ.6) THEN
- FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
- & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
- ENDIF
- FACQQG=COMFAC*FF*FACQQG
- ENDIF
- IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
- ENDIF
-
- ELSEIF(ISUB.EQ.433) THEN
-C...g + g -> QQ~[3P21] + g
- PGTW=(SH*TH+TH*UH+UH*SH)/SH2
- QGTW=(SH*TH*UH)/SH**3
- RGTW=SQMQQ/SH
- IF(MSTP(145).EQ.0) THEN
- FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
- & (12D0*RGTW**2*PGTW**4*
- & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
- & -3D0*RGTW*PGTW**3*QGTW*
- & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
- & +2D0*PGTW**2*QGTW**2*
- & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
- & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
- & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
- ELSE
- FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
- & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
- C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
- & *SH*SH2**7
- C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
- & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
- & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
- & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
- & +10D0*(SH2**2+TH2**2))
- & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
- & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
- & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
- & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
- & +4D0*SH*TH*UH2**4*SHTH2)
- C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
- & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
- & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
- & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
- & +10D0*(SH2**2+UH2**2))
- & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
- & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
- & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
- & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
- & +4D0*SH*UH*TH2**4*UHSH2)
- C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
- & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
- & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
- & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
- & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
- & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
- & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
- & -SH2**2*TH*UH*(114D0*TH**3*UH**3
- & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
- & +3D0*(TH2**3+UH2**3)))
- C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
- & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
- C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
- & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
- C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
- & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
- & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
- & 82D0*TH**3)
- & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
- & +45D0*TH**3)
- & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
- & 8D0*TH**3)
- & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
- & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
- & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
- C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
- & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
- & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
- & 82D0*UH**3)
- & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
- & +45D0*UH**3)
- & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
- & 8D0*UH**3)
- & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
- & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
- & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
- C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
- & +4D0*SH*TH2**2*UH2**2*THUH2
- & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
- & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
- & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
- & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
- & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
- C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
- & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
- & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
- & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
- & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
- & +SH**5*TH*UH*(-428D0*TH**3*UH**3
- & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
- & +2D0*(TH2**3+UH2**3))
- & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
- & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
- & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
- & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
- IF(MSTP(147).EQ.0) THEN
- FACQQG=1D0/3D0*(C1*3D0
- & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
- & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
- & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
- & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
- & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
- & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
- & *(EL1K10*EL2K20-EL1K11*EL2K21)
- & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
- & *(EL1K10*EL2K20-EL1K11*EL2K21)
- & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
- & *(EL1K20*EL2K20-EL1K21*EL2K21)
- & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=C1*2D0
- & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
- & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
- & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
- & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
- & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
- & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
- & +EL1K10*EL2K20*EL1K11*EL2K11)
- & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
- & +EL1K10*EL2K20*EL1K21*EL2K21)
- & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
- & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
- & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
- & +EL1K20*EL2K20*EL1K11*EL2K11)
- ELSEIF(MSTP(147).EQ.2) THEN
- FACQQG=2D0*(C1
- & -C2*EL1K11*EL2K11
- & -C3*EL1K21*EL2K21
- & -C4*EL1K11*EL2K21
- & +C5*(EL1K11*EL2K11)**2
- & +C6*(EL1K21*EL2K21)**2
- & +C7*EL1K11*EL2K11*EL1K11*EL2K21
- & +C8*EL1K21*EL2K21*EL1K11*EL2K21
- & +(C9+C0)*(EL1K11*EL2K21)**2)
- ENDIF
- FACQQG=COMFAC*FF*FACQQG
- ENDIF
- IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
- ENDIF
-
- ELSEIF(ISUB.EQ.434) THEN
-C...q + g -> q + QQ~[3P01]
- IF(MSTP(145).EQ.0) THEN
- FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
- & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
- ELSE
- FA=-PARU(1)*AS**3*(16D0/243D0)*
- & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
- IF(MSTP(147).EQ.0) THEN
- FACQQG=COMFAC*FA
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=COMFAC*2D0*FA
- ELSEIF(MSTP(147).EQ.3) THEN
- FACQQG=COMFAC*FA
- ELSEIF(MSTP(147).EQ.4) THEN
- FACQQG=COMFAC*FA
- ELSEIF(MSTP(147).EQ.5) THEN
- FACQQG=0D0
- ELSEIF(MSTP(147).EQ.6) THEN
- FACQQG=0D0
- ENDIF
- ENDIF
- DO 2452 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
- DO 2451 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
- 2451 CONTINUE
- 2452 CONTINUE
-
- ELSEIF(ISUB.EQ.435) THEN
-C...q + g -> q + QQ~[3P11]
- IF(MSTP(145).EQ.0) THEN
- FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
- & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
- ELSE
- FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
- C1=SH*UH
- C2=2D0*SH
- C3=0D0
- C4=2D0*(SH-UH)
- IF(MSTP(147).EQ.0) THEN
- FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
- & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
- & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
- ELSEIF(MSTP(147).EQ.3) THEN
- FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
- & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
- ELSEIF(MSTP(147).EQ.4) THEN
- FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
- & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
- ELSEIF(MSTP(147).EQ.5) THEN
- FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
- & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
- ELSEIF(MSTP(147).EQ.6) THEN
- FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
- & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
- ENDIF
- FACQQG=COMFAC*FF*FACQQG
- ENDIF
- DO 2454 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
- DO 2453 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
- 2453 CONTINUE
- 2454 CONTINUE
-
- ELSEIF(ISUB.EQ.436) THEN
-C...q + g -> q + QQ~[3P21]
- IF(MSTP(145).EQ.0) THEN
- FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
- & ((6D0*SQMQQ**2+TH2)*UHSH2
- & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
- & (SQMQQR*TH*UHSH2**2)
- ELSE
- FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
- C1=TH*UHSH2
- C2=4D0*(SH2+TH2+2D0*TH*UHSH)
- C3=4D0*UHSH2
- C4=8D0*SH*UHSH
- C5=8D0*TH
- C6=0D0
- C7=16D0*TH
- C8=0D0
- C9=-16D0*UHSH
- C0=16D0*SQMQQ
- IF(MSTP(147).EQ.0) THEN
- FACQQG=1D0/3D0*(C1*3D0
- & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
- & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
- & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
- & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
- & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
- & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
- & *(EL1K10*EL2K20-EL1K11*EL2K21)
- & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
- & *(EL1K10*EL2K20-EL1K11*EL2K21)
- & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
- & *(EL1K20*EL2K20-EL1K21*EL2K21)
- & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=C1*2D0
- & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
- & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
- & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
- & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
- & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
- & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
- & +EL1K10*EL2K20*EL1K11*EL2K11)
- & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
- & +EL1K10*EL2K20*EL1K21*EL2K21)
- & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
- & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
- & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
- & +EL1K20*EL2K20*EL1K11*EL2K11)
- ELSEIF(MSTP(147).EQ.2) THEN
- FACQQG=2D0*(C1
- & -C2*EL1K11*EL2K11
- & -C3*EL1K21*EL2K21
- & -C4*EL1K11*EL2K21
- & +C5*(EL1K11*EL2K11)**2
- & +C6*(EL1K21*EL2K21)**2
- & +C7*EL1K11*EL2K11*EL1K11*EL2K21
- & +C8*EL1K21*EL2K21*EL1K11*EL2K21
- & +(C9+C0)*(EL1K11*EL2K21)**2)
- ENDIF
- FACQQG=COMFAC*FF*FACQQG
- ENDIF
- DO 2456 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
- DO 2455 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
- 2455 CONTINUE
- 2456 CONTINUE
-
- ELSEIF(ISUB.EQ.437) THEN
-C...q + q~ -> g + QQ~[3P01]
- IF(MSTP(145).EQ.0) THEN
- FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
- & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
- ELSE
- FA=PARU(1)*AS**3*(128D0/729D0)*
- & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
- IF(MSTP(147).EQ.0) THEN
- FACQQG=COMFAC*FA
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=COMFAC*2D0*FA
- ELSEIF(MSTP(147).EQ.3) THEN
- FACQQG=COMFAC*FA
- ELSEIF(MSTP(147).EQ.4) THEN
- FACQQG=COMFAC*FA
- ELSEIF(MSTP(147).EQ.5) THEN
- FACQQG=0D0
- ELSEIF(MSTP(147).EQ.6) THEN
- FACQQG=0D0
- ENDIF
- ENDIF
- DO 2457 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
- 2457 CONTINUE
-
- ELSEIF(ISUB.EQ.438) THEN
-C...q + q~ -> g + QQ~[3P11]
- IF(MSTP(145).EQ.0) THEN
- FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
- & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
- ELSE
- FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
- C1=TH*UH
- C2=2D0*UH
- C3=2D0*TH
- C4=2D0*THUH
- IF(MSTP(147).EQ.0) THEN
- FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
- & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
- & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
- ELSEIF(MSTP(147).EQ.3) THEN
- FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
- & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
- ELSEIF(MSTP(147).EQ.4) THEN
- FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
- & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
- ELSEIF(MSTP(147).EQ.5) THEN
- FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
- & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
- ELSEIF(MSTP(147).EQ.6) THEN
- FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
- & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
- ENDIF
- FACQQG=COMFAC*FF*FACQQG
- ENDIF
- DO 2458 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
- 2458 CONTINUE
-
- ELSEIF(ISUB.EQ.439) THEN
-C...q + q~ -> g + QQ~[3P21]
- IF(MSTP(145).EQ.0) THEN
- FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
- & ((6D0*SQMQQ**2+SH2)*THUH2
- & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
- & (SQMQQR*SH*THUH2**2)
- ELSE
- FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
- C1=SH*THUH2
- C2=4D0*(SH2+UH2+2D0*SH*THUH)
- C3=4D0*(SH2+TH2+2D0*SH*THUH)
- C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
- C5=8D0*SH
- C6=C5
- C7=16D0*SH
- C8=C7
- C9=-16D0*THUH
- C0=16D0*SQMQQ
- IF(MSTP(147).EQ.0) THEN
- FACQQG=1D0/3D0*(C1*3D0
- & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
- & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
- & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
- & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
- & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
- & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
- & *(EL1K10*EL2K20-EL1K11*EL2K21)
- & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
- & *(EL1K10*EL2K20-EL1K11*EL2K21)
- & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
- & *(EL1K20*EL2K20-EL1K21*EL2K21)
- & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
- ELSEIF(MSTP(147).EQ.1) THEN
- FACQQG=C1*2D0
- & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
- & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
- & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
- & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
- & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
- & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
- & +EL1K10*EL2K20*EL1K11*EL2K11)
- & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
- & +EL1K10*EL2K20*EL1K21*EL2K21)
- & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
- & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
- & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
- & +EL1K20*EL2K20*EL1K11*EL2K11)
- ELSEIF(MSTP(147).EQ.2) THEN
- FACQQG=2D0*(C1
- & -C2*EL1K11*EL2K11
- & -C3*EL1K21*EL2K21
- & -C4*EL1K11*EL2K21
- & +C5*(EL1K11*EL2K11)**2
- & +C6*(EL1K21*EL2K21)**2
- & +C7*EL1K11*EL2K11*EL1K11*EL2K21
- & +C8*EL1K21*EL2K21*EL1K11*EL2K21
- & +(C9+C0)*(EL1K11*EL2K21)**2)
- ENDIF
- FACQQG=COMFAC*FF*FACQQG
- ENDIF
- DO 2459 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
- 2459 CONTINUE
- ENDIF
-C...QUARKONIA---
-
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSGWZ
-C...Subprocess cross sections for W/Z processes,
-C...except that longitudinal WW scattering is in Higgs sector.
-C...Auxiliary to PYSIGH.
-
- SUBROUTINE PYSGWZ(NCHN,SIGS)
-
-C...Double precision and integer declarations
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
- COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
- &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
- &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
- &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
- &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
-C...Local arrays and complex numbers
- DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
- &HL4(3),HR4(3)
- COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
-
-C...Differential cross section expressions.
-
- IF(ISUB.LE.20) THEN
- IF(ISUB.EQ.1) THEN
-C...f + fbar -> gamma*/Z0
- MINT(61)=2
- CALL PYWIDT(23,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACZ=4D0*COMFAC*3D0
- HP0=AEM/3D0*SH
- HP1=AEM/3D0*XWC*SH
- DO 100 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI)
- VI=AI-4D0*EI*XWV
- HI0=HP0
- IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
- HI1=HP1
- IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
- & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
- & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
- & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
- 100 CONTINUE
-
- ELSEIF(ISUB.EQ.2) THEN
-C...f + fbar' -> W+/-
- CALL PYWIDT(24,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
- HP=AEM/(24D0*XW)*SH
- DO 120 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
- IA=IABS(I)
- DO 110 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
- JA=IABS(J)
- IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
- IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
- & GOTO 110
- KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
- HI=HP*2D0
- IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
- SIGH(NCHN)=HI*FACBW*HF
- 110 CONTINUE
- 120 CONTINUE
-
- ELSEIF(ISUB.EQ.15) THEN
-C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
- FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
-C...gamma, gamma/Z interference and Z couplings to final fermion pairs
- HFGG=0D0
- HFGZ=0D0
- HFZZ=0D0
- RADC4=1D0+PYALPS(SQM4)/PARU(1)
- DO 130 I=1,MIN(16,MDCY(23,3))
- IDC=I+MDCY(23,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 130
- IMDM=0
- IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
- & IMDM=1
- IF(I.LE.8) THEN
- EF=KCHG(I,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- ELSEIF(I.LE.16) THEN
- EF=KCHG(I+2,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- ENDIF
- RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
- IF(4D0*RM1.LT.1D0) THEN
- FCOF=1D0
- IF(I.LE.8) FCOF=3D0*RADC4
- BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
- IF(IMDM.EQ.1) THEN
- HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
- HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
- HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
- & AF**2*(1D0-4D0*RM1))*BE34
- ENDIF
- ENDIF
- 130 CONTINUE
-C...Propagators: as simulated in PYOFSH and as desired
- HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
- MINT15=MINT(15)
- MINT(15)=1
- MINT(61)=1
- CALL PYWIDT(23,SQM4,WDTP,WDTE)
- MINT(15)=MINT15
- HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
- HFGG=HFGG*HFAEM*VINT(111)/SQM4
- HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
- HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
-C...Loop over flavours; consider full gamma/Z structure
- DO 140 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI)
- VI=AI-4D0*EI*XWV
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
- & (VI**2+AI**2)*HFZZ)/HBW4
- 140 CONTINUE
-
- ELSEIF(ISUB.EQ.16) THEN
-C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
- FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
-C...Propagators: as simulated in PYOFSH and as desired
- HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
- CALL PYWIDT(24,SQM4,WDTP,WDTE)
- GMMWC=SQRT(SQM4)*WDTP(0)
- HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
- FACWG=FACWG*HBW4C/HBW4
- DO 160 I=MMIN1,MMAX1
- IA=IABS(I)
- IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
- DO 150 J=MMIN2,MMAX2
- JA=IABS(J)
- IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
- IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
- KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
- WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
- FCKM=VCKM((IA+1)/2,(JA+1)/2)
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACWG*FCKM*WIDSC
- 150 CONTINUE
- 160 CONTINUE
-
- ELSEIF(ISUB.EQ.19) THEN
-C...f + fbar -> gamma + (gamma*/Z0)
- FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
-C...gamma, gamma/Z interference and Z couplings to final fermion pairs
- HFGG=0D0
- HFGZ=0D0
- HFZZ=0D0
- RADC4=1D0+PYALPS(SQM4)/PARU(1)
- DO 170 I=1,MIN(16,MDCY(23,3))
- IDC=I+MDCY(23,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 170
- IMDM=0
- IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
- & IMDM=1
- IF(I.LE.8) THEN
- EF=KCHG(I,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- ELSEIF(I.LE.16) THEN
- EF=KCHG(I+2,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- ENDIF
- RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
- IF(4D0*RM1.LT.1D0) THEN
- FCOF=1D0
- IF(I.LE.8) FCOF=3D0*RADC4
- BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
- IF(IMDM.EQ.1) THEN
- HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
- HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
- HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
- & AF**2*(1D0-4D0*RM1))*BE34
- ENDIF
- ENDIF
- 170 CONTINUE
-C...Propagators: as simulated in PYOFSH and as desired
- HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
- MINT15=MINT(15)
- MINT(15)=1
- MINT(61)=1
- CALL PYWIDT(23,SQM4,WDTP,WDTE)
- MINT(15)=MINT15
- HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
- HFGG=HFGG*HFAEM*VINT(111)/SQM4
- HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
- HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
-C...Loop over flavours; consider full gamma/Z structure
- DO 180 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI)
- VI=AI-4D0*EI*XWV
- FCOI=1D0
- IF(IABS(I).LE.10) FCOI=FACA/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
- & (VI**2+AI**2)*HFZZ)/HBW4
- 180 CONTINUE
-
- ELSEIF(ISUB.EQ.20) THEN
-C...f + fbar' -> gamma + W+/-
- FACGW=COMFAC*0.5D0*AEM**2/XW
-C...Propagators: as simulated in PYOFSH and as desired
- HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
- CALL PYWIDT(24,SQM4,WDTP,WDTE)
- GMMWC=SQRT(SQM4)*WDTP(0)
- HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
- FACGW=FACGW*HBW4C/HBW4
-C...Anomalous couplings
- TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
- TERM2=0D0
- TERM3=0D0
- IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
- TERM2=RTCM(46)*(TH-UH)/(TH+UH)
- TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
- & (4D0*SQMW))/(TH+UH)**2
- ENDIF
- DO 200 I=MMIN1,MMAX1
- IA=IABS(I)
- IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
- DO 190 J=MMIN2,MMAX2
- JA=IABS(J)
- IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
- IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
- IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
- & GOTO 190
- KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
- WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
- IF(IA.LE.10) THEN
- FACWR=UH/(TH+UH)-1D0/3D0
- FCKM=VCKM((IA+1)/2,(JA+1)/2)
- FCOI=FACA/3D0
- ELSE
- FACWR=-TH/(TH+UH)
- FCKM=1D0
- FCOI=1D0
- ENDIF
- FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
- 190 CONTINUE
- 200 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.40) THEN
- IF(ISUB.EQ.22) THEN
-C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
-C...Kinematics dependence
- FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
- & SQM3*SQM4*(1D0/TH2+1D0/UH2))
-C...gamma, gamma/Z interference and Z couplings to final fermion pairs
- DO 220 I=1,6
- DO 210 J=1,3
- HGZ(I,J)=0D0
- 210 CONTINUE
- 220 CONTINUE
- RADC3=1D0+PYALPS(SQM3)/PARU(1)
- RADC4=1D0+PYALPS(SQM4)/PARU(1)
- DO 230 I=1,MIN(16,MDCY(23,3))
- IDC=I+MDCY(23,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 230
- IMDM=0
- IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
- IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
- IF(I.LE.8) THEN
- EF=KCHG(I,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- ELSEIF(I.LE.16) THEN
- EF=KCHG(I+2,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- ENDIF
- RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
- IF(4D0*RM1.LT.1D0) THEN
- FCOF=1D0
- IF(I.LE.8) FCOF=3D0*RADC3
- BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
- IF(IMDM.GE.1) THEN
- HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
- HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
- HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
- & AF**2*(1D0-4D0*RM1))*BE34
- ENDIF
- ENDIF
- RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
- IF(4D0*RM1.LT.1D0) THEN
- FCOF=1D0
- IF(I.LE.8) FCOF=3D0*RADC4
- BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
- IF(IMDM.GE.1) THEN
- HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
- HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
- HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
- & AF**2*(1D0-4D0*RM1))*BE34
- ENDIF
- ENDIF
- 230 CONTINUE
-C...Propagators: as simulated in PYOFSH and as desired
- HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
- HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
- MINT15=MINT(15)
- MINT(15)=1
- MINT(61)=1
- CALL PYWIDT(23,SQM3,WDTP,WDTE)
- MINT(15)=MINT15
- HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
- DO 240 J=1,3
- HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
- HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
- HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
- 240 CONTINUE
- MINT15=MINT(15)
- MINT(15)=1
- MINT(61)=1
- CALL PYWIDT(23,SQM4,WDTP,WDTE)
- MINT(15)=MINT15
- HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
- DO 250 J=1,3
- HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
- HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
- HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
- 250 CONTINUE
-C...Loop over flavours; separate left- and right-handed couplings
- DO 270 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI)
- VI=AI-4D0*EI*XWV
- VALI=VI-AI
- VARI=VI+AI
- FCOI=1D0
- IF(IABS(I).LE.10) FCOI=FACA/3D0
- DO 260 J=1,3
- HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
- HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
- HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
- HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
- 260 CONTINUE
- FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
- & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
- & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
- & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
- 270 CONTINUE
-
- ELSEIF(ISUB.EQ.23) THEN
-C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
- FACZW=COMFAC*0.5D0*(AEM/XW)**2
- FACZW=FACZW*WIDS(23,2)
- THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
- FACBW=1D0/((SH-SQMW)**2+GMMW**2)
- DO 290 I=MMIN1,MMAX1
- IA=IABS(I)
- IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
- DO 280 J=MMIN2,MMAX2
- JA=IABS(J)
- IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
- IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
- IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
- & GOTO 280
- KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
- EI=KCHG(IA,1)/3D0
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*XWV
- EJ=KCHG(JA,1)/3D0
- AJ=SIGN(1D0,EJ+0.1D0)
- VJ=AJ-4D0*EJ*XWV
- IF(VI+AI.GT.0) THEN
- VISAV=VI
- AISAV=AI
- VI=VJ
- AI=AJ
- VJ=VISAV
- AJ=AISAV
- ENDIF
- FCKM=1D0
- IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
- FCOI=1D0
- IF(IA.LE.10) FCOI=FACA/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
- & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
- & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
- & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
- & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
- & WIDS(24,(5-KCHW)/2)
-C***Protect against slightly negative cross sections. (Reason yet to be
-C***sorted out. One possibility: addition of width to the W propagator.)
- SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
- 280 CONTINUE
- 290 CONTINUE
-
- ELSEIF(ISUB.EQ.25) THEN
-C...f + fbar -> W+ + W-
-C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
- GMMZC=GMMZ
- HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
- HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
- CALL PYWIDT(24,SQM3,WDTP,WDTE)
- GMMW3=SQRT(SQM3)*WDTP(0)
- HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
- HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
- CALL PYWIDT(24,SQM4,WDTP,WDTE)
- GMMW4=SQRT(SQM4)*WDTP(0)
- HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
-C...Kinematical functions
- THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
- THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
- GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
- GT=THUH34+4D0*THUH/TH2
- GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
- GU=THUH34+4D0*THUH/UH2
- GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
-C...Common factors and couplings
- FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
- FACWW=FACWW*WIDS(24,1)
- CGG=AEM**2/2D0
- CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
- CZZ=AEM**2/(32D0*XW**2)*HBWZC
- CNG=AEM**2/(4D0*XW)
- CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
- CNN=AEM**2/(16D0*XW**2)
-C...Coulomb factor for W+W- pair
- IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
- COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
- COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
- IF(COULE.LT.100D0*PMAS(24,2)) THEN
- COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
- & PMAS(24,2)**2)-COULE))
- ELSE
- COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
- ENDIF
- IF(COULE.GT.-100D0*PMAS(24,2)) THEN
- COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
- & PMAS(24,2)**2)+COULE))
- ELSE
- COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
- & ABS(COULE)))
- ENDIF
- IF(MSTP(40).EQ.1) THEN
- COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
- & MAX(1D-10,2D0*COULP*COULP1))
- FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
- ELSEIF(MSTP(40).EQ.2) THEN
- COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
- COULCP=DCMPLX(0D0,DBLE(COULP))
- COULCD=(COULCK+COULCP)/(COULCK-COULCP)
- COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
- & (4D0*COULCP)*LOG(COULCD)
- COULCS=DCMPLX(0D0,0D0)
- NSTP=100
- DO 300 ISTP=1,NSTP
- COULXX=(ISTP-0.5)/NSTP
- COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
- & (1D0+COULXX/COULCD))
- 300 CONTINUE
- COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
- & (COULCS/NSTP)
- FACCOU=ABS(COULCR)**2
- ELSEIF(MSTP(40).EQ.3) THEN
- COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
- & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
- FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
- ENDIF
- ELSEIF(MSTP(40).EQ.4) THEN
- FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
- ELSE
- FACCOU=1D0
- ENDIF
- VINT(95)=FACCOU
- FACWW=FACWW*FACCOU
-C...Loop over allowed flavours
- DO 310 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*XWV
- FCOI=1D0
- IF(IABS(I).LE.10) FCOI=FACA/3D0
- IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
- IF(AI.LT.0D0) THEN
- DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
- & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
- ELSE
- DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
- & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
- ENDIF
- ELSE
- XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
- BET=SQRT(1D0-4D0*XMW02/SH)
- GAT=1D0/SQRT(1D0-BET**2)
- STHE2=1D0-CTH**2
- AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
- AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
- & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
- AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
- & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
- & (1D0-2D0*BET*CTH+BET**2))
- PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
- PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
- A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
- A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
- A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
- ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
- ATOT=ATOT*CNN/SQMW*SH/BET*2D0
- DSIGWW=ATOT
- ENDIF
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACWW*FCOI*DSIGWW
- 310 CONTINUE
-
- ELSEIF(ISUB.EQ.30) THEN
-C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
- FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
- & (-SH*UH)
-C...gamma, gamma/Z interference and Z couplings to final fermion pairs
- HFGG=0D0
- HFGZ=0D0
- HFZZ=0D0
- RADC4=1D0+PYALPS(SQM4)/PARU(1)
- DO 320 I=1,MIN(16,MDCY(23,3))
- IDC=I+MDCY(23,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 320
- IMDM=0
- IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
- & IMDM=1
- IF(I.LE.8) THEN
- EF=KCHG(I,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- ELSEIF(I.LE.16) THEN
- EF=KCHG(I+2,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- ENDIF
- RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
- IF(4D0*RM1.LT.1D0) THEN
- FCOF=1D0
- IF(I.LE.8) FCOF=3D0*RADC4
- BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
- IF(IMDM.EQ.1) THEN
- HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
- HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
- HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
- & AF**2*(1D0-4D0*RM1))*BE34
- ENDIF
- ENDIF
- 320 CONTINUE
-C...Propagators: as simulated in PYOFSH and as desired
- HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
- MINT15=MINT(15)
- MINT(15)=1
- MINT(61)=1
- CALL PYWIDT(23,SQM4,WDTP,WDTE)
- MINT(15)=MINT15
- HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
- HFGG=HFGG*HFAEM*VINT(111)/SQM4
- HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
- HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
-C...Loop over flavours; consider full gamma/Z structure
- DO 340 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI)
- VI=AI-4D0*EI*XWV
- FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
- & (VI**2+AI**2)*HFZZ)/HBW4
- DO 330 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACZQ
- 330 CONTINUE
- 340 CONTINUE
-
- ELSEIF(ISUB.EQ.31) THEN
-C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
- FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
- & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
-C...Propagators: as simulated in PYOFSH and as desired
- HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
- CALL PYWIDT(24,SQM4,WDTP,WDTE)
- GMMWC=SQRT(SQM4)*WDTP(0)
- HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
- FACWQ=FACWQ*HBW4C/HBW4
- DO 360 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
- IA=IABS(I)
- KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
- WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
- DO 350 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
- 350 CONTINUE
- 360 CONTINUE
-
- ELSEIF(ISUB.EQ.35) THEN
-C...f + gamma -> f + (gamma*/Z0)
- IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
- FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
- FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
- ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
- FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
- FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
- ELSE
- FZQN=SH2+UH2+2D0*SQM4*TH
- FZQDTM=-SH*UH
- ENDIF
- FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
-C...gamma, gamma/Z interference and Z couplings to final fermion pairs
- HFGG=0D0
- HFGZ=0D0
- HFZZ=0D0
- RADC4=1D0+PYALPS(SQM4)/PARU(1)
- DO 370 I=1,MIN(16,MDCY(23,3))
- IDC=I+MDCY(23,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 370
- IMDM=0
- IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
- & IMDM=1
- IF(I.LE.8) THEN
- EF=KCHG(I,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- ELSEIF(I.LE.16) THEN
- EF=KCHG(I+2,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- ENDIF
- RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
- IF(4D0*RM1.LT.1D0) THEN
- FCOF=1D0
- IF(I.LE.8) FCOF=3D0*RADC4
- BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
- IF(IMDM.EQ.1) THEN
- HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
- HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
- HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
- & AF**2*(1D0-4D0*RM1))*BE34
- ENDIF
- ENDIF
- 370 CONTINUE
-C...Propagators: as simulated in PYOFSH and as desired
- HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
- MINT15=MINT(15)
- MINT(15)=1
- MINT(61)=1
- CALL PYWIDT(23,SQM4,WDTP,WDTE)
- MINT(15)=MINT15
- HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
- HFGG=HFGG*HFAEM*VINT(111)/SQM4
- HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
- HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
-C...Loop over flavours; consider full gamma/Z structure
- DO 390 I=MMINA,MMAXA
- IF(I.EQ.0) GOTO 390
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI)
- VI=AI-4D0*EI*XWV
- FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
- & (VI**2+AI**2)*HFZZ)/HBW4
- FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
- DO 380 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
- IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACZQ*FZQN/FZQD
- 380 CONTINUE
- 390 CONTINUE
-
- ELSEIF(ISUB.EQ.36) THEN
-C...f + gamma -> f' + W+/-
- FWQ=COMFAC*AEM**2/(2D0*XW)*
- & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
-C...Propagators: as simulated in PYOFSH and as desired
- HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
- CALL PYWIDT(24,SQM4,WDTP,WDTE)
- GMMWC=SQRT(SQM4)*WDTP(0)
- HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
- FWQ=FWQ*HBW4C/HBW4
- DO 410 I=MMINA,MMAXA
- IF(I.EQ.0) GOTO 410
- IA=IABS(I)
- EIA=ABS(KCHG(IABS(I),1)/3D0)
- FACWQ=FWQ*(EIA-SH/(SH+UH))**2
- KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
- WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
- DO 400 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
- IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
- 400 CONTINUE
- 410 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.100) THEN
- IF(ISUB.EQ.69) THEN
-C...gamma + gamma -> W+ + W-
- SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
- FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
- FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
- & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
- IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
- NCHN=NCHN+1
- ISIG(NCHN,1)=22
- ISIG(NCHN,2)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACWW
- 420 CONTINUE
-
- ELSEIF(ISUB.EQ.70) THEN
-C...gamma + W+/- -> Z0 + W+/-
- SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
- FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
- FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
- & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
- & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
- DO 440 KCHW=1,-1,-2
- DO 430 ISDE=1,2
- IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=22
- ISIG(NCHN,3-ISDE)=24*KCHW
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
- 430 CONTINUE
- 440 CONTINUE
- ENDIF
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSGHG
-C...Subprocess cross sections for Higgs processes,
-C...except Higgs pairs in PYSGSU, but including WW scattering.
-C...Auxiliary to PYSIGH.
-
- SUBROUTINE PYSGHG(NCHN,SIGS)
-
-C...Double precision and integer declarations
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
- &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
- &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
- &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
- &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
-C...Local arrays and complex variables
- DIMENSION WDTP(0:400),WDTE(0:400,0:5)
- COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
- COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
-
-C...Convert H or A process into equivalent h one
- IHIGG=1
- KFHIGG=25
- IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
- KFHIGG=KFPR(ISUB,1)
- END IF
- IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
- &ISUB.LE.190)) THEN
- IHIGG=2
- IF(MOD(ISUB-1,10).GE.5) IHIGG=3
- KFHIGG=33+IHIGG
- IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
- IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
- IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
- IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
- IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
- IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
- IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
- IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
- IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
- IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
- IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
- IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
- ENDIF
- SQMH=PMAS(KFHIGG,1)**2
- GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
-
-C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
- IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
- &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
-C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
- IF(MSTP(46).LE.4) THEN
- HDTLH=LOG(PMAS(25,1)/PARP(44))
- HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
- HDTNR=-1D0/18D0+HDTLH/6D0
- ELSE
- HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
- HDTLQ=LOG(PARP(45)/PARP(44))
- HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
- HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
- ENDIF
-
-C...Calculate lowest and next-to-lowest order partial wave amplitudes
- HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
- A00L=DBLE(HDTV*SH)
- A20L=-0.5D0*A00L
- A11L=A00L/6D0
- HDTLS=LOG(SH/PARP(44)**2)
- A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
- & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
- & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
- A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
- & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
- & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
- A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
- & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
-
-C...Unitarize partial wave amplitudes with Pade or K-matrix method
- IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
- A00U=A00L/(1D0-A004/A00L)
- A20U=A20L/(1D0-A204/A20L)
- A11U=A11L/(1D0-A114/A11L)
- ELSE
- A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
- A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
- A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
- ENDIF
- ENDIF
-
-C...Differential cross section expressions.
-
- IF(ISUB.LE.60) THEN
- IF(ISUB.EQ.3) THEN
-C...f + fbar -> h0 (or H0, or A0)
- CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
- IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
- & FACBW=0D0
- HP=AEM/(8D0*XW)*SH/SQMW*SH
- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- DO 100 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
- IA=IABS(I)
- RMQ=PYMRUN(IA,SH)**2/SH
- HI=HP*RMQ
- IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
- IKFI=1
- IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
- IF(IA.GT.10) IKFI=3
- HI=HI*PARU(150+10*IHIGG+IKFI)**2
- IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
- HI=HI/(1D0+RMSS(41))**2
- IF(IHIGG.NE.3) THEN
- HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
- & PARU(151+10*IHIGG))**2
- ENDIF
- ENDIF
- ENDIF
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=HI*FACBW*HF
- 100 CONTINUE
-
- ELSEIF(ISUB.EQ.5) THEN
-C...Z0 + Z0 -> h0
- CALL PYWIDT(25,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
- IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
- HP=AEM/(8D0*XW)*SH/SQMW*SH
- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- HI=HP/4D0
- FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
- DO 120 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
- DO 110 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI)
- VI=AI-4D0*EI*XWV
- EJ=KCHG(IABS(J),1)/3D0
- AJ=SIGN(1D0,EJ)
- VJ=AJ-4D0*EJ*XWV
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
- 110 CONTINUE
- 120 CONTINUE
-
- ELSEIF(ISUB.EQ.8) THEN
-C...W+ + W- -> h0
- CALL PYWIDT(25,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
- IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
- HP=AEM/(8D0*XW)*SH/SQMW*SH
- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- HI=HP/2D0
- FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
- DO 140 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
- EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
- DO 130 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
- EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
- IF(EI*EJ.GT.0D0) GOTO 130
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
- 130 CONTINUE
- 140 CONTINUE
-
- ELSEIF(ISUB.EQ.24) THEN
-C...f + fbar -> Z0 + h0 (or H0, or A0)
-C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
- HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
- CALL PYWIDT(23,SQM3,WDTP,WDTE)
- GMMZ3=SQRT(SQM3)*WDTP(0)
- HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
- HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
- CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
- GMMH4=SQRT(SQM4)*WDTP(0)
- HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
- THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
- FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
- & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
- FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
- & PARU(154+10*IHIGG)**2
- DO 150 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI)
- VI=AI-4D0*EI*XWV
- FCOI=1D0
- IF(IABS(I).LE.10) FCOI=FACA/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
- 150 CONTINUE
-
- ELSEIF(ISUB.EQ.26) THEN
-C...f + fbar' -> W+/- + h0 (or H0, or A0)
-C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
- HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
- CALL PYWIDT(24,SQM3,WDTP,WDTE)
- GMMW3=SQRT(SQM3)*WDTP(0)
- HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
- HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
- CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
- GMMH4=SQRT(SQM4)*WDTP(0)
- HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
- THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
- FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
- & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
- FACHW=FACHW*WIDS(KFHIGG,2)
- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
- & PARU(155+10*IHIGG)**2
- DO 170 I=MMIN1,MMAX1
- IA=IABS(I)
- IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
- DO 160 J=MMIN2,MMAX2
- JA=IABS(J)
- IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
- IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
- IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
- & GOTO 160
- KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
- FCKM=1D0
- IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
- FCOI=1D0
- IF(IA.LE.10) FCOI=FACA/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
- 160 CONTINUE
- 170 CONTINUE
-
- ELSEIF(ISUB.EQ.32) THEN
-C...f + g -> f + h0 (q + g -> q + h0 only)
- FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
-C...H propagator: as simulated in PYOFSH and as desired
- SQMHC=PMAS(25,1)**2
- GMMHC=PMAS(25,1)*PMAS(25,2)
- HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
- CALL PYWIDT(25,SQM4,WDTP,WDTE)
- GMMHCC=SQRT(SQM4)*WDTP(0)
- HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
- FHCQ=FHCQ*HBW4C/HBW4
- DO 190 I=MMINA,MMAXA
- IA=IABS(I)
- IF(IA.NE.5) GOTO 190
- SQML=PYMRUN(IA,SH)**2
- SQMQ=PMAS(IA,1)**2
- FACHCQ=FHCQ*SQML/SQMW*
- & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
- & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
- & (SQM4-SQMQ-SH)/SH)
- DO 180 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACHCQ*WIDS(25,2)
- 180 CONTINUE
- 190 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.80) THEN
- IF(ISUB.EQ.71) THEN
-C...Z0 + Z0 -> Z0 + Z0
- IF(SH.LE.4.01D0*SQMZ) GOTO 220
-
- IF(MSTP(46).LE.2) THEN
-C...Exact scattering ME:s for on-mass-shell gauge bosons
- BE2=1D0-4D0*SQMZ/SH
- TH=-0.5D0*SH*BE2*(1D0-CTH)
- UH=-0.5D0*SH*BE2*(1D0+CTH)
- IF(MAX(TH,UH).GT.-1D0) GOTO 220
- SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
- ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
- ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
- THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
- ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
- ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
- UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
- AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
- AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
- FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
- & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
- IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
- IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
- & (ASHIM+ATHIM+AUHIM)**2)
- IF(MSTP(46).EQ.2) FACZZ=0D0
-
- ELSE
-C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
- FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
- & ABS(A00U+2D0*A20U)**2
- ENDIF
- FACZZ=FACZZ*WIDS(23,1)
-
- DO 210 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI)
- VI=AI-4D0*EI*XWV
- AVI=AI**2+VI**2
- DO 200 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
- EJ=KCHG(IABS(J),1)/3D0
- AJ=SIGN(1D0,EJ)
- VJ=AJ-4D0*EJ*XWV
- AVJ=AJ**2+VJ**2
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
- 200 CONTINUE
- 210 CONTINUE
- 220 CONTINUE
-
- ELSEIF(ISUB.EQ.72) THEN
-C...Z0 + Z0 -> W+ + W-
- IF(SH.LE.4.01D0*SQMZ) GOTO 250
-
- IF(MSTP(46).LE.2) THEN
-C...Exact scattering ME:s for on-mass-shell gauge bosons
- BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
- CTH2=CTH**2
- TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
- UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
- IF(MAX(TH,UH).GT.-1D0) GOTO 250
- SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
- & (1D0-2D0*SQMZ/SH)
- ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
- ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
- ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
- & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
- & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
- & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
- & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
- ATWIM=0D0
- AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
- & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
- & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
- & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
- & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
- AUWIM=0D0
- A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
- A4IM=0D0
- FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
- & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
- IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
- IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
- & (ASHIM+ATWIM+AUWIM+A4IM)**2)
- IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
- & (ATWIM+AUWIM+A4IM)**2)
-
- ELSE
-C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
- FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
- & ABS(A00U-A20U)**2
- ENDIF
- FACWW=FACWW*WIDS(24,1)
-
- DO 240 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI)
- VI=AI-4D0*EI*XWV
- AVI=AI**2+VI**2
- DO 230 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
- EJ=KCHG(IABS(J),1)/3D0
- AJ=SIGN(1D0,EJ)
- VJ=AJ-4D0*EJ*XWV
- AVJ=AJ**2+VJ**2
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACWW*AVI*AVJ
- 230 CONTINUE
- 240 CONTINUE
- 250 CONTINUE
-
- ELSEIF(ISUB.EQ.73) THEN
-C...Z0 + W+/- -> Z0 + W+/-
- IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
-
- IF(MSTP(46).LE.2) THEN
-C...Exact scattering ME:s for on-mass-shell gauge bosons
- BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
- EP1=1D0-(SQMZ-SQMW)/SH
- EP2=1D0+(SQMZ-SQMW)/SH
- TH=-0.5D0*SH*BE2*(1D0-CTH)
- UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
- IF(MAX(TH,UH).GT.-1D0) GOTO 280
- THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
- ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
- ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
- ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
- & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
- & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
- & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
- ASWIM=0D0
- AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
- & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
- & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
- & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
- & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
- & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
- & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
- & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
- & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
- & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
- & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
- & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
- AUWIM=0D0
- A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
- & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
- A4IM=0D0
- FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
- & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
- IF(MSTP(46).LE.0) FACZW=0D0
- IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
- & (ATHIM+ASWIM+AUWIM+A4IM)**2)
- IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
- & (ASWIM+AUWIM+A4IM)**2)
-
- ELSE
-C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
- FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
- & ABS(A20U+3D0*A11U*DBLE(CTH))**2
- ENDIF
- FACZW=FACZW*WIDS(23,2)
-
- DO 270 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI)
- VI=AI-4D0*EI*XWV
- AVI=AI**2+VI**2
- KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
- DO 260 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
- EJ=KCHG(IABS(J),1)/3D0
- AJ=SIGN(1D0,EJ)
- VJ=AI-4D0*EJ*XWV
- AVJ=AJ**2+VJ**2
- KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
- 260 CONTINUE
- 270 CONTINUE
- 280 CONTINUE
-
- ELSEIF(ISUB.EQ.75) THEN
-C...W+ + W- -> gamma + gamma
-
- ELSEIF(ISUB.EQ.76) THEN
-C...W+ + W- -> Z0 + Z0
- IF(SH.LE.4.01D0*SQMZ) GOTO 310
-
- IF(MSTP(46).LE.2) THEN
-C...Exact scattering ME:s for on-mass-shell gauge bosons
- BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
- CTH2=CTH**2
- TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
- UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
- IF(MAX(TH,UH).GT.-1D0) GOTO 310
- SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
- & (1D0-2D0*SQMZ/SH)
- ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
- ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
- ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
- & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
- & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
- & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
- & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
- ATWIM=0D0
- AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
- & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
- & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
- & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
- & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
- AUWIM=0D0
- A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
- A4IM=0D0
- FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
- & (SH/SQMW)**2*SH2
- IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
- IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
- & (ASHIM+ATWIM+AUWIM+A4IM)**2)
- IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
- & (ATWIM+AUWIM+A4IM)**2)
-
- ELSE
-C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
- FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
- & ABS(A00U-A20U)**2
- ENDIF
- FACZZ=FACZZ*WIDS(23,1)
-
- DO 300 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
- EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
- DO 290 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
- EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
- IF(EI*EJ.GT.0D0) GOTO 290
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
- 290 CONTINUE
- 300 CONTINUE
- 310 CONTINUE
-
- ELSEIF(ISUB.EQ.77) THEN
-C...W+/- + W+/- -> W+/- + W+/-
- IF(SH.LE.4.01D0*SQMW) GOTO 340
-
- IF(MSTP(46).LE.2) THEN
-C...Exact scattering ME:s for on-mass-shell gauge bosons
- BE2=1D0-4D0*SQMW/SH
- BE4=BE2**2
- CTH2=CTH**2
- CTH3=CTH**3
- TH=-0.5D0*SH*BE2*(1D0-CTH)
- UH=-0.5D0*SH*BE2*(1D0+CTH)
- IF(MAX(TH,UH).GT.-1D0) GOTO 340
- SHANG=(1D0+BE2)**2
- ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
- ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
- THANG=(BE2-CTH)**2
- ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
- ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
- UHANG=(BE2+CTH)**2
- AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
- AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
- SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
- ASGRE=XW*SGZANG
- ASGIM=0D0
- ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
- ASZIM=0D0
- TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
- & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
- ATGRE=0.5D0*XW*SH/TH*TGZANG
- ATGIM=0D0
- ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
- ATZIM=0D0
- UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
- & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
- AUGRE=0.5D0*XW*SH/UH*UGZANG
- AUGIM=0D0
- AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
- AUZIM=0D0
- A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
- A4AIM=0D0
- A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
- A4SIM=0D0
- FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
- & (SH/SQMW)**2*SH2
- IF(MSTP(46).LE.0) THEN
- AWWARE=ASHRE
- AWWAIM=ASHIM
- AWWSRE=0D0
- AWWSIM=0D0
- ELSEIF(MSTP(46).EQ.1) THEN
- AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
- AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
- AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
- AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
- ELSE
- AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
- AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
- AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
- AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
- ENDIF
- AWWA2=AWWARE**2+AWWAIM**2
- AWWS2=AWWSRE**2+AWWSIM**2
-
- ELSE
-C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
- FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
- & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
- FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
- ENDIF
-
- DO 330 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
- EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
- DO 320 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
- EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
- IF(EI*EJ.LT.0D0) THEN
-C...W+W-
- IF(MSTP(45).EQ.1) GOTO 320
- IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
- IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
- ELSE
-C...W+W+/W-W-
- IF(MSTP(45).EQ.2) GOTO 320
- IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
- IF(MSTP(46).GE.3) FACWW=FWWS
- IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
- IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
- ENDIF
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
- IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
- 320 CONTINUE
- 330 CONTINUE
- 340 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.120) THEN
- IF(ISUB.EQ.102) THEN
-C...g + g -> h0 (or H0, or A0)
- CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
- WDTP13=0D0
- DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
- IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
- & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
- 345 CONTINUE
- IF(WDTP13.EQ.0D0) CALL PYERRM(26,
- & '(PYSGHG:) did not find Higgs -> g g channel')
- HS=SHR*WDTP(0)
- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
- IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
- & FACBW=0D0
- HI=SHR*WDTP13/32D0
- IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=HI*FACBW*HF
- 350 CONTINUE
-
- ELSEIF(ISUB.EQ.103) THEN
-C...gamma + gamma -> h0 (or H0, or A0)
- CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
- WDTP14=0D0
- DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
- IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
- & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
- 355 CONTINUE
- IF(WDTP14.EQ.0D0) CALL PYERRM(26,
- & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
- HS=SHR*WDTP(0)
- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
- IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
- & FACBW=0D0
- HI=SHR*WDTP14*2D0
- IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
- NCHN=NCHN+1
- ISIG(NCHN,1)=22
- ISIG(NCHN,2)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=HI*FACBW*HF
- 360 CONTINUE
-
- ELSEIF(ISUB.EQ.110) THEN
-C...f + fbar -> gamma + h0
- THUH=MAX(TH*UH,SH*CKIN(3)**2)
- FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
- FACHG=FACHG*WIDS(KFHIGG,2)
-C...Calculate loop contributions for intermediate gamma* and Z0
- CIGTOT=DCMPLX(0D0,0D0)
- CIZTOT=DCMPLX(0D0,0D0)
- JMAX=3*MSTP(1)+1
- DO 370 J=1,JMAX
- IF(J.LE.2*MSTP(1)) THEN
- FNC=1D0
- EJ=KCHG(J,1)/3D0
- AJ=SIGN(1D0,EJ+0.1D0)
- VJ=AJ-4D0*EJ*XWV
- BALP=SQM4/(2D0*PMAS(J,1))**2
- BBET=SH/(2D0*PMAS(J,1))**2
- ELSEIF(J.LE.3*MSTP(1)) THEN
- FNC=3D0
- JL=2*(J-2*MSTP(1))-1
- EJ=KCHG(10+JL,1)/3D0
- AJ=SIGN(1D0,EJ+0.1D0)
- VJ=AJ-4D0*EJ*XWV
- BALP=SQM4/(2D0*PMAS(10+JL,1))**2
- BBET=SH/(2D0*PMAS(10+JL,1))**2
- ELSE
- BALP=SQM4/(2D0*PMAS(24,1))**2
- BBET=SH/(2D0*PMAS(24,1))**2
- ENDIF
- BABI=1D0/(BALP-BBET)
- IF(BALP.LT.1D0) THEN
- F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
- F1ALP=F0ALP**2
- ELSE
- F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
- & -DBLE(0.5D0*PARU(1)))
- F1ALP=-F0ALP**2
- ENDIF
- F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
- IF(BBET.LT.1D0) THEN
- F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
- F1BET=F0BET**2
- ELSE
- F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
- & -DBLE(0.5D0*PARU(1)))
- F1BET=-F0BET**2
- ENDIF
- F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
- IF(J.LE.3*MSTP(1)) THEN
- FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
- & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
- CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
- CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
- ELSE
- TXW=XW/XW1
- CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
- & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
- & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
- CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
- & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
- & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
- & (F1BET-F1ALP))
- ENDIF
- 370 CONTINUE
- CIGTOT=CIGTOT/DBLE(SH)
- CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
-C...Loop over initial flavours
- DO 380 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI)
- VI=AI-4D0*EI*XWV
- FCOI=1D0
- IF(IABS(I).LE.10) FCOI=FACA/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
- & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
- 380 CONTINUE
-
- ELSEIF(ISUB.EQ.111) THEN
-C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
- IF(MSTP(38).NE.0) THEN
-C...Simple case: only do gg <-> h exactly.
- CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
- WDTP13=0D0
- DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
- IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
- & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
- 385 CONTINUE
- IF(WDTP13.EQ.0D0) CALL PYERRM(26,
- & '(PYSGHG:) did not find Higgs -> g g channel')
- FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
- & (TH**2+UH**2)/(SH*SQM4)
-C...Propagators: as simulated in PYOFSH and as desired
- HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
- GMMHC=SQRT(SQM4)*WDTP(0)
- HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
- & ((SQM4-SQMH)**2+GMMHC**2)
- FACGH=FACGH*HBW4C/HBW4
- ELSE
-C...Messy case: do full loop integrals
- A5STUR=0D0
- A5STUI=0D0
- DO 390 I=1,2*MSTP(1)
- SQMQ=PMAS(I,1)**2
- EPSS=4D0*SQMQ/SH
- EPSH=4D0*SQMQ/SQMH
- CALL PYWAUX(1,EPSS,W1SR,W1SI)
- CALL PYWAUX(1,EPSH,W1HR,W1HI)
- CALL PYWAUX(2,EPSS,W2SR,W2SI)
- CALL PYWAUX(2,EPSH,W2HR,W2HI)
- A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
- & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
- A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
- & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
- 390 CONTINUE
- FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
- & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
- FACGH=FACGH*WIDS(25,2)
- ENDIF
- DO 400 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACGH
- 400 CONTINUE
-
- ELSEIF(ISUB.EQ.112) THEN
-C...f + g -> f + h0 (q + g -> q + h0 only)
- IF(MSTP(38).NE.0) THEN
-C...Simple case: only do gg <-> h exactly.
- CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
- WDTP13=0D0
- DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
- IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
- & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
- 405 CONTINUE
- IF(WDTP13.EQ.0D0) CALL PYERRM(26,
- & '(PYSGHG:) did not find Higgs -> g g channel')
- FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
- & (SH**2+UH**2)/(-TH*SQM4)
-C...Propagators: as simulated in PYOFSH and as desired
- HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
- GMMHC=SQRT(SQM4)*WDTP(0)
- HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
- & ((SQM4-SQMH)**2+GMMHC**2)
- FACQH=FACQH*HBW4C/HBW4
- ELSE
-C...Messy case: do full loop integrals
- A5TSUR=0D0
- A5TSUI=0D0
- DO 410 I=1,2*MSTP(1)
- SQMQ=PMAS(I,1)**2
- EPST=4D0*SQMQ/TH
- EPSH=4D0*SQMQ/SQMH
- CALL PYWAUX(1,EPST,W1TR,W1TI)
- CALL PYWAUX(1,EPSH,W1HR,W1HI)
- CALL PYWAUX(2,EPST,W2TR,W2TI)
- CALL PYWAUX(2,EPSH,W2HR,W2HI)
- A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
- & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
- A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
- & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
- 410 CONTINUE
- FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
- & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
- FACQH=FACQH*WIDS(25,2)
- ENDIF
- DO 430 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
- DO 420 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQH
- 420 CONTINUE
- 430 CONTINUE
-
- ELSEIF(ISUB.EQ.113) THEN
-C...g + g -> g + h0
- IF(MSTP(38).NE.0) THEN
-C...Simple case: only do gg <-> h exactly.
- CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
- WDTP13=0D0
- DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
- IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
- & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
- 435 CONTINUE
- IF(WDTP13.EQ.0D0) CALL PYERRM(26,
- & '(PYSGHG:) did not find Higgs -> g g channel')
- FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
- & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
-C...Propagators: as simulated in PYOFSH and as desired
- HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
- GMMHC=SQRT(SQM4)*WDTP(0)
- HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
- & ((SQM4-SQMH)**2+GMMHC**2)
- FACGH=FACGH*HBW4C/HBW4
- ELSE
-C...Messy case: do full loop integrals
- A2STUR=0D0
- A2STUI=0D0
- A2USTR=0D0
- A2USTI=0D0
- A2TUSR=0D0
- A2TUSI=0D0
- A4STUR=0D0
- A4STUI=0D0
- DO 440 I=1,2*MSTP(1)
- SQMQ=PMAS(I,1)**2
- EPSS=4D0*SQMQ/SH
- EPST=4D0*SQMQ/TH
- EPSU=4D0*SQMQ/UH
- EPSH=4D0*SQMQ/SQMH
- IF(EPSH.LT.1D-6) GOTO 440
- CALL PYWAUX(1,EPSS,W1SR,W1SI)
- CALL PYWAUX(1,EPST,W1TR,W1TI)
- CALL PYWAUX(1,EPSU,W1UR,W1UI)
- CALL PYWAUX(1,EPSH,W1HR,W1HI)
- CALL PYWAUX(2,EPSS,W2SR,W2SI)
- CALL PYWAUX(2,EPST,W2TR,W2TI)
- CALL PYWAUX(2,EPSU,W2UR,W2UI)
- CALL PYWAUX(2,EPSH,W2HR,W2HI)
- CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
- CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
- CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
- CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
- CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
- CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
- CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
- CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
- CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
- CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
- CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
- CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
- W3STUR=YHSTUR-Y3STUR-Y3UTSR
- W3STUI=YHSTUI-Y3STUI-Y3UTSI
- W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
- W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
- W3TSUR=YHTSUR-Y3TSUR-Y3USTR
- W3TSUI=YHTSUI-Y3TSUI-Y3USTI
- W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
- W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
- W3USTR=YHUSTR-Y3USTR-Y3TSUR
- W3USTI=YHUSTI-Y3USTI-Y3TSUI
- W3UTSR=YHUTSR-Y3UTSR-Y3STUR
- W3UTSI=YHUTSI-Y3UTSI-Y3STUI
- B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
- & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
- & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
- & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
- & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
- B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
- & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
- & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
- & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
- & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
- B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
- & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
- & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
- & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
- & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
- B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
- & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
- & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
- & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
- & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
- B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
- & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
- & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
- & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
- & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
- B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
- & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
- & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
- & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
- & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
- B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
- & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
- & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
- & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
- & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
- B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
- & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
- & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
- & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
- & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
- B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
- & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
- & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
- & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
- & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
- B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
- & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
- & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
- & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
- & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
- B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
- & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
- & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
- & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
- & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
- B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
- & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
- & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
- & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
- & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
- B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
- & (W2SR-W2HR+W3STUR))
- B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
- B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
- & (W2TR-W2HR+W3TUSR))
- B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
- B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
- & (W2UR-W2HR+W3USTR))
- B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
- A2STUR=A2STUR+B2STUR+B2SUTR
- A2STUI=A2STUI+B2STUI+B2SUTI
- A2USTR=A2USTR+B2USTR+B2UTSR
- A2USTI=A2USTI+B2USTI+B2UTSI
- A2TUSR=A2TUSR+B2TUSR+B2TSUR
- A2TUSI=A2TUSI+B2TUSI+B2TSUI
- A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
- A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
- 440 CONTINUE
- FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
- & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
- & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
- FACGH=FACGH*WIDS(25,2)
- ENDIF
- IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACGH
- 450 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.170) THEN
- IF(ISUB.EQ.121) THEN
-C...g + g -> Q + Qbar + h0
- IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
- IA=KFPR(ISUBSV,2)
- PMF=PYMRUN(IA,SH)
- FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
- & (0.5D0*PMF/PMAS(24,1))**2
- WID2=1D0
- IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
- FACQQH=FACQQH*WID2
- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
- IKFI=1
- IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
- IF(IA.GT.10) IKFI=3
- FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
- IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
- FACQQH=FACQQH/(1D0+RMSS(41))**2
- IF(IHIGG.NE.3) THEN
- FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
- & PARU(151+10*IHIGG))**2
- ENDIF
- ENDIF
- ENDIF
- CALL PYQQBH(WTQQBH)
- CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
- IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
- & FACBW=0D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQH*WTQQBH*FACBW
- 460 CONTINUE
-
- ELSEIF(ISUB.EQ.122) THEN
-C...q + qbar -> Q + Qbar + h0
- IA=KFPR(ISUBSV,2)
- PMF=PYMRUN(IA,SH)
- FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
- & (0.5D0*PMF/PMAS(24,1))**2
- WID2=1D0
- IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
- FACQQH=FACQQH*WID2
- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
- IKFI=1
- IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
- IF(IA.GT.10) IKFI=3
- FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
- IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
- FACQQH=FACQQH/(1D0+RMSS(41))**2
- IF(IHIGG.NE.3) THEN
- FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
- & PARU(151+10*IHIGG))**2
- ENDIF
- ENDIF
- ENDIF
- CALL PYQQBH(WTQQBH)
- CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
- IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
- & FACBW=0D0
- DO 470 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQH*WTQQBH*FACBW
- 470 CONTINUE
-
- ELSEIF(ISUB.EQ.123) THEN
-C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
-C...inner process)
- FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
- & PARU(154+10*IHIGG)**2
- FACPRP=1D0/((VINT(215)-VINT(204)**2)*
- & (VINT(216)-VINT(209)**2))**2
- FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
- FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
- CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
- IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
- & FACBW=0D0
- DO 490 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
- IA=IABS(I)
- DO 480 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
- JA=IABS(J)
- EI=KCHG(IA,1)*ISIGN(1,I)/3D0
- AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
- VI=AI-4D0*EI*XWV
- EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
- AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
- VJ=AJ-4D0*EJ*XWV
- FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
- FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
- 480 CONTINUE
- 490 CONTINUE
-
- ELSEIF(ISUB.EQ.124) THEN
-C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
-C...inner process)
- FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
- & PARU(155+10*IHIGG)**2
- FACPRP=1D0/((VINT(215)-VINT(204)**2)*
- & (VINT(216)-VINT(209)**2))**2
- FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
- CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
- IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
- & FACBW=0D0
- DO 510 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
- EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
- DO 500 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
- EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
- IF(EI*EJ.GT.0D0) GOTO 500
- FACLR=VINT(180+I)*VINT(180+J)
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACLR*FACWW*FACBW
- 500 CONTINUE
- 510 CONTINUE
-
- ELSEIF(ISUB.EQ.143) THEN
-C...f + fbar' -> H+/-
- SQMHC=PMAS(37,1)**2
- CALL PYWIDT(37,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
- HP=AEM/(8D0*XW)*SH/SQMW*SH
- DO 530 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
- IA=IABS(I)
- IM=(MOD(IA,10)+1)/2
- DO 520 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
- JA=IABS(J)
- JM=(MOD(JA,10)+1)/2
- IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
- IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
- & GOTO 520
- IF(MOD(IA,2).EQ.0) THEN
- IU=IA
- IL=JA
- ELSE
- IU=JA
- IL=IA
- ENDIF
- RML=PYMRUN(IL,SH)**2/SH
- RMU=PYMRUN(IU,SH)**2/SH
- HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
- IF(IA.LE.10) HI=HI*FACA/3D0
- KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
- HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=HI*FACBW*HF
- 520 CONTINUE
- 530 CONTINUE
-
- ELSEIF(ISUB.EQ.161) THEN
-C...f + g -> f' + H+/- (b + g -> t + H+/- only)
-C...(choice of only b and t to avoid kinematics problems)
- FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
-C...H propagator: as simulated in PYOFSH and as desired
- SQMHC=PMAS(37,1)**2
- GMMHC=PMAS(37,1)*PMAS(37,2)
- HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
- CALL PYWIDT(37,SQM4,WDTP,WDTE)
- GMMHCC=SQRT(SQM4)*WDTP(0)
- HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
- FHCQ=FHCQ*HBW4C/HBW4
- Q2RM=SH
- IF(MSTP(32).EQ.12) Q2RM=PARP(194)
- DO 550 I=MMINA,MMAXA
- IA=IABS(I)
- IF(IA.NE.5) GOTO 550
- SQML=PYMRUN(IA,Q2RM)**2
- IUA=IA+MOD(IA,2)
- SQMQ=PYMRUN(IUA,Q2RM)**2
- FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
- & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
- & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
- & (SQMHC-SQMQ-SH)/SH)
- KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
- DO 540 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
- IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
- 540 CONTINUE
- 550 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.402) THEN
- IF(ISUB.EQ.401) THEN
-C... g + g -> t + bbar + H-
- IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
- IA=KFPR(ISUBSV,2)
- CALL PYSTBH(WTTBH)
- CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
- IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
- & FACBW=0D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
-c Since we don't know yet if H+ or H-, assume H+
-c when calculating suppression due to closed channels.
- SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
- IF(ABS(WIDS(37,2)-WIDS(37,3))
- & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
- & ABS(WIDS(6,2)-WIDS(6,3))
- & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
- WRITE(*,*)'Error: Process 401 cannot handle different'
- WRITE(*,*)'decays for H+ and H- or t and tbar.'
- WRITE(*,*)'Execution stopped.'
- CALL PYSTOP(108)
- END IF
- 560 CONTINUE
-
- ELSEIF(ISUB.EQ.402) THEN
-C... q + qbar -> t + bbar + H-
- IA=KFPR(ISUBSV,2)
- CALL PYSTBH(WTTBH)
- CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
- IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
- & FACBW=0D0
- DO 570 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
-c Since we don't know yet if H+ or H-, assume H+
-c when calculating suppression due to closed channels.
- SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
- IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
- & .GE.1D-6.OR.
- & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
- & .GE.1D-6) THEN
- WRITE(*,*)'Error: Process 402 cannot handle different'
- WRITE(*,*)'decays for H+ and H- or t and tbar.'
- WRITE(*,*)'Execution stopped.'
- CALL PYSTOP(108)
- END IF
- 570 CONTINUE
- ENDIF
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSGSU
-C...Subprocess cross sections for SUSY processes,
-C...including Higgs pair production.
-C...Auxiliary to PYSIGH.
-
- SUBROUTINE PYSGSU(NCHN,SIGS)
-
-C...Double precision and integer declarations
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
- &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
- &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
- &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
- SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
- &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
-C...Local arrays and complex variables
- DIMENSION WDTP(0:400),WDTE(0:400,0:5)
- COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
- COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
- COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
-
-CMRENNA++
-C...Z and W width, combinations of weak mixing angle
- ZWID=PMAS(23,2)
- WWID=PMAS(24,2)
- TANW=SQRT(XW/XW1)
- CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
-
-C...Convert almost equivalent SUSY processes into each other
-C...Extract differences in flavours and couplings
-
-C...Sleptons and sneutrinos
- IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
- KFID=MOD(KFPR(ISUB,1),KSUSY1)
- ISUB=201
- ILR=0
- ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
- KFID=MOD(KFPR(ISUB,1),KSUSY1)
- ISUB=201
- ILR=1
- ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
- KFID=MOD(KFPR(ISUB,1),KSUSY1)
- ISUB=203
- ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
- IF(ISUB.EQ.210) THEN
- RKF=2.0D0
- ELSEIF(ISUB.EQ.211) THEN
- RKF=SFMIX(15,1)**2
- ELSEIF(ISUB.EQ.212) THEN
- RKF=SFMIX(15,2)**2
- ENDIF
- ISUB=210
- ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
- IF(ISUB.EQ.213) THEN
- KFID=MOD(KFPR(ISUB,1),KSUSY1)
- RKF=2.0D0
- ELSEIF(ISUB.EQ.214) THEN
- KFID=16
- RKF=1.0D0
- ENDIF
- ISUB=213
-
-C...Neutralinos
- ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
- IF(ISUB.EQ.216) THEN
- IZID1=1
- IZID2=1
- ELSEIF(ISUB.EQ.217) THEN
- IZID1=2
- IZID2=2
- ELSEIF(ISUB.EQ.218) THEN
- IZID1=3
- IZID2=3
- ELSEIF(ISUB.EQ.219) THEN
- IZID1=4
- IZID2=4
- ELSEIF(ISUB.EQ.220) THEN
- IZID1=1
- IZID2=2
- ELSEIF(ISUB.EQ.221) THEN
- IZID1=1
- IZID2=3
- ELSEIF(ISUB.EQ.222) THEN
- IZID1=1
- IZID2=4
- ELSEIF(ISUB.EQ.223) THEN
- IZID1=2
- IZID2=3
- ELSEIF(ISUB.EQ.224) THEN
- IZID1=2
- IZID2=4
- ELSEIF(ISUB.EQ.225) THEN
- IZID1=3
- IZID2=4
- ENDIF
- ISUB=216
-
-C...Charginos
- ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
- IF(ISUB.EQ.226) THEN
- IZID1=1
- IZID2=1
- ELSEIF(ISUB.EQ.227) THEN
- IZID1=2
- IZID2=2
- ELSEIF(ISUB.EQ.228) THEN
- IZID1=1
- IZID2=2
- ENDIF
- ISUB=226
-
-C...Neutralino + chargino
- ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
- IF(ISUB.EQ.229) THEN
- IZID1=1
- IZID2=1
- ELSEIF(ISUB.EQ.230) THEN
- IZID1=1
- IZID2=2
- ELSEIF(ISUB.EQ.231) THEN
- IZID1=1
- IZID2=3
- ELSEIF(ISUB.EQ.232) THEN
- IZID1=1
- IZID2=4
- ELSEIF(ISUB.EQ.233) THEN
- IZID1=2
- IZID2=1
- ELSEIF(ISUB.EQ.234) THEN
- IZID1=2
- IZID2=2
- ELSEIF(ISUB.EQ.235) THEN
- IZID1=2
- IZID2=3
- ELSEIF(ISUB.EQ.236) THEN
- IZID1=2
- IZID2=4
- ENDIF
- ISUB=229
-
-C...Gluino + neutralino
- ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
- IF(ISUB.EQ.237) THEN
- IZID=1
- ELSEIF(ISUB.EQ.238) THEN
- IZID=2
- ELSEIF(ISUB.EQ.239) THEN
- IZID=3
- ELSEIF(ISUB.EQ.240) THEN
- IZID=4
- ENDIF
- ISUB=237
-
-C...Gluino + chargino
- ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
- IF(ISUB.EQ.241) THEN
- IZID=1
- ELSEIF(ISUB.EQ.242) THEN
- IZID=2
- ENDIF
- ISUB=241
-
-C...Squark + neutralino
- ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
- ILR=0
- IF(MOD(ISUB,2).NE.0) ILR=1
- IF(ISUB.LE.247) THEN
- IZID=1
- ELSEIF(ISUB.LE.249) THEN
- IZID=2
- ELSEIF(ISUB.LE.251) THEN
- IZID=3
- ELSEIF(ISUB.LE.253) THEN
- IZID=4
- ENDIF
- ISUB=246
- RKF=5D0
-
-C...Squark + chargino
- ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
- IF(ISUB.LE.255) THEN
- IZID=1
- ELSEIF(ISUB.LE.257) THEN
- IZID=2
- ENDIF
- IF(MOD(ISUB,2).EQ.0) THEN
- ILR=0
- ELSE
- ILR=1
- ENDIF
- ISUB=254
- RKF=5D0
-
-C...Squark + gluino
- ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
- ISUB=258
- RKF=4D0
-
-C...Stops
- ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
- ILR=0
- IF(ISUB.EQ.262) ILR=1
- ISUB=261
- ELSEIF(ISUB.EQ.265) THEN
- ISUB=264
-
-C...Squarks
- ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
- ILR=0
- IF(ISUB.LE.273) THEN
- IF(ISUB.EQ.273) ILR=1
- ISUB=271
- RKF=16D0
- ELSEIF(ISUB.LE.276) THEN
- IF(ISUB.EQ.276) ILR=1
- ISUB=274
- RKF=16D0
- ELSEIF(ISUB.LE.278) THEN
- IF(ISUB.EQ.278) ILR=1
- ISUB=277
- RKF=4D0
- ELSE
- IF(ISUB.EQ.280) ILR=1
- ISUB=279
- RKF=4D0
- ENDIF
-C...Sbottoms
- ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
- ILR=0
- IF(ISUB.LE.283) THEN
- IF(ISUB.EQ.283) ILR=1
- ISUB=271
- RKF=4D0
- ELSEIF(ISUB.LE.286) THEN
- IF(ISUB.EQ.286) ILR=1
- ISUB=274
- RKF=4D0
- ELSEIF(ISUB.LE.288) THEN
- IF(ISUB.EQ.288) ILR=1
- ISUB=277
- RKF=1D0
- ELSEIF(ISUB.LE.290) THEN
- IF(ISUB.EQ.290) ILR=1
- ISUB=279
- RKF=1D0
- ELSEIF(ISUB.LE.293) THEN
- IF(ISUB.EQ.293) ILR=1
- ISUB=271
- RKF=1D0
- ELSEIF(ISUB.EQ.296) THEN
- ILR=1
- ISUB=274
- RKF=1D0
-C...Squark + gluino
- ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
- ISUB=258
- RKF=1D0
- ENDIF
-C...H+/- + H0
- ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
- IF(ISUB.EQ.297) THEN
- RKF=.5D0*PARU(195)**2
- ELSEIF(ISUB.EQ.298) THEN
- RKF=.5D0*(1D0-PARU(195)**2)
- ENDIF
- ISUB=210
-C...A0 + H0
- ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
- IF(ISUB.EQ.299) THEN
- RKF=PARU(186)**2
- KFID=25
- ELSEIF(ISUB.EQ.300) THEN
- RKF=PARU(187)**2
- KFID=35
- ENDIF
- ISUB=213
-C...H+ + H-
- ELSEIF(ISUB.EQ.301) THEN
- KFID=37
- RKF=1D0
- ISUB=201
- ENDIF
-
-C...Supersymmetric processes - all of type 2 -> 2 :
-C...correct final-state Breit-Wigners from fixed to running width.
- IF(MSTP(42).GT.0) THEN
- DO 100 I=1,2
- KFLW=KFPR(ISUBSV,I)
- KCW=PYCOMP(KFLW)
- IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
- IF(I.EQ.1) SQMI=SQM3
- IF(I.EQ.2) SQMI=SQM4
- SQMS=PMAS(KCW,1)**2
- GMMS=PMAS(KCW,1)*PMAS(KCW,2)
- HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
- CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
- GMMI=SQRT(SQMI)*WDTP(0)
- HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
- COMFAC=COMFAC*(HBWI/HBWS)
- 100 CONTINUE
- ENDIF
-
-C...Differential cross section expressions.
-
- IF(ISUB.LE.210) THEN
- IF(ISUB.EQ.201) THEN
-C...f + fbar -> e_L + e_Lbar
- COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
- DO 130 I=MMIN1,MMAX1
- IA=IABS(I)
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
- EI=KCHG(IA,1)/3D0
- TT3I=SIGN(1D0,EI+1D-6)/2D0
- EJ=-1D0
- TT3J=-1D0/2D0
- FCOL=1D0
-C...Color factor for e+ e-
- IF(IA.GE.11) FCOL=3D0
- IF(ISUBSV.EQ.301) THEN
- A1=1D0
- A2=0D0
- ELSEIF(ILR.EQ.1) THEN
- A1=SFMIX(KFID,3)**2
- A2=SFMIX(KFID,4)**2
- ELSEIF(ILR.EQ.0) THEN
- A1=SFMIX(KFID,1)**2
- A2=SFMIX(KFID,2)**2
- ENDIF
- XLQ=(TT3J-EJ*XW)*A1
- XRQ=(-EJ*XW)*A2
- XLF=(TT3I-EI*XW)
- XRF=(-EI*XW)
- TAA=(EI*EJ)**2*(POLL+POLR)
- TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
- TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
- TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
- TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
- TNN=0.0D0
- TAN=0.0D0
- TZN=0.0D0
- IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
- FAC2=SQRT(2D0)
- TNN1=0D0
- TNN2=0D0
- TNN3=0D0
- DO 120 II=1,4
- DK=1D0/(TH-SMZ(II)**2)
- FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
- & ZMIX(II,1))
- FREK=FAC2*TANW*EI*ZMIX(II,1)
- TNN1=TNN1+FLEK**2*DK
- TNN2=TNN2+FREK**2*DK
- DO 110 JJ=1,4
- DL=1D0/(TH-SMZ(JJ)**2)
- FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
- & ZMIX(JJ,1))
- FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
- TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
- 110 CONTINUE
- 120 CONTINUE
- TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
- & A2**2*TNN2**2*POLR)
- TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
- & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
- TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
- & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
- TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
- & (1D0-SQMZ/SH)/SH
- TZN=TZN/XW**2/XW1
- TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
- & A2*TNN2*POLR)/XW
- ENDIF
- FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
- FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
- FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ1+FACQQ2
- 130 CONTINUE
-
- ELSEIF(ISUB.EQ.203) THEN
-C...f + fbar -> e_L + e_Rbar
- DO 160 I=MMIN1,MMAX1
- IA=IABS(I)
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
- EI=KCHG(IABS(I),1)/3D0
- TT3I=SIGN(1D0,EI)/2D0
- EJ=-1
- TT3J=-1D0/2D0
- FCOL=1D0
-C...Color factor for e+ e-
- IF(IA.GE.11) FCOL=3D0
- A1=SFMIX(KFID,1)**2
- A2=SFMIX(KFID,2)**2
- XLQ=(TT3J-EJ*XW)
- XRQ=(-EJ*XW)
- XLF=(TT3I-EI*XW)
- XRF=(-EI*XW)
- TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
- & /XW**2/XW1**2*A1*A2
- TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
- TNN=0.0D0
- TZN=0.0D0
- TNNA=0D0
- TNNB=0D0
- IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
- FAC2=SQRT(2D0)
- TNN1=0D0
- TNN2=0D0
- TNN3=0D0
- DO 150 II=1,4
- DK=1D0/(TH-SMZ(II)**2)
- FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
- & ZMIX(II,1))
- FREK=FAC2*TANW*EI*ZMIX(II,1)
- TNN1=TNN1+FLEK**2*DK
- TNN2=TNN2+FREK**2*DK
- DO 140 JJ=1,4
- DL=1D0/(TH-SMZ(JJ)**2)
- FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
- & ZMIX(JJ,1))
- FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
- TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
- 140 CONTINUE
- 150 CONTINUE
- TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
- TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
- TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
- TZN=(UH*TH-SQM3*SQM4)*A1*A2
- TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
- TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
- & (1D0-SQMZ/SH)/SH
- ENDIF
- FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
- FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
- FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
-C%%%%%%%%%%%
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=2
- SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
- 160 CONTINUE
-
- ELSEIF(ISUB.EQ.210) THEN
-C...q + qbar' -> W*- > ~l_L + ~nu_L
- FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
- FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
- DO 180 I=MMIN1,MMAX1
- IA=IABS(I)
- IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
- DO 170 J=MMIN2,MMAX2
- JA=IABS(J)
- IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
- IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
- FCKM=3D0
- IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
- KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
- KCHW=2
- IF(KCHSUM.LT.0) KCHW=3
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
- FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
- ELSE
- FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
- ENDIF
- SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
- 170 CONTINUE
- 180 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.220) THEN
- IF(ISUB.EQ.213) THEN
-C...f + fbar -> ~nu_L + ~nu_Lbar
- IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
- FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
- ELSE
- FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
- ENDIF
- COMFAC=COMFAC*FACR
- PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
- XLL=0.5D0
- XLR=0.0D0
- DO 190 I=MMIN1,MMAX1
- IA=IABS(I)
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
- EI=KCHG(IA,1)/3D0
- FCOL=1D0
-C...Color factor for e+ e-
- IF(IA.GE.11) FCOL=3D0
- XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
- XRQ=-EI*XW
- TZC=0.0D0
- TCC=0.0D0
- IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
- TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
- & (TH-SMW(2)**2)
- TCC=TZC**2
- TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
- ENDIF
- FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
- FACQQ2=TZC+TCC/4D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
- & *AEM**2*FCOL/3D0/XW**2
- 190 CONTINUE
-
- ELSEIF(ISUB.EQ.216) THEN
-C...q + qbar -> ~chi0_1 + ~chi0_1
- IF(IZID1.EQ.IZID2) THEN
- COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
- ELSE
- COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
- ENDIF
- FACXX=COMFAC*AEM**2/3D0/XW**2
- IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
- ZM12=SQM3
- ZM22=SQM4
- WU2 = (UH-ZM12)*(UH-ZM22)
- WT2 = (TH-ZM12)*(TH-ZM22)
- WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
- PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
- PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
- DO 200 I=1,4
- ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
- IF(IZID2.NE.IZID1) THEN
- ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
- ENDIF
- 200 CONTINUE
- OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
- & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
- ORPP=DCONJG(OLPP)
- DO 210 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
- EI=KCHG(IABS(I),1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
- XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
- GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
- & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
- GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
- QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
- QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
- & /DCMPLX(TH-XML2)
- QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
- QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
- & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
- FCOL=1D0
- IF(IABS(I).GE.11) FCOL=3D0
- FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
- & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
- & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
- & QRL*DCONJG(QRR)*POLR)*WS2
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACXX*FACGG1*FCOL
- 210 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.230) THEN
- IF(ISUB.EQ.226) THEN
-C...f + fbar -> ~chi+_1 + ~chi-_1
- FACXX=COMFAC*AEM**2/3D0
- ZM12=SQM3
- ZM22=SQM4
- WU2 = (UH-ZM12)*(UH-ZM22)
- WT2 = (TH-ZM12)*(TH-ZM22)
- WS2 = SMW(IZID1)*SMW(IZID2)*SH
- PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
- PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
- DIFF=0D0
- IF(IZID1.EQ.IZID2) DIFF=1D0
- DO 220 I=1,2
- VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
- UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
- IF(IZID2.NE.IZID1) THEN
- VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
- UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
- ENDIF
- 220 CONTINUE
- OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
- & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
- ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
- & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
- DO 230 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
- EI=KCHG(IABS(I),1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
- QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
- QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
- IF(MOD(I,2).EQ.0) THEN
- XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
- QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
- & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
- & DCMPLX(T3I/XW/(TH-XML2))
- ELSE
- XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
- QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
- & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
- & DCMPLX(T3I/XW/(TH-XML2))
- ENDIF
- FCOL=1D0
- IF(IABS(I).GE.11) FCOL=3D0
- FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
- & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
- & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
- & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- IF(IZID1.EQ.IZID2) THEN
- SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
- ELSE
- SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
- ENDIF
- 230 CONTINUE
-
- ELSEIF(ISUB.EQ.229) THEN
-C...q + qbar' -> ~chi0_1 + ~chi+-_1
- FACXX=COMFAC*AEM**2/6D0/XW**2
- ZM12=SQM3
- ZM22=SQM4
- WU2 = (UH-ZM12)*(UH-ZM22)
- WT2 = (TH-ZM12)*(TH-ZM22)
- WS2 = SMW(IZID1)*SMZ(IZID2)*SH
- RT2I = 1D0/SQRT(2D0)
- PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
- & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
- DO 240 I=1,2
- VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
- UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
- 240 CONTINUE
- DO 250 I=1,4
- ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
- 250 CONTINUE
- OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
- & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
- OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
- & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
-
- DO 270 I=MMIN1,MMAX1
- IA=IABS(I)
- IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
- EI=KCHG(IA,1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- DO 260 J=MMIN2,MMAX2
- JA=IABS(J)
- IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
- IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
- EJ=KCHG(JA,1)/3D0
- T3J=SIGN(1D0,EJ+1D-6)/2D0
- FCKM=3D0
- IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
- KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
- KCHW=2
- IF(KCHSUM.LT.0) KCHW=3
- IF(MOD(IA,2).EQ.0) THEN
- ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
- ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
- QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
- & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
- QLR=OR-DCONJG(UMIXC(IZID1,1))*(
- & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
- & /DCMPLX(TH-ZMJ2)
- ELSE
- ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
- ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
- QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
- & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
- QLR=OR-DCONJG(UMIXC(IZID1,1))*(
- & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
- & /DCMPLX(TH-ZMI2)
- ENDIF
- ZINTR=DBLE(QLR*DCONJG(QLL))
- FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
- & 2D0*ZINTR*WS2)
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
- 260 CONTINUE
- 270 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.240) THEN
- IF(ISUB.EQ.237) THEN
-C...q + qbar -> gluino + ~chi0_1
- COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
- ASYUK=RMSS(42)*AS
- FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
- GM2=SQM3
- ZM2=SQM4
- DO 280 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
- EI=KCHG(IABS(I),1)/3D0
- IA=IABS(I)
- XLQC = -TANW*EI*ZMIX(IZID,1)
- XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
- & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
- XLQ2=XLQC**2
- XRQ2=XRQC**2
- XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
- XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
- ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
- AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
- ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
- SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
- ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
- AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
- ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
- SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
- 280 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.250) THEN
- IF(ISUB.EQ.241) THEN
-C...q + qbar' -> ~chi+-_1 + gluino
- FACWG=COMFAC*AS*AEM/XW*2D0/9D0
- GM2=SQM3
- ZM2=SQM4
- FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
- FAC0=UMIX(IZID,1)**2
- FAC1=VMIX(IZID,1)**2
- DO 300 I=MMIN1,MMAX1
- IA=IABS(I)
- IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
- DO 290 J=MMIN2,MMAX2
- JA=IABS(J)
- IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
- IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
- FCKM=1D0
- IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
- KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
- KCHW=2
- IF(KCHSUM.LT.0) KCHW=3
- XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
- XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
- ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
- AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
- ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
- XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
- XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
- ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
- AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
- ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
- & SH/(TH-XMU2)/(UH-XMD2))/2D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
- & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
- 290 CONTINUE
- 300 CONTINUE
-
- ELSEIF(ISUB.EQ.243) THEN
-C...q + qbar -> gluino + gluino
- COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
- XMT=SQM3-TH
- XMU=SQM3-UH
- DO 310 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
- NCHN=NCHN+1
- XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
- XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
- FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
- & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
- & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
- & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
- XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
- XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
- FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
- & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
- & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
- & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
-C...1/2 for identical particles
- SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
- 310 CONTINUE
-
- ELSEIF(ISUB.EQ.244) THEN
-C...g + g -> gluino + gluino
- COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
- XMT=SQM3-TH
- XMU=SQM3-UH
- FACQQ1=COMFAC*AS**2*9D0/4D0*(
- & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
- & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
- FACQQ2=COMFAC*AS**2*9D0/4D0*(
- & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
- & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
- FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
- & SQM3*(SH-4D0*SQM3)/XMT/XMU)
- IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ1/2D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQQ2/2D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=3
- SIGH(NCHN)=FACQQ3/2D0
- 320 CONTINUE
-
- ELSEIF(ISUB.EQ.246) THEN
-C...g + q_j -> ~chi0_1 + ~q_j
- FAC0=COMFAC*AS*AEM/6D0/XW
- ZM2=SQM4
- QM2=SQM3
- FACZQ0=FAC0*( (ZM2-TH)/SH +
- & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
- & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
- KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
- DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
- IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
- EI=KCHG(IABS(I),1)/3D0
- IA=IABS(I)
- XRQZ = -TANW*EI*ZMIX(IZID,1)
- XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
- & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
- IF(ILR.EQ.0) THEN
- BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
- ELSE
- BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
- ENDIF
- FACZQ=FACZQ0*BS
- KCHQ=2
- IF(I.LT.0) KCHQ=3
- DO 330 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
- 330 CONTINUE
- 340 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.260) THEN
- IF(ISUB.EQ.254) THEN
-C...g + q_j -> ~chi1_1 + ~q_i
- FAC0=COMFAC*AS*AEM/12D0/XW
- ZM2=SQM4
- QM2=SQM3
- AU=UMIX(IZID,1)**2
- AD=VMIX(IZID,1)**2
- FACZQ0=FAC0*( (ZM2-TH)/SH +
- & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
- & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
- KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
- IF(MOD(KFNSQ1,2).EQ.0) THEN
- KFNSQ=KFNSQ1-1
- KCHW=2
- ELSE
- KFNSQ=KFNSQ1+1
- KCHW=3
- ENDIF
- DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
- IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
- IA=IABS(I)
- IF(MOD(IA,2).EQ.0) THEN
- FACZQ=FACZQ0*AU
- ELSE
- FACZQ=FACZQ0*AD
- ENDIF
- FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
- KCHQ=2
- IF(I.LT.0) KCHQ=3
- KCHWQ=KCHW
- IF(I.LT.0) KCHWQ=5-KCHW
- DO 350 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
- 350 CONTINUE
- 360 CONTINUE
-
- ELSEIF(ISUB.EQ.258) THEN
-C...g + q_j -> gluino + ~q_i
- XG2=SQM4
- XQ2=SQM3
- XMT=XG2-TH
- XMU=XG2-UH
- XST=XQ2-TH
- XSU=XQ2-UH
- FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
- & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
- & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
- & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
- FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
- & (SH*(UH+XG2)
- & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
- & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
- & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
- ASYUK=RMSS(42)*AS
- FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
- FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
- KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
- DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
- IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
- IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
- KCHQ=2
- IF(I.LT.0) KCHQ=3
- FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
- DO 370 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQG1*FACSEL
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQG2*FACSEL
- 370 CONTINUE
- 380 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.270) THEN
- IF(ISUB.EQ.261) THEN
-C...q_i + q_ibar -> ~t_1 + ~t_1bar
- FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
- & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
- KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
- FAC0=AS**2*4D0/9D0
- DO 390 I=MMIN1,MMAX1
- IA=IABS(I)
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
- IF(IA.GE.11.AND.IA.LE.18) THEN
- EI=KCHG(IA,1)/3D0
- EJ=KCHG(KFNSQ,1)/3D0
- T3I=SIGN(1D0,EI)/2D0
- T3J=SIGN(1D0,EJ)/2D0
- XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
- XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
- XLF=2D0*(T3I-EI*XW)
- XRF=2D0*(-EI*XW)
- TAA=0.5D0*(EI*EJ)**2
- TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
- TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
- TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
- TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
- FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
- ENDIF
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ1*FAC0
- 390 CONTINUE
-
- ELSEIF(ISUB.EQ.263) THEN
-C...f + fbar -> ~t1 + ~t2bar
- DO 400 I=MMIN1,MMAX1
- IA=IABS(I)
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
- EI=KCHG(IABS(I),1)/3D0
- TT3I=SIGN(1D0,EI)/2D0
- EJ=2D0/3D0
- TT3J=1D0/2D0
- FCOL=1D0
-C...Color factor for e+ e-
- IF(IA.GE.11) FCOL=3D0
- XLQ=2D0*(TT3J-EJ*XW)
- XRQ=2D0*(-EJ*XW)
- XLF=2D0*(TT3I-EI*XW)
- XRF=2D0*(-EI*XW)
- TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
- TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
- TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
-C...Factor of 2 for t1 t2bar + t2 t1bar
- FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
- FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
- 400 CONTINUE
-
- ELSEIF(ISUB.EQ.264) THEN
-C...g + g -> ~t_1 + ~t_1bar
- XSU=SQM3-UH
- XST=SQM3-TH
- FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
- & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
- FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
- FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
- IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ1
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQQ2
- 410 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.280) THEN
- IF(ISUB.EQ.271) THEN
-C...q + q' -> ~q + ~q' (~g exchange)
- XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
- XMT=XMG2-TH
- XMU=XMG2-UH
- XSU1=SQM3-UH
- XSU2=SQM4-UH
- XST1=SQM3-TH
- XST2=SQM4-TH
- ASYUK=RMSS(42)*AS
- IF(ILR.EQ.1) THEN
- FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
- FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
- FACQQB=0.0D0
- ELSE
- FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
- FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
- FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
- & XMT/XMU )
- ENDIF
- KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
- KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
- DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
- IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
- IA=IABS(I)
- IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
- KCHQ=2
- IF(I.LT.0) KCHQ=3
- DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
- IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
- JA=IABS(J)
- IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
- IF(I*J.LT.0) GOTO 420
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
- IF(I.EQ.J) THEN
- IF(ILR.EQ.0) THEN
- SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
- & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
- ELSE
- SIGH(NCHN)=0.5D0*FACQQ1*RKF*
- & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
- ENDIF
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=2
- IF(ILR.EQ.0) THEN
- SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
- & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
- ELSE
- SIGH(NCHN)=0.5D0*FACQQ2*RKF*
- & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
- ENDIF
- ENDIF
- 420 CONTINUE
- 430 CONTINUE
-
- ELSEIF(ISUB.EQ.274) THEN
-C...q + qbar' -> ~q + ~qbar'
- XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
- XMT=XMG2-TH
- XMU=XMG2-UH
- IF(ILR.EQ.0) THEN
-C...Mrenna...Normalization.and.1/XMT
- FACQQ1=COMFAC*AS**2*2D0/9D0*(
- & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
- FACQQB=COMFAC*AS**2*4D0/9D0*(
- & (UH*TH-SQM3*SQM4)/SH2 )
- FACQQI=-COMFAC*AS**2*4D0/27D0*(
- & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
- FACQQB=FACQQB+FACQQ1+FACQQI
- ELSE
- FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
- FACQQB=FACQQ1
- ENDIF
- KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
- KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
- DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
- IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
- IA=IABS(I)
- IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
- KCHQ=2
- IF(I.LT.0) KCHQ=3
- DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
- IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
- JA=IABS(J)
- IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
- IF(I*J.GT.0) GOTO 440
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
- & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
- IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
- & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
- 440 CONTINUE
- 450 CONTINUE
-
- ELSEIF(ISUB.EQ.277) THEN
-C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
-C...if i .eq. j covered in 274
- FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
- KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
- FAC0=0D0
- DO 460 I=MMIN1,MMAX1
- IA=IABS(I)
- IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
- IF(IA.EQ.KFNSQ) GOTO 460
- IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
- EI=KCHG(IA,1)/3D0
- EJ=KCHG(KFNSQ,1)/3D0
- T3J=SIGN(0.5D0,EJ)
- T3I=SIGN(1D0,EI)/2D0
- IF(ILR.EQ.0) THEN
- XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
- XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
- ELSE
- XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
- XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
- ENDIF
- XLF=2D0*(T3I-EI*XW)
- XRF=2D0*(-EI*XW)
- IF(ILR.EQ.0) THEN
- XRQ=0D0
- ELSE
- XLQ=0D0
- ENDIF
- TAA=0.5D0*(EI*EJ)**2
- TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
- TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
- TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
- TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
- FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
- ELSEIF(IA.LE.6) THEN
- FAC0=AS**2*8D0/9D0/2D0
- ENDIF
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
- 460 CONTINUE
-
- ELSEIF(ISUB.EQ.279) THEN
-C...g + g -> ~q_j + ~q_jbar
- XSU=SQM3-UH
- XST=SQM3-TH
-C...5=RKF because ~t ~tbar treated separately
- FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
- FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
- FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
- IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
- 470 CONTINUE
-
- ENDIF
- ENDIF
-CMRENNA--
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSGTC
-C...Subprocess cross sections for Technicolor processes.
-C...Auxiliary to PYSIGH.
-
- SUBROUTINE PYSGTC(NCHN,SIGS)
-
-C...Double precision and integer declarations
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
- COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
- &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
- &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
- &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
- &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
-C...Local arrays and complex variables
- DIMENSION WDTP(0:400),WDTE(0:400,0:5)
- COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
- COMPLEX*16 SSMX,DAAST,DZAST,DWAST
- COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
- COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
- COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
- COMPLEX*16 DVVS,DVVT,DVVU
- INTEGER INDX(6)
-
-C...Combinations of weak mixing angle.
- TANW=SQRT(XW/XW1)
- CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
-
-C...Convert almost equivalent technicolor processes into
-C...a few basic processes, and set distinguishing parameters.
- IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
- SQTV=RTCM(12)**2
- SQTA=RTCM(13)**2
- SN2W=2D0*SQRT(XW*XW1)
- CS2W=1D0-2D0*XW
- CT2W=CS2W/SN2W
- CSXI=COS(ASIN(RTCM(3)))
- CSXIP=COS(ASIN(RTCM(4)))
- QUPD=2D0*RTCM(2)-1D0
- Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
- CAB2=0D0
- VOGP=0D0
- VRGP=0D0
- AOGP=0D0
- ARGP=0D0
- VXGP=0D0
- AXGP=0D0
- VAGP=0D0
- VZGP=0D0
- VWGP=0D0
-C... rho_tc0, etc. -> W_L W_L, W_L W_T
- IF(ISUB.EQ.361) THEN
- KFA=24
- KFB=24
- CAB2=RTCM(3)**4
- AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
- ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
- VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
-C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
- AXGP = SQRT(2D0)*AXGP
- ARGP = SQRT(2D0)*ARGP
- VOGP = SQRT(2D0)*VOGP
-C... rho_tc0 -> W_L pi_tc-
- ELSEIF(ISUB.EQ.362) THEN
- KFA=24
- KFB=KTECHN+211
- ISUB=361
- CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
-C... pi_tc pi_tc
- ELSEIF(ISUB.EQ.363) THEN
- KFA=KTECHN+211
- KFB=KTECHN+211
- ISUB=361
- CAB2=(1D0-RTCM(3)**2)**2
-C... rho_tc0/omega_tc -> gamma pi_tc
- ELSEIF(ISUB.EQ.364) THEN
- KFA=22
- KFB=KTECHN+111
- ISUB=361
- VOGP=CSXI/RTCM(12)
- VRGP=VOGP*QUPD
- VAGP=2D0*QUPD*CSXI
- VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
-C... gamma pi_tc'
- ELSEIF(ISUB.EQ.365) THEN
- KFA=22
- KFB=KTECHN+221
- ISUB=361
- VRGP=CSXIP/RTCM(12)
- VOGP=VRGP*QUPD
- VAGP=2D0*Q2UD*CSXIP
- VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
-C... Z pi_tc
- ELSEIF(ISUB.EQ.366) THEN
- KFA=23
- KFB=KTECHN+111
- ISUB=361
- VOGP=CSXI*CT2W/RTCM(12)
- VRGP=-QUPD*CSXI*TANW/RTCM(12)
- VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
- VZGP=-QUPD*CSXI*CS2W/XW1
-C... Z pi_tc'
- ELSEIF(ISUB.EQ.367) THEN
- KFA=23
- KFB=KTECHN+221
- ISUB=361
-C...RTCM(48) is the M_V for the techni-a
- VXGP=-CSXIP/SN2W/RTCM(48)
- VRGP=CSXIP*CT2W/RTCM(12)
- VOGP=-QUPD*CSXIP*TANW/RTCM(12)
- VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
- VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
-C... W_T pi_tc
- ELSEIF(ISUB.EQ.368) THEN
- KFA=24
- KFB=KTECHN+211
- ISUB=361
-C...RTCM(49) is the M_A for the techni-a
- AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
- VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
- ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
- VAGP=QUPD*CSXI/(2D0*SQRT(XW))
- VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
-C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
- ELSEIF(ISUB.EQ.370) THEN
- KFA=24
- KFB=23
- CAB2=RTCM(3)**4
- ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
- AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
-C... W_L pi_tc0
- ELSEIF(ISUB.EQ.371) THEN
- KFA=24
- KFB=KTECHN+111
- ISUB=370
- CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
-C... Z_L pi_tc+
- ELSEIF(ISUB.EQ.372) THEN
- KFA=KTECHN+211
- KFB=23
- ISUB=370
- CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
-C... pi_tc+ pi_tc0
- ELSEIF(ISUB.EQ.373) THEN
- KFA=KTECHN+211
- KFB=KTECHN+111
- ISUB=370
- CAB2=(1D0-RTCM(3)**2)**2
-C... gamma pi_tc+
- ELSEIF(ISUB.EQ.374) THEN
- KFA=KTECHN+211
- KFB=22
- ISUB=370
- VRGP=QUPD*CSXI/RTCM(12)
- VWGP=QUPD*CSXI/(2D0*SQRT(XW))
- AXGP=-CSXI/RTCM(49)
-C... Z_T pi_tc+
- ELSEIF(ISUB.EQ.375) THEN
- KFA=KTECHN+211
- KFB=23
- ISUB=370
- VRGP=-QUPD*CSXI*TANW/RTCM(12)
- ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
- VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
- AXGP=-CSXI*CT2W/RTCM(49)
-C... W_T pi_tc0
- ELSEIF(ISUB.EQ.376) THEN
- KFA=24
- KFB=KTECHN+111
- ISUB=370
- VRGP=0D0
- ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
- AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
-C... W_T pi_tc0'
- ELSEIF(ISUB.EQ.377) THEN
- KFA=24
- KFB=KTECHN+221
- ISUB=370
- VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
- VWGP=CSXIP/(2D0*XW)
- VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
-C... gamma W+
- ELSEIF(ISUB.EQ.378) THEN
- KFA=24
- KFB=22
- ISUB=370
- VRGP=QUPD*RTCM(3)/RTCM(12)
- AXGP=-RTCM(3)/RTCM(49)
-C... gamma Z
- ELSEIF(ISUB.EQ.379) THEN
- KFA=23
- KFB=22
- ISUB=361
- VOGP=RTCM(3)/RTCM(12)
- VRGP=QUPD*RTCM(3)/RTCM(12)
- ELSEIF(ISUB.EQ.380) THEN
- KFA=23
- KFB=23
- ISUB=361
- VOGP=RTCM(3)*CT2W/RTCM(12)
- VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
- ENDIF
- ENDIF
-
-C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
- IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
- IF(ITCM(5).LE.4) THEN
- SQDQQS=1D0/SH2
- SQDQQT=1D0/TH2
- SQDQQU=1D0/UH2
- SQDGGS=SQDQQS
- SQDGGT=SQDQQT
- SQDGGU=SQDQQU
- REDGGS=1D0/SH
- REDGGT=1D0/TH
- REDGGU=1D0/UH
- REDGTU=1D0/UH/TH
- REDGSU=1D0/SH/UH
- REDGST=1D0/SH/TH
- REDQST=1D0/SH/TH
- REDQTU=1D0/UH/TH
- SQDLGS=0D0
- SQDLGT=0D0
- SQDQTS=SQDQQS
- ELSEIF(ITCM(5).EQ.5) THEN
- TANT3=RTCM(21)
- IF(ITCM(2).EQ.0) THEN
- IMDL=1
- ELSE
- IMDL=2
- ENDIF
- ALPRHT=2.16D0*(3D0/ITCM(1))
- SIN2T=2D0*TANT3/(TANT3**2+1D0)
- SINT3=TANT3/SQRT(TANT3**2+1D0)
- XIG=SQRT(PYALPS(SH)/ALPRHT)
- X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
- & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
- X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
- & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
- X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
- & SINT3**2)*2D0/SIN2T
- X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
- & SINT3**2)*2D0/SIN2T
-
- SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
- SM1112=X12*RTCM(28)**2*SIN2T
- SM1121=-X21*RTCM(28)**2*SIN2T
- SM2212=-SM1112
- SM2221=-SM1121
- SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
- & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
-
-C.........SH LOOP
- ZTC(1,1)=DCMPLX(SH,0D0)
- CALL PYWIDT(3100021,SH,WDTP,WDTE)
- IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
- ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
- CALL PYWIDT(3100113,SH,WDTP,WDTE)
- ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
- CALL PYWIDT(3400113,SH,WDTP,WDTE)
- ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
- CALL PYWIDT(3200113,SH,WDTP,WDTE)
- ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
- CALL PYWIDT(3300113,SH,WDTP,WDTE)
- ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
- ZTC(1,2)=(0D0,0D0)
- ZTC(1,3)=DCMPLX(SH*XIG,0D0)
- ZTC(1,4)=ZTC(1,3)
- ZTC(1,5)=ZTC(1,2)
- ZTC(1,6)=ZTC(1,2)
- ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
- ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
- ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
- ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
- ZTC(3,4)=-SM1122
- ZTC(3,5)=-SM1112
- ZTC(3,6)=-SM1121
- ZTC(4,5)=-SM2212
- ZTC(4,6)=-SM2221
- ZTC(5,6)=-SM1221
-
- DO 110 I=1,5
- DO 100 J=I+1,6
- ZTC(J,I)=ZTC(I,J)
- 100 CONTINUE
- 110 CONTINUE
- CALL PYLDCM(ZTC,6,6,INDX,D)
- DO 130 I=1,6
- DO 120 J=1,6
- YTC(I,J)=(0D0,0D0)
- IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
- 120 CONTINUE
- 130 CONTINUE
-
- DO 140 I=1,6
- CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
- 140 CONTINUE
- DGGS=YTC(1,1)
- DVVS=YTC(2,2)
- DGVS=YTC(1,2)
-
- XIG=SQRT(PYALPS(-TH)/ALPRHT)
-C.........TH LOOP
- ZTC(1,1)=DCMPLX(TH)
- ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
- ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
- ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
- ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
- ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
- ZTC(1,2)=(0D0,0D0)
- ZTC(1,3)=DCMPLX(TH*XIG,0D0)
- ZTC(1,4)=ZTC(1,3)
- ZTC(1,5)=ZTC(1,2)
- ZTC(1,6)=ZTC(1,2)
- ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
- ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
- ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
- ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
- ZTC(3,4)=-SM1122
- ZTC(3,5)=-SM1112
- ZTC(3,6)=-SM1121
- ZTC(4,5)=-SM2212
- ZTC(4,6)=-SM2221
- ZTC(5,6)=-SM1221
- DO 160 I=1,5
- DO 150 J=I+1,6
- ZTC(J,I)=ZTC(I,J)
- 150 CONTINUE
- 160 CONTINUE
- CALL PYLDCM(ZTC,6,6,INDX,D)
- DO 180 I=1,6
- DO 170 J=1,6
- YTC(I,J)=(0D0,0D0)
- IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
- 170 CONTINUE
- 180 CONTINUE
- DO 190 I=1,6
- CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
- 190 CONTINUE
- DGGT=YTC(1,1)
- DVVT=YTC(2,2)
- DGVT=YTC(1,2)
-
- XIG=SQRT(PYALPS(-UH)/ALPRHT)
-C.........UH LOOP
- ZTC(1,1)=DCMPLX(UH,0D0)
- ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
- ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
- ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
- ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
- ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
- ZTC(1,2)=(0D0,0D0)
- ZTC(1,3)=DCMPLX(UH*XIG,0D0)
- ZTC(1,4)=ZTC(1,3)
- ZTC(1,5)=ZTC(1,2)
- ZTC(1,6)=ZTC(1,2)
- ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
- ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
- ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
- ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
- ZTC(3,4)=-SM1122
- ZTC(3,5)=-SM1112
- ZTC(3,6)=-SM1121
- ZTC(4,5)=-SM2212
- ZTC(4,6)=-SM2221
- ZTC(5,6)=-SM1221
- DO 210 I=1,5
- DO 200 J=I+1,6
- ZTC(J,I)=ZTC(I,J)
- 200 CONTINUE
- 210 CONTINUE
- CALL PYLDCM(ZTC,6,6,INDX,D)
- DO 230 I=1,6
- DO 220 J=1,6
- YTC(I,J)=(0D0,0D0)
- IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
- 220 CONTINUE
- 230 CONTINUE
- DO 240 I=1,6
- CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
- 240 CONTINUE
- DGGU=YTC(1,1)
- DVVU=YTC(2,2)
- DGVU=YTC(1,2)
-
- IF(IMDL.EQ.1) THEN
- DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
- DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
- DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
- DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
- DQGS=DGGS-DGVS*DCMPLX(TANT3)
- DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
- ELSE
- DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
- DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
- DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
- DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
- DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
- DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
- ENDIF
-
- SQDQTS=ABS(DQTS)**2
- SQDQQS=ABS(DQQS)**2
- SQDQQT=ABS(DQQT)**2
- SQDQQU=ABS(DQQU)**2
- SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
- REDLGS=DBLE(DQGS)
- SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
- REDHGS=DBLE(DTGS)
- SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
-
- SQDGGS=ABS(DGGS)**2
- SQDGGT=ABS(DGGT)**2
- SQDGGU=ABS(DGGU)**2
- REDGGS=DBLE(DGGS)
- REDGGT=DBLE(DGGT)
- REDGGU=DBLE(DGGU)
- REDGTU=DBLE(DGGU*DCONJG(DGGT))
- REDGSU=DBLE(DGGU*DCONJG(DGGS))
- REDGST=DBLE(DGGS*DCONJG(DGGT))
- REDQST=DBLE(DQQS*DCONJG(DQQT))
- REDQTU=DBLE(DQQT*DCONJG(DQQU))
- ENDIF
- ENDIF
-
-
-C...Differential cross section expressions.
-
- IF(ISUB.LE.190) THEN
- IF(ISUB.EQ.149) THEN
-C...g + g -> eta_tc
- KCTC=PYCOMP(KTECHN+331)
- CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
- IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
- HP=SH
- IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
- HI=HP*WDTP(3)
- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=HI*FACBW*HF
- 250 CONTINUE
-
- ELSEIF(ISUB.EQ.165) THEN
-C...q + qbar -> l+ + l- (including contact term for compositeness)
- ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
- ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
- KFF=IABS(KFPR(ISUB,1))
- EF=KCHG(KFF,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- VALF=VF+AF
- VARF=VF-AF
- FCOF=1D0
- IF(KFF.LE.10) FCOF=3D0
- WID2=1D0
- IF(KFF.EQ.6) WID2=WIDS(6,1)
- IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
- IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
- DO 260 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*XWV
- VALI=VI+AI
- VARI=VI-AI
- FCOI=1D0
- IF(IABS(I).LE.10) FCOI=FACA/3D0
- IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
- FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
- & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
- & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
- ELSE
- FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
- & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
- ENDIF
- FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
- & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
- FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
- IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
- & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
- 260 CONTINUE
-
- ELSEIF(ISUB.EQ.166) THEN
-C...q + q'bar -> l + nu_l (including contact term for compositeness)
- WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
- WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
- KFF=IABS(KFPR(ISUB,1))
- FCOF=1D0
- IF(KFF.LE.10) FCOF=3D0
- DO 280 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
- IA=IABS(I)
- DO 270 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
- JA=IABS(J)
- IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
- IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
- & GOTO 270
- FCOI=1D0
- IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
- WID2=1D0
- IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
- & MOD(J,2).EQ.0)) THEN
- IF(KFF.EQ.5) WID2=WIDS(6,2)
- IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
- IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
- ELSE
- IF(KFF.EQ.5) WID2=WIDS(6,3)
- IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
- IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
- ENDIF
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
- IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
- & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
- 270 CONTINUE
- 280 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.200) THEN
- IF(ISUB.EQ.191) THEN
-C...q + qbar -> rho_tc0.
- KCTC=PYCOMP(KTECHN+113)
- SQMRHT=PMAS(KCTC,1)**2
- CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
- IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- ALPRHT=2.16D0*(3D0/ITCM(1))
- HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
- XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
- BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
- BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
- DO 290 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
- IA=IABS(I)
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*XWV
- VALI=0.5D0*(VI+AI)
- VARI=0.5D0*(VI-AI)
- HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
- & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
- IF(IA.LE.10) HI=HI*FACA/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=HI*FACBW*HF
- 290 CONTINUE
-
- ELSEIF(ISUB.EQ.192) THEN
-C...q + qbar' -> rho_tc+/-.
- KCTC=PYCOMP(KTECHN+213)
- SQMRHT=PMAS(KCTC,1)**2
- CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
- IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
- ALPRHT=2.16D0*(3D0/ITCM(1))
- HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
- & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
- DO 310 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
- IA=IABS(I)
- DO 300 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
- JA=IABS(J)
- IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
- IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
- & GOTO 300
- KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
- HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
- HI=HP
- IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=HI*FACBW*HF
- 300 CONTINUE
- 310 CONTINUE
-
- ELSEIF(ISUB.EQ.193) THEN
-C...q + qbar -> omega_tc0.
- KCTC=PYCOMP(KTECHN+223)
- SQMOMT=PMAS(KCTC,1)**2
- CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
- IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- ALPRHT=2.16D0*(3D0/ITCM(1))
- HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
- & (2D0*RTCM(2)-1D0)**2
- BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
- BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
- DO 320 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
- IA=IABS(I)
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*XWV
- VALI=0.5D0*(VI+AI)
- VARI=0.5D0*(VI-AI)
- HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
- & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
- IF(IA.LE.10) HI=HI*FACA/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=HI*FACBW*HF
- 320 CONTINUE
-
- ELSEIF(ISUB.EQ.194) THEN
-C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
-C...Default final state is e+e-
- KFA=KFPR(ISUBSV,1)
- ALPRHT=2.16D0*(3D0/ITCM(1))
- HP=AEM**2*COMFAC
-
- SN2W=2D0*SQRT(XW*XW1)
-C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
-C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
-
- QUPD=2D0*RTCM(2)-1D0
- FAR=SQRT(AEM/ALPRHT)
- FAO=FAR*QUPD
- FZR=FAR*CT2W
- FZO=-FAO*TANW
-C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
- FZX=-FAR/SN2W*RTCM(47)
- SFAR=FAR**2
- SFAO=FAO**2
- SFZR=FZR**2
- SFZO=FZO**2
- SFZX=FZX**2
- CALL PYWIDT(23,SH,WDTP,WDTE)
- SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
- CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
- SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
- CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
- SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
- CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
- SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
-C...Propagator including a_T^0
- DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
- $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
-C...Add in techni-a contribution
- DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
- DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
- $ SFZX*SSMR*SSMO)/DETD/SH
- DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
- DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
-
- XWRHT=1D0/(4D0*XW*(1D0-XW))
- KFF=IABS(KFPR(ISUB,1))
- EF=KCHG(KFF,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- VALF=0.5D0*(VF+AF)
- VARF=0.5D0*(VF-AF)
- FCOF=1D0
- IF(KFF.LE.10) FCOF=3D0
-
- WID2=1D0
- IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
- IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
- DZZ=DZZ*DCMPLX(XWRHT,0D0)
- DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
-
- DO 330 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*XWV
- VALI=0.5D0*(VI+AI)
- VARI=0.5D0*(VI-AI)
- FCOI=FCOF
- IF(IABS(I).LE.10) FCOI=FCOI/3D0
- DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
- DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
- DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
- DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
- FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
- & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=HP*FCOI*FACSIG*WID2
- 330 CONTINUE
-
- ELSEIF(ISUB.EQ.195) THEN
-C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
- KFA=KFPR(ISUBSV,1)
- KFB=KFA+1
- ALPRHT=2.16D0*(3D0/ITCM(1))
- FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
-
- FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
-C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
-C
-C...Propagator including a_T^+
- FWX=-FWR*RTCM(47)
- CALL PYWIDT(24,SH,WDTP,WDTE)
- SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
- CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
- SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
- CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
- SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
- DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
- & DCMPLX(FWX**2,0D0)*SSMR
- DWW=SSMR*SSMX/DETD/SH
- FCOF=1D0
- IF(KFA.LE.8) FCOF=3D0
- HP=FACTC*ABS(DWW)**2*FCOF
-
- DO 350 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
- IA=IABS(I)
- DO 340 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
- JA=IABS(J)
- IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
- IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
- & GOTO 340
- KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
- HI=HP
- IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
- 340 CONTINUE
- 350 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.380) THEN
- ALPRHT=2.16D0*(3D0/ITCM(1))
- IF(ISUB.EQ.361) THEN
- FAR=SQRT(AEM/ALPRHT)
- FAO=FAR*QUPD
- FZR=FAR*CT2W
- FZO=-FAO*TANW
-C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
- FZX=-FAR/SN2W*RTCM(47)
- SFAR=FAR**2
- SFAO=FAO**2
- SFZR=FZR**2
- SFZO=FZO**2
- SFZX=FZX**2
- CALL PYWIDT(23,SH,WDTP,WDTE)
- SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
- CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
- SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
- CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
- SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
- CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
- SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
- DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
- $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
-C...Add in techni-a contribution
- DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
- DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
- $ SFZX*FAR*SSMO)/DETD/SH
- DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
- DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
- $ SFZX*FAO*SSMR)/DETD/SH
- DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
- DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
- DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
- DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
- $ SFZX*SSMR*SSMO)/DETD/SH
- DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
- DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
-
-C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
-C...W+W-, W pi_tc, pi_T pi_T, etc.
- FACA=(SH**2*BE34**2-(TH-UH)**2)
- VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
- AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
- FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
- HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
- DO 370 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
- IA=IABS(I)
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*XWV
- VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
- VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
-C...........Eqs. (5) and (6) in LSTC-rates.pdf
- F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
- F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
- F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
- F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
- $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
- F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
- F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
- F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
- F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
- $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
- HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
-C...........Eqs. (5) and (7) in LSTC-rates.pdf
- F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
- F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
- F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
- F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
- F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
- F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
- HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
-C
-C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
-C
-c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
-c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
-c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
-c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
- F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
- F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
- HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
- HI=HI+HJ+HK
- IF(IA.LE.10) HI=HI/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- IF(KFA.EQ.KFB) THEN
- SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
- ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
- SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=2
- SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
- ELSE
- SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
- ENDIF
- 370 CONTINUE
-
- ELSEIF(ISUB.EQ.370) THEN
-C...f + fbar' -> W_L Z_L, W_L Z_T, W_T, Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
-C...f + fbar' -> gamma pi_tc, etc.
- FACA=(SH**2*BE34**2-(TH-UH)**2)
- FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
- VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
- AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
- ALPRHT=2.16D0*(3D0/ITCM(1))
- FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
- FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
-C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
- FWX=-FWR*RTCM(47)
- CALL PYWIDT(24,SH,WDTP,WDTE)
- SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
- CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
- SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
- CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
- SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
- DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
- & DCMPLX(FWX**2,0D0)*SSMR
- DWW=SSMR*SSMX/DETD/SH
- DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
- DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
- HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
- $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
-C
-C...........Eq. (25) in PRD67-115011 with DWW term dropped.
-C
-c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
- HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
-C...Add in W_L Z_T axial and vector contributions.
- IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
- $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses.
- $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
- $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
- DO 410 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
- IA=IABS(I)
- DO 400 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
- JA=IABS(J)
- IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
- IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
- & GOTO 400
- KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
- HI=HP
- IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
- SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
- ELSE
- SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
- & WIDS(PYCOMP(KFB),2)
- ENDIF
- 400 CONTINUE
- 410 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.390) THEN
- IF(ISUB.EQ.381) THEN
-C...f + f' -> f + f' (g exchange)
- FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
- FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
- & MSTP(34)*2D0/3D0*UH2*REDQST)
- FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
- FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
- RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
- IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
-C...Modifications from contact interactions (compositeness)
- FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
- FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
- & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
- FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
- & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
- FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
- RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
- ELSEIF(ITCM(5).EQ.5) THEN
- FACCI1=FACQQ1
- FACCIB=FACQQB
- FACCI2=FACQQ2
- FACCI3=FACQQ1
-CSM.......Check this change from
-CSM RATCII=1D0
- RATCII=RATQQI
- ENDIF
- DO 430 I=MMIN1,MMAX1
- IA=IABS(I)
- IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
- DO 420 J=MMIN2,MMAX2
- JA=IABS(J)
- IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
- & JA.GE.3))) THEN
- SIGH(NCHN)=FACQQ1
- IF(I.EQ.-J) SIGH(NCHN)=FACQQB
- ELSE
- SIGH(NCHN)=FACCI1
- IF(I*J.LT.0) SIGH(NCHN)=FACCI3
- IF(I.EQ.-J) SIGH(NCHN)=FACCIB
- ENDIF
- IF(I.EQ.J) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=2
- IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
- SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
- SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
- ELSE
- SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
- SIGH(NCHN)=0.5D0*FACCI2*RATCII
- ENDIF
- ENDIF
- 420 CONTINUE
- 430 CONTINUE
-
- ELSEIF(ISUB.EQ.382) THEN
-C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
- CALL PYWIDT(21,SH,WDTP,WDTE)
- FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
- FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- IF(ITCM(5).EQ.1) THEN
-C...Modifications from contact interactions (compositeness)
- FACCIB=FACQQB
- DO 440 I=1,2
- FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
- & WDTE(I,2)+WDTE(I,4))
- 440 CONTINUE
- ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
- FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
- & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- ELSEIF(ITCM(5).EQ.5) THEN
- FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
- & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
- FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
- ENDIF
- DO 450 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
- SIGH(NCHN)=FACQQB
- ELSEIF(ITCM(5).EQ.5) THEN
- SIGH(NCHN)=FACQQB
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACCIB
- ELSE
- SIGH(NCHN)=FACCIB
- ENDIF
- 450 CONTINUE
-
- ELSEIF(ISUB.EQ.383) THEN
-C...f + fbar -> g + g (q + qbar -> g + g only)
- FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
- & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
- FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
- & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
- IF(ITCM(5).EQ.5) THEN
- FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
- & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
- FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
- & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
- ENDIF
- DO 460 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=0.5D0*FACGG1
- IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=2
- SIGH(NCHN)=0.5D0*FACGG2
- IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
- 460 CONTINUE
-
- ELSEIF(ISUB.EQ.384) THEN
-C...f + g -> f + g (q + g -> q + g only)
- FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
- & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
- FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
- & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
- DO 480 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
- DO 470 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQG1
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQG2
- 470 CONTINUE
- 480 CONTINUE
-
- ELSEIF(ISUB.EQ.385) THEN
-C...g + g -> f + fbar (g + g -> q + qbar only)
- IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
- IDC0=MDCY(21,2)-1
-C...Begin by d, u, s flavours.
- FLAVWT=0D0
- IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
- & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
- IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
- & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
- IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
- & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
- FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
- & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
- FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
- & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ1
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQQ2
-C...Next c and b flavours: modified that and uhat for fixed
-C...cos(theta-hat).
- DO 490 IFL=4,5
- SQMAVG=PMAS(IFL,1)**2
- IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
- BE34=SQRT(1D0-4D0*SQMAVG/SH)
- THQ=-0.5D0*SH*(1D0-BE34*CTH)
- UHQ=-0.5D0*SH*(1D0+BE34*CTH)
- THUHQ=THQ*UHQ-SQMAVG*SH
- IF(MSTP(34).EQ.0) THEN
- FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
- FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
- ELSE
- FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
- & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
- FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
- & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
- ENDIF
- IF(ITCM(5).GE.5) THEN
- IF(IFL.EQ.4) THEN
- FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
- & 2.25D0*THQ*UHQ/SH2*SQDLGS
- FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
- & 2.25D0*THQ*UHQ/SH2*SQDLGS
- ELSE
- FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
- & 2.25D0*THQ*UHQ/SH2*SQDHGS
- FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
- & 2.25D0*THQ*UHQ/SH2*SQDHGS
- ENDIF
- ENDIF
- FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
- FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1+2*(IFL-3)
- SIGH(NCHN)=FACQQ1
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=2+2*(IFL-3)
- SIGH(NCHN)=FACQQ2
- ENDIF
- 490 CONTINUE
- 500 CONTINUE
-
- ELSEIF(ISUB.EQ.386) THEN
-C...g + g -> g + g
- IF(ITCM(5).LE.4) THEN
- FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
- & 2D0*TH/SH+TH2/SH2)*FACA
- FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
- & 2D0*SH/UH+SH2/UH2)*FACA
- FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
- & 2D0*UH/TH+UH2/TH2)
- ELSE
- GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
- & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
- & 4D0*REDGST*(SH + 2D0*TH)*
- & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
- & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
- & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
- & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
- & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
- & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
- GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
- & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
- & 4D0*REDGSU*(SH + 2D0*UH)*
- & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
- & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
- & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
- & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
- & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
- & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
- GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
- & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
- & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
- & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
- & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
- & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
- & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
- & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
- & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
- & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
- & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
- & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
- & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
- FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
- FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
- FACGG3=COMFAC*AS**2*9D0/4D0*GUT
- ENDIF
- IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=0.5D0*FACGG1
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=0.5D0*FACGG2
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=3
- SIGH(NCHN)=0.5D0*FACGG3
- 510 CONTINUE
-
- ELSEIF(ISUB.EQ.387) THEN
-C...q + qbar -> Q + Qbar
- SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
- THQ=-0.5D0*SH*(1D0-BE34*CTH)
- UHQ=-0.5D0*SH*(1D0+BE34*CTH)
- FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
- & 2D0*SQMAVG/SH)
- IF(ITCM(5).GE.5) THEN
- IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
- FACQQB=FACQQB*SH2*SQDQTS
- ELSE
- FACQQB=FACQQB*SH2*SQDQQS
- ENDIF
- ENDIF
- IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
- WID2=1D0
- IF(MINT(55).EQ.6) WID2=WIDS(6,1)
- IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
- FACQQB=FACQQB*WID2
- DO 520 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQB
- 520 CONTINUE
-
- ELSEIF(ISUB.EQ.388) THEN
-C...g + g -> Q + Qbar
- SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
- THQ=-0.5D0*SH*(1D0-BE34*CTH)
- UHQ=-0.5D0*SH*(1D0+BE34*CTH)
- THUHQ=THQ*UHQ-SQMAVG*SH
- IF(MSTP(34).EQ.0) THEN
- FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
- FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
- ELSE
- FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
- & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
- FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
- & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
- ENDIF
- IF(ITCM(5).GE.5) THEN
- IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
- FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
- & 2.25D0*THQ*UHQ/SH2*SQDHGS
- FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
- & 2.25D0*THQ*UHQ/SH2*SQDHGS
- ELSE
- FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
- & 2.25D0*THQ*UHQ/SH2*SQDLGS
- FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
- & 2.25D0*THQ*UHQ/SH2*SQDLGS
- ENDIF
- ENDIF
- FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
- FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
- IF(MSTP(35).GE.1) THEN
- FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
- FACQQ1=FACQQ1*FATRE
- FACQQ2=FACQQ2*FATRE
- ENDIF
- WID2=1D0
- IF(MINT(55).EQ.6) WID2=WIDS(6,1)
- IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
- FACQQ1=FACQQ1*WID2
- FACQQ2=FACQQ2*WID2
- IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACQQ1
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=2
- SIGH(NCHN)=FACQQ2
- 530 CONTINUE
- ENDIF
- ENDIF
-
-CMRENNA--
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSGEX
-C...Subprocess cross sections for assorted exotic processes,
-C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
-C...Auxiliary to PYSIGH.
-
- SUBROUTINE PYSGEX(NCHN,SIGS)
-
-C...Double precision and integer declarations
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
- COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
- &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
- &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
- &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
- &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
-C...Local arrays
- DIMENSION WDTP(0:400),WDTE(0:400,0:5)
-
-C...Differential cross section expressions.
-
- IF(ISUB.LE.160) THEN
- IF(ISUB.EQ.141) THEN
-C...f + fbar -> gamma*/Z0/Z'0
- SQMZP=PMAS(32,1)**2
- MINT(61)=2
- CALL PYWIDT(32,SH,WDTP,WDTE)
- HP0=AEM/3D0*SH
- HP1=AEM/3D0*XWC*SH
- HP2=HP1
- HS=SHR*VINT(117)
- HSP=SHR*WDTP(0)
- FACZP=4D0*COMFAC*3D0
- DO 100 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI)
- VI=AI-4D0*EI*XWV
- IA=IABS(I)
- IF(IA.LT.10) THEN
- IF(IA.LE.2) THEN
- VPI=PARU(123-2*MOD(IABS(I),2))
- API=PARU(124-2*MOD(IABS(I),2))
- ELSEIF(IA.LE.4) THEN
- VPI=PARJ(182-2*MOD(IABS(I),2))
- API=PARJ(183-2*MOD(IABS(I),2))
- ELSE
- VPI=PARJ(190-2*MOD(IABS(I),2))
- API=PARJ(191-2*MOD(IABS(I),2))
- ENDIF
- ELSE
- IF(IA.LE.12) THEN
- VPI=PARU(127-2*MOD(IABS(I),2))
- API=PARU(128-2*MOD(IABS(I),2))
- ELSEIF(IA.LE.14) THEN
- VPI=PARJ(186-2*MOD(IABS(I),2))
- API=PARJ(187-2*MOD(IABS(I),2))
- ELSE
- VPI=PARJ(194-2*MOD(IABS(I),2))
- API=PARJ(195-2*MOD(IABS(I),2))
- ENDIF
- ENDIF
- HI0=HP0
- IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
- HI1=HP1
- IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
- HI2=HP2
- IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
- & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
- & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
- & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
- & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
- & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
- & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
- & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
- 100 CONTINUE
-
- ELSEIF(ISUB.EQ.142) THEN
-C...f + fbar' -> W'+/-
- SQMWP=PMAS(34,1)**2
- CALL PYWIDT(34,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
- HP=AEM/(24D0*XW)*SH
- DO 120 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
- IA=IABS(I)
- DO 110 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
- JA=IABS(J)
- IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
- IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
- & GOTO 110
- KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
- HI=HP*(PARU(133)**2+PARU(134)**2)
- IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
- & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
- SIGH(NCHN)=HI*FACBW*HF
- 110 CONTINUE
- 120 CONTINUE
-
- ELSEIF(ISUB.EQ.144) THEN
-C...f + fbar' -> R
- SQMR=PMAS(41,1)**2
- CALL PYWIDT(41,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
- HP=AEM/(12D0*XW)*SH
- DO 140 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
- IA=IABS(I)
- DO 130 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
- JA=IABS(J)
- IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
- HI=HP
- IF(IA.LE.10) HI=HI*FACA/3D0
- HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=HI*FACBW*HF
- 130 CONTINUE
- 140 CONTINUE
-
- ELSEIF(ISUB.EQ.145) THEN
-C...q + l -> LQ (leptoquark)
- SQMLQ=PMAS(42,1)**2
- CALL PYWIDT(42,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
- IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
- HP=AEM/4D0*SH
- KFLQQ=KFDP(MDCY(42,2),1)
- KFLQL=KFDP(MDCY(42,2),2)
- DO 160 I=MMIN1,MMAX1
- IF(KFAC(1,I).EQ.0) GOTO 160
- IA=IABS(I)
- IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
- DO 150 J=MMIN2,MMAX2
- IF(KFAC(2,J).EQ.0) GOTO 150
- JA=IABS(J)
- IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
- IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
- IF(JA.EQ.IA) GOTO 150
- IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
- IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
- HI=HP*PARU(151)
- HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=HI*FACBW*HF
- 150 CONTINUE
- 160 CONTINUE
-
- ELSEIF(ISUB.EQ.146) THEN
-C...e + gamma* -> e* (excited lepton)
- KFQSTR=KFPR(ISUB,1)
- KCQSTR=PYCOMP(KFQSTR)
- KFQEXC=MOD(KFQSTR,KEXCIT)
- CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
- QF=-RTCM(43)/2D0-RTCM(44)/2D0
- FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
- IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
- & FACBW=0D0
- HP=SH
- DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
- DO 170 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
- IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
- HI=HP
- IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=22
- ISIG(NCHN,3)=1
- SIGH(NCHN)=HI*FACBW*HF
- 170 CONTINUE
- 180 CONTINUE
-
- ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
-C...d + g -> d* and u + g -> u* (excited quarks)
- KFQSTR=KFPR(ISUB,1)
- KCQSTR=PYCOMP(KFQSTR)
- KFQEXC=MOD(KFQSTR,KEXCIT)
- CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
- FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
- IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
- & FACBW=0D0
- HP=SH
- DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
- DO 190 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
- HI=HP
- IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=HI*FACBW*HF
- 190 CONTINUE
- 200 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.190) THEN
- IF(ISUB.EQ.162) THEN
-C...q + g -> LQ + lbar; LQ=leptoquark
- SQMLQ=PMAS(42,1)**2
- FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
- & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
- KFLQQ=KFDP(MDCY(42,2),1)
- DO 220 I=MMINA,MMAXA
- IF(IABS(I).NE.KFLQQ) GOTO 220
- KCHLQ=ISIGN(1,I)
- DO 210 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
- 210 CONTINUE
- 220 CONTINUE
-
- ELSEIF(ISUB.EQ.163) THEN
-C...g + g -> LQ + LQbar; LQ=leptoquark
- SQMLQ=PMAS(42,1)**2
- FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
- & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
- & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
- & ((TH-SQMLQ)*(UH-SQMLQ)))
- IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
-C...Since don't know proper colour flow, randomize between alternatives
- ISIG(NCHN,3)=INT(1.5D0+PYR(0))
- SIGH(NCHN)=FACLQ
- 230 CONTINUE
-
- ELSEIF(ISUB.EQ.164) THEN
-C...q + qbar -> LQ + LQbar; LQ=leptoquark
- DELTA=0.25D0*(SQM3-SQM4)**2/SH
- SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
- TH=TH-DELTA
- UH=UH-DELTA
-C SQMLQ=PMAS(42,1)**2
- FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
- & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
- FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
- & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
- & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
- KFLQQ=KFDP(MDCY(42,2),1)
- DO 240 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACLQA
- IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
- 240 CONTINUE
-
- ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
-C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
- KFQSTR=KFPR(ISUB,2)
- KCQSTR=PYCOMP(KFQSTR)
- KFQEXC=MOD(KFQSTR,KEXCIT)
- FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
- FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
- & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
-C...Propagators: as simulated in PYOFSH and as desired
- GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
- HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
- CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
- GMMQC=SQRT(SQM4)*WDTP(0)
- HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
- FACQSA=FACQSA*HBW4C/HBW4
- FACQSB=FACQSB*HBW4C/HBW4
-C...Branching ratios.
- BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
- BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
- DO 260 I=MMIN1,MMAX1
- IA=IABS(I)
- IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
- DO 250 J=MMIN2,MMAX2
- JA=IABS(J)
- IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
- IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
- IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=2
- IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
- IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
- ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
- IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
- IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
- ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
- IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=2
- IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
- IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
- ELSEIF(I.EQ.-J) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
- IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=2
- IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
- IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
- ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
- IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
- IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
- ENDIF
- 250 CONTINUE
- 260 CONTINUE
-
- ELSEIF(ISUB.EQ.169) THEN
-C...q + qbar -> e + e* (excited lepton)
- KFQSTR=KFPR(ISUB,2)
- KCQSTR=PYCOMP(KFQSTR)
- KFQEXC=MOD(KFQSTR,KEXCIT)
- FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
- & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
-C...Propagators: as simulated in PYOFSH and as desired
- GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
- HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
- CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
- GMMQC=SQRT(SQM4)*WDTP(0)
- HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
- FACQSB=FACQSB*HBW4C/HBW4
-C...Branching ratios.
- BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
- BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
- DO 270 I=MMIN1,MMAX1
- IA=IABS(I)
- IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
- J=-I
- JA=IABS(J)
- IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
- IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=2
- IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
- IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
- 270 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.360) THEN
- IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
-C...l + l -> H_L++/-- or H_R++/--.
- KFRES=KFPR(ISUB,1)
- KFREC=PYCOMP(KFRES)
- CALL PYWIDT(KFRES,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
- DO 290 I=MMIN1,MMAX1
- IA=IABS(I)
- IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
- & GOTO 290
- DO 280 J=MMIN2,MMAX2
- JA=IABS(J)
- IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
- & GOTO 280
- IF(I*J.LT.0) GOTO 280
- KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
- HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
- SIGH(NCHN)=HI*FACBW*HF
- 280 CONTINUE
- 290 CONTINUE
-
- ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
-C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
- KFRES=KFPR(ISUB,1)
- KFREC=PYCOMP(KFRES)
-C...Propagators: as simulated in PYOFSH and as desired
- HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
- & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
- CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
- GMMC=SQRT(SQM3)*WDTP(0)
- HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
- FHCC=COMFAC*AEM*HBW3C/HBW3
- DO 310 I=MMINA,MMAXA
- IA=IABS(I)
- IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
- SQML=PMAS(IA,1)**2
- J=ISIGN(KFPR(ISUB,2),-I)
- KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
- WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
- SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
- & (UH-SQM3)**2
- SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
- & (TH-SQM4)*SH)/(TH-SQM4)**2
- SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
- & SH)/(SH-SQML)**2
- SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
- & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
- & ((UH-SQM3)*(TH-SQM4))
- SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
- & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
- & ((UH-SQM3)*(SH-SQML))
- SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
- & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
- & ((SH-SQML)*(TH-SQM4))
- SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
- & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
- DO 300 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
- IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=22
- ISIG(NCHN,3)=0
- SIGH(NCHN)=FHCC*SMM*WIDSC
- 300 CONTINUE
- 310 CONTINUE
-
- ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
-C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
- KFRES=KFPR(ISUB,1)
- KFREC=PYCOMP(KFRES)
- SQMH=PMAS(KFREC,1)**2
- GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
-C...Propagators: H++/-- as simulated in PYOFSH and as desired
- HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
- CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
- GMMH3=SQRT(SQM3)*WDTP(0)
- HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
- HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
- CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
- GMMH4=SQRT(SQM4)*WDTP(0)
- HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
-C...Kinematical and coupling functions
- FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
- XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
-C...Loop over allowed flavours
- DO 320 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*XWV
- FCOI=1D0
- IF(IABS(I).LE.10) FCOI=FACA/3D0
- IF(ISUB.EQ.349) THEN
- HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
- IF(IABS(I).LT.10) THEN
- DSIGHH=8D0*AEM**2*(EI**2/SH2+
- & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
- & (VI**2+AI**2)*XWHH**2*HBWZ)
- ELSE
- IAOFF=181+3*((IABS(I)-11)/2)
- HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
- & (4D0*PARU(1))
- DSIGHH=8D0*AEM**2*(EI**2/SH2+
- & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
- & (VI**2+AI**2)*XWHH**2*HBWZ)+
- & 8D0*AEM*(EI*HSUM/(SH*TH)+
- & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
- & 4D0*HSUM**2/TH2
- ENDIF
- ELSE
- IF(IABS(I).LT.10) THEN
- DSIGHH=8D0*AEM**2*EI**2/SH2
- ELSE
- IAOFF=181+3*((IABS(I)-11)/2)
- HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
- & (4D0*PARU(1))
- DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
- & 4D0*HSUM**2/TH2
- ENDIF
- ENDIF
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACHH*FCOI*DSIGHH
- 320 CONTINUE
-
- ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
-C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
- KFRES=KFPR(ISUB,1)
- KFREC=PYCOMP(KFRES)
- SQMH=PMAS(KFREC,1)**2
- IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
- IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
- & PMAS(PYCOMP(9900024),1)**2
- FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
- FACPRT=1D0/((VINT(204)**2-VINT(215))*
- & (VINT(209)**2-VINT(216)))
- FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
- & (VINT(209)**2+2D0*VINT(218)))
- CALL PYWIDT(KFRES,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
- IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
- & FACBW=0D0
- DO 340 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
- IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
- KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
- DO 330 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
- IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
- KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
- KCHH=KCHWI+KCHWJ
- IF(IABS(KCHH).NE.2) GOTO 330
- FACLR=VINT(180+I)*VINT(180+J)
- HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
- IF(I.EQ.J.AND.IABS(I).GT.10) THEN
- FACPRP=0.5D0*(FACPRT+FACPRU)**2
- ELSE
- FACPRP=FACPRT**2
- ENDIF
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
- 330 CONTINUE
- 340 CONTINUE
-
- ELSEIF(ISUB.EQ.353) THEN
-C...f + fbar -> Z_R0
- SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
- CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
- DO 350 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
- IF(IABS(I).LE.8) THEN
- EI=KCHG(IABS(I),1)/3D0
- AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
- VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
- ELSE
- AI=-(1D0-2D0*XW)
- VI=-1D0+4D0*XW
- ENDIF
- HI=HP*(VI**2+AI**2)
- IF(IABS(I).LE.10) HI=HI*FACA/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=HI*FACBW*HF
- 350 CONTINUE
-
- ELSEIF(ISUB.EQ.354) THEN
-C...f + fbar' -> W_R+/-
- SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
- CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
- HP=AEM/(24D0*XW)*SH
- DO 370 I=MMIN1,MMAX1
- IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
- IA=IABS(I)
- DO 360 J=MMIN2,MMAX2
- IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
- JA=IABS(J)
- IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
- IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
- & GOTO 360
- KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
- HI=HP*2D0
- IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=J
- ISIG(NCHN,3)=1
- HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
- SIGH(NCHN)=HI*FACBW*HF
- 360 CONTINUE
- 370 CONTINUE
- ENDIF
-
- ELSEIF(ISUB.LE.400) THEN
- IF(ISUB.EQ.391) THEN
-C...f + fbar -> G*.
- KFGSTR=KFPR(ISUB,1)
- KCGSTR=PYCOMP(KFGSTR)
- CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
- & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
-C...Modify cross section in wings of peak.
- FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
- DO 380 I=MMINA,MMAXA
- IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
- HI=1D0
- IF(IABS(I).LE.10) HI=HI*FACA/3D0
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACG*HI
- 380 CONTINUE
-
- ELSEIF(ISUB.EQ.392) THEN
-C...g + g -> G*.
- KFGSTR=KFPR(ISUB,1)
- KCGSTR=PYCOMP(KFGSTR)
- CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
- HS=SHR*WDTP(0)
- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
- & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
-C...Modify cross section in wings of peak.
- FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
- IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACG
- 390 CONTINUE
-
- ELSEIF(ISUB.EQ.393) THEN
-C...q + qbar -> g + G*.
- KFGSTR=KFPR(ISUB,2)
- KCGSTR=PYCOMP(KFGSTR)
- FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
- & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
- & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
- & 2D0*SH2/(TH*UH))
-C...Propagators: as simulated in PYOFSH and as desired
- GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
- HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
- CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
- HS=SQRT(SQM4)*WDTP(0)
- HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
- FACG=FACG*HBW4C/HBW4
- DO 400 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
- & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
- NCHN=NCHN+1
- ISIG(NCHN,1)=I
- ISIG(NCHN,2)=-I
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACG
- 400 CONTINUE
-
- ELSEIF(ISUB.EQ.394) THEN
-C...q + g -> q + G*.
- KFGSTR=KFPR(ISUB,2)
- KCGSTR=PYCOMP(KFGSTR)
- FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
- & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
- & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
- & 2D0*TH2*TH/(UH*SH2))
-C...Propagators: as simulated in PYOFSH and as desired
- GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
- HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
- CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
- HS=SQRT(SQM4)*WDTP(0)
- HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
- FACG=FACG*HBW4C/HBW4
- DO 420 I=MMINA,MMAXA
- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
- DO 410 ISDE=1,2
- IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
- IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
- NCHN=NCHN+1
- ISIG(NCHN,ISDE)=I
- ISIG(NCHN,3-ISDE)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACG
- 410 CONTINUE
- 420 CONTINUE
-
- ELSEIF(ISUB.EQ.395) THEN
-C...g + g -> g + G*.
- KFGSTR=KFPR(ISUB,2)
- KCGSTR=PYCOMP(KFGSTR)
- FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
- & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
- & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
-C...Propagators: as simulated in PYOFSH and as desired
- GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
- HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
- CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
- HS=SQRT(SQM4)*WDTP(0)
- HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
- HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
- FACG=FACG*HBW4C/HBW4
- IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
- NCHN=NCHN+1
- ISIG(NCHN,1)=21
- ISIG(NCHN,2)=21
- ISIG(NCHN,3)=1
- SIGH(NCHN)=FACG
- ENDIF
- ENDIF
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYPDFU
-C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
-C...parton distributions according to a few different parametrizations.
-C...Note that what is coded is x times the probability distribution,
-C...i.e. xq(x,Q2) etc.
-
- SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
- &XPDIR(-6:6)
- COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
- COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
- & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
- & XMI(2,240),PT2MI(240),IMISEP(0:240)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
- &/PYINT9/,/PYINTM/
-C...Local arrays.
- DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
- &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
- SAVE PPAR
-
-C...Interface to PDFLIB.
- COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
- SAVE /LW50513/
- DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
- &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
- CHARACTER*20 PARM(20)
- DATA VALUE/20*0D0/,PARM/20*' '/
-
-C...Data related to Schuler-Sjostrand photon distributions.
- DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
-
-C...Valence PDF momentum integral parametrizations PER PARTON!
- DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
- DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
- PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
- &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
-
-C...Reset parton distributions.
- MINT(92)=0
- DO 100 KFL=-25,25
- XPQ(KFL)=0D0
- 100 CONTINUE
- DO 110 KFL=-6,6
- XPVAL(KFL)=0D0
- 110 CONTINUE
-
-C...Check x and particle species.
- IF(X.LE.0D0.OR.X.GE.1D0) THEN
- WRITE(MSTU(11),5000) X
- GOTO 9999
- ENDIF
- KFA=IABS(KF)
- IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
- &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
- &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
- &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
- &KFA.NE.310.AND.KFA.NE.130) THEN
- WRITE(MSTU(11),5100) KF
- GOTO 9999
- ENDIF
-
-C...Electron (or muon or tau) parton distribution call.
- IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
- CALL PYPDEL(KFA,X,Q2,XPEL)
- DO 120 KFL=-25,25
- XPQ(KFL)=XPEL(KFL)
- 120 CONTINUE
-
-C...Photon parton distribution call (VDM+anomalous).
- ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
- IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
- CALL PYPDGA(X,Q2,XPGA)
- DO 130 KFL=-6,6
- XPQ(KFL)=XPGA(KFL)
- 130 CONTINUE
- XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
- XPVAL(1)=XPVU/4D0
- XPVAL(2)=XPVU
- XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
- XPVAL(4)=MIN(XPQ(4),XPVU)
- XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
- XPVAL(-1)=XPVAL(1)
- XPVAL(-2)=XPVAL(2)
- XPVAL(-3)=XPVAL(3)
- XPVAL(-4)=XPVAL(4)
- XPVAL(-5)=XPVAL(5)
- ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
- Q2MX=Q2
- P2MX=0.36D0
- IF(MSTP(55).GE.7) P2MX=4.0D0
- IF(MSTP(57).EQ.0) Q2MX=P2MX
- P2=0D0
- IF(VINT(120).LT.0D0) P2=VINT(120)**2
- CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
- DO 140 KFL=-6,6
- XPQ(KFL)=XPGA(KFL)
- XPVAL(KFL)=VXPDGM(KFL)
- 140 CONTINUE
- VINT(231)=P2MX
- ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
- Q2MX=Q2
- P2MX=0.36D0
- IF(MSTP(55).GE.11) P2MX=4.0D0
- IF(MSTP(57).EQ.0) Q2MX=P2MX
- P2=0D0
- IF(VINT(120).LT.0D0) P2=VINT(120)**2
- CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
- DO 150 KFL=-6,6
- XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
- XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
- 150 CONTINUE
- VINT(231)=P2MX
- ELSEIF(MSTP(56).EQ.2) THEN
-C...Call PDFLIB parton distributions.
- PARM(1)='NPTYPE'
- VALUE(1)=3
- PARM(2)='NGROUP'
- VALUE(2)=MSTP(55)/1000
- PARM(3)='NSET'
- VALUE(3)=MOD(MSTP(55),1000)
- IF(MINT(93).NE.3000000+MSTP(55)) THEN
- CALL PDFSET(PARM,VALUE)
- MINT(93)=3000000+MSTP(55)
- ENDIF
- XX=X
- QQ2=MAX(0D0,Q2MIN,Q2)
- IF(MSTP(57).EQ.0) QQ2=Q2MIN
- P2=0D0
- IF(VINT(120).LT.0D0) P2=VINT(120)**2
- IP2=MSTP(60)
- IF(MSTP(55).EQ.5004) THEN
- IF(5D0*P2.LT.QQ2.AND.
- & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
- & P2.GE.0D0.AND.P2.LT.10D0.AND.
- & XX.GT.1D-4.AND.XX.LT.1D0) THEN
- CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
- & BOT,TOP,GLU)
- ELSE
- UPV=0D0
- DNV=0D0
- USEA=0D0
- DSEA=0D0
- STR=0D0
- CHM=0D0
- BOT=0D0
- TOP=0D0
- GLU=0D0
- ENDIF
- ELSE
- IF(P2.LT.QQ2) THEN
- CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
- & BOT,TOP,GLU)
- ELSE
- UPV=0D0
- DNV=0D0
- USEA=0D0
- DSEA=0D0
- STR=0D0
- CHM=0D0
- BOT=0D0
- TOP=0D0
- GLU=0D0
- ENDIF
- ENDIF
- VINT(231)=Q2MIN
- XPQ(0)=GLU
- XPQ(1)=DNV
- XPQ(-1)=DNV
- XPQ(2)=UPV
- XPQ(-2)=UPV
- XPQ(3)=STR
- XPQ(-3)=STR
- XPQ(4)=CHM
- XPQ(-4)=CHM
- XPQ(5)=BOT
- XPQ(-5)=BOT
- XPQ(6)=TOP
- XPQ(-6)=TOP
- XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
- XPVAL(1)=XPVU/4D0
- XPVAL(2)=XPVU
- XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
- XPVAL(4)=MIN(XPQ(4),XPVU)
- XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
- XPVAL(-1)=XPVAL(1)
- XPVAL(-2)=XPVAL(2)
- XPVAL(-3)=XPVAL(3)
- XPVAL(-4)=XPVAL(4)
- XPVAL(-5)=XPVAL(5)
- ELSE
- WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
- ENDIF
-
-C...Pion/gammaVDM parton distribution call.
- ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
- &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
- IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
- & MSTP(55).LE.12) THEN
- ISET=1+MOD(MSTP(55)-1,4)
- Q2MX=Q2
- P2MX=0.36D0
- IF(ISET.GE.3) P2MX=4.0D0
- IF(MSTP(57).EQ.0) Q2MX=P2MX
- P2=0D0
- IF(VINT(120).LT.0D0) P2=VINT(120)**2
- CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
- DO 160 KFL=-6,6
- XPQ(KFL)=XPVMD(KFL)
- XPVAL(KFL)=VXPVMD(KFL)
- 160 CONTINUE
- VINT(231)=P2MX
- ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
- CALL PYPDPI(X,Q2,XPPI)
- DO 170 KFL=-6,6
- XPQ(KFL)=XPPI(KFL)
- 170 CONTINUE
- XPVAL(2)=XPQ(2)-XPQ(-2)
- XPVAL(-1)=XPQ(-1)-XPQ(1)
- ELSEIF(MSTP(54).EQ.2) THEN
-C...Call PDFLIB parton distributions.
- PARM(1)='NPTYPE'
- VALUE(1)=2
- PARM(2)='NGROUP'
- VALUE(2)=MSTP(53)/1000
- PARM(3)='NSET'
- VALUE(3)=MOD(MSTP(53),1000)
- IF(MINT(93).NE.2000000+MSTP(53)) THEN
- CALL PDFSET(PARM,VALUE)
- MINT(93)=2000000+MSTP(53)
- ENDIF
- XX=X
- QQ=SQRT(MAX(0D0,Q2MIN,Q2))
- IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
- CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
- VINT(231)=Q2MIN
- XPQ(0)=GLU
- XPQ(1)=DSEA
- XPQ(-1)=UPV+DSEA
- XPQ(2)=UPV+USEA
- XPQ(-2)=USEA
- XPQ(3)=STR
- XPQ(-3)=STR
- XPQ(4)=CHM
- XPQ(-4)=CHM
- XPQ(5)=BOT
- XPQ(-5)=BOT
- XPQ(6)=TOP
- XPQ(-6)=TOP
- XPVAL(2)=UPV
- XPVAL(-1)=UPV
- ELSE
- WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
- ENDIF
-
-C...Anomalous photon parton distribution call.
- ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
- Q2MX=Q2
- P2MX=PARP(15)**2
- IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
- IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
- IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
- IF(MSTP(57).EQ.0) Q2MX=P2MX
- P2=0D0
- IF(VINT(120).LT.0D0) P2=VINT(120)**2
- CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
- DO 180 KFL=-6,6
- XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
- XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
- 180 CONTINUE
- VINT(231)=P2MX
- ELSEIF(MSTP(56).EQ.1) THEN
- IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
- IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
- IF(MSTP(57).EQ.0) Q2MX=P2MX
- P2=0D0
- IF(VINT(120).LT.0D0) P2=VINT(120)**2
- CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
- DO 190 KFL=-6,6
- XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
- XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
- 190 CONTINUE
- VINT(231)=P2MX
- ELSEIF(MSTP(56).EQ.2) THEN
- IF(MSTP(57).EQ.0) Q2MX=P2MX
- CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
- DO 200 KFL=-6,6
- XPQ(KFL)=XPGA(KFL)
- XPVAL(KFL)=VXPGA(KFL)
- 200 CONTINUE
- VINT(231)=P2MX
- ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
- IF(MSTP(57).EQ.0) Q2MX=P2MX
- CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
- DO 210 KFL=-6,6
- XPQ(KFL)=XPGA(KFL)
- XPVAL(KFL)=VXPGA(KFL)
- 210 CONTINUE
- VINT(231)=P2MX
- ELSE
- 220 RKF=11D0*PYR(0)
- KFR=1
- IF(RKF.GT.1D0) KFR=2
- IF(RKF.GT.5D0) KFR=3
- IF(RKF.GT.6D0) KFR=4
- IF(RKF.GT.10D0) KFR=5
- IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
- IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
- IF(MSTP(57).EQ.0) Q2MX=P2MX
- CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
- DO 230 KFL=-6,6
- XPQ(KFL)=XPGA(KFL)
- XPVAL(KFL)=VXPGA(KFL)
- 230 CONTINUE
- VINT(231)=P2MX
- ENDIF
-
-C...Proton parton distribution call.
- ELSE
- IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
- CALL PYPDPR(X,Q2,XPPR)
- DO 240 KFL=-6,6
- XPQ(KFL)=XPPR(KFL)
- 240 CONTINUE
- XPVAL(1)=XPQ(1)-XPQ(-1)
- XPVAL(2)=XPQ(2)-XPQ(-2)
- ELSEIF(MSTP(52).EQ.2) THEN
-C...Call PDFLIB parton distributions.
- PARM(1)='NPTYPE'
- VALUE(1)=1
- PARM(2)='NGROUP'
- VALUE(2)=MSTP(51)/1000
- PARM(3)='NSET'
- VALUE(3)=MOD(MSTP(51),1000)
- IF(MINT(93).NE.1000000+MSTP(51)) THEN
- CALL PDFSET(PARM,VALUE)
- MINT(93)=1000000+MSTP(51)
- ENDIF
- XX=X
- QQ=SQRT(MAX(0D0,Q2MIN,Q2))
- IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
- CALL STRUCTM_ALICE
- + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
- VINT(231)=Q2MIN
- XPQ(0)=GLU
- XPQ(1)=DNV+DSEA
- XPQ(-1)=DSEA
- XPQ(2)=UPV+USEA
- XPQ(-2)=USEA
- XPQ(3)=STR
- XPQ(-3)=STR
- XPQ(4)=CHM
- XPQ(-4)=CHM
- XPQ(5)=BOT
- XPQ(-5)=BOT
- XPQ(6)=TOP
- XPQ(-6)=TOP
- XPVAL(1)=DNV
- XPVAL(2)=UPV
- ELSE
- WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
- ENDIF
- ENDIF
-
-C...Isospin average for pi0/gammaVDM.
- IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
- IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
- XPV=XPQ(2)-XPQ(1)
- XPQ(2)=XPQ(1)
- XPQ(-2)=XPQ(-1)
- ELSE
- XPS=0.5D0*(XPQ(1)+XPQ(-2))
- XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
- XPQ(2)=XPS
- XPQ(-1)=XPS
- ENDIF
- XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
- & XPVAL(3)+XPVAL(4)+XPVAL(5)
- DO 250 KFL=-6,6
- XPVAL(KFL)=0D0
- 250 CONTINUE
- IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
- XPQ(1)=XPQ(1)+0.2D0*XPV
- XPQ(2)=XPQ(2)+0.8D0*XPV
- XPVAL(1)=0.2D0*XPVL
- XPVAL(2)=0.8D0*XPVL
- ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
- XPQ(3)=XPQ(3)+XPV
- XPVAL(3)=XPVL
- ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
- XPQ(4)=XPQ(4)+XPV
- XPVAL(4)=XPVL
- IF(MSTP(55).GE.9) THEN
- DO 260 KFL=-6,6
- XPQ(KFL)=0D0
- 260 CONTINUE
- ENDIF
- ELSE
- XPQ(1)=XPQ(1)+0.5D0*XPV
- XPQ(2)=XPQ(2)+0.5D0*XPV
- XPVAL(1)=0.5D0*XPVL
- XPVAL(2)=0.5D0*XPVL
- ENDIF
- DO 270 KFL=1,6
- XPQ(-KFL)=XPQ(KFL)
- XPVAL(-KFL)=XPVAL(KFL)
- 270 CONTINUE
-
-C...Rescale for gammaVDM by effective gamma -> rho coupling.
-C+++Do not rescale?
- IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
- & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
- DO 280 KFL=-6,6
- XPQ(KFL)=VINT(281)*XPQ(KFL)
- XPVAL(KFL)=VINT(281)*XPVAL(KFL)
- 280 CONTINUE
- VINT(232)=VINT(281)*XPV
- ENDIF
-
-C...Simple recipes for kaons.
- ELSEIF(KFA.EQ.321) THEN
- XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
- XPQ(-1)=XPQ(1)
- XPVAL(-3)=XPVAL(-1)
- XPVAL(-1)=0D0
- ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
- XPS=0.5D0*(XPQ(1)+XPQ(-2))
- XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
- XPQ(2)=XPS
- XPQ(-1)=XPS
- XPQ(1)=XPQ(1)+0.5D0*XPV
- XPQ(-1)=XPQ(-1)+0.5D0*XPV
- XPQ(3)=XPQ(3)+0.5D0*XPV
- XPQ(-3)=XPQ(-3)+0.5D0*XPV
- XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
- XPVAL(2)=0D0
- XPVAL(-1)=0D0
- XPVAL(1)=0.5D0*XPV
- XPVAL(-1)=0.5D0*XPV
- XPVAL(3)=0.5D0*XPV
- XPVAL(-3)=0.5D0*XPV
-
-C...Isospin conjugation for neutron.
- ELSEIF(KFA.EQ.2112) THEN
- XPSV=XPQ(1)
- XPQ(1)=XPQ(2)
- XPQ(2)=XPSV
- XPSV=XPQ(-1)
- XPQ(-1)=XPQ(-2)
- XPQ(-2)=XPSV
- XPSV=XPVAL(1)
- XPVAL(1)=XPVAL(2)
- XPVAL(2)=XPSV
-
-C...Simple recipes for hyperon (average valence parton distribution).
- ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
- & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
- XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
- XPS=0.5D0*(XPQ(-1)+XPQ(-2))
- XPQ(1)=XPS
- XPQ(2)=XPS
- XPQ(-1)=XPS
- XPQ(-2)=XPS
- XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
- XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
- XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
- XPV=(XPVAL(1)+XPVAL(2))/3D0
- XPVAL(1)=0D0
- XPVAL(2)=0D0
- XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
- XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
- XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
- ENDIF
-
-C...Charge conjugation for antiparticle.
- IF(KF.LT.0) THEN
- DO 290 KFL=1,25
- IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
- XPSV=XPQ(KFL)
- XPQ(KFL)=XPQ(-KFL)
- XPQ(-KFL)=XPSV
- 290 CONTINUE
- DO 300 KFL=1,6
- XPSV=XPVAL(KFL)
- XPVAL(KFL)=XPVAL(-KFL)
- XPVAL(-KFL)=XPSV
- 300 CONTINUE
- ENDIF
-
-C...MULTIPLE INTERACTIONS - PDF RESHAPING.
-C...Set side.
- JS=MINT(30)
-C...Only reshape PDFs for the non-first interactions;
-C...But need valence/sea separation already from first interaction.
- IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
- KFVSEL=KFIVAL(JS,1)
-C...If valence quark kicked out of pi0 or gamma then that decides
-C...whether we should consider state as d dbar, u ubar, s sbar, etc.
- IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
- XPVL=0D0
- DO 310 KFL=1,6
- XPVL=XPVL+XPVAL(KFL)
- XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
- XPVAL(KFL)=0D0
- 310 CONTINUE
- XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
- XPVAL(IABS(KFVSEL))=XPVL
- DO 320 KFL=1,6
- XPQ(-KFL)=XPQ(KFL)
- XPVAL(-KFL)=XPVAL(KFL)
- 320 CONTINUE
-
-C...If valence quark kicked out of K0S or K0S then that decides whether
-C...we should consider state as d sbar or s dbar.
- ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
- KFS=1
- IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
- XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
- XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
- XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
- XPVAL(-KFS)=0D0
- KFS=-3*KFS
- XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
- XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
- XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
- XPVAL(-KFS)=0D0
- ENDIF
-
-C...XPQ distributions are nominal for a (signed) beam particle
-C...of KF type, with 1-Sum(x_prev) rescaled to 1.
- CMPFAC=1D0
- NRESC=0
- 345 NRESC=NRESC+1
- PVCTOT(JS,-1)=0D0
- PVCTOT(JS, 0)=0D0
- PVCTOT(JS, 1)=0D0
- DO 350 IFL=-6,6
- IF(IFL.EQ.0) GOTO 350
-
-C...Count up number of original IFL valence quarks.
- IVORG=0
- IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
- IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
- IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
-C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
-C...bookkeep as if d dbar (for total momentum sum in valence sector).
- IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
-C...Count down number of remaining IFL valence quarks. Skip current
-C...interaction initiator.
- IVREM=IVORG
- DO 330 I1=1,NMI(JS)
- IF (I1.EQ.MINT(36)) GOTO 330
- IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
- & IVREM=IVREM-1
- 330 CONTINUE
-
-C...Separate out original VALENCE and SEA content.
- VAL=XPVAL(IFL)
- SEA=MAX(0D0,XPQ(IFL)-VAL)
- XPSVC(IFL,0)=VAL
- XPSVC(IFL,-1)=SEA
-
-C...Rescale valence content if changed.
- IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
- & (VAL*IVREM)/IVORG
-
-C...Momentum integrals of original and removed valence quarks.
- IF(IVORG.NE.0) THEN
-C...For p/n/pbar/nbar beams can split into d_val and u_val.
-C...Isospin conjugation for neutrons
- IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
- IAFLP=IABS(IFL)
- IF (KFA.EQ.2112) IAFLP=3-IAFLP
- VPAVG=PAVG(IAFLP,Q2)
-C...For other baryons average d_val and u_val, like for PDFs.
- ELSEIF(KFA.GT.1000) THEN
- VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
-C...For mesons and photon average d_val and u_val and scale by 3/2.
-C...Very crude, especially for photon.
- ELSE
- VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
- ENDIF
- PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
- PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
- ENDIF
-
-C...Now add companions (at X with partner having been at Z=XASSOC).
-C...NOTE: due to the assumed simple x scaling, the partner was at what
-C...corresponds to a higher Z than XASSOC, if there were intermediate
-C...scatterings. Nothing done about that for the moment.
- DO 340 IVC=1,NVC(JS,IFL)
-C...Skip companions that have been kicked out
- IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
- XPSVC(IFL,IVC)=0D0
- GOTO 340
- ELSE
-C...Momentum fraction of the partner quark.
-C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
- XS=XASSOC(JS,IFL,IVC)
- XREM=VINT(142+JS)
- YS=XS/(XREM+XS)
-C...Momentum fraction of the companion quark.
-C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
- Y=X*(1D0-YS)
- XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
-C...Add to momentum sum, with rescaling compensation factor.
- XCFAC=(XREM+XS)/XREM*CMPFAC
- PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
- ENDIF
- 340 CONTINUE
- 350 CONTINUE
-
-C...Wait until all flavours treated, then rescale seas and gluon.
- XPSVC(0,-1)=XPQ(0)
- XPSVC(0,0)=0D0
- RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
- IF (RSFAC.LE.0D0) THEN
-C...First calculate factor needed to exactly restore pz cons.
- IF (NRESC.EQ.1) CMPFAC =
- & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
-C...Add a bit of headroom
- CMPFAC=0.99*CMPFAC
-C...Try a few times if more headroom is needed, then print error message.
- IF (NRESC.LE.10) GOTO 345
- CALL PYERRM(15,
- & '(PYPDFU:) Negative reshaping factor persists!')
- WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
- RSFAC=0D0
- ENDIF
- DO 370 IFL=-6,6
- XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
-C...Also store resulting distributions in XPQ
- XPQ(IFL)=0D0
- DO 360 ISVC=-1,NVC(JS,IFL)
- XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
- 360 CONTINUE
- 370 CONTINUE
-C...Save companion reweighting factor for PYPTIS.
- VINT(140)=CMPFAC
- ENDIF
-
-
-C...Allow gluon also in position 21.
- XPQ(21)=XPQ(0)
-
-C...Check positivity and reset above maximum allowed flavour.
- DO 380 KFL=-25,25
- XPQ(KFL)=MAX(0D0,XPQ(KFL))
- IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
- 380 CONTINUE
-
-C...Formats for error printouts.
- 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
- 5100 FORMAT(' Error: illegal particle code for parton distribution;',
- &' KF =',I5)
- 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
- &3I5)
- 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
- & ' Removed valence momentum fraction : ',F6.3/
- & ' Added companion momentum fraction : ',F6.3/
- & ' Resulting rescale factor : ',F6.3)
-
-C...Reset side pointer and return
- 9999 MINT(30)=0
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYPDFL
-C...Gives proton parton distribution at small x and/or Q^2 according to
-C...correct limiting behaviour.
-
- SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
-C...Local arrays.
- DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
- DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
-
-C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
- MINT(92)=0
- KFA=IABS(KF)
- IACC=0
- IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
- IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
- IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
- IF(IACC.EQ.0) THEN
- CALL PYPDFU(KF,X,Q2,XPQ)
- RETURN
- ENDIF
-
-C...Reset. Check x.
- DO 100 KFL=-25,25
- XPQ(KFL)=0D0
- 100 CONTINUE
- IF(X.LE.0D0.OR.X.GE.1D0) THEN
- WRITE(MSTU(11),5000) X
- RETURN
- ENDIF
-
-C...Define valence content.
- KFC=KF
- NV1=2
- NV2=1
- IF(KF.EQ.2212) THEN
- KFV1=2
- KFV2=1
- ELSEIF(KF.EQ.-2212) THEN
- KFV1=-2
- KFV2=-1
- ELSEIF(KF.EQ.2112) THEN
- KFV1=1
- KFV2=2
- ELSEIF(KF.EQ.-2112) THEN
- KFV1=-1
- KFV2=-2
- ELSEIF(KF.EQ.211) THEN
- NV1=1
- KFV1=2
- KFV2=-1
- ELSEIF(KF.EQ.-211) THEN
- NV1=1
- KFV1=-2
- KFV2=1
- ELSEIF(MINT(105).LE.223) THEN
- KFV1=1
- WTV1=0.2D0
- KFV2=2
- WTV2=0.8D0
- ELSEIF(MINT(105).EQ.333) THEN
- KFV1=3
- WTV1=1.0D0
- KFV2=1
- WTV2=0.0D0
- ELSEIF(MINT(105).EQ.443) THEN
- KFV1=4
- WTV1=1.0D0
- KFV2=1
- WTV2=0.0D0
- ENDIF
-
-C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
- MINT30=MINT(30)
- CALL PYPDFU(KFC,X,Q2,XPA)
- Q2MN=MAX(3D0,VINT(231))
- Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
- XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
-
-C...Large Q2 and large x: naive call is enough.
- IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
- DO 110 KFL=-25,25
- XPQ(KFL)=XPA(KFL)
- 110 CONTINUE
- MINT(92)=1
-
-C...Small Q2 and large x: dampen boundary value.
- ELSEIF(X.GT.XMN) THEN
-
-C...Evaluate at boundary and define dampening factors.
- MINT(30)=MINT30
- CALL PYPDFU(KFC,X,Q2MN,XPA)
- FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
- FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
-
-C...Separate valence and sea parts of parton distribution.
- IF(KFA.NE.22) THEN
- XFV1=XPA(KFV1)-XPA(-KFV1)
- XPA(KFV1)=XPA(-KFV1)
- XFV2=XPA(KFV2)-XPA(-KFV2)
- XPA(KFV2)=XPA(-KFV2)
- ELSE
- XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
- XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
- XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
- XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
- ENDIF
-
-C...Dampen valence and sea separately. Put back together.
- DO 120 KFL=-25,25
- XPQ(KFL)=FS*XPA(KFL)
- 120 CONTINUE
- IF(KFA.NE.22) THEN
- XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
- XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
- ELSE
- XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
- XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
- XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
- XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
- ENDIF
- MINT(92)=2
-
-C...Large Q2 and small x: interpolate behaviour.
- ELSEIF(Q2.GT.Q2MN) THEN
-
-C...Evaluate at extremes and define coefficients for interpolation.
- MINT(30)=MINT30
- CALL PYPDFU(KFC,XMN,Q2MN,XPA)
- VI232A=VINT(232)
- MINT(30)=MINT30
- CALL PYPDFU(KFC,X,Q2B,XPB)
- VI232B=VINT(232)
- FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
- FVA=(X/XMN)**0.45D0*FLA
- FSA=(X/XMN)**(-0.08D0)*FLA
- FB=1D0-FLA
-
-C...Separate valence and sea parts of parton distribution.
- IF(KFA.NE.22) THEN
- XFVA1=XPA(KFV1)-XPA(-KFV1)
- XPA(KFV1)=XPA(-KFV1)
- XFVA2=XPA(KFV2)-XPA(-KFV2)
- XPA(KFV2)=XPA(-KFV2)
- XFVB1=XPB(KFV1)-XPB(-KFV1)
- XPB(KFV1)=XPB(-KFV1)
- XFVB2=XPB(KFV2)-XPB(-KFV2)
- XPB(KFV2)=XPB(-KFV2)
- ELSE
- XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
- XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
- XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
- XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
- XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
- XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
- XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
- XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
- ENDIF
-
-C...Interpolate for valence and sea. Put back together.
- DO 130 KFL=-25,25
- XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
- 130 CONTINUE
- IF(KFA.NE.22) THEN
- XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
- XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
- ELSE
- XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
- XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
- XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
- XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
- ENDIF
- MINT(92)=3
-
-C...Small Q2 and small x: dampen boundary value and add term.
- ELSE
-
-C...Evaluate at boundary and define dampening factors.
- MINT(30)=MINT30
- CALL PYPDFU(KFC,XMN,Q2MN,XPA)
- FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
- FA=1D0-FB
- FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
- FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
- FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
- FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
- FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
- FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
-
-C...Separate valence and sea parts of parton distribution.
- IF(KFA.NE.22) THEN
- XFV1=XPA(KFV1)-XPA(-KFV1)
- XPA(KFV1)=XPA(-KFV1)
- XFV2=XPA(KFV2)-XPA(-KFV2)
- XPA(KFV2)=XPA(-KFV2)
- ELSE
- XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
- XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
- XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
- XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
- ENDIF
-
-C...Dampen valence and sea separately. Add constant terms.
-C...Put back together.
- DO 140 KFL=-25,25
- XPQ(KFL)=FSA*XPA(KFL)
- 140 CONTINUE
- IF(KFA.NE.22) THEN
- DO 150 KFL=-3,3
- XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
- 150 CONTINUE
- XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
- XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
- ELSE
- DO 160 KFL=-3,3
- XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
- 160 CONTINUE
- XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
- XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
- XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
- XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
- ENDIF
- XPQ(21)=XPQ(0)
- MINT(92)=4
- ENDIF
-
-C...Format for error printout.
- 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYPDEL
-C...Gives electron (or muon, or tau) parton distribution.
-
- SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
-C...Local arrays.
- DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
-
-C...Interface to PDFLIB.
- COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
- SAVE /LW50513/
- DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
- &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
- CHARACTER*20 PARM(20)
- DATA VALUE/20*0D0/,PARM/20*' '/
-
-C...Some common constants.
- DO 100 KFL=-25,25
- XPEL(KFL)=0D0
- 100 CONTINUE
- AEM=PARU(101)
- PME=PMAS(11,1)
- IF(KFA.EQ.13) PME=PMAS(13,1)
- IF(KFA.EQ.15) PME=PMAS(15,1)
- XL=LOG(MAX(1D-10,X))
- X1L=LOG(MAX(1D-10,1D0-X))
- HLE=LOG(MAX(3D0,Q2/PME**2))
- HBE2=(AEM/PARU(1))*(HLE-1D0)
-
-C...Electron inside electron, see R. Kleiss et al., in Z physics at
-C...LEP 1, CERN 89-08, p. 34
- IF(MSTP(59).LE.1) THEN
- HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
- & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
- HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
- & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
- & 4D0*XL/(1D0-X)-5D0-X)
- ELSE
- HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
- & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
- & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
- ENDIF
-C...Zero distribution for very large x and rescale it for intermediate.
- IF(X.GT.1D0-1D-10) THEN
- HEE=0D0
- ELSEIF(X.GT.1D0-1D-7) THEN
- HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
- ENDIF
- XPEL(KFA)=X*HEE
-
-C...Photon and (transverse) W- inside electron.
- AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
- IF(MSTP(13).LE.1) THEN
- HLG=HLE
- ELSE
- HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
- ENDIF
- XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
- HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
- XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
-
-C...Electron or positron inside photon inside electron.
- IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
- XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
- & 2D0*X*(1D0+X)*XL)
- XPEL(11)=XPEL(11)+XFSEA
- XPEL(-11)=XFSEA
-
-C...Initialize PDFLIB photon parton distributions.
- IF(MSTP(56).EQ.2) THEN
- PARM(1)='NPTYPE'
- VALUE(1)=3
- PARM(2)='NGROUP'
- VALUE(2)=MSTP(55)/1000
- PARM(3)='NSET'
- VALUE(3)=MOD(MSTP(55),1000)
- IF(MINT(93).NE.3000000+MSTP(55)) THEN
- CALL PDFSET(PARM,VALUE)
- MINT(93)=3000000+MSTP(55)
- ENDIF
- ENDIF
-
-C...Quarks and gluons inside photon inside electron:
-C...numerical convolution required.
- DO 110 KFL=0,6
- SXP(KFL)=0D0
- 110 CONTINUE
- SUMXPP=0D0
- ITER=-1
- 120 ITER=ITER+1
- SUMXP=SUMXPP
- NSTP=2**(ITER-1)
- IF(ITER.EQ.0) NSTP=2
- DO 130 KFL=0,6
- SXP(KFL)=0.5D0*SXP(KFL)
- 130 CONTINUE
- WTSTP=0.5D0/NSTP
- IF(ITER.EQ.0) WTSTP=0.5D0
-C...Pick grid of x_{gamma} values logarithmically even.
- DO 150 ISTP=1,NSTP
- IF(ITER.EQ.0) THEN
- XLE=XL*(ISTP-1)
- ELSE
- XLE=XL*(ISTP-0.5D0)/NSTP
- ENDIF
- XE=MIN(1D0-1D-10,EXP(XLE))
- XG=MIN(1D0-1D-10,X/XE)
-C...Evaluate photon inside electron parton distribution for convolution.
- XPGP=1D0+(1D0-XE)**2
- IF(MSTP(13).LE.1) THEN
- XPGP=XPGP*HLE
- ELSE
- XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
- ENDIF
-C...Evaluate photon parton distributions for convolution.
- IF(MSTP(56).EQ.1) THEN
- IF(MSTP(55).EQ.1) THEN
- CALL PYPDGA(XG,Q2,XPGA)
- ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
- Q2MX=Q2
- P2MX=0.36D0
- IF(MSTP(55).GE.7) P2MX=4.0D0
- IF(MSTP(57).EQ.0) Q2MX=P2MX
- P2=0D0
- IF(VINT(120).LT.0D0) P2=VINT(120)**2
- CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
- VINT(231)=P2MX
- ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
- Q2MX=Q2
- P2MX=0.36D0
- IF(MSTP(55).GE.11) P2MX=4.0D0
- IF(MSTP(57).EQ.0) Q2MX=P2MX
- P2=0D0
- IF(VINT(120).LT.0D0) P2=VINT(120)**2
- CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
- VINT(231)=P2MX
- ENDIF
- DO 140 KFL=0,5
- SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
- 140 CONTINUE
- ELSEIF(MSTP(56).EQ.2) THEN
-C...Call PDFLIB parton distributions.
- XX=XG
- QQ=SQRT(MAX(0D0,Q2MIN,Q2))
- IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
- CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
- SXP(0)=SXP(0)+WTSTP*XPGP*GLU
- SXP(1)=SXP(1)+WTSTP*XPGP*DNV
- SXP(2)=SXP(2)+WTSTP*XPGP*UPV
- SXP(3)=SXP(3)+WTSTP*XPGP*STR
- SXP(4)=SXP(4)+WTSTP*XPGP*CHM
- SXP(5)=SXP(5)+WTSTP*XPGP*BOT
- SXP(6)=SXP(6)+WTSTP*XPGP*TOP
- ENDIF
- 150 CONTINUE
- SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
- IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
- & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
-
-C...Put convolution into output arrays.
- FCONV=AEMP*(-XL)
- XPEL(0)=FCONV*SXP(0)
- DO 160 KFL=1,6
- XPEL(KFL)=FCONV*SXP(KFL)
- XPEL(-KFL)=XPEL(KFL)
- 160 CONTINUE
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYPDGA
-C...Gives photon parton distribution.
-
- SUBROUTINE PYPDGA(X,Q2,XPGA)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYDAT1/,/PYPARS/,/PYINT1/
-C...Local arrays.
- DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
- &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
- &DGCS(4,3),DGDS(4,3),DGES(4,3)
-
-C...The following data lines are coefficients needed in the
-C...Drees and Grassie photon parton distribution parametrization.
- DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
- &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
- DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
- &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
- DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
- &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
- DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
- &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
- DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
- &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
- DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
- &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
- DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
- &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
- DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
- &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
- DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
- &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
- DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
- &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
- DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
- &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
- DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
- &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
- DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
- &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
-
-C...Photon parton distribution from Drees and Grassie.
-C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
- DO 100 KFL=-6,6
- XPGA(KFL)=0D0
- 100 CONTINUE
- VINT(231)=1D0
- IF(MSTP(57).LE.0) THEN
- T=LOG(1D0/0.16D0)
- ELSE
- T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
- ENDIF
- X1=1D0-X
- NF=3
- IF(Q2.GT.25D0) NF=4
- IF(Q2.GT.300D0) NF=5
- NFE=NF-2
- AEM=PARU(101)
-
-C...Evaluate gluon content.
- DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
- DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
- DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
- XPGL=DGA*X**DGB*X1**DGC
-
-C...Evaluate up- and down-type quark content.
- DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
- DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
- DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
- DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
- DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
- XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
- DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
- DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
- DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
- DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
- DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
- DGF=9D0
- IF(NF.EQ.4) DGF=10D0
- IF(NF.EQ.5) DGF=55D0/6D0
- XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
- IF(NF.LE.3) THEN
- XPQU=(XPQS+9D0*XPQN)/6D0
- XPQD=(XPQS-4.5D0*XPQN)/6D0
- ELSEIF(NF.EQ.4) THEN
- XPQU=(XPQS+6D0*XPQN)/8D0
- XPQD=(XPQS-6D0*XPQN)/8D0
- ELSE
- XPQU=(XPQS+7.5D0*XPQN)/10D0
- XPQD=(XPQS-5D0*XPQN)/10D0
- ENDIF
-
-C...Put into output arrays.
- XPGA(0)=AEM*XPGL
- XPGA(1)=AEM*XPQD
- XPGA(2)=AEM*XPQU
- XPGA(3)=AEM*XPQD
- IF(NF.GE.4) XPGA(4)=AEM*XPQU
- IF(NF.GE.5) XPGA(5)=AEM*XPQD
- DO 110 KFL=1,6
- XPGA(-KFL)=XPGA(KFL)
- 110 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYGGAM
-C...Constructs the F2 and parton distributions of the photon
-C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
-C...For F2, c and b are included by the Bethe-Heitler formula;
-C...in the 'MSbar' scheme additionally a Cgamma term is added.
-C...Contains the SaS sets 1D, 1M, 2D and 2M.
-C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
-
- SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
- &XPDIR(-6:6)
- COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
- SAVE /PYINT8/,/PYINT9/
-C...Local arrays.
- DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
-C...Charm and bottom masses (low to compensate for J/psi etc.).
- DATA PMC/1.3D0/, PMB/4.6D0/
-C...alpha_em and alpha_em/(2*pi).
- DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
-C...Lambda value for 4 flavours.
- DATA ALAM/0.20D0/
-C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
- DATA FRACU/0.8D0/
-C...VMD couplings f_V**2/(4*pi).
- DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
-C...Masses for rho (=omega) and phi.
- DATA PMRHO/0.770D0/, PMPHI/1.020D0/
-C...Number of points in integration for IP2=1.
- DATA NSTEP/100/
-
-C...Reset output.
- F2GM=0D0
- DO 100 KFL=-6,6
- XPDFGM(KFL)=0D0
- XPVMD(KFL)=0D0
- XPANL(KFL)=0D0
- XPANH(KFL)=0D0
- XPBEH(KFL)=0D0
- XPDIR(KFL)=0D0
- VXPVMD(KFL)=0D0
- VXPANL(KFL)=0D0
- VXPANH(KFL)=0D0
- VXPDGM(KFL)=0D0
- 100 CONTINUE
-
-C...Set Q0 cut-off parameter as function of set used.
- IF(ISET.LE.2) THEN
- Q0=0.6D0
- ELSE
- Q0=2D0
- ENDIF
- Q02=Q0**2
-
-C...Scale choice for off-shell photon; common factors.
- Q2A=Q2
- FACNOR=1D0
- IF(IP2.EQ.1) THEN
- P2MX=P2+Q02
- Q2A=Q2+P2*Q02/MAX(Q02,Q2)
- FACNOR=LOG(Q2/Q02)/NSTEP
- ELSEIF(IP2.EQ.2) THEN
- P2MX=MAX(P2,Q02)
- ELSEIF(IP2.EQ.3) THEN
- P2MX=P2+Q02
- Q2A=Q2+P2*Q02/MAX(Q02,Q2)
- ELSEIF(IP2.EQ.4) THEN
- P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
- & ((Q2+P2)*(Q02+P2)))
- ELSEIF(IP2.EQ.5) THEN
- P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
- & ((Q2+P2)*(Q02+P2)))
- P2MX=Q0*SQRT(P2MXA)
- FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
- ELSEIF(IP2.EQ.6) THEN
- P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
- & ((Q2+P2)*(Q02+P2)))
- P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
- ELSE
- P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
- & ((Q2+P2)*(Q02+P2)))
- P2MX=Q0*SQRT(P2MXA)
- P2MXB=P2MX
- P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
- P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
- IF(ABS(Q2-Q02).GT.1D-6) THEN
- FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
- ELSEIF(P2.LT.Q02) THEN
- FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
- ELSE
- FACNOR=1D0
- ENDIF
- ENDIF
-
-C...Call VMD parametrization for d quark and use to give rho, omega,
-C...phi. Note dipole dampening for off-shell photon.
- CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
- XFVAL=VXPGA(1)
- XPGA(1)=XPGA(2)
- XPGA(-1)=XPGA(-2)
- FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
- FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
- DO 110 KFL=-5,5
- XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
- 110 CONTINUE
- XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
- XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
- XPVMD(3)=XPVMD(3)+FACS*XFVAL
- XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
- XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
- XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
- VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
- VXPVMD(2)=FRACU*FACUD*XFVAL
- VXPVMD(3)=FACS*XFVAL
- VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
- VXPVMD(-2)=FRACU*FACUD*XFVAL
- VXPVMD(-3)=FACS*XFVAL
-
- IF(IP2.NE.1) THEN
-C...Anomalous parametrizations for different strategies
-C...for off-shell photons; except full integration.
-
-C...Call anomalous parametrization for d + u + s.
- CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
- DO 120 KFL=-5,5
- XPANL(KFL)=FACNOR*XPGA(KFL)
- VXPANL(KFL)=FACNOR*VXPGA(KFL)
- 120 CONTINUE
-
-C...Call anomalous parametrization for c and b.
- CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
- DO 130 KFL=-5,5
- XPANH(KFL)=FACNOR*XPGA(KFL)
- VXPANH(KFL)=FACNOR*VXPGA(KFL)
- 130 CONTINUE
- CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
- DO 140 KFL=-5,5
- XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
- VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
- 140 CONTINUE
-
- ELSE
-C...Special option: loop over flavours and integrate over k2.
- DO 170 KF=1,5
- DO 160 ISTEP=1,NSTEP
- Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
- IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
- & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
- CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
- FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
- IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
- IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
- DO 150 KFL=-5,5
- IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
- IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
- IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
- IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
- 150 CONTINUE
- 160 CONTINUE
- 170 CONTINUE
- ENDIF
-
-C...Call Bethe-Heitler term expression for charm and bottom.
- CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
- XPBEH(4)=XPBH
- XPBEH(-4)=XPBH
- CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
- XPBEH(5)=XPBH
- XPBEH(-5)=XPBH
-
-C...For MSbar subtraction call C^gamma term expression for d, u, s.
- IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
- CALL PYGDIR(X,Q2,P2,Q02,XPGA)
- DO 180 KFL=-5,5
- XPDIR(KFL)=XPGA(KFL)
- 180 CONTINUE
- ENDIF
-
-C...Store result in output array.
- DO 190 KFL=-5,5
- CHSQ=1D0/9D0
- IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
- XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
- IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
- XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
- VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
- 190 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYGVMD
-C...Evaluates the VMD parton distributions of a photon,
-C...evolved homogeneously from an initial scale P2 to Q2.
-C...Does not include dipole suppression factor.
-C...ISET is parton distribution set, see above;
-C...additionally ISET=0 is used for the evolution of an anomalous photon
-C...which branched at a scale P2 and then evolved homogeneously to Q2.
-C...ALAM is the 4-flavour Lambda, which is automatically converted
-C...to 3- and 5-flavour equivalents as needed.
-C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
-
- SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Local arrays and data.
- DIMENSION XPGA(-6:6), VXPGA(-6:6)
- DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
-
-C...Reset output.
- DO 100 KFL=-6,6
- XPGA(KFL)=0D0
- VXPGA(KFL)=0D0
- 100 CONTINUE
- KFA=IABS(KF)
-
-C...Calculate Lambda; protect against unphysical Q2 and P2 input.
- ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
- ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
- P2EFF=MAX(P2,1.2D0*ALAM3**2)
- IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
- IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
- Q2EFF=MAX(Q2,P2EFF)
-
-C...Find number of flavours at lower and upper scale.
- NFP=4
- IF(P2EFF.LT.PMC**2) NFP=3
- IF(P2EFF.GT.PMB**2) NFP=5
- NFQ=4
- IF(Q2EFF.LT.PMC**2) NFQ=3
- IF(Q2EFF.GT.PMB**2) NFQ=5
-
-C...Find s as sum of 3-, 4- and 5-flavour parts.
- S=0D0
- IF(NFP.EQ.3) THEN
- Q2DIV=PMC**2
- IF(NFQ.EQ.3) Q2DIV=Q2EFF
- S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
- ENDIF
- IF(NFP.LE.4.AND.NFQ.GE.4) THEN
- P2DIV=P2EFF
- IF(NFP.EQ.3) P2DIV=PMC**2
- Q2DIV=Q2EFF
- IF(NFQ.EQ.5) Q2DIV=PMB**2
- S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
- ENDIF
- IF(NFQ.EQ.5) THEN
- P2DIV=PMB**2
- IF(NFP.EQ.5) P2DIV=P2EFF
- S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
- ENDIF
-
-C...Calculate frequent combinations of x and s.
- X1=1D0-X
- XL=-LOG(X)
- S2=S**2
- S3=S**3
- S4=S**4
-
-C...Evaluate homogeneous anomalous parton distributions below or
-C...above threshold.
- IF(ISET.EQ.0) THEN
- IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
- & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
- XVAL = X * 1.5D0 * (X**2+X1**2)
- XGLU = 0D0
- XSEA = 0D0
- ELSE
- XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
- & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
- & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
- & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
- XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
- & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
- & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
- XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
- & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
- & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
- & (2D0*X-1D0)*X*XL**2)
- ENDIF
-
-C...Evaluate set 1D parton distributions below or above threshold.
- ELSEIF(ISET.EQ.1) THEN
- IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
- & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
- XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
- XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
- XSEA = 0.100D0 * X1**3.76D0
- ELSE
- XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
- & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
- XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
- & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
- & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
- & X**0.40D0 * X1**(1.76D0+3D0*S)
- XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
- & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
- & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
- XSEA0 = 0.100D0 * X1**3.76D0
- ENDIF
-
-C...Evaluate set 1M parton distributions below or above threshold.
- ELSEIF(ISET.EQ.2) THEN
- IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
- & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
- XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
- XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
- XSEA = 0D0
- ELSE
- XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
- & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
- XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
- & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
- & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
- & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
- XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
- & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
- & XL**(2.8D0*S)
- XSEA0 = 0D0
- ENDIF
-
-C...Evaluate set 2D parton distributions below or above threshold.
- ELSEIF(ISET.EQ.3) THEN
- IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
- & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
- XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
- XGLU = 1.925D0 * X1**2
- XSEA = 0.242D0 * X1**4
- ELSE
- XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
- & X**(0.46D0+0.25D0*S) *
- & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
- & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
- XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
- & EXP(-18.67D0*S) *
- & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
- & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
- & XL**(9.3D0*S/(1D0+1.7D0*S))
- XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
- & (1D0-0.607D0*S+21.95D0*S2) *
- & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
- XSEA0 = 0.242D0 * X1**4
- ENDIF
-
-C...Evaluate set 2M parton distributions below or above threshold.
- ELSEIF(ISET.EQ.4) THEN
- IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
- & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
- XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
- XGLU = 1.808D0 * X1**2
- XSEA = 0.209D0 * X1**4
- ELSE
- XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
- & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
- & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
- & XL**(5.15D0*S/(1D0+2D0*S)) +
- & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
- XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
- & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
- & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
- & XL**(10.9D0*S/(1D0+2.5D0*S))
- XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
- & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
- & X1**(4D0+S) * XL**(0.45D0*S)
- XSEA0 = 0.209D0 * X1**4
- ENDIF
- ENDIF
-
-C...Threshold factors for c and b sea.
- SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
- XCHM=0D0
- IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
- SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
- IF(ISET.EQ.0) THEN
- XCHM=XSEA*(1D0-(SCH/SLL)**2)
- ELSE
- XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
- ENDIF
- ENDIF
- XBOT=0D0
- IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
- SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
- IF(ISET.EQ.0) THEN
- XBOT=XSEA*(1D0-(SBT/SLL)**2)
- ELSE
- XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
- ENDIF
- ENDIF
-
-C...Fill parton distributions.
- XPGA(0)=XGLU
- XPGA(1)=XSEA
- XPGA(2)=XSEA
- XPGA(3)=XSEA
- XPGA(4)=XCHM
- XPGA(5)=XBOT
- XPGA(KFA)=XPGA(KFA)+XVAL
- DO 110 KFL=1,5
- XPGA(-KFL)=XPGA(KFL)
- 110 CONTINUE
- VXPGA(KFA)=XVAL
- VXPGA(-KFA)=XVAL
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYGANO
-C...Evaluates the parton distributions of the anomalous photon,
-C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
-C...KF=0 gives the sum over (up to) 5 flavours,
-C...KF<0 limits to flavours up to abs(KF),
-C...KF>0 is for flavour KF only.
-C...ALAM is the 4-flavour Lambda, which is automatically converted
-C...to 3- and 5-flavour equivalents as needed.
-C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
-
- SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Local arrays and data.
- DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
- DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
-
-C...Reset output.
- DO 100 KFL=-6,6
- XPGA(KFL)=0D0
- VXPGA(KFL)=0D0
- 100 CONTINUE
- IF(Q2.LE.P2) RETURN
- KFA=IABS(KF)
-
-C...Calculate Lambda; protect against unphysical Q2 and P2 input.
- ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
- ALAMSQ(4)=ALAM**2
- ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
- P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
- IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
- IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
- Q2EFF=MAX(Q2,P2EFF)
- XL=-LOG(X)
-
-C...Find number of flavours at lower and upper scale.
- NFP=4
- IF(P2EFF.LT.PMC**2) NFP=3
- IF(P2EFF.GT.PMB**2) NFP=5
- NFQ=4
- IF(Q2EFF.LT.PMC**2) NFQ=3
- IF(Q2EFF.GT.PMB**2) NFQ=5
-
-C...Define range of flavour loop.
- IF(KF.EQ.0) THEN
- KFLMN=1
- KFLMX=5
- ELSEIF(KF.LT.0) THEN
- KFLMN=1
- KFLMX=KFA
- ELSE
- KFLMN=KFA
- KFLMX=KFA
- ENDIF
-
-C...Loop over flavours the photon can branch into.
- DO 110 KFL=KFLMN,KFLMX
-
-C...Light flavours: calculate t range and (approximate) s range.
- IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
- TDIFF=LOG(Q2EFF/P2EFF)
- S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
- & LOG(P2EFF/ALAMSQ(NFQ)))
- IF(NFQ.GT.NFP) THEN
- Q2DIV=PMB**2
- IF(NFQ.EQ.4) Q2DIV=PMC**2
- SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
- & LOG(P2EFF/ALAMSQ(NFQ)))
- SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
- & LOG(P2EFF/ALAMSQ(NFQ-1)))
- S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
- ENDIF
- IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
- Q2DIV=PMC**2
- SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
- & LOG(P2EFF/ALAMSQ(4)))
- SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
- & LOG(P2EFF/ALAMSQ(3)))
- S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
- ENDIF
-
-C...u and s quark do not need a separate treatment when d has been done.
- ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
-
-C...Charm: as above, but only include range above c threshold.
- ELSEIF(KFL.EQ.4) THEN
- IF(Q2.LE.PMC**2) GOTO 110
- P2EFF=MAX(P2EFF,PMC**2)
- Q2EFF=MAX(Q2EFF,P2EFF)
- TDIFF=LOG(Q2EFF/P2EFF)
- S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
- & LOG(P2EFF/ALAMSQ(NFQ)))
- IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
- Q2DIV=PMB**2
- SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
- & LOG(P2EFF/ALAMSQ(NFQ)))
- SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
- & LOG(P2EFF/ALAMSQ(NFQ-1)))
- S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
- ENDIF
-
-C...Bottom: as above, but only include range above b threshold.
- ELSEIF(KFL.EQ.5) THEN
- IF(Q2.LE.PMB**2) GOTO 110
- P2EFF=MAX(P2EFF,PMB**2)
- Q2EFF=MAX(Q2,P2EFF)
- TDIFF=LOG(Q2EFF/P2EFF)
- S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
- & LOG(P2EFF/ALAMSQ(NFQ)))
- ENDIF
-
-C...Evaluate flavour-dependent prefactor (charge^2 etc.).
- CHSQ=1D0/9D0
- IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
- FAC=AEM2PI*2D0*CHSQ*TDIFF
-
-C...Evaluate parton distributions (normalized to unit momentum sum).
- IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
- XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
- & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
- & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
- & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
- XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
- & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
- & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
- XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
- & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
- & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
- & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
-
-C...Threshold factors for c and b sea.
- SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
- XCHM=0D0
- IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
- SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
- XCHM=XSEA*(1D0-(SCH/SLL)**3)
- ENDIF
- XBOT=0D0
- IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
- SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
- XBOT=XSEA*(1D0-(SBT/SLL)**3)
- ENDIF
- ENDIF
-
-C...Add contribution of each valence flavour.
- XPGA(0)=XPGA(0)+FAC*XGLU
- XPGA(1)=XPGA(1)+FAC*XSEA
- XPGA(2)=XPGA(2)+FAC*XSEA
- XPGA(3)=XPGA(3)+FAC*XSEA
- XPGA(4)=XPGA(4)+FAC*XCHM
- XPGA(5)=XPGA(5)+FAC*XBOT
- XPGA(KFL)=XPGA(KFL)+FAC*XVAL
- VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
- 110 CONTINUE
- DO 120 KFL=1,5
- XPGA(-KFL)=XPGA(KFL)
- VXPGA(-KFL)=VXPGA(KFL)
- 120 CONTINUE
-
- RETURN
- END
-
-
-C*********************************************************************
-
-C...PYGBEH
-C...Evaluates the Bethe-Heitler cross section for heavy flavour
-C...production.
-C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
-
- SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...Local data.
- DATA AEM2PI/0.0011614D0/
-
-C...Reset output.
- XPBH=0D0
- SIGBH=0D0
-
-C...Check kinematics limits.
- IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
- W2=Q2*(1D0-X)/X-P2
- BETA2=1D0-4D0*PM2/W2
- IF(BETA2.LT.1D-10) RETURN
- BETA=SQRT(BETA2)
- RMQ=4D0*PM2/Q2
-
-C...Simple case: P2 = 0.
- IF(P2.LT.1D-4) THEN
- IF(BETA.LT.0.99D0) THEN
- XBL=LOG((1D0+BETA)/(1D0-BETA))
- ELSE
- XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
- ENDIF
- SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
- & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
-
-C...Complicated case: P2 > 0, based on approximation of
-C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
- ELSE
- RPQ=1D0-4D0*X**2*P2/Q2
- IF(RPQ.GT.1D-10) THEN
- RPBE=SQRT(RPQ*BETA2)
- IF(RPBE.LT.0.99D0) THEN
- XBL=LOG((1D0+RPBE)/(1D0-RPBE))
- XBI=2D0*RPBE/(1D0-RPBE**2)
- ELSE
- RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
- XBL=LOG((1D0+RPBE)**2/RPBESN)
- XBI=2D0*RPBE/RPBESN
- ENDIF
- SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
- & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
- & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
- ENDIF
- ENDIF
-
-C...Multiply by charge-squared etc. to get parton distribution.
- CHSQ=1D0/9D0
- IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
- XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYGDIR
-C...Evaluates the direct contribution, i.e. the C^gamma term,
-C...as needed in MSbar parametrizations.
-C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
-
- SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Local array and data.
- DIMENSION XPGA(-6:6)
- DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
-
-C...Reset output.
- DO 100 KFL=-6,6
- XPGA(KFL)=0D0
- 100 CONTINUE
-
-C...Evaluate common x-dependent expression.
- XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
- CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
-
-C...d, u, s part by simple charge factor.
- XPGA(1)=(1D0/9D0)*CGAM
- XPGA(2)=(4D0/9D0)*CGAM
- XPGA(3)=(1D0/9D0)*CGAM
-
-C...Also fill for antiquarks.
- DO 110 KF=1,5
- XPGA(-KF)=XPGA(KF)
- 110 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYPDPI
-C...Gives pi+ parton distribution according to two different
-C...parametrizations.
-
- SUBROUTINE PYPDPI(X,Q2,XPPI)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYDAT1/,/PYPARS/,/PYINT1/
-C...Local arrays.
- DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
-
-C...The following data lines are coefficients needed in the
-C...Owens pion parton distribution parametrizations, see below.
-C...Expansion coefficients for up and down valence quark distributions.
- DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
- &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
- &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
- &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
- DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
- &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
- &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
- &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
-C...Expansion coefficients for gluon distribution.
- DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
- &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
- &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
- &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
- DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
- &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
- &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
- &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
-C...Expansion coefficients for (up+down+strange) quark sea distribution.
- DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
- &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
- &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
- &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
- DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
- &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
- &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
- &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
-C...Expansion coefficients for charm quark sea distribution.
- DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
- &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
- &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
- &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
- DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
- &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
- &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
- &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
-
-C...Euler's beta function, requires ordinary Gamma function
- EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
-
-C...Reset output array.
- DO 100 KFL=-6,6
- XPPI(KFL)=0D0
- 100 CONTINUE
-
- IF(MSTP(53).LE.2) THEN
-C...Pion parton distributions from Owens.
-C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
-
-C...Determine set, Lambda and s expansion variable.
- NSET=MSTP(53)
- IF(NSET.EQ.1) ALAM=0.2D0
- IF(NSET.EQ.2) ALAM=0.4D0
- VINT(231)=4D0
- IF(MSTP(57).LE.0) THEN
- SD=0D0
- ELSE
- Q2IN=MIN(2D3,MAX(4D0,Q2))
- SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
- ENDIF
-
-C...Calculate parton distributions.
- DO 120 KFL=1,4
- DO 110 IS=1,5
- TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
- & COW(3,IS,KFL,NSET)*SD**2
- 110 CONTINUE
- IF(KFL.EQ.1) THEN
- XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
- ELSE
- XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
- & TS(5)*X**2)
- ENDIF
- 120 CONTINUE
-
-C...Put into output array.
- XPPI(0)=XQ(2)
- XPPI(1)=XQ(3)/6D0
- XPPI(2)=XQ(1)+XQ(3)/6D0
- XPPI(3)=XQ(3)/6D0
- XPPI(4)=XQ(4)
- XPPI(-1)=XQ(1)+XQ(3)/6D0
- XPPI(-2)=XQ(3)/6D0
- XPPI(-3)=XQ(3)/6D0
- XPPI(-4)=XQ(4)
-
-C...Leading order pion parton distributions from Glueck, Reya and Vogt.
-C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
-C...10^-5 < x < 1.
- ELSE
-
-C...Determine s expansion variable and some x expressions.
- VINT(231)=0.25D0
- IF(MSTP(57).LE.0) THEN
- SD=0D0
- ELSE
- Q2IN=MIN(1D8,MAX(0.25D0,Q2))
- SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
- ENDIF
- SD2=SD**2
- XL=-LOG(X)
- XS=SQRT(X)
-
-C...Evaluate valence, gluon and sea distributions.
- XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
- & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
- XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
- & SD-0.175D0*SD2)+
- & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
- & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
- & XL)))*
- & (1D0-X)**(0.390D0+1.053D0*SD)
- XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
- & X)**3.359D0*
- & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
- & XL))/
- & XL**(2.538D0-0.763D0*SD)
- IF(SD.LE.0.888D0) THEN
- XFCHM=0D0
- ELSE
- XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
- & 0.771D0*SD)*
- & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
- & XL))
- ENDIF
- IF(SD.LE.1.351D0) THEN
- XFBOT=0D0
- ELSE
- XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
- & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
- & XL))
- ENDIF
-
-C...Put into output array.
- XPPI(0)=XFGLU
- XPPI(1)=XFSEA
- XPPI(2)=XFSEA
- XPPI(3)=XFSEA
- XPPI(4)=XFCHM
- XPPI(5)=XFBOT
- DO 130 KFL=1,5
- XPPI(-KFL)=XPPI(KFL)
- 130 CONTINUE
- XPPI(2)=XPPI(2)+XFVAL
- XPPI(-1)=XPPI(-1)+XFVAL
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYPDPR
-C...Gives proton parton distributions according to a few different
-C...parametrizations.
-
- SUBROUTINE PYPDPR(X,Q2,XPPR)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
-C...Arrays and data.
- DIMENSION XPPR(-6:6),Q2MIN(16)
- DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
- &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
-
-C...Reset output array.
- DO 100 KFL=-6,6
- XPPR(KFL)=0D0
- 100 CONTINUE
-
-C...Common preliminaries.
- NSET=MAX(1,MIN(16,MSTP(51)))
- IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
- VINT(231)=Q2MIN(NSET)
- IF(MSTP(57).EQ.0) THEN
- Q2L=Q2MIN(NSET)
- ELSE
- Q2L=MAX(Q2MIN(NSET),Q2)
- ENDIF
-
- IF(NSET.GE.1.AND.NSET.LE.3) THEN
-C...Interface to the CTEQ 3 parton distributions.
- QRT=SQRT(MAX(1D0,Q2L))
-
-C...Loop over flavours.
- DO 110 I=-6,6
- IF(I.LE.0) THEN
- XPPR(I)=PYCTEQ(NSET,I,X,QRT)
- ELSEIF(I.LE.2) THEN
- XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
- ELSE
- XPPR(I)=XPPR(-I)
- ENDIF
- 110 CONTINUE
-
- ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
-C...Interface to the GRV 94 distributions.
- IF(NSET.EQ.4) THEN
- CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
- ELSEIF(NSET.EQ.5) THEN
- CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
- ELSE
- CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
- ENDIF
-
-C...Put into output array.
- XPPR(0)=GL
- XPPR(-1)=0.5D0*(UDB+DEL)
- XPPR(-2)=0.5D0*(UDB-DEL)
- XPPR(-3)=SB
- XPPR(-4)=CHM
- XPPR(-5)=BOT
- XPPR(1)=DV+XPPR(-1)
- XPPR(2)=UV+XPPR(-2)
- XPPR(3)=SB
- XPPR(4)=CHM
- XPPR(5)=BOT
-
- ELSEIF(NSET.EQ.7) THEN
-C...Interface to the CTEQ 5L parton distributions.
-C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
-C...freezing x*f(x,Q2) at borders.
- QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
- XIN=MAX(1D-6,MIN(1D0,X))
-
-C...Loop over flavours (with u <-> d notation mismatch).
- SUMUDB=PYCT5L(-1,XIN,QRT)
- RATUDB=PYCT5L(-2,XIN,QRT)
- DO 120 I=-5,2
- IF(I.EQ.1) THEN
- XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
- ELSEIF(I.EQ.2) THEN
- XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
- ELSEIF(I.EQ.-1) THEN
- XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
- ELSEIF(I.EQ.-2) THEN
- XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
- ELSE
- XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
- IF(I.LT.0) XPPR(-I)=XPPR(I)
- ENDIF
- 120 CONTINUE
-
- ELSEIF(NSET.EQ.8) THEN
-C...Interface to the CTEQ 5M1 parton distributions.
- QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
- XIN=MAX(1D-6,MIN(1D0,X))
-
-C...Loop over flavours (with u <-> d notation mismatch).
- SUMUDB=PYCT5M(-1,XIN,QRT)
- RATUDB=PYCT5M(-2,XIN,QRT)
- DO 130 I=-5,2
- IF(I.EQ.1) THEN
- XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
- ELSEIF(I.EQ.2) THEN
- XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
- ELSEIF(I.EQ.-1) THEN
- XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
- ELSEIF(I.EQ.-2) THEN
- XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
- ELSE
- XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
- IF(I.LT.0) XPPR(-I)=XPPR(I)
- ENDIF
- 130 CONTINUE
-
- ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
-C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
-C...obsolete but offers backwards compatibility.
- CALL PYPDPO(X,Q2L,XPPR)
-
-C...Symmetric choice for debugging only
- ELSEIF(NSET.EQ.16) THEN
- XPPR(0)=.5D0/X
- XPPR(1)=.05D0/X
- XPPR(2)=.05D0/X
- XPPR(3)=.05D0/X
- XPPR(4)=.05D0/X
- XPPR(5)=.05D0/X
- XPPR(-1)=.05D0/X
- XPPR(-2)=.05D0/X
- XPPR(-3)=.05D0/X
- XPPR(-4)=.05D0/X
- XPPR(-5)=.05D0/X
-
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYCTEQ
-C...Gives the CTEQ 3 parton distribution function sets in
-C...parametrized form, of October 24, 1994.
-C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
-C...J. Qiu, W.K. Tung and H. Weerts.
-
- FUNCTION PYCTEQ (ISET, IPRT, X, Q)
-
-C...Double precision declaration.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-
-C...Data on Lambda values of fits, minimum Q and quark masses.
- DIMENSION ALM(3), QMS(4:6)
- DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
- DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
-
-C....Check flavour thresholds. Set up QI for SB.
- IP = IABS(IPRT)
- IF(IP .GE. 4) THEN
- IF(Q .LE. QMS(IP)) THEN
- PYCTEQ = 0D0
- RETURN
- ENDIF
- QI = QMS(IP)
- ELSE
- QI = QMN
- ENDIF
-
-C...Use "standard lambda" of parametrization program for expansion.
- ALAM = ALM (ISET)
- SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
- SB = LOG (SBL)
- SB2 = SB*SB
- SB3 = SB2*SB
-
-C...Expansion for CTEQ3L.
- IF(ISET .EQ. 1) THEN
- IF(IPRT .EQ. 2) THEN
- A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
- & 0.3171D+00*SB3)
- A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
- A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
- A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
- A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
- A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
- ELSEIF(IPRT .EQ. 1) THEN
- A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
- & 0.7728D+00*SB3)
- A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
- A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
- A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
- A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
- A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
- ELSEIF(IPRT .EQ. 0) THEN
- A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
- & 0.5343D+00*SB3)
- A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
- A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
- A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
- A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
- A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
- ELSEIF(IPRT .EQ. -1) THEN
- A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
- & 0.2031D+01*SB3)
- A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
- A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
- A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
- A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
- A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
- ELSEIF(IPRT .EQ. -2) THEN
- A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
- & 0.9872D-01*SB3)
- A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
- A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
- A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
- A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
- A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
- ELSEIF(IPRT .EQ. -3) THEN
- A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
- & 0.8390D+00*SB3)
- A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
- A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
- A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
- A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
- A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
- ELSEIF(IPRT .EQ. -4) THEN
- A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
- & 0.1651D-01*SB2)
- A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
- A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
- A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
- A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
- A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
- ELSEIF(IPRT .EQ. -5) THEN
- A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
- & 0.3702D+01*SB2)
- A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
- A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
- A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
- A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
- A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
- ELSEIF(IPRT .EQ. -6) THEN
- A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
- & 0.6943D+00*SB2)
- A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
- A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
- A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
- A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
- A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
- ENDIF
-
-C...Expansion for CTEQ3M.
- ELSEIF(ISET .EQ. 2) THEN
- IF(IPRT .EQ. 2) THEN
- A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
- & 0.2935D+00*SB3)
- A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
- A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
- A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
- A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
- A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
- ELSEIF(IPRT .EQ. 1) THEN
- A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
- & 0.4305D-01*SB3)
- A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
- A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
- A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
- A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
- A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
- ELSEIF(IPRT .EQ. 0) THEN
- A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
- & 0.1037D-01*SB3)
- A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
- A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
- A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
- A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
- A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
- ELSEIF(IPRT .EQ. -1) THEN
- A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
- & 0.1602D+01*SB3)
- A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
- A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
- A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
- A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
- A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
- ELSEIF(IPRT .EQ. -2) THEN
- A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
- & 0.2496D+00*SB3)
- A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
- A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
- A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
- A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
- A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
- ELSEIF(IPRT .EQ. -3) THEN
- A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
- & 0.1936D+01*SB3)
- A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
- A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
- A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
- A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
- A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
- ELSEIF(IPRT .EQ. -4) THEN
- A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
- & 0.5348D+00*SB2)
- A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
- A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
- A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
- A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
- A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
- ELSEIF(IPRT .EQ. -5) THEN
- A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
- & 0.1569D+01*SB2)
- A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
- A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
- A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
- A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
- A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
- ELSEIF(IPRT .EQ. -6) THEN
- A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
- & 0.8838D+01*SB2)
- A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
- A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
- A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
- A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
- A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
- ENDIF
-
-C...Expansion for CTEQ3D.
- ELSEIF(ISET .EQ. 3) THEN
- IF(IPRT .EQ. 2) THEN
- A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
- & 0.2902D+00*SB3)
- A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
- A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
- A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
- A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
- A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
- ELSEIF(IPRT .EQ. 1) THEN
- A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
- & 0.7257D+00*SB3)
- A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
- A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
- A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
- A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
- A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
- ELSEIF(IPRT .EQ. 0) THEN
- A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
- & 0.2734D-04*SB3)
- A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
- A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
- A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
- A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
- A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
- ELSEIF(IPRT .EQ. -1) THEN
- A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
- & 0.1671D+01*SB3)
- A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
- A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
- A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
- A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
- A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
- ELSEIF(IPRT .EQ. -2) THEN
- A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
- & 0.2223D+00*SB3)
- A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
- A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
- A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
- A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
- A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
- ELSEIF(IPRT .EQ. -3) THEN
- A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
- & 0.1937D+01*SB3)
- A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
- A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
- A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
- A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
- A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
- ELSEIF(IPRT .EQ. -4) THEN
- A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
- & 0.5137D+00*SB2)
- A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
- A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
- A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
- A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
- A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
- ELSEIF(IPRT .EQ. -5) THEN
- A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
- & 0.2143D+01*SB2)
- A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
- A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
- A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
- A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
- A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
- ELSEIF(IPRT .EQ. -6) THEN
- A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
- & 0.9998D+01*SB2)
- A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
- A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
- A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
- A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
- A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
- ENDIF
- ENDIF
-
-C...Calculation of x * f(x, Q).
- PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
- & *(LOG(1D0+1D0/X))**A5 )
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYGRVL
-C...Gives the GRV 94 L (leading order) parton distribution function set
-C...in parametrized form.
-C...Authors: M. Glueck, E. Reya and A. Vogt.
-
- SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
-
-C...Double precision declaration.
- IMPLICIT DOUBLE PRECISION (A - Z)
-
-C...Common expressions.
- MU2 = 0.23D0
- LAM2 = 0.2322D0 * 0.2322D0
- S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
- DS = SQRT (S)
- S2 = S * S
- S3 = S2 * S
-
-C...uv :
- NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
- AKU = 0.590D0 - 0.024D0 * S
- BKU = 0.131D0 + 0.063D0 * S
- AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
- BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
- CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
- DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
- UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
-
-C...dv :
- ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
- AKD = 0.376D0
- BKD = 0.486D0 + 0.062D0 * S
- AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
- BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
- CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
- DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
- DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
-
-C...del :
- NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
- AKE = 0.409D0 - 0.005D0 * S
- BKE = 0.799D0 + 0.071D0 * S
- AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
- BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
- CE = 0.0D0
- DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
- DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
-
-C...udb :
- ALX = 1.451D0
- BEX = 0.271D0
- AKX = 0.410D0 - 0.232D0 * S
- BKX = 0.534D0 - 0.457D0 * S
- AGX = 0.890D0 - 0.140D0 * S
- BGX = -0.981D0
- CX = 0.320D0 + 0.683D0 * S
- DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
- EX = 4.119D0 + 1.713D0 * S
- ESX = 0.682D0 + 2.978D0 * S
- UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
- & DX, EX, ESX)
-
-C...sb :
- STS = 0D0
- ALS = 0.914D0
- BES = 0.577D0
- AKS = 1.798D0 - 0.596D0 * S
- AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
- BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
- DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
- EST = 3.981D0 + 1.638D0 * S
- ESS = 6.402D0
- SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
-
-C...cb :
- STC = 0.888D0
- ALC = 1.01D0
- BEC = 0.37D0
- AKC = 0D0
- AC = 0D0
- BC = 4.24D0 - 0.804D0 * S
- DCT = 3.46D0 - 1.076D0 * S
- ECT = 4.61D0 + 1.49D0 * S
- ESC = 2.555D0 + 1.961D0 * S
- CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
-
-C...bb :
- STB = 1.351D0
- ALB = 1.00D0
- BEB = 0.51D0
- AKB = 0D0
- AB = 0D0
- BB = 1.848D0
- DBT = 2.929D0 + 1.396D0 * S
- EBT = 4.71D0 + 1.514D0 * S
- ESB = 4.02D0 + 1.239D0 * S
- BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
-
-C...gl :
- ALG = 0.524D0
- BEG = 1.088D0
- AKG = 1.742D0 - 0.930D0 * S
- BKG = - 0.399D0 * S2
- AG = 7.486D0 - 2.185D0 * S
- BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
- CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
- DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
- EG = 0.807D0 + 2.005D0 * S
- ESG = 3.841D0 + 0.316D0 * S
- GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
- & DG, EG, ESG)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYGRVM
-C...Gives the GRV 94 M (MSbar) parton distribution function set
-C...in parametrized form.
-C...Authors: M. Glueck, E. Reya and A. Vogt.
-
- SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
-
-C...Double precision declaration.
- IMPLICIT DOUBLE PRECISION (A - Z)
-
-C...Common expressions.
- MU2 = 0.34D0
- LAM2 = 0.248D0 * 0.248D0
- S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
- DS = SQRT (S)
- S2 = S * S
- S3 = S2 * S
-
-C...uv :
- NU = 1.304D0 + 0.863D0 * S
- AKU = 0.558D0 - 0.020D0 * S
- BKU = 0.183D0 * S
- AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
- BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
- CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
- DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
- UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
-
-C...dv :
- ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
- AKD = 0.270D0 - 0.019D0 * S
- BKD = 0.260D0
- AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
- BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
- CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
- DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
- DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
-
-C...del :
- NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
- AKE = 0.409D0 - 0.007D0 * S
- BKE = 0.782D0 + 0.082D0 * S
- AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
- BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
- CE = 0.0D0
- DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
- DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
-
-C...udb :
- ALX = 0.877D0
- BEX = 0.561D0
- AKX = 0.275D0
- BKX = 0.0D0
- AGX = 0.997D0
- BGX = 3.210D0 - 1.866D0 * S
- CX = 7.300D0
- DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
- EX = 3.077D0 + 1.446D0 * S
- ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
- UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
- & DX, EX, ESX)
-
-C...sb :
- STS = 0D0
- ALS = 0.756D0
- BES = 0.216D0
- AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
- AS = -4.329D0 + 1.131D0 * S
- BS = 9.568D0 - 1.744D0 * S
- DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
- EST = 3.031D0 + 1.639D0 * S
- ESS = 5.837D0 + 0.815D0 * S
- SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
-
-C...cb :
- STC = 0.820D0
- ALC = 0.98D0
- BEC = 0D0
- AKC = -0.625D0 - 0.523D0 * S
- AC = 0D0
- BC = 1.896D0 + 1.616D0 * S
- DCT = 4.12D0 + 0.683D0 * S
- ECT = 4.36D0 + 1.328D0 * S
- ESC = 0.677D0 + 0.679D0 * S
- CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
-
-C...bb :
- STB = 1.297D0
- ALB = 0.99D0
- BEB = 0D0
- AKB = - 0.193D0 * S
- AB = 0D0
- BB = 0D0
- DBT = 3.447D0 + 0.927D0 * S
- EBT = 4.68D0 + 1.259D0 * S
- ESB = 1.892D0 + 2.199D0 * S
- BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
-
-C...gl :
- ALG = 1.014D0
- BEG = 1.738D0
- AKG = 1.724D0 + 0.157D0 * S
- BKG = 0.800D0 + 1.016D0 * S
- AG = 7.517D0 - 2.547D0 * S
- BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
- CG = 4.039D0 + 1.491D0 * S
- DG = 3.404D0 + 0.830D0 * S
- EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
- ESG = 3.256D0 - 0.436D0 * S
- GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYGRVD
-C...Gives the GRV 94 D (DIS) parton distribution function set
-C...in parametrized form.
-C...Authors: M. Glueck, E. Reya and A. Vogt.
-
- SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
-
-C...Double precision declaration.
- IMPLICIT DOUBLE PRECISION (A - Z)
-
-C...Common expressions.
- MU2 = 0.34D0
- LAM2 = 0.248D0 * 0.248D0
- S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
- DS = SQRT (S)
- S2 = S * S
- S3 = S2 * S
-
-C...uv :
- NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
- AKU = 0.563D0 - 0.025D0 * S
- BKU = 0.054D0 + 0.154D0 * S
- AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
- BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
- CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
- DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
- UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
-
-C...dv :
- ND = 0.156D0 - 0.017D0 * S
- AKD = 0.299D0 - 0.022D0 * S
- BKD = 0.259D0 - 0.015D0 * S
- AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
- BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
- CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
- DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
- DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
-
-C...del :
- NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
- AKE = 0.419D0 - 0.013D0 * S
- BKE = 1.064D0 - 0.038D0 * S
- AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
- BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
- CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
- DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
- DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
-
-C...udb :
- ALX = 1.215D0
- BEX = 0.466D0
- AKX = 0.326D0 + 0.150D0 * S
- BKX = 0.956D0 + 0.405D0 * S
- AGX = 0.272D0
- BGX = 3.794D0 - 2.359D0 * DS
- CX = 2.014D0
- DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
- EX = 3.049D0 + 1.597D0 * S
- ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
- UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
- & DX, EX, ESX)
-
-C...sb :
- STS = 0D0
- ALS = 0.175D0
- BES = 0.344D0
- AKS = 1.415D0 - 0.641D0 * DS
- AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
- BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
- DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
- EST = 4.546D0 + 0.372D0 * S2
- ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
- SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
-
-C...cb :
- STC = 0.820D0
- ALC = 0.98D0
- BEC = 0D0
- AKC = -0.625D0 - 0.523D0 * S
- AC = 0D0
- BC = 1.896D0 + 1.616D0 * S
- DCT = 4.12D0 + 0.683D0 * S
- ECT = 4.36D0 + 1.328D0 * S
- ESC = 0.677D0 + 0.679D0 * S
- CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
-
-C...bb :
- STB = 1.297D0
- ALB = 0.99D0
- BEB = 0D0
- AKB = - 0.193D0 * S
- AB = 0D0
- BB = 0D0
- DBT = 3.447D0 + 0.927D0 * S
- EBT = 4.68D0 + 1.259D0 * S
- ESB = 1.892D0 + 2.199D0 * S
- BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
-
-C...gl :
- ALG = 1.258D0
- BEG = 1.846D0
- AKG = 2.423D0
- BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
- AG = 25.09D0 - 7.935D0 * S
- BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
- CG = 590.3D0 - 173.8D0 * S
- DG = 5.196D0 + 1.857D0 * S
- EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
- ESG = 3.232D0 - 0.542D0 * S
- GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYGRVV
-C...Auxiliary for the GRV 94 parton distribution functions
-C...for u and d valence and d-u sea.
-C...Authors: M. Glueck, E. Reya and A. Vogt.
-
- FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
-
-C...Double precision declaration.
- IMPLICIT DOUBLE PRECISION (A - Z)
-
-C...Evaluation.
- DX = SQRT (X)
- PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
- & (1D0- X)**D
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYGRVW
-C...Auxiliary for the GRV 94 parton distribution functions
-C...for d+u sea and gluon.
-C...Authors: M. Glueck, E. Reya and A. Vogt.
-
- FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
-
-C...Double precision declaration.
- IMPLICIT DOUBLE PRECISION (A - Z)
-
-C...Evaluation.
- LX = LOG (1D0/X)
- PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
- & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYGRVS
-C...Auxiliary for the GRV 94 parton distribution functions
-C...for s, c and b sea.
-C...Authors: M. Glueck, E. Reya and A. Vogt.
-
- FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
-
-C...Double precision declaration.
- IMPLICIT DOUBLE PRECISION (A - Z)
-
-C...Evaluation.
- IF(S.LE.STH) THEN
- PYGRVS = 0D0
- ELSE
- DX = SQRT (X)
- LX = LOG (1D0/X)
- PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
- & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYCT5L
-C...Auxiliary function for parametrization of CTEQ5L.
-C...Author: J. Pumplin 9/99.
-
-C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
-C...in Parametrized Form
-C... September 15, 1999
-C
-C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
-C... CTEQ5 PPARTON DISTRIBUTIONS"
-C...hep-ph/9903282
-
-C...The CTEQ5M1 set given here is an updated version of the original
-C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
-C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
-C...almost all applications.
-C...The improvement is in the QCD evolution which is now more
-C...accurate, and which agrees completely with the benchmark work
-C...of the HERA 96/97 Workshop.
-C...The differences between the parametrized and the corresponding
-C...table versions (on which it is based) are of similar order as
-C...between the two version.
-
-C...!! Because accurate parametrizations over a wide range of (x,Q)
-C...is hard to obtain, only the most widely used sets CTEQ5M and
-C...CTEQ5L are available in parametrized form for now.
-
-C...These parametrizations were obtained by Jon Pumplin.
-
-C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
-C -------------------------------------------------------------------
-C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
-C 3 CTEQ5L Leading Order 0.127 192 146
-C -------------------------------------------------------------------
-C...Note the Qcd-lambda values given for CTEQ5L is for the leading
-C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
-C...calibration.
-
-C...The two Iset value are adopted to agree with the standard table
-C...versions.
-
-C...Range of validity:
-C...The range of (x, Q) covered by this parametrization of the QCD
-C...evolved parton distributions is 1E-6 < x < 1 ;
-C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
-C...data only in a subset of that region; and the assumed DGLAP
-C...evolution is unlikely to be valid for all of it either.
-
-C...The range of (x, Q) used in the CTEQ5 round of global analysis is
-C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
-C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
-C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
-
- FUNCTION PYCT5L(IFL,X,Q)
-
-C...Double precision declaration.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-
- PARAMETER (NEX=8, NLF=2)
- DIMENSION AM(0:NEX,0:NLF,-5:2)
- DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
- DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
- DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
- DIMENSION AF(0:NEX)
-
- DATA MEXVEC( 2) / 8 /
- DATA MLFVEC( 2) / 2 /
- DATA UT1VEC( 2) / 0.4971265E+01 /
- DATA UT2VEC( 2) / -0.1105128E+01 /
- DATA ALFVEC( 2) / 0.2987216E+00 /
- DATA QMAVEC( 2) / 0.0000000E+00 /
- DATA (AM( 0,K, 2),K=0, 2)
- & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
- DATA (AM( 1,K, 2),K=0, 2)
- & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
- DATA (AM( 2,K, 2),K=0, 2)
- & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
- DATA (AM( 3,K, 2),K=0, 2)
- & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
- DATA (AM( 4,K, 2),K=0, 2)
- & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
- DATA (AM( 5,K, 2),K=0, 2)
- & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
- DATA (AM( 6,K, 2),K=0, 2)
- & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
- DATA (AM( 7,K, 2),K=0, 2)
- & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
- DATA (AM( 8,K, 2),K=0, 2)
- & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
-
- DATA MEXVEC( 1) / 8 /
- DATA MLFVEC( 1) / 2 /
- DATA UT1VEC( 1) / 0.2612618E+01 /
- DATA UT2VEC( 1) / -0.1258304E+06 /
- DATA ALFVEC( 1) / 0.3407552E+00 /
- DATA QMAVEC( 1) / 0.0000000E+00 /
- DATA (AM( 0,K, 1),K=0, 2)
- & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
- DATA (AM( 1,K, 1),K=0, 2)
- & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
- DATA (AM( 2,K, 1),K=0, 2)
- & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
- DATA (AM( 3,K, 1),K=0, 2)
- & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
- DATA (AM( 4,K, 1),K=0, 2)
- & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
- DATA (AM( 5,K, 1),K=0, 2)
- & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
- DATA (AM( 6,K, 1),K=0, 2)
- & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
- DATA (AM( 7,K, 1),K=0, 2)
- & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
- DATA (AM( 8,K, 1),K=0, 2)
- & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
-
- DATA MEXVEC( 0) / 8 /
- DATA MLFVEC( 0) / 2 /
- DATA UT1VEC( 0) / -0.4656819E+00 /
- DATA UT2VEC( 0) / -0.2742390E+03 /
- DATA ALFVEC( 0) / 0.4491863E+00 /
- DATA QMAVEC( 0) / 0.0000000E+00 /
- DATA (AM( 0,K, 0),K=0, 2)
- & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
- DATA (AM( 1,K, 0),K=0, 2)
- & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
- DATA (AM( 2,K, 0),K=0, 2)
- & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
- DATA (AM( 3,K, 0),K=0, 2)
- & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
- DATA (AM( 4,K, 0),K=0, 2)
- & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
- DATA (AM( 5,K, 0),K=0, 2)
- & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
- DATA (AM( 6,K, 0),K=0, 2)
- & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
- DATA (AM( 7,K, 0),K=0, 2)
- & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
- DATA (AM( 8,K, 0),K=0, 2)
- & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
-
- DATA MEXVEC(-1) / 8 /
- DATA MLFVEC(-1) / 2 /
- DATA UT1VEC(-1) / 0.3862583E+01 /
- DATA UT2VEC(-1) / -0.1265969E+01 /
- DATA ALFVEC(-1) / 0.2457668E+00 /
- DATA QMAVEC(-1) / 0.0000000E+00 /
- DATA (AM( 0,K,-1),K=0, 2)
- & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
- DATA (AM( 1,K,-1),K=0, 2)
- & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
- DATA (AM( 2,K,-1),K=0, 2)
- & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
- DATA (AM( 3,K,-1),K=0, 2)
- & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
- DATA (AM( 4,K,-1),K=0, 2)
- & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
- DATA (AM( 5,K,-1),K=0, 2)
- & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
- DATA (AM( 6,K,-1),K=0, 2)
- & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
- DATA (AM( 7,K,-1),K=0, 2)
- & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
- DATA (AM( 8,K,-1),K=0, 2)
- & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
-
- DATA MEXVEC(-2) / 7 /
- DATA MLFVEC(-2) / 2 /
- DATA UT1VEC(-2) / 0.1895615E+00 /
- DATA UT2VEC(-2) / -0.3069097E+01 /
- DATA ALFVEC(-2) / 0.5293999E+00 /
- DATA QMAVEC(-2) / 0.0000000E+00 /
- DATA (AM( 0,K,-2),K=0, 2)
- & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
- DATA (AM( 1,K,-2),K=0, 2)
- & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
- DATA (AM( 2,K,-2),K=0, 2)
- & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
- DATA (AM( 3,K,-2),K=0, 2)
- & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
- DATA (AM( 4,K,-2),K=0, 2)
- & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
- DATA (AM( 5,K,-2),K=0, 2)
- & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
- DATA (AM( 6,K,-2),K=0, 2)
- & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
- DATA (AM( 7,K,-2),K=0, 2)
- & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
-
- DATA MEXVEC(-3) / 7 /
- DATA MLFVEC(-3) / 2 /
- DATA UT1VEC(-3) / 0.3753257E+01 /
- DATA UT2VEC(-3) / -0.1113085E+01 /
- DATA ALFVEC(-3) / 0.3713141E+00 /
- DATA QMAVEC(-3) / 0.0000000E+00 /
- DATA (AM( 0,K,-3),K=0, 2)
- & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
- DATA (AM( 1,K,-3),K=0, 2)
- & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
- DATA (AM( 2,K,-3),K=0, 2)
- & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
- DATA (AM( 3,K,-3),K=0, 2)
- & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
- DATA (AM( 4,K,-3),K=0, 2)
- & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
- DATA (AM( 5,K,-3),K=0, 2)
- & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
- DATA (AM( 6,K,-3),K=0, 2)
- & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
- DATA (AM( 7,K,-3),K=0, 2)
- & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
-
- DATA MEXVEC(-4) / 7 /
- DATA MLFVEC(-4) / 2 /
- DATA UT1VEC(-4) / 0.4400772E+01 /
- DATA UT2VEC(-4) / -0.1356116E+01 /
- DATA ALFVEC(-4) / 0.3712017E-01 /
- DATA QMAVEC(-4) / 0.1300000E+01 /
- DATA (AM( 0,K,-4),K=0, 2)
- & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
- DATA (AM( 1,K,-4),K=0, 2)
- & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
- DATA (AM( 2,K,-4),K=0, 2)
- & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
- DATA (AM( 3,K,-4),K=0, 2)
- & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
- DATA (AM( 4,K,-4),K=0, 2)
- & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
- DATA (AM( 5,K,-4),K=0, 2)
- & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
- DATA (AM( 6,K,-4),K=0, 2)
- & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
- DATA (AM( 7,K,-4),K=0, 2)
- & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
-
- DATA MEXVEC(-5) / 6 /
- DATA MLFVEC(-5) / 2 /
- DATA UT1VEC(-5) / 0.5562568E+01 /
- DATA UT2VEC(-5) / -0.1801317E+01 /
- DATA ALFVEC(-5) / 0.4952010E-02 /
- DATA QMAVEC(-5) / 0.4500000E+01 /
- DATA (AM( 0,K,-5),K=0, 2)
- & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
- DATA (AM( 1,K,-5),K=0, 2)
- & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
- DATA (AM( 2,K,-5),K=0, 2)
- & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
- DATA (AM( 3,K,-5),K=0, 2)
- & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
- DATA (AM( 4,K,-5),K=0, 2)
- & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
- DATA (AM( 5,K,-5),K=0, 2)
- & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
- DATA (AM( 6,K,-5),K=0, 2)
- & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
-
- IF(Q .LE. QMAVEC(IFL)) THEN
- PYCT5L = 0.D0
- RETURN
- ENDIF
-
- IF(X .GE. 1.D0) THEN
- PYCT5L = 0.D0
- RETURN
- ENDIF
-
- TMP = LOG(Q/ALFVEC(IFL))
- IF(TMP .LE. 0.D0) THEN
- PYCT5L = 0.D0
- RETURN
- ENDIF
-
- SB = LOG(TMP)
- SB1 = SB - 1.2D0
- SB2 = SB1*SB1
-
- DO 110 I = 0, NEX
- AF(I) = 0.D0
- SBX = 1.D0
- DO 100 K = 0, MLFVEC(IFL)
- AF(I) = AF(I) + SBX*AM(I,K,IFL)
- SBX = SB1*SBX
- 100 CONTINUE
- 110 CONTINUE
-
- Y = -LOG(X)
- U = LOG(X/0.00001D0)
-
- PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
- PART2 = AF(0)*(1.D0 - X) + AF(3)*X
- PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
- PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
- & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
-
- PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
-
-C...Include threshold factor.
- PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYCT5M
-C...Auxiliary function for parametrization of CTEQ5M1.
-C...Author: J. Pumplin 9/99.
-
- FUNCTION PYCT5M(IFL,X,Q)
-
-C...Double precision declaration.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-
- PARAMETER (NEX=8, NLF=2)
- DIMENSION AM(0:NEX,0:NLF,-5:2)
- DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
- DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
- DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
- DIMENSION AF(0:NEX)
-
- DATA MEXVEC( 2) / 8 /
- DATA MLFVEC( 2) / 2 /
- DATA UT1VEC( 2) / 0.5141718E+01 /
- DATA UT2VEC( 2) / -0.1346944E+01 /
- DATA ALFVEC( 2) / 0.5260555E+00 /
- DATA QMAVEC( 2) / 0.0000000E+00 /
- DATA (AM( 0,K, 2),K=0, 2)
- & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
- DATA (AM( 1,K, 2),K=0, 2)
- & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
- DATA (AM( 2,K, 2),K=0, 2)
- & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
- DATA (AM( 3,K, 2),K=0, 2)
- & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
- DATA (AM( 4,K, 2),K=0, 2)
- & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
- DATA (AM( 5,K, 2),K=0, 2)
- & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
- DATA (AM( 6,K, 2),K=0, 2)
- & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
- DATA (AM( 7,K, 2),K=0, 2)
- & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
- DATA (AM( 8,K, 2),K=0, 2)
- & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
-
- DATA MEXVEC( 1) / 8 /
- DATA MLFVEC( 1) / 2 /
- DATA UT1VEC( 1) / 0.4138426E+01 /
- DATA UT2VEC( 1) / -0.3221374E+01 /
- DATA ALFVEC( 1) / 0.4960962E+00 /
- DATA QMAVEC( 1) / 0.0000000E+00 /
- DATA (AM( 0,K, 1),K=0, 2)
- & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
- DATA (AM( 1,K, 1),K=0, 2)
- & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
- DATA (AM( 2,K, 1),K=0, 2)
- & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
- DATA (AM( 3,K, 1),K=0, 2)
- & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
- DATA (AM( 4,K, 1),K=0, 2)
- & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
- DATA (AM( 5,K, 1),K=0, 2)
- & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
- DATA (AM( 6,K, 1),K=0, 2)
- & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
- DATA (AM( 7,K, 1),K=0, 2)
- & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
- DATA (AM( 8,K, 1),K=0, 2)
- & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
-
- DATA MEXVEC( 0) / 8 /
- DATA MLFVEC( 0) / 2 /
- DATA UT1VEC( 0) / -0.1026789E+01 /
- DATA UT2VEC( 0) / -0.9051707E+01 /
- DATA ALFVEC( 0) / 0.9462977E+00 /
- DATA QMAVEC( 0) / 0.0000000E+00 /
- DATA (AM( 0,K, 0),K=0, 2)
- & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
- DATA (AM( 1,K, 0),K=0, 2)
- & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
- DATA (AM( 2,K, 0),K=0, 2)
- & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
- DATA (AM( 3,K, 0),K=0, 2)
- & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
- DATA (AM( 4,K, 0),K=0, 2)
- & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
- DATA (AM( 5,K, 0),K=0, 2)
- & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
- DATA (AM( 6,K, 0),K=0, 2)
- & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
- DATA (AM( 7,K, 0),K=0, 2)
- & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
- DATA (AM( 8,K, 0),K=0, 2)
- & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
-
- DATA MEXVEC(-1) / 8 /
- DATA MLFVEC(-1) / 2 /
- DATA UT1VEC(-1) / 0.5243571E+01 /
- DATA UT2VEC(-1) / -0.2870513E+01 /
- DATA ALFVEC(-1) / 0.6701448E+00 /
- DATA QMAVEC(-1) / 0.0000000E+00 /
- DATA (AM( 0,K,-1),K=0, 2)
- & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
- DATA (AM( 1,K,-1),K=0, 2)
- & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
- DATA (AM( 2,K,-1),K=0, 2)
- & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
- DATA (AM( 3,K,-1),K=0, 2)
- & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
- DATA (AM( 4,K,-1),K=0, 2)
- & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
- DATA (AM( 5,K,-1),K=0, 2)
- & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
- DATA (AM( 6,K,-1),K=0, 2)
- & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
- DATA (AM( 7,K,-1),K=0, 2)
- & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
- DATA (AM( 8,K,-1),K=0, 2)
- & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
-
- DATA MEXVEC(-2) / 7 /
- DATA MLFVEC(-2) / 2 /
- DATA UT1VEC(-2) / 0.4782210E+01 /
- DATA UT2VEC(-2) / -0.1976856E+02 /
- DATA ALFVEC(-2) / 0.7558374E+00 /
- DATA QMAVEC(-2) / 0.0000000E+00 /
- DATA (AM( 0,K,-2),K=0, 2)
- & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
- DATA (AM( 1,K,-2),K=0, 2)
- & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
- DATA (AM( 2,K,-2),K=0, 2)
- & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
- DATA (AM( 3,K,-2),K=0, 2)
- & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
- DATA (AM( 4,K,-2),K=0, 2)
- & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
- DATA (AM( 5,K,-2),K=0, 2)
- & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
- DATA (AM( 6,K,-2),K=0, 2)
- & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
- DATA (AM( 7,K,-2),K=0, 2)
- & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
-
- DATA MEXVEC(-3) / 7 /
- DATA MLFVEC(-3) / 2 /
- DATA UT1VEC(-3) / 0.4518239E+01 /
- DATA UT2VEC(-3) / -0.2690590E+01 /
- DATA ALFVEC(-3) / 0.6124079E+00 /
- DATA QMAVEC(-3) / 0.0000000E+00 /
- DATA (AM( 0,K,-3),K=0, 2)
- & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
- DATA (AM( 1,K,-3),K=0, 2)
- & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
- DATA (AM( 2,K,-3),K=0, 2)
- & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
- DATA (AM( 3,K,-3),K=0, 2)
- & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
- DATA (AM( 4,K,-3),K=0, 2)
- & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
- DATA (AM( 5,K,-3),K=0, 2)
- & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
- DATA (AM( 6,K,-3),K=0, 2)
- & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
- DATA (AM( 7,K,-3),K=0, 2)
- & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
-
- DATA MEXVEC(-4) / 7 /
- DATA MLFVEC(-4) / 2 /
- DATA UT1VEC(-4) / 0.2783230E+01 /
- DATA UT2VEC(-4) / -0.1746328E+01 /
- DATA ALFVEC(-4) / 0.1115653E+01 /
- DATA QMAVEC(-4) / 0.1300000E+01 /
- DATA (AM( 0,K,-4),K=0, 2)
- & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
- DATA (AM( 1,K,-4),K=0, 2)
- & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
- DATA (AM( 2,K,-4),K=0, 2)
- & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
- DATA (AM( 3,K,-4),K=0, 2)
- & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
- DATA (AM( 4,K,-4),K=0, 2)
- & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
- DATA (AM( 5,K,-4),K=0, 2)
- & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
- DATA (AM( 6,K,-4),K=0, 2)
- & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
- DATA (AM( 7,K,-4),K=0, 2)
- & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
-
- DATA MEXVEC(-5) / 6 /
- DATA MLFVEC(-5) / 2 /
- DATA UT1VEC(-5) / 0.1619654E+02 /
- DATA UT2VEC(-5) / -0.3367346E+01 /
- DATA ALFVEC(-5) / 0.5109891E-02 /
- DATA QMAVEC(-5) / 0.4500000E+01 /
- DATA (AM( 0,K,-5),K=0, 2)
- & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
- DATA (AM( 1,K,-5),K=0, 2)
- & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
- DATA (AM( 2,K,-5),K=0, 2)
- & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
- DATA (AM( 3,K,-5),K=0, 2)
- & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
- DATA (AM( 4,K,-5),K=0, 2)
- & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
- DATA (AM( 5,K,-5),K=0, 2)
- & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
- DATA (AM( 6,K,-5),K=0, 2)
- & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
-
- IF(Q .LE. QMAVEC(IFL)) THEN
- PYCT5M = 0.D0
- RETURN
- ENDIF
-
- IF(X .GE. 1.D0) THEN
- PYCT5M = 0.D0
- RETURN
- ENDIF
-
- TMP = LOG(Q/ALFVEC(IFL))
- IF(TMP .LE. 0.D0) THEN
- PYCT5M = 0.D0
- RETURN
- ENDIF
-
- SB = LOG(TMP)
- SB1 = SB - 1.2D0
- SB2 = SB1*SB1
-
- DO 110 I = 0, NEX
- AF(I) = 0.D0
- SBX = 1.D0
- DO 100 K = 0, MLFVEC(IFL)
- AF(I) = AF(I) + SBX*AM(I,K,IFL)
- SBX = SB1*SBX
- 100 CONTINUE
- 110 CONTINUE
-
- Y = -LOG(X)
- U = LOG(X/0.00001D0)
-
- PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
- PART2 = AF(0)*(1.D0 - X) + AF(3)*X
- PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
- PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
- & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
-
- PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
-
-C...Include threshold factor.
- PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYPDPO
-C...Auxiliary to PYPDPR. Gives proton parton distributions according to
-C...a few older parametrizations, now obsolete but convenient for
-C...backwards checks.
-
- SUBROUTINE PYPDPO(X,Q2,XPPR)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
- DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
- &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
-
-
-C...The following data lines are coefficients needed in the
-C...Eichten, Hinchliffe, Lane, Quigg proton structure function
-C...parametrizations, see below.
-C...Powers of 1-x in different cases.
- DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
-C...Expansion coefficients for up valence quark distribution.
- DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
- 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
- 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
- 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
- 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
- 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
- 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
- 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
- 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
- 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
- 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
- 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
- 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
- DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
- 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
- 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
- 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
- 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
- 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
- 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
- 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
- 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
- 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
- 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
- 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
- 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
-C...Expansion coefficients for down valence quark distribution.
- DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
- 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
- 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
- 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
- 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
- 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
- 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
- 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
- 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
- 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
- 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
- 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
- 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
- DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
- 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
- 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
- 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
- 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
- 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
- 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
- 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
- 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
- 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
- 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
- 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
- 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
-C...Expansion coefficients for up and down sea quark distributions.
- DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
- 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
- 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
- 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
- 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
- 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
- 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
- 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
- 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
- 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
- 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
- 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
- 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
- DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
- 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
- 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
- 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
- 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
- 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
- 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
- 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
- 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
- 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
- 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
- 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
- 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
-C...Expansion coefficients for gluon distribution.
- DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
- 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
- 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
- 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
- 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
- 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
- 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
- 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
- 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
- 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
- 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
- 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
- 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
- DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
- 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
- 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
- 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
- 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
- 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
- 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
- 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
- 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
- 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
- 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
- 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
- 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
-C...Expansion coefficients for strange sea quark distribution.
- DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
- 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
- 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
- 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
- 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
- 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
- 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
- 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
- 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
- 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
- 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
- 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
- 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
- DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
- 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
- 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
- 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
- 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
- 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
- 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
- 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
- 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
- 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
- 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
- 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
- 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
-C...Expansion coefficients for charm sea quark distribution.
- DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
- 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
- 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
- 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
- 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
- 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
- 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
- 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
- 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
- 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
- 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
- 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
- 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
- DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
- 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
- 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
- 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
- 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
- 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
- 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
- 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
- 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
- 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
- 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
- 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
- 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
-C...Expansion coefficients for bottom sea quark distribution.
- DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
- 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
- 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
- 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
- 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
- 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
- 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
- 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
- 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
- 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
- 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
- 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
- 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
- DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
- 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
- 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
- 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
- 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
- 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
- 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
- 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
- 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
- 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
- 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
- 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
- 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
-C...Expansion coefficients for top sea quark distribution.
- DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
- 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
- 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
- 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
- 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
- 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
- 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
- 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
- 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
- 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
- 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
- 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
- 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
- DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
- 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
- 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
- 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
- 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
- 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
- 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
- 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
- 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
- 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
- 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
- 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
- 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
-
-C...The following data lines are coefficients needed in the
-C...Duke, Owens proton structure function parametrizations, see below.
-C...Expansion coefficients for (up+down) valence quark distribution.
- DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
- 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
- 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
- 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
- DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
- 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
- 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
- 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
-C...Expansion coefficients for down valence quark distribution.
- DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
- 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
- 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
- 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
- DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
- 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
- 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
- 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
-C...Expansion coefficients for (up+down+strange) sea quark distribution.
- DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
- 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
- 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
- 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
- DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
- 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
- 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
- 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
-C...Expansion coefficients for charm sea quark distribution.
- DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
- 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
- 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
- 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
- DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
- 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
- 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
- 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
-C...Expansion coefficients for gluon distribution.
- DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
- 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
- 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
- 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
- DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
- 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
- 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
- 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
-
-C...Euler's beta function, requires ordinary Gamma function
- EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
-
-C...Leading order proton parton distributions from Glueck, Reya and
-C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
-C...10^-5 < x < 1.
- IF(MSTP(51).EQ.11) THEN
-
-C...Determine s expansion variable and some x expressions.
- Q2IN=MIN(1D8,MAX(0.25D0,Q2))
- SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
- SD2=SD**2
- XL=-LOG(X)
- XS=SQRT(X)
-
-C...Evaluate valence, gluon and sea distributions.
- XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
- & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
- & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
- & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
- XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
- & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
- & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
- XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
- & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
- & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
- & SQRT(4.066D0*SD**1.218D0*XL)))*
- & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
- XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
- & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
- & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
- & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
- XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
- & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
- & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
- & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
- IF(SD.LE.0.888D0) THEN
- XFCHM=0D0
- ELSE
- XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
- & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
- & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
- ENDIF
- IF(SD.LE.1.351D0) THEN
- XFBOT=0D0
- ELSE
- XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
- & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
- & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
- ENDIF
-
-C...Put into output array.
- XPPR(0)=XFGLU
- XPPR(1)=XFVDD+XFSEA
- XPPR(2)=XFVUD-XFVDD+XFSEA
- XPPR(3)=XFSTR
- XPPR(4)=XFCHM
- XPPR(5)=XFBOT
- XPPR(-1)=XFSEA
- XPPR(-2)=XFSEA
- XPPR(-3)=XFSTR
- XPPR(-4)=XFCHM
- XPPR(-5)=XFBOT
-
-C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
-C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
- ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
-
-C...Determine set, Lambda and x and t expansion variables.
- NSET=MSTP(51)-11
- IF(NSET.EQ.1) ALAM=0.2D0
- IF(NSET.EQ.2) ALAM=0.29D0
- TMIN=LOG(5D0/ALAM**2)
- TMAX=LOG(1D8/ALAM**2)
- T=LOG(MAX(1D0,Q2/ALAM**2))
- VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
- NX=1
- IF(X.LE.0.1D0) NX=2
- IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
- IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
-
-C...Chebyshev polynomials for x and t expansion.
- TX(1)=1D0
- TX(2)=VX
- TX(3)=2D0*VX**2-1D0
- TX(4)=4D0*VX**3-3D0*VX
- TX(5)=8D0*VX**4-8D0*VX**2+1D0
- TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
- TT(1)=1D0
- TT(2)=VT
- TT(3)=2D0*VT**2-1D0
- TT(4)=4D0*VT**3-3D0*VT
- TT(5)=8D0*VT**4-8D0*VT**2+1D0
- TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
-
-C...Calculate structure functions.
- DO 120 KFL=1,6
- XQSUM=0D0
- DO 110 IT=1,6
- DO 100 IX=1,6
- XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
- 100 CONTINUE
- 110 CONTINUE
- XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
- 120 CONTINUE
-
-C...Put into output array.
- XPPR(0)=XQ(4)
- XPPR(1)=XQ(2)+XQ(3)
- XPPR(2)=XQ(1)+XQ(3)
- XPPR(3)=XQ(5)
- XPPR(4)=XQ(6)
- XPPR(-1)=XQ(3)
- XPPR(-2)=XQ(3)
- XPPR(-3)=XQ(5)
- XPPR(-4)=XQ(6)
-
-C...Special expansion for bottom (threshold effects).
- IF(MSTP(58).GE.5) THEN
- IF(NSET.EQ.1) TMIN=8.1905D0
- IF(NSET.EQ.2) TMIN=7.4474D0
- IF(T.GT.TMIN) THEN
- VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
- TT(1)=1D0
- TT(2)=VT
- TT(3)=2D0*VT**2-1D0
- TT(4)=4D0*VT**3-3D0*VT
- TT(5)=8D0*VT**4-8D0*VT**2+1D0
- TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
- XQSUM=0D0
- DO 140 IT=1,6
- DO 130 IX=1,6
- XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
- 130 CONTINUE
- 140 CONTINUE
- XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
- XPPR(-5)=XPPR(5)
- ENDIF
- ENDIF
-
-C...Special expansion for top (threshold effects).
- IF(MSTP(58).GE.6) THEN
- IF(NSET.EQ.1) TMIN=11.5528D0
- IF(NSET.EQ.2) TMIN=10.8097D0
- TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
- TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
- IF(T.GT.TMIN) THEN
- VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
- TT(1)=1D0
- TT(2)=VT
- TT(3)=2D0*VT**2-1D0
- TT(4)=4D0*VT**3-3D0*VT
- TT(5)=8D0*VT**4-8D0*VT**2+1D0
- TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
- XQSUM=0D0
- DO 160 IT=1,6
- DO 150 IX=1,6
- XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
- 150 CONTINUE
- 160 CONTINUE
- XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
- XPPR(-6)=XPPR(6)
- ENDIF
- ENDIF
-
-C...Proton parton distributions from Duke, Owens.
-C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
- ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
-
-C...Determine set, Lambda and s expansion parameter.
- NSET=MSTP(51)-13
- IF(NSET.EQ.1) ALAM=0.2D0
- IF(NSET.EQ.2) ALAM=0.4D0
- Q2IN=MIN(1D6,MAX(4D0,Q2))
- SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
-
-C...Calculate structure functions.
- DO 180 KFL=1,5
- DO 170 IS=1,6
- TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
- & CDO(3,IS,KFL,NSET)*SD**2
- 170 CONTINUE
- IF(KFL.LE.2) THEN
- XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
- & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
- ELSE
- XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
- & TS(5)*X**2+TS(6)*X**3)
- ENDIF
- 180 CONTINUE
-
-C...Put into output arrays.
- XPPR(0)=XQ(5)
- XPPR(1)=XQ(2)+XQ(3)/6D0
- XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
- XPPR(3)=XQ(3)/6D0
- XPPR(4)=XQ(4)
- XPPR(-1)=XQ(3)/6D0
- XPPR(-2)=XQ(3)/6D0
- XPPR(-3)=XQ(3)/6D0
- XPPR(-4)=XQ(4)
-
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYHFTH
-C...Gives threshold attractive/repulsive factor for heavy flavour
-C...production.
-
- FUNCTION PYHFTH(SH,SQM,FRATT)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYDAT1/,/PYPARS/,/PYINT1/
-
-C...Value for alpha_strong.
- IF(MSTP(35).LE.1) THEN
- ALSSG=PARP(35)
- ELSE
- MST115=MSTU(115)
- MSTU(115)=MSTP(36)
- Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
- & PARP(36)**2)))
- ALSSG=PYALPS(Q2BN)
- MSTU(115)=MST115
- ENDIF
-
-C...Evaluate attractive and repulsive factors.
- XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
- FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
- XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
- FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
- PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
- VINT(138)=PYHFTH
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSPLI
-C...Splits a hadron remnant into two (partons or hadron + parton)
-C...in case it is more complicated than just a quark or a diquark.
-
- SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks. PYDAT1 temporary
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYPARS/,/PYINT1/,/PYDAT1/
-C...Local array.
- DIMENSION KFL(3)
-
-C...Preliminaries. Parton composition.
- KFA=IABS(KF)
- KFS=ISIGN(1,KF)
- KFL(1)=MOD(KFA/1000,10)
- KFL(2)=MOD(KFA/100,10)
- KFL(3)=MOD(KFA/10,10)
- IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
- KFL(2)=INT(1.5D0+PYR(0))
- IF(MINT(105).EQ.333) KFL(2)=3
- IF(MINT(105).EQ.443) KFL(2)=4
- KFL(3)=KFL(2)
- ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
- KFL(2)=2
- KFL(3)=2
- ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
- KFL(2)=1
- KFL(3)=1
- ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
- KFL(2)=MOD(KFA/10,10)
- KFL(3)=MOD(KFA/100,10)
- ENDIF
- IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
- KFLR=KFLIN*KFS
- ELSE
- KFLR=KFLIN
- ENDIF
- KFLCH=0
-
-C...Subdivide lepton.
- IF(KFA.GE.11.AND.KFA.LE.18) THEN
- IF(KFLR.EQ.KFA) THEN
- KFLSP=KFS*22
- ELSEIF(KFLR.EQ.22) THEN
- KFLSP=KFA
- ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
- KFLSP=KFA+1
- ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
- KFLSP=KFA-1
- ELSEIF(KFLR.EQ.21) THEN
- KFLSP=KFA
- KFLCH=KFS*21
- ELSE
- KFLSP=KFA
- KFLCH=-KFLR
- ENDIF
-
-C...Subdivide photon.
- ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
- IF(KFLR.NE.21) THEN
- KFLSP=-KFLR
- ELSE
- RAGR=0.75D0*PYR(0)
- KFLSP=1
- IF(RAGR.GT.0.125D0) KFLSP=2
- IF(RAGR.GT.0.625D0) KFLSP=3
- IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
- KFLCH=-KFLSP
- ENDIF
-
-C...Subdivide Reggeon or Pomeron.
- ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
- IF(KFLIN.EQ.21) THEN
- KFLSP=KFS*21
- ELSE
- KFLSP=-KFLIN
- ENDIF
-
-C...Subdivide meson.
- ELSEIF(KFL(1).EQ.0) THEN
- KFL(2)=KFL(2)*(-1)**KFL(2)
- KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
- IF(KFLR.EQ.KFL(2)) THEN
- KFLSP=KFL(3)
- ELSEIF(KFLR.EQ.KFL(3)) THEN
- KFLSP=KFL(2)
- ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
- KFLSP=KFL(2)
- KFLCH=KFL(3)
- ELSEIF(KFLR.EQ.21) THEN
- KFLSP=KFL(3)
- KFLCH=KFL(2)
- ELSEIF(KFLR*KFL(2).GT.0) THEN
- NTRY=0
- 100 NTRY=NTRY+1
- CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
- IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
- GOTO 100
- ELSEIF(KFLCH.EQ.0) THEN
- CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
- MINT(51)=1
- RETURN
- ENDIF
- KFLSP=KFL(3)
- ELSE
- NTRY=0
- 110 NTRY=NTRY+1
- CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
- IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
- GOTO 110
- ELSEIF(KFLCH.EQ.0) THEN
- CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
- MINT(51)=1
- RETURN
- ENDIF
- KFLSP=KFL(2)
- ENDIF
-
-C...Special case for extracting photon from baryon without splitting
-C...the latter. (Currently only used by external programs.)
- ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
- KFLSP=KFA
- KFLCH=0
-
-C...Subdivide baryon.
- ELSE
- NAGR=0
- DO 120 J=1,3
- IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
- 120 CONTINUE
- IF(NAGR.GE.1) THEN
- RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
- IAGR=0
- DO 130 J=1,3
- IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
- IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
- 130 CONTINUE
- ELSE
- IAGR=1.00001D0+2.99998D0*PYR(0)
- ENDIF
- ID1=1
- IF(IAGR.EQ.1) ID1=2
- IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
- ID2=6-IAGR-ID1
- KSP=3
- IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
- IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
- ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
- IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
- ELSEIF(MOD(KFA,10).EQ.2) THEN
- IF(IAGR.EQ.1) KSP=1
- IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
- ENDIF
- KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
- IF(KFLR.EQ.21) THEN
- KFLCH=KFL(IAGR)
- ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
- NTRY=0
- 140 NTRY=NTRY+1
- CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
- IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
- GOTO 140
- ELSEIF(KFLCH.EQ.0) THEN
- CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
- MINT(51)=1
- RETURN
- ENDIF
- ELSEIF(NAGR.EQ.0) THEN
- NTRY=0
- 150 NTRY=NTRY+1
- CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
- IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
- GOTO 150
- ELSEIF(KFLCH.EQ.0) THEN
- CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
- MINT(51)=1
- RETURN
- ENDIF
- KFLSP=KFL(IAGR)
- ENDIF
- ENDIF
-
-C...Add on correct sign for result.
- KFLCH=KFLCH*KFS
- KFLSP=KFLSP*KFS
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYGAMM
-C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
-C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
-C...(Dover, 1965) 6.1.36.
-
- FUNCTION PYGAMM(X)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Local array and data.
- DIMENSION B(8)
- DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
- &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
-
- NX=INT(X)
- DX=X-NX
-
- PYGAMM=1D0
- DXP=1D0
- DO 100 I=1,8
- DXP=DXP*DX
- PYGAMM=PYGAMM+B(I)*DXP
- 100 CONTINUE
- IF(X.LT.1D0) THEN
- PYGAMM=PYGAMM/X
- ELSE
- DO 110 IX=1,NX-1
- PYGAMM=(X-IX)*PYGAMM
- 110 CONTINUE
- ENDIF
-
- RETURN
- END
-
-C***********************************************************************
-
-C...PYWAUX
-C...Calculates real and imaginary parts of the auxiliary functions W1
-C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
-C...der Bij, Nucl. Phys. B297 (1988) 221.
-
- SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-
- ASINH(X)=LOG(X+SQRT(X**2+1D0))
- ACOSH(X)=LOG(X+SQRT(X**2-1D0))
-
- IF(EPS.LT.0D0) THEN
- IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
- IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
- WIM=0D0
- ELSEIF(EPS.LT.1D0) THEN
- IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
- IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
- IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
- IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
- ELSE
- IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
- IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
- WIM=0D0
- ENDIF
-
- RETURN
- END
-
-C***********************************************************************
-
-C...PYI3AU
-C...Calculates real and imaginary parts of the auxiliary function I3;
-C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
-C...Nucl. Phys. B297 (1988) 221.
-
- SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-
- BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
- IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
-
- IF(EPS.LT.0D0) THEN
- IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
- F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
- & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
- & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
- & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
- & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
- & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
- & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
- & EPS))
- ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
- F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
- & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
- & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
- & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
- & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
- & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
- & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
- ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
- F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
- & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
- & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
- & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
- & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
- & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
- & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
- ELSE
- F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
- & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
- & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
- & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
- & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
- ENDIF
- F3IM=0D0
- ELSEIF(EPS.LT.1D0) THEN
- IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
- F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
- & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
- & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
- & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
- & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
- & (0.25D0*(RAT+1D0)*EPS))
- F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
- & (0.25D0*(RAT+1D0)*EPS))
- ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
- F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
- & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
- & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
- & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
- & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
- & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
- F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
- ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
- F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
- & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
- & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
- & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
- & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
- & (1D0+0.25D0*RAT*EPS-GA))
- F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
- & (1D0+0.25D0*RAT*EPS-GA))
- ELSE
- F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
- & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
- & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
- & LOG((GA+BE-1D0)/(BE-GA))
- F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
- ENDIF
- ELSE
- RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
- RCTHE=RSQ*(1D0-2D0*BE/EPS)
- RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
- RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
- RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
- R=SQRT(RSQ)
- THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
- PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
- F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
- & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
- & (PHI-THE)*(PHI+THE-PARU(1))
- F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
- & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
- ENDIF
-
- Y3RE=2D0/(2D0*BE-1D0)*F3RE
- Y3IM=2D0/(2D0*BE-1D0)*F3IM
-
- RETURN
- END
-
-C***********************************************************************
-
-C...PYSPEN
-C...Calculates real and imaginary part of Spence function; see
-C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
-
- FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-C...Local array and data.
- DIMENSION B(0:14)
- DATA B/
- &1.000000D+00, -5.000000D-01, 1.666667D-01,
- &0.000000D+00, -3.333333D-02, 0.000000D+00,
- &2.380952D-02, 0.000000D+00, -3.333333D-02,
- &0.000000D+00, 7.575757D-02, 0.000000D+00,
- &-2.531135D-01, 0.000000D+00, 1.166667D+00/
-
- XRE=XREIN
- XIM=XIMIN
- IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
- IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
- IF(IREIM.EQ.2) PYSPEN=0D0
- RETURN
- ENDIF
-
- XMOD=SQRT(XRE**2+XIM**2)
- IF(XMOD.LT.1D-6) THEN
- IF(IREIM.EQ.1) PYSPEN=0D0
- IF(IREIM.EQ.2) PYSPEN=0D0
- RETURN
- ENDIF
-
- XARG=SIGN(ACOS(XRE/XMOD),XIM)
- SP0RE=0D0
- SP0IM=0D0
- SGN=1D0
- IF(XMOD.GT.1D0) THEN
- ALGXRE=LOG(XMOD)
- ALGXIM=XARG-SIGN(PARU(1),XARG)
- SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
- SP0IM=-ALGXRE*ALGXIM
- SGN=-1D0
- XMOD=1D0/XMOD
- XARG=-XARG
- XRE=XMOD*COS(XARG)
- XIM=XMOD*SIN(XARG)
- ENDIF
- IF(XRE.GT.0.5D0) THEN
- ALGXRE=LOG(XMOD)
- ALGXIM=XARG
- XRE=1D0-XRE
- XIM=-XIM
- XMOD=SQRT(XRE**2+XIM**2)
- XARG=SIGN(ACOS(XRE/XMOD),XIM)
- ALGYRE=LOG(XMOD)
- ALGYIM=XARG
- SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
- SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
- SGN=-SGN
- ENDIF
-
- XRE=1D0-XRE
- XIM=-XIM
- XMOD=SQRT(XRE**2+XIM**2)
- XARG=SIGN(ACOS(XRE/XMOD),XIM)
- ZRE=-LOG(XMOD)
- ZIM=-XARG
-
- SPRE=0D0
- SPIM=0D0
- SAVERE=1D0
- SAVEIM=0D0
- DO 100 I=0,14
- IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
- TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
- TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
- SAVERE=TERMRE
- SAVEIM=TERMIM
- SPRE=SPRE+B(I)*TERMRE
- SPIM=SPIM+B(I)*TERMIM
- 100 CONTINUE
-
- 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
- IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
-
- RETURN
- END
-
-C***********************************************************************
-
-C...PYQQBH
-C...Calculates the matrix element for the processes
-C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
-C...REDUCE output and part of the rest courtesy Z. Kunszt, see
-C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
-
- SUBROUTINE PYQQBH(WTQQBH)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
-C...Local arrays and function.
- DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
- DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
- &PP(I,3)*PP(J,3)
-
-C...Mass parameters.
- WTQQBH=0D0
- ISUB=MINT(1)
- SHPR=SQRT(VINT(26))*VINT(1)
- PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
- PH=SQRT(VINT(21))*VINT(1)
- SPQ=PQ**2
- SPH=PH**2
-
-C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
- DO 100 I=1,2
- PT=SQRT(MAX(0D0,VINT(197+5*I)))
- PP(I,1)=PT*COS(VINT(198+5*I))
- PP(I,2)=PT*SIN(VINT(198+5*I))
- 100 CONTINUE
- PP(3,1)=-PP(1,1)-PP(2,1)
- PP(3,2)=-PP(1,2)-PP(2,2)
- PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
- PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
- PMS3=SPH+PP(3,1)**2+PP(3,2)**2
- PMT3=SQRT(PMS3)
- PP(3,3)=PMT3*SINH(VINT(211))
- PP(3,4)=PMT3*COSH(VINT(211))
- PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
- PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
- &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
- PP(2,3)=-PP(1,3)-PP(3,3)
- PP(1,4)=SQRT(PMS1+PP(1,3)**2)
- PP(2,4)=SQRT(PMS2+PP(2,3)**2)
-
-C...Set up incoming kinematics and derived momentum combinations.
- DO 110 I=4,5
- PP(I,1)=0D0
- PP(I,2)=0D0
- PP(I,3)=-0.5D0*SHPR*(-1)**I
- PP(I,4)=-0.5D0*SHPR
- 110 CONTINUE
- DO 120 J=1,4
- PP(6,J)=PP(1,J)+PP(2,J)
- PP(7,J)=PP(1,J)+PP(3,J)
- PP(8,J)=PP(1,J)+PP(4,J)
- PP(9,J)=PP(1,J)+PP(5,J)
- PP(10,J)=-PP(2,J)-PP(3,J)
- PP(11,J)=-PP(2,J)-PP(4,J)
- PP(12,J)=-PP(2,J)-PP(5,J)
- PP(13,J)=-PP(4,J)-PP(5,J)
- 120 CONTINUE
-
-C...Derived kinematics invariants.
- X1=DOT(1,2)
- X2=DOT(1,3)
- X3=DOT(1,4)
- X4=DOT(1,5)
- X5=DOT(2,3)
- X6=DOT(2,4)
- X7=DOT(2,5)
- X8=DOT(3,4)
- X9=DOT(3,5)
- X10=DOT(4,5)
-
-C...Propagators.
- SS1=DOT(7,7)-SPQ
- SS2=DOT(8,8)-SPQ
- SS3=DOT(9,9)-SPQ
- SS4=DOT(10,10)-SPQ
- SS5=DOT(11,11)-SPQ
- SS6=DOT(12,12)-SPQ
- SS7=DOT(13,13)
- DX(1)=SS1*SS6
- DX(2)=SS2*SS6
- DX(3)=SS2*SS4
- DX(4)=SS1*SS5
- DX(5)=SS3*SS5
- DX(6)=SS3*SS4
- DX(7)=SS7*SS1
- DX(8)=SS7*SS4
-
-C...Define colour coefficients for g + g -> Q + Qbar + H.
- IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
- DO 140 I=1,3
- DO 130 J=1,3
- CLR(I,J)=16D0/3D0
- CLR(I+3,J+3)=16D0/3D0
- CLR(I,J+3)=-2D0/3D0
- CLR(I+3,J)=-2D0/3D0
- 130 CONTINUE
- 140 CONTINUE
- DO 160 L=1,2
- DO 150 I=1,3
- CLR(I,6+L)=-6D0
- CLR(I+3,6+L)=6D0
- CLR(6+L,I)=-6D0
- CLR(6+L,I+3)=6D0
- 150 CONTINUE
- 160 CONTINUE
- DO 180 K1=1,2
- DO 170 K2=1,2
- CLR(6+K1,6+K2)=12D0
- 170 CONTINUE
- 180 CONTINUE
-
-C...Evaluate matrix elements for g + g -> Q + Qbar + H.
- FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
- & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
- & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
- FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
- & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
- & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
- & X10)
- FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
- & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
- & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
- & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
- & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
- & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
- FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
- & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
- & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
- & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
- & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
- FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
- & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
- & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
- & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
- & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
- & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
- & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
- & X4*X6*X5)
- FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
- & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
- & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
- & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
- & +X4*X9*X5+X4*X5**2)
- FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
- & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
- & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
- & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
- & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
- & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
- FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
- & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
- & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
- & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
- & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
- & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
- & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
- & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
- & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
- FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
- & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
- FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
- & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
- & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
- & X6)
- FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
- & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
- & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
- & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
- & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
- & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
- & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
- & X5+X4*X6*X5)
- FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
- & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
- & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
- & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
- & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
- & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
- & X6**2)
- FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
- & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
- & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
- & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
- & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
- & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
- & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
- & X4*X6*X5)
- FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
- & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
- & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
- & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
- & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
- & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
- & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
- & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
- & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
- & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
- & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
- FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
- & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
- & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
- & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
- & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
- & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
- & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
- & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
- & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
- & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
- & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
- FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
- & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
- & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
- FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
- & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
- & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
- & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
- & +X3*X8*X5+X3*X5**2)
- FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
- & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
- & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
- & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
- & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
- & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
- & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
- & X5+X4*X6*X5)
- FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
- & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
- & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
- & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
- & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
- FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
- & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
- & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
- & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
- & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
- & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
- & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
- & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
- & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
- FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
- & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
- & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
- & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
- & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
- & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
- FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
- & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
- & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
- FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
- & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
- & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
- & X10)
- FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
- & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
- & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
- & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
- & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
- & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
- FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
- & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
- & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
- & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
- & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
- & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
- FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
- & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
- & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
- & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
- & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
- & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
- & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
- & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
- & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
- FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
- & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
- FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
- & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
- & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
- & X7)
- FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
- & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
- & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
- & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
- & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
- & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
- & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
- & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
- & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
- & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
- & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
- FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
- & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
- & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
- & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
- & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
- & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
- & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
- & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
- & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
- & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
- & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
- FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
- & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
- & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
- FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
- & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
- & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
- & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
- & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
- & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
- & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
- & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
- & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
- FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
- & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
- & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
- & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
- & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
- & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
- FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
- & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
- & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
- & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
- & *X6)
- FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
- & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
- & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
- & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
- & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
- & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
- & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
- FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
- & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
- & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
- & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
- & X8)
- FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
- & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
- & )+2*X2*(-X10*X5+X9*X6+X8*X7)
- FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
- & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
- & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
- & X9*X5)
- FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
- & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
- & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
- & X8*X5)
- FM(9,10)=0.5D0*(FMXX+FM(9,10))
- FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
- & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
- & )+2*X5*(-X10*X2+X9*X3+X8*X4)
-
-C...Repackage matrix elements.
- DO 200 I=1,8
- DO 190 J=I,8
- RM(I,J)=FM(I,J)
- 190 CONTINUE
- 200 CONTINUE
- RM(7,7)=FM(7,7)-2D0*FM(9,9)
- RM(7,8)=FM(7,8)-2D0*FM(9,10)
- RM(8,8)=FM(8,8)-2D0*FM(10,10)
-
-C...Produce final result: matrix elements * colours * propagators.
- DO 220 I=1,8
- DO 210 J=I,8
- FAC=8D0
- IF(I.EQ.J)FAC=4D0
- WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
- 210 CONTINUE
- 220 CONTINUE
- WTQQBH=-WTQQBH/256D0
-
- ELSE
-C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
- A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
- & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
- & *X6+X8*X7)
- A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
- & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
- & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
- & X5)
- A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
- & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
- & *X9+X4*X8)
-
-C...Produce final result: matrix elements * propagators.
- A11=A11/DX(7)**2
- A12=A12/(DX(7)*DX(8))
- A22=A22/DX(8)**2
- WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSTBH (and auxiliaries)
-C.. Evaluates the matrix elements for t + b + H production.
-
- SUBROUTINE PYSTBH(WTTBH)
-
-C...DOUBLE PRECISION AND INTEGER DECLARATIONS
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...COMMONBLOCKS
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
- &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
- &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
- &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
- COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
- DOUBLE PRECISION MW2
- SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
- &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
-
-C...LOCAL ARRAYS AND COMPLEX VARIABLES
- DIMENSION QQ(4,2),PP(4,3)
- DATA QQ/8*0D0/
-
- WTTBH=0D0
-
-C...KINEMATIC PARAMETERS.
- SHPR=SQRT(VINT(26))*VINT(1)
- PH=SQRT(VINT(21))*VINT(1)
- SPH=PH**2
-
-C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
- DO 100 I=1,2
- PT=SQRT(MAX(0D0,VINT(197+5*I)))
- PP(1,I)=PT*COS(VINT(198+5*I))
- PP(2,I)=PT*SIN(VINT(198+5*I))
- 100 CONTINUE
- PP(1,3)=-PP(1,1)-PP(1,2)
- PP(2,3)=-PP(2,1)-PP(2,2)
- PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
- PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
- PMS3=SPH+PP(1,3)**2+PP(2,3)**2
- PMT3=SQRT(PMS3)
- PP(3,3)=PMT3*SINH(VINT(211))
- PP(4,3)=PMT3*COSH(VINT(211))
- PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
- PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
- &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
- PP(3,2)=-PP(3,1)-PP(3,3)
- PP(4,1)=SQRT(PMS1+PP(3,1)**2)
- PP(4,2)=SQRT(PMS2+PP(3,2)**2)
-
-C...CM SYSTEM, INGOING QUARKS/GLUONS
- QQ(3,1) = SHPR/2.D0
- QQ(4,1) = QQ(3,1)
- QQ(3,2) = -QQ(3,1)
- QQ(4,2) = QQ(4,1)
-
-C...PARAMETERS FOR AMPLITUDE METHOD
- ALPHA = AEM
- ALPHAS = AS
- SW2 = PARU(102)
- MW2 = PMAS(24,1)**2
- TANB = PARU(141)
- VTB = VCKM(3,3)
- RMB=PYMRUN(5,VINT(52))
-
- ISUB=MINT(1)
-
- IF (ISUB.EQ.401) THEN
- CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
- & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
- ELSE IF (ISUB.EQ.402) THEN
- CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
- & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
- END IF
-
- RETURN
- END
-C------------------------------------------------------------------
- SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
-C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
- COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
- SAVE /PYCTBH/
-
-C TOP WIDTH CALCULATION
-C VTB = 0.99
- MW=DSQRT(MW2)
- XB=(MB/MT)**2
- XW=(MW/MT)**2
- XH =(MHP/MT)**2
- GAMTBH = 0D0
- IF (MT .LT. (MHP+MB)) THEN
-C T ->B W ONLY
- BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
- GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
- & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
- GAMT = GAMTBW
- ELSE
-C T ->BW +T ->B H^+
- BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
- GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
- & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
-C
- KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
- & -4.D0*(MHP*MB/MT**2)**2 )
- GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
- & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
- GAMT = GAMTBW+GAMTBH
- ENDIF
-C THUS BR IS
- BR=GAMTBH/GAMT
- RETURN
- END
-
-C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
-C GG->TBH^+, QQBAR->TBH^+
-C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
-C (FOR INSTANCE WITH PYTHIA)
-C------------------------------------------------------------
-C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
-C PHYS REV. D 60 (1999) 115011
-C (THESE FILES PREPARED BY J.-L. KNEUR)
-C------------------------------------------------------------
-C 1) GG->TBH^+
- SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
-C
-C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
-C
-C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
-C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
-C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
-C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
-C "PHYSICAL PARAMETERS" INPUT:
-C MT,MB TOP AND BOTTOM MASSES;
-C MHP CHARGED HIGGS MASS
-C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
-C
-C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
-C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
-C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
-C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
-C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
-C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
-C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
-C
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- DOUBLE PRECISION MW2,MT,MB,MHP,MW
- DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
-
- COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
- SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
-C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
-C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
-C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
-C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
-C (TAN BETA) VALUES
-C
-C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
-C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
-
- PI = 4*DATAN(1.D0)
- MW = DSQRT(MW2)
-C
-C COLLECTING THE RELEVANT OVERALL FACTORS:
-C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
- PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
-C COUPLING CONSTANT (OVERALL NORMALIZATION)
- FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
-C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
-C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
-C ALPHAS IS ALPHA_STRONG;
-C SW2 IS SIN(THETA_W)**2.
-C
-C VTB=.998D0
-C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
-C
- V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
- A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
-C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
-C
-C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
-C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
- DO 100 KK=1,4
- P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
- 100 CONTINUE
-C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
- S = 2*PYTBHS(Q1,Q2)
- P1Q1=PYTBHS(Q1,P1)
- P1Q2=PYTBHS(P1,Q2)
- P2Q1=PYTBHS(P2,Q1)
- P2Q2=PYTBHS(P2,Q2)
- P1P2=PYTBHS(P1,P2)
-C
-C TOP WIDTH CALCULATION
- CALL PYTBHB(MT,MB,MHP,BR,GAMT)
-C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
-C THEN DEFINE TOP (RESONANT) PROPAGATOR:
- A1INV= S -2*P1Q1 -2*P1Q2
- A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
-C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
-C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
-C THE TOP WIDTH
- A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
- A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
-C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
-C NOW COMES THE AMP**2:
-C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
-C THE EXPRESSIONS BELOW
- V18=0.D0
- A18=0.D0
- V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
- &512*A1*A2*MB*MT/3-
- &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
- &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
- &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
- &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
- &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
- &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
- &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
- &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
- &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
- &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
- &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
- &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
- &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
- &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
- &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
- V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
- &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
- &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
- &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
- &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
- &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
- &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
- &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
- &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
- &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
- &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
- &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
- &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
- &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
- &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
- &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
- &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
- V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
- &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
- &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
- &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
- &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
- &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
- &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
- &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
- &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
- &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
- &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
- &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
- &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
- &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
- &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
- &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
- &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
- V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
- &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
- &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
- &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
- &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
- &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
- &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
- &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
- &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
- &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
- &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
- &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
- &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
- &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
- &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
- &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
- &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
- V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
- &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
- &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
- &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
- &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
- &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
- &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
- &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
- &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
- &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
- &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
- &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
- &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
- &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
- &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
- &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
- &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
- V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
- &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
- &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
- &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
- &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
- &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
- &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
- &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
- &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
- &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
- &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
- &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
- &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
- &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
- &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
- &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
- &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
- V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
- &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
- &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
- &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
- &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
- &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
- &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
- &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
- &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
- &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
- &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
- &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
- &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
- &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
- &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
- &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
- &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
- V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
- &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
- &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
- &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
- &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
- &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
- &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
- &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
- &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
- &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
- &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
- &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
- &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
- &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
- &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
- &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
- &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
- V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
- &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
- &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
- &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
- &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
- &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
- &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
- &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
- &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
- &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
- &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
- &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
- &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
- &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
- &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
- &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
- &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
- V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
- &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
- &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
- &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
- &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
- &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
- &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
- &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
- &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
- &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
- &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
- &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
- &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
- &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
- &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
- &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
- &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
- V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
- &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
- &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
- &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
- &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
- &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
- &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
- &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
- &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
- &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
- &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
- &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
- &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
- &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
- &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
- &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
- &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
- V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
- &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
- &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
- &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
- &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
- &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
- &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
- &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
- &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
- &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
- &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
- &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
- &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
- &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
- &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
- &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
- &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
- V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
- &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
- &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
- &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
- &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
- &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
- &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
- &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
- &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
- &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
- &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
- &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
- &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
- &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
- &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
- &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
- &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
- V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
- &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
- &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
- &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
- &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
- &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
- &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
- &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
- &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
- &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
- &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
- &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
- &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
- &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
- &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
- &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
- &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
- V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
- &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
- &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
- &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
- &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
- &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
- &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
- &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
- &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
- &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
- &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
- &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
- &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
- &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
- &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
- &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
- &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
- V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
- &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
- &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
- &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
- &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
- &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
- &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
- &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
- &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
- &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
- &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
- &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
- &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
- &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
- &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
- &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
- &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
- V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
- &384*A12*MB*MT*P1Q1**2/S**2+
- &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
- &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
- &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
- &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
- &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
- &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
- &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
- &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
- &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
- &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
- &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
- &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
- &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
- &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
- &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
- &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
- V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
- &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
- &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
- &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
- &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
- &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
- &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
- &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
- &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
- &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
- &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
- &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
- &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
- &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
- &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
- &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
- &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
- V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
- &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
- &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
- &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
- &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
- &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
- &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
- &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
- &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
- &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
- &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
- &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
- &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
- &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
- &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
- &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
- &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
- &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
- V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
- &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
- &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
- &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
- &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
- &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
- &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
- &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
- &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
- &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
- &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
- &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
- &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
- &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
- &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
- &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
- &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
- V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
- &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
- &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
- &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
- &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
- &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
- &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
- &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
- &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
- &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
- &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
- &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
- &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
- &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
- &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
- &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
- &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
- &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
- V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
- &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
- &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
- &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
- &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
- &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
- &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
- &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
- &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
- &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
- &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
- &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
- &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
- &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
- &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
- &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
- &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
- V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
- &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
- &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
- &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
- &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
- &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
- &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
- &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
- &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
- &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
- &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
- &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
- &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
- &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
- &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
- &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
- &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
- V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
- &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
- &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
- &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
- &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
- &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
- &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
- &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
- &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
- &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
- &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
- &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
- &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
- &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
- &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
- &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
- &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
- V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
- &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
- &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
- &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
- &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
- &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
- &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
- &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
- &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
- &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
- &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
- &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
- &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
- &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
- &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
- &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
- &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
- V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
- &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
- &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
- &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
- &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
- &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
- &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
- &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
- &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
- &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
- &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
- &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
- &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
- &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
- &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
- &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
- &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
- V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
- &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
- &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
- &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
- &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
-
- V18BIS=
- &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
- &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
- &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
- &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
- &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
- &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
- &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
- &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
- &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
- &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
- &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
- &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
- &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
- &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
- &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
- &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
- V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
- &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
- &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
- &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
- &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
- &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
- &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
- &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
- &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
- &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
- &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
- &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
- &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
- &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
- &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
- &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
- &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
- V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
- &272*A1*A2*P1Q1*S/(3*P1Q2)+
- &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
- &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
- &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
- &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
- &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
- &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
- &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
- &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
- &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
- &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
- &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
- &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
- &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
- &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
- &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
- V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
- &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
- &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
- &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
- &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
- &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
- &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
- &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
- &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
- &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
- &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
- &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
- &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
- &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
- &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
- &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
- &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
- V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
- &32*A12*P2Q1*S/(3*P1Q1)-
- &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
- &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
- &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
- &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
- &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
- &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
- &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
- &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
- &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
- &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
- &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
- &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
- &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
- &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
- &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
- V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
- &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
- &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
- &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
- &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
- &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
- &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
- &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
- &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
- &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
- &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
- &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
- &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
- &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
- &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
- &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
- &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
- V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
- &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
- &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
- &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
- &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
- &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
- &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
- &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
- &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
- &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
- &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
- &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
- &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
- &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
- &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
- &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
- &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
- V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
- &272*A1*A2*P2Q1*S/(3*P2Q2)-
- &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
- &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
- &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
- &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
- &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
- &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
- &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
- &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
- &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
- &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
- &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
- &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
- &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
- &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
- &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
- V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
- &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
- &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
- &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
- &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
- &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
- &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
- &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
-C
-
- A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
- &512*A1*A2*MB*MT/3+
- &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
- &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
- &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
- &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
- &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
- &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
- &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
- &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
- &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
- &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
- &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
- &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
- &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
- &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
- &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
- A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
- &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
- &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
- &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
- &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
- &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
- &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
- &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
- &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
- &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
- &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
- &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
- &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
- &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
- &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
- &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
- &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
- A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
- &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
- &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
- &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
- &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
- &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
- &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
- &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
- &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
- &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
- &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
- &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
- &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
- &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
- &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
- &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
- &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
- A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
- &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
- &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
- &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
- &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
- &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
- &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
- &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
- &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
- &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
- &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
- &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
- &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
- &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
- &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
- &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
- &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
- A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
- &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
- &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
- &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
- &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
- &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
- &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
- &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
- &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
- &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
- &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
- &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
- &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
- &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
- &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
- &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
- &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
- A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
- &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
- &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
- &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
- &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
- &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
- &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
- &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
- &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
- &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
- &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
- &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
- &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
- &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
- &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
- &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
- &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
- A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
- &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
- &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
- &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
- &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
- &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
- &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
- &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
- &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
- &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
- &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
- &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
- &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
- &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
- &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
- &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
- &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
- A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
- &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
- &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
- &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
- &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
- &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
- &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
- &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
- &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
- &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
- &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
- &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
- &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
- &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
- &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
- &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
- &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
- A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
- &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
- &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
- &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
- &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
- &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
- &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
- &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
- &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
- &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
- &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
- &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
- &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
- &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
- &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
- &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
- &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
- A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
- &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
- &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
- &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
- &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
- &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
- &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
- &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
- &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
- &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
- &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
- &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
- &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
- &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
- &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
- &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
- &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
- A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
- &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
- &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
- &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
- &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
- &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
- &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
- &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
- &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
- &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
- &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
- &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
- &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
- &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
- &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
- &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
- &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
- A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
- &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
- &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
- &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
- &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
- &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
- &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
- &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
- &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
- &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
- &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
- &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
- &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
- &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
- &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
- &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
- &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
- A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
- &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
- &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
- &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
- &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
- &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
- &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
- &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
- &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
- &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
- &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
- &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
- &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
- &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
- &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
- &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
- &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
- A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
- &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
- &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
- &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
- &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
- &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
- &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
- &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
- &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
- &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
- &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
- &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
- &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
- &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
- &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
- &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
- &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
- A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
- &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
- &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
- &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
- &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
- &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
- &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
- &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
- &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
- &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
- &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
- &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
- &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
- &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
- &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
- &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
- &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
- A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
- &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
- &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
- &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
- &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
- &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
- &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
- &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
- &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
- &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
- &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
- &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
- &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
- &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
- &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
- &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
- &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
- A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
- &384*A12*MB*MT*P1Q1**2/S**2+
- &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
- &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
- &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
- &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
- &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
- &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
- &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
- &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
- &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
- &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
- &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
- &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
- &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
- &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
- &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
- A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
- &384*A2**2*MB*MT*P2Q2**2/S**2+
- &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
- &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
- &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
- &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
- &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
- &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
- &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
- &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
- &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
- &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
- &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
- &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
- &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
- &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
- &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
- A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
- &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
- &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
- &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
- &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
- &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
- &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
- &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
- &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
- &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
- &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
- &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
- &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
- &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
- &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
- &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
- &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
- A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
- &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
- &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
- &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
- &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
- &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
- &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
- &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
- &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
- &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
- &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
- &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
- &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
- &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
- &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
- &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
- &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
- A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
- &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
- &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
- &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
- &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
- &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
- &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
- &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
- &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
- &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
- &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
- &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
- &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
- &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
- &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
- &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
- &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
- A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
- &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
- &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
- &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
- &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
- &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
- &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
- &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
- &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
- &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
- &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
- &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
- &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
- &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
- &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
- &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
- &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
- A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
- &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
- &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
- &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
- &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
- &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
- &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
- &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
- &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
- &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
- &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
- &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
- &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
- &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
- &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
- &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
- &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
- A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
- &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
- &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
- &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
- &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
- &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
- &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
- &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
- &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
- &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
- &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
- &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
- &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
- &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
- &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
- &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
- &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
- A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
- &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
- &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
- &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
- &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
- &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
- &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
- &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
- &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
- &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
- &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
- &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
- &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
- &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
- &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
- &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
- &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
- A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
- &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
- &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
- &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
- &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
- &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
- &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
- &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
- &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
- &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
- &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
- &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
- &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
- &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
- &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
- &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
- &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
- A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
- &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
- &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
- &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
- &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
- &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
- &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
- &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
- &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
- &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
- &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
- &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
- &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
- &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
- &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
- &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
- &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
- A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
- &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
- &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
- &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
- &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
- &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
- &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
- &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
- &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
- &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
- &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
- &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
- &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
- &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
- &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
- &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
- &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
- A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
- &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
- &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
- &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
- &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
- &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
- &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
- &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
-
- A18BIS=
- &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
- &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
- &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
- &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
- &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
- &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
- &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
- &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
- &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
- &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
- &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
- &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
- &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
- &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
- &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
- &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
- A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
- &12*S/(P1Q2*P2Q1)+
- &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
- &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
- &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
- &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
- &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
- &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
- &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
- &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
- &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
- &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
- &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
- &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
- &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
- &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
- &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
- A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
- &32*MB**2*S/(3*P1Q1*P2Q2**2)+
- &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
- &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
- &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
- &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
- &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
- &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
- &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
- &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
- &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
- &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
- &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
- &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
- &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
- &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
- &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
- A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
- &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
- &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
- &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
- &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
- &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
- &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
- &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
- &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
- &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
- &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
- &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
- &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
- &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
- &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
- &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
- &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
- A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
- &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
- &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
- &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
- &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
- &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
- &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
- &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
- &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
- &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
- &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
- &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
- &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
- &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
- &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
- &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
- &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
- A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
- &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
- &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
- &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
- &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
- &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
- &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
- &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
- &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
- &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
- &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
- &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
- &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
- &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
- &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
- &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
- &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
- A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
- &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
- &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
-C
- V18=V18+V18BIS
- A18=A18+A18BIS
- V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
- &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
- &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
- &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
- &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
- &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
- &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
- &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
- &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
- &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
- &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
- &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
- &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
- &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
- &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
- &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
- &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
- V910=V910+96*A1*A2*P1P2*P2Q1/S-
- &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
- &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
- &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
- &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
- &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
-C
- A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
- &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
- &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
- &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
- &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
- &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
- &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
- &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
- &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
- &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
- &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
- &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
- &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
- &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
- &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
- &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
- &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
- A910=A910+96*A1*A2*P1P2*P2Q1/S-
- &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
- &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
- &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
- &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
- &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
-C
-C FINAL RESULT;
-C
- AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
-
- END
-C---------------------------------------------------------
-C 2) Q QBAR ->TBH^+
- SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
-C
-C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
-C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- DOUBLE PRECISION MW2,MT,MB,MHP,MW
- DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
- SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
-C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
-C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
-C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
-C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
-C
-C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
-C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
-C
- DIMENSION YY(2,2)
-
- PI = 4*DATAN(1.D0)
- MW = DSQRT(MW2)
-
-C COLLECTING THE RELEVANT OVERALL FACTORS:
-C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
- PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
-C COUPLING CONSTANT (OVERALL NORMALIZATION)
- FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
-C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
-C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
-C ALPHAS IS ALPHA_STRONG;
-C SW2 IS SIN(THETA_W)**2.
-C
-C VTB=.998D0
-C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
-C
- V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
- A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
-C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
-C
-C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
-C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
- DO 100 KK=1,4
- P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
- 100 CONTINUE
-C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
- S = 2*PYTBHS(Q1,Q2)
- P1Q1=PYTBHS(Q1,P1)
- P1Q2=PYTBHS(P1,Q2)
- P2Q1=PYTBHS(P2,Q1)
- P2Q2=PYTBHS(P2,Q2)
- P1P2=PYTBHS(P1,P2)
-C
-C TOP WIDTH CALCULATION
- CALL PYTBHB(MT,MB,MHP,BR,GAMT)
-C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
-C THEN DEFINE TOP (RESONANT) PROPAGATOR:
- A1INV= S -2*P1Q1 -2*P1Q2
- A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
-C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
-C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
- A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
- A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
-C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
-C NOW COMES THE AMP**2:
-C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
-C THE EXPRESSIONS BELOW
- YY(1, 1) = -16*A**2*A2**2*MB*MT+
- &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
- &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
- &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
- &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
- &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
- &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
- &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
- &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
- &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
- &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
- &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
- &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
- &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
- &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
- &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
- &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
- YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
- &32*A2**2*MB**2*P1P2*V**2/S+
- &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
- &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
- &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
- YY(1, 1)=2*YY(1, 1)
-
- YY(1, 2) = -32*A**2*A1*A2*MB*MT+
- &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
- &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
- &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
- &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
- &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
- &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
- &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
- &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
- &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
- &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
- &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
- &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
- &64*A**2*A1*A2*MB*MT*P1P2/S+
- &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
- &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
- &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
- YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
- &64*A**2*A1*A2*P1Q1*P2Q1/S-
- &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
- &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
- &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
- &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
- &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
- &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
- &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
- &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
- &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
- &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
- &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
- &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
- &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
- &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
- &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
- YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
- &32*A1*A2*P1P2*P1Q1*V**2/S+
- &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
- &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
- &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
- &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
-
-
- YY(2, 2) =-16*A**2*A12*MB*MT+
- &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
- &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
- &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
- &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
- &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
- &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
- &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
- &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
- &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
- &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
- &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
- &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
- &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
- &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
- &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
- &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
- YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
- &32*A12*MT**2*P2Q2*V**2/S-
- &32*A12*P1Q2*P2Q2*V**2/S
- YY(2, 2)=2*YY(2, 2)
-
- RES=YY(1,1)+2*YY(1,2)+YY(2,2)
- AMP2= FACT*PS*VTB**2*RES
-
- END
-C=====================================================================
-C ************* FUNCTION SCALAR PRODUCTS *************************
- DOUBLE PRECISION FUNCTION PYTBHS(A,B)
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- DIMENSION A(4),B(4)
- DUM=A(4)*B(4)
- DO 100 ID=1,3
- DUM=DUM-A(ID)*B(ID)
- 100 CONTINUE
- PYTBHS=DUM
- RETURN
- END
-
-C*********************************************************************
-
-C...PYMSIN
-C...Initializes supersymmetry: finds sparticle masses and
-C...branching ratios and stores this information.
-C...AUTHOR: STEPHEN MRENNA
-C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
-
- SUBROUTINE PYMSIN
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYDAT4/CHAF(500,2)
- CHARACTER CHAF*16
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- COMMON/PYHTRI/HHH(7)
- COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
- &/PYMSSM/,/PYMSRV/,/PYSSMT/
-
-C...Local variables.
- DOUBLE PRECISION ALFA,BETA
- DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
- INTEGER I,J,J1,I1,K1
- INTEGER KC,LKNT,IDLAM(400,3)
- DOUBLE PRECISION XLAM(0:400)
- DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
- DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
- DOUBLE PRECISION DELM,XMDIF
- DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
- DOUBLE PRECISION ARG,SGNMU,R
- INTEGER IMSSM
- INTEGER IRPRTY
- INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
- SAVE MWIDSU,MDCYSU
- DATA KFSUSY/
- &1000001,2000001,1000002,2000002,1000003,2000003,
- &1000004,2000004,1000005,2000005,1000006,2000006,
- &1000011,2000011,1000012,2000012,1000013,2000013,
- &1000014,2000014,1000015,2000015,1000016,2000016,
- &1000021,1000022,1000023,1000025,1000035,1000024,
- &1000037,1000039, 25, 35, 36, 37,
- & 6, 24, 45, 46,1000045, 9*0/
- DATA INIT/0/
-
-C...Automatically read QNUMBERS, MASS, and DECAY tables
- IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
- NQNUM=0
- CALL PYSLHA(0,0,IFAIL)
- CALL PYSLHA(5,0,IFAIL)
- ENDIF
- IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
-
-C...Do nothing further if SUSY not requested
- IMSSM=IMSS(1)
- IF(IMSSM.EQ.0) RETURN
-
-C...Save copy of MWID(KC) and MDCY(KC,1) values before
-C...they are set to zero for the LSP.
- IF(INIT.EQ.0) THEN
- INIT=1
- DO 100 I=1,36
- KF=KFSUSY(I)
- KC=PYCOMP(KF)
- MWIDSU(I)=MWID(KC)
- MDCYSU(I)=MDCY(KC,1)
- 100 CONTINUE
- ENDIF
-
-C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
- DO 110 I=1,36
- KF=KFSUSY(I)
- KC=PYCOMP(KF)
- IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
- MWID(KC)=MWIDSU(I)
- MDCY(KC,1)=MDCYSU(I)
- ENDIF
- 110 CONTINUE
-
-C...First part of routine: set masses and couplings.
-
-C...Reset mixing values in sfermion sector to pure left/right.
- DO 120 I=1,16
- SFMIX(I,1)=1D0
- SFMIX(I,4)=1D0
- SFMIX(I,2)=0D0
- SFMIX(I,3)=0D0
- 120 CONTINUE
-
-C...Add NMSSM states if NMSSM switched on, and change old names.
- IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
-C... Switch on NMSSM
- WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
-
- KFN=25
- KCN=KFN
- CHAF(KCN,1)='h_10'
- CHAF(KCN,2)=' '
-
- KFN=35
- KCN=KFN
- CHAF(KCN,1)='h_20'
- CHAF(KCN,2)=' '
-
- KFN=45
- KCN=KFN
- CHAF(KCN,1)='h_30'
- CHAF(KCN,2)=' '
-
- KFN=36
- KCN=KFN
- CHAF(KCN,1)='A_10'
- CHAF(KCN,2)=' '
-
- KFN=46
- KCN=KFN
- CHAF(KCN,1)='A_20'
- CHAF(KCN,2)=' '
-
- KFN=1000045
- KCN=PYCOMP(KFN)
- IF (KCN.EQ.0) THEN
- DO 123 KCT=100,MSTU(6)
- IF(KCHG(KCT,4).GT.100) KCN=KCT
- 123 CONTINUE
- KCN=KCN+1
- KCHG(KCN,4)=KFN
- MSTU(20)=0
- ENDIF
-C... Set stable for now
- PMAS(KCN,2)=1D-6
- MWID(KCN)=0
- MDCY(KCN,1)=0
- MDCY(KCN,2)=0
- MDCY(KCN,3)=0
- CHAF(KCN,1)='~chi_50'
- CHAF(KCN,2)=' '
- ENDIF
-
-C...Read spectrum from SLHA file.
- IF (IMSSM.EQ.11) THEN
- CALL PYSLHA(1,0,IFAIL)
- ENDIF
-
-C...Common couplings.
- TANB=RMSS(5)
- BETA=ATAN(TANB)
- COSB=COS(BETA)
- SINB=TANB*COSB
- COS2B=COS(2D0*BETA)
- ALFA=RMSS(18)
- XMW2=PMAS(24,1)**2
- XMZ2=PMAS(23,1)**2
- XW=PARU(102)
-
-C...Define sparticle masses for a general MSSM simulation.
- IF(IMSSM.EQ.1) THEN
- IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
- DO 130 I=1,5,2
- KC=PYCOMP(KSUSY1+I)
- PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
- KC=PYCOMP(KSUSY2+I)
- PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
- KC=PYCOMP(KSUSY1+I+1)
- PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
- KC=PYCOMP(KSUSY2+I+1)
- PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
- 130 CONTINUE
- XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
- IF(XARG.LT.0D0) THEN
- WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
- & ' FROM THE SUM RULE. '
- WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
- RETURN
- ELSE
- XARG=SQRT(XARG)
- ENDIF
- DO 140 I=11,15,2
- PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
- PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
- PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
- PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
- 140 CONTINUE
- IF(IMSS(8).EQ.1) THEN
- RMSS(13)=RMSS(6)
- RMSS(14)=RMSS(7)
- ENDIF
-
-C...Alternatively derive masses from SUGRA relations.
- ELSEIF(IMSSM.EQ.2) THEN
- RMSS(36)=RMSS(16)
- CALL PYAPPS
-C...Or use ISASUSY
- ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
- RMSS(36)=RMSS(16)
- CALL PYSUGI
- ALFA=RMSS(18)
- GOTO 170
- ELSE
- GOTO 170
- ENDIF
-
-C...Add in extra D-term contributions.
- IF(IMSS(7).EQ.1) THEN
- R=0.43D0
- DX=RMSS(23)
- DY=RMSS(24)
- DS=RMSS(25)
- WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
- WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
- WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
- WRITE(MSTU(11),*) 'C DX = ',DX
- WRITE(MSTU(11),*) 'C DY = ',DY
- WRITE(MSTU(11),*) 'C DS = ',DS
- WRITE(MSTU(11),*) 'C '
- DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
- WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
- WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
- DQ2=DY/6D0-DX/3D0-DS/3D0
- DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
- DD2=DY/3D0+DX-2D0*DS/3D0
- DL2=-DY/2D0+DX-2D0*DS/3D0
- DE2=DY-DX/3D0-DS/3D0
- DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
- DHD2=-DY/2D0-2D0*DX/3D0+DS
- DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
- & /ABS(COS2B)
- DMA2 = 2D0*DMU2+DHU2+DHD2
- DO 150 I=1,5,2
- KC=PYCOMP(KSUSY1+I)
- PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
- KC=PYCOMP(KSUSY2+I)
- PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
- KC=PYCOMP(KSUSY1+I+1)
- PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
- KC=PYCOMP(KSUSY2+I+1)
- PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
- 150 CONTINUE
- DO 160 I=11,15,2
- KC=PYCOMP(KSUSY1+I)
- PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
- KC=PYCOMP(KSUSY2+I)
- PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
- KC=PYCOMP(KSUSY1+I+1)
- PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
- 160 CONTINUE
- IF(RMSS(4)**2+DMU2.LT.0D0) THEN
- WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
- CALL PYSTOP(104)
- ENDIF
- SGNMU=SIGN(1D0,RMSS(4))
- RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
- ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
- RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
- ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
- RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
- ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
- RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
- ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
- RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
- ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
- RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
- IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
- WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
- CALL PYSTOP(104)
- ENDIF
- RMSS(19)=SQRT(RMSS(19)**2+DMA2)
- RMSS(6)=SQRT(RMSS(6)**2+DL2)
- RMSS(7)=SQRT(RMSS(7)**2+DE2)
- WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
- WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
- WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
- WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
- WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
- ENDIF
-
-C...Fix the third generation sfermions.
- CALL PYTHRG
-
-C...Fix the neutralino--chargino--gluino sector.
- CALL PYINOM
-
-C...Fix the Higgs sector.
- CALL PYHGGM(ALFA)
-
-C...Choose the Gunion-Haber convention.
- ALFA=-ALFA
- RMSS(18)=ALFA
-
-C...Print information on mass parameters.
- IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
- WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
- WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
- WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
- WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
- WRITE(MSTU(11),*) ' TANB=',RMSS(5)
- WRITE(MSTU(11),*) ' MU = ',RMSS(4)
- WRITE(MSTU(11),*) ' AT = ',RMSS(16)
- WRITE(MSTU(11),*) ' MA = ',RMSS(19)
- WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
- WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
- ENDIF
- IF(IMSS(20).EQ.1) THEN
- WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
- WRITE(MSTU(11),*) ' DEBUG MODE '
- WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
- & UMIX(2,1),UMIX(2,2)
- WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
- & UMIXI(2,1),UMIXI(2,2)
- WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
- & VMIX(2,1),VMIX(2,2)
- WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
- & VMIXI(2,1),VMIXI(2,2)
- WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
- WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
- WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
- WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
- WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
- WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
- WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
- WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
- WRITE(MSTU(11),*) ' ALFA = ',ALFA
- WRITE(MSTU(11),*) ' BETA = ',BETA
- WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
- WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
- WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
- ENDIF
-
-C...Set up the Higgs couplings - needed here since initialization
-C...in PYINRE did not yet occur when PYWIDT is called below.
- 170 AL=ALFA
- BE=BETA
- SINA=SIN(AL)
- COSA=COS(AL)
- COSB=COS(BE)
- SINB=TANB*COSB
- SBMA=SIN(BE-AL)
- SAPB=SIN(AL+BE)
- CAPB=COS(AL+BE)
- CBMA=COS(BE-AL)
- C2A=COS(2D0*AL)
- C2B=COSB**2-SINB**2
-C...tanb (used for H+)
- PARU(141)=TANB
-
-C...Firstly: h
-C...Coupling to d-type quarks
- PARU(161)=SINA/COSB
-C...Coupling to u-type quarks
- PARU(162)=-COSA/SINB
-C...Coupling to leptons
- PARU(163)=PARU(161)
-C...Coupling to Z
- PARU(164)=SBMA
-C...Coupling to W
- PARU(165)=PARU(164)
-
-C...Secondly: H
-C...Coupling to d-type quarks
- PARU(171)=-COSA/COSB
-C...Coupling to u-type quarks
- PARU(172)=-SINA/SINB
-C...Coupling to leptons
- PARU(173)=PARU(171)
-C...Coupling to Z
- PARU(174)=CBMA
-C...Coupling to W
- PARU(175)=PARU(174)
-C...Coupling to h
- IF(IMSS(4).GE.2) THEN
- PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
- ELSE
- HHH(3)=HHH(3)+HHH(4)+HHH(5)
- PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
- 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
- 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
- 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
- ENDIF
-C...Coupling to H+
-C...Define later
- IF(IMSS(4).GE.2) THEN
- PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
- ELSE
- PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
- 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
- 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
- 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
- ENDIF
-C...Coupling to A
- IF(IMSS(4).GE.2) THEN
- PARU(177)=COS(2D0*BE)*COS(BE+AL)
- ELSE
- PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
- 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
- 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
- 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
- ENDIF
-C...Coupling to H+
- IF(IMSS(4).GE.2) THEN
- PARU(178)=PARU(177)
- ELSE
- PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
- ENDIF
-C...Thirdly, A
-C...Coupling to d-type quarks
- PARU(181)=TANB
-C...Coupling to u-type quarks
- PARU(182)=1D0/PARU(181)
-C...Coupling to leptons
- PARU(183)=PARU(181)
- PARU(184)=0D0
- PARU(185)=0D0
-C...Coupling to Z h
- PARU(186)=COS(BE-AL)
-C...Coupling to Z H
- PARU(187)=SIN(BE-AL)
- PARU(188)=0D0
- PARU(189)=0D0
- PARU(190)=0D0
-
-C...Finally: H+
-C...Coupling to W h
- PARU(195)=COS(BE-AL)
-
-C...Tell that all Higgs couplings have been set.
- MSTP(4)=1
-
-C...Set R-Violating couplings.
-C...Set lambda couplings to common value or "natural values".
- IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
- VIR3=1D0/(126D0)**3
- DO 200 IRK=1,3
- DO 190 IRI=1,3
- DO 180 IRJ=1,3
- IF (IRI.NE.IRJ) THEN
- IF (IRI.LT.IRJ) THEN
- RVLAM(IRI,IRJ,IRK)=RMSS(51)
- IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
- & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
- & PMAS(9+2*IRK,1)*VIR3)
- ELSE
- RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
- ENDIF
- ELSE
- RVLAM(IRI,IRJ,IRK)=0D0
- ENDIF
- 180 CONTINUE
- 190 CONTINUE
- 200 CONTINUE
- ENDIF
-C...Set lambda' couplings to common value or "natural values".
- IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
- VIR3=1D0/(126D0)**3
- DO 230 IRI=1,3
- DO 220 IRJ=1,3
- DO 210 IRK=1,3
- RVLAMP(IRI,IRJ,IRK)=RMSS(52)
- IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
- & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
- & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
- 210 CONTINUE
- 220 CONTINUE
- 230 CONTINUE
- ENDIF
-C...Set lambda'' couplings to common value or "natural values".
- IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
- VIR3=1D0/(126D0)**3
- DO 260 IRI=1,3
- DO 250 IRJ=1,3
- DO 240 IRK=1,3
- IF (IRJ.NE.IRK) THEN
- IF (IRJ.LT.IRK) THEN
- RVLAMB(IRI,IRJ,IRK)=RMSS(53)
- IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
- & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
- & PMAS(2*IRK-1,1)*VIR3)
- ELSE
- RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
- ENDIF
- ELSE
- RVLAMB(IRI,IRJ,IRK) = 0D0
- ENDIF
- 240 CONTINUE
- 250 CONTINUE
- 260 CONTINUE
- ENDIF
-
-C...Antisymmetrize couplings set by user
- IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
- DO 290 IRI=1,3
- DO 280 IRJ=1,3
- DO 270 IRK=1,3
- IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
- RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
- IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
- ENDIF
- IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
- RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
- IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
- ENDIF
- 270 CONTINUE
- 280 CONTINUE
- 290 CONTINUE
- ENDIF
-
-C...Write spectrum to SLHA file
- IF (IMSS(23).NE.0) THEN
- IFAIL=0
- CALL PYSLHA(3,0,IFAIL)
- ENDIF
-
-C...Second part of routine: set decay modes and branching ratios.
-
-C...Allow chi10 -> gravitino + gamma or not.
- KC=PYCOMP(KSUSY1+39)
- IF( IMSS(11) .NE. 0 ) THEN
- PMAS(KC,1)=RMSS(21)/1D9
- PMAS(KC,2)=0D0
- IRPRTY=0
- WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
- ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
- IRPRTY=0
- IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
- & ' ALLOWING SUSY LLE DECAYS'
- IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
- & ' ALLOWING SUSY LQD DECAYS'
- IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
- & ' ALLOWING SUSY UDD DECAYS'
- IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
- & ' --- Warning: R-Violating couplings possibly',
- & ' incompatible with proton decay'
- ELSE
- PMAS(KC,1)=9999D0
- IRPRTY=1
- ENDIF
-
-C...Loop over sparticle and Higgs species.
- PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
-C...Find the LSP or NLSP for a gravitino LSP
- ILSP=0
- PMLSP=1D20
- DO 300 I=1,36
- KF=KFSUSY(I)
- IF(KF.EQ.1000039) GOTO 300
- KC=PYCOMP(KF)
- IF(PMAS(KC,1).LT.PMLSP) THEN
- ILSP=I
- PMLSP=PMAS(KC,1)
- ENDIF
- 300 CONTINUE
- DO 370 I=1,50
- IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
- KF=KFSUSY(I)
- IF (KF.EQ.0) GOTO 370
- KC=PYCOMP(KF)
- LKNT=0
-
-C...Check if there are any decays listed for this sparticle
-C...in a file
- IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
- IFAIL=0
- CALL PYSLHA(2,KF,IFAIL)
- IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
- ELSEIF (I.GE.37) THEN
- GOTO 370
- ENDIF
-
-C...Sfermion decays.
- IF(I.LE.24) THEN
-C...First check to see if sneutrino is lighter than chi10.
- IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
- & PMAS(KC,1).LT.PMCHI1) THEN
- ELSE
- CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
- ENDIF
-
-C...Gluino decays.
- ELSEIF(I.EQ.25) THEN
- CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
- IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
-
-C...Neutralino decays.
- ELSEIF(I.GE.26.AND.I.LE.29) THEN
- CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
-C...chi10 stable or chi10 -> gravitino + gamma.
- IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
- PMAS(KC,2)=1D-6
- MDCY(KC,1)=0
- MWID(KC)=0
- ENDIF
-
-C...Chargino decays.
- ELSEIF(I.GE.30.AND.I.LE.31) THEN
- CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
-
-C...Gravitino is stable.
- ELSEIF(I.EQ.32) THEN
- MDCY(KC,1)=0
- MWID(KC)=0
-
-C...Higgs decays.
- ELSEIF(I.GE.33.AND.I.LE.36) THEN
-C...Calculate decays to non-SUSY particles.
- CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
- LKNT=0
- DO 310 I1=0,100
- XLAM(I1)=0D0
- 310 CONTINUE
- DO 330 I1=1,MDCY(KC,3)
- K1=MDCY(KC,2)+I1-1
- IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
- & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
- XLAM(I1)=WDTP(I1)
- XLAM(0)=XLAM(0)+XLAM(I1)
- DO 320 J1=1,3
- IDLAM(I1,J1)=KFDP(K1,J1)
- 320 CONTINUE
- LKNT=LKNT+1
- 330 CONTINUE
-C...Add the decays to SUSY particles.
- CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
- ENDIF
-C...Zero the branching ratios for use in loop mode
-C...thanks to K. Matchev (FNAL)
- DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
- BRAT(IDC)=0D0
- 340 CONTINUE
-
-C...Set stable particles.
- IF(LKNT.EQ.0) THEN
- MDCY(KC,1)=0
- MWID(KC)=0
- PMAS(KC,2)=1D-6
- PMAS(KC,3)=1D-5
- PMAS(KC,4)=0D0
-
-C...Store branching ratios in the standard tables.
- ELSE
- IDC=MDCY(KC,2)+MDCY(KC,3)-1
- DELM=1D6
- DO 360 IL=1,LKNT
- IDCSV=IDC
- 350 IDC=IDC+1
- BRAT(IDC)=0D0
- IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
- IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
- & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
- BRAT(IDC)=XLAM(IL)/XLAM(0)
- XMDIF=PMAS(KC,1)
- IF(MDME(IDC,1).GE.1) THEN
- XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
- & PMAS(PYCOMP(KFDP(IDC,2)),1)
- IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
- & PMAS(PYCOMP(KFDP(IDC,3)),1)
- ENDIF
- IF(I.LE.32) THEN
- IF(XMDIF.GE.0D0) THEN
- DELM=MIN(DELM,XMDIF)
- ELSE
- WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
- WRITE(MSTU(11),*) ' KF = ',KF
- WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
- ENDIF
- ENDIF
- GOTO 360
- ELSEIF(IDC.EQ.IDCSV) THEN
- WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
- & 'channel not recognized:'
- WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
- GOTO 360
- ELSE
- GOTO 350
- ENDIF
- 360 CONTINUE
-
-C...Store width, cutoff and lifetime.
- PMAS(KC,2)=XLAM(0)
- IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
- PMAS(KC,3)=PMAS(KC,2)*10D0
- ELSE
- PMAS(KC,3)=0.95D0*DELM
- ENDIF
- IF(PMAS(KC,2).NE.0D0) THEN
- PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
- ENDIF
-C...Write decays to SLHA file
- IF (IMSS(24).NE.0) THEN
- IFAIL=0
- CALL PYSLHA(4,KF,IFAIL)
- ENDIF
-
- ENDIF
- 370 CONTINUE
-
- RETURN
- END
-C*********************************************************************
-
-C...PYSLHA
-C...Read/write spectrum or decay data from SLHA standard file(s).
-C...P. Skands
-
-C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
-C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
-C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
-C... (KFORIG=0 : read all decay tables)
-C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
-C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
-C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
-C... (KFORIG=0 : read all MASS entries)
-
-C...Recent updates:
-C...17 Sep 2007: introduced /PYQNUM/ for QNUMBERS storage
-C... : Corrected QNUMBERS name-formation; root only until space
- SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYDAT4/CHAF(500,2)
- CHARACTER CHAF*16
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- CHARACTER*40 ISAVER,VISAJE
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
-C...SUSY blocks
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
- SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
-
-C...Local arrays, character variables and data.
- COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
- & AU(3,3),AD(3,3),AE(3,3)
- COMMON/PYLH3C/CPRO(2),CVER(2)
-C...The common block of new states (QNUMBERS / PARTICLE)
- COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
-C...- NQNUM : Number of QNUMBERS blocks that have been read in
-C...- KQNUM(I,0) : KF of new state
-C...- KQNUM(I,1) : 3 times electric charge
-C...- KQNUM(I,2) : Number of spin states: (2S + 1)
-C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
-C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
-C...- KQNUM(I,5:9) : space available for further quantum numbers
- DIMENSION MMOD(100),MSPC(100),KFDEC(100)
- SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
-C...MMOD: flags to set for each block read in.
-C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
-C...MSPC: Flags to set for each block read in.
-C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
-C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
-C...11: AD 12: AE 13: YU 14: YD 15: YE
-C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
- CHARACTER CPRO*12,CVER*12,CHNLIN*6
- CHARACTER DOC*11, CHDUM*120, CHBLCK*60
- CHARACTER CHINL*120,CHKF*9,CHTMP*16
- INTEGER VERBOS
- SAVE VERBOS
-C...Date of last Change
- PARAMETER (DOC='05 Nov 2007')
-C...Local arrays and initial values
- DIMENSION IDC(5),KFSUSY(50)
- SAVE KFSUSY
- DATA NQNUM /0/
- DATA NDECAY /0/
- DATA VERBOS /1/
- DATA NHELLO /0/
- DATA MLHEF /0/
- DATA MLHEFD /0/
- DATA KFSUSY/
- &1000001,1000002,1000003,1000004,1000005,1000006,
- &2000001,2000002,2000003,2000004,2000005,2000006,
- &1000011,1000012,1000013,1000014,1000015,1000016,
- &2000011,2000012,2000013,2000014,2000015,2000016,
- &1000021,1000022,1000023,1000025,1000035,1000024,
- &1000037,1000039, 25, 35, 36, 37,
- & 6, 24, 45, 46,1000045, 9*0/
- DATA KFDEC/100*0/
- RMFUN(IP)=PMAS(PYCOMP(IP),1)
-
-C...Shorthand for spectrum and decay table unit numbers
- IMSS21=IMSS(21)
- IMSS22=IMSS(22)
-
-C...Default for LHEF input: read header information
- IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
- IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
- IF (IMSS21.EQ.MSTP(161)) MLHEF=1
- IF (IMSS22.EQ.MSTP(161)) MLHEFD=1
-
-C...Hello World
- IF (NHELLO.EQ.0) THEN
- IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
- WRITE(MSTU(11),5000) DOC
- NHELLO=1
- ENDIF
- ENDIF
-
-C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
-C...+MUPDA).
- LFN=IMSS21
- IF (MUPDA.EQ.2) LFN=IMSS22
- IF (MUPDA.EQ.3) LFN=IMSS(23)
- IF (MUPDA.EQ.4) LFN=IMSS(24)
-C...Flag that we have not yet found whatever we were asked to find.
- IRETRN=1
-
-C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
- IF (LFN.EQ.0) THEN
- WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
- GOTO 9999
- ENDIF
-
-C...If reading LHEF header, start by rewinding file
- IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
-
-C...If told to read spectrum, first zero all previous information.
- IF (MUPDA.EQ.1) THEN
-C...Zero all block read flags
- DO 100 M=1,100
- MMOD(M)=0
- MSPC(M)=0
- 100 CONTINUE
-C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
- DO 110 ISUSY=1,36
- KC=PYCOMP(KFSUSY(ISUSY))
- PMAS(KC,1)=0D0
- 110 CONTINUE
-C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
- DO 130 J=1,4
- SFMIX(5,J) =0D0
- SFMIX(6,J) =0D0
- SFMIX(15,J)=0D0
- DO 120 L=1,4
- ZMIX(L,J) =0D0
- ZMIXI(L,J)=0D0
- IF (J.LE.2.AND.L.LE.2) THEN
- UMIX(L,J) =0D0
- UMIXI(L,J)=0D0
- VMIX(L,J) =0D0
- VMIXI(L,J)=0D0
- ENDIF
- 120 CONTINUE
-C...Zero signed masses.
- SMZ(J)=0D0
- IF (J.LE.2) SMW(J)=0D0
- 130 CONTINUE
-
-C...If reading decays, reset PYTHIA decay counters.
- ELSEIF (MUPDA.EQ.2) THEN
-C...Check if DECAY for this KF already read
- IF (KFORIG.NE.0) THEN
- DO 140 IDEC=1,NDECAY
- IF (KFORIG.EQ.KFDEC(IDEC)) THEN
- IRETRN=0
- RETURN
- ENDIF
- 140 CONTINUE
- ENDIF
- KCC=100
- NDC=0
- BRSUM=0D0
- DO 150 KC=1,MSTU(6)
- IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
- NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
- 150 CONTINUE
- ELSEIF (MUPDA.EQ.5) THEN
-C...Zero block read flags
- DO 160 M=1,100
- MSPC(M)=0
- 160 CONTINUE
- ENDIF
-
-C............READ
-C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
- IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
-C...Initialize program and version strings
- IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
- CPRO(MUPDA)=' '
- CVER(MUPDA)=' '
- ENDIF
-
-C...Initialize read loop
- MERR=0
- NLINE=0
- CHBLCK=' '
-C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
- 170 CHINL=' '
- READ(LFN,'(A120)',END=400) CHINL
-C...Count which line number we're at.
- NLINE=NLINE+1
- WRITE(CHNLIN,'(I6)') NLINE
-
-C...Skip comment and empty lines without processing.
- IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
-
-C...We assume all upper case below. Rewrite CHINL to all upper case.
- INL=0
- IGOOD=0
- 180 INL=INL+1
- IF (CHINL(INL:INL).NE.'#') THEN
- DO 190 ICH=97,122
- IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
- 190 CONTINUE
-C...Extra safety. Chek for sensible input on line
- IF (IGOOD.EQ.0) THEN
- DO 200 ICH=48,90
- IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
- 200 CONTINUE
- ENDIF
- IF (INL.LT.120) GOTO 180
- ENDIF
- IF (IGOOD.EQ.0) GOTO 170
-
-C...Exit when first <event> tag reached in LHEF file
- DO 210 I1=1,10
- IF (CHINL(I1:I1+5).EQ.'<EVENT') THEN
- REWIND(LFN)
- GOTO 400
- ENDIF
- 210 CONTINUE
-
-C...Check for BLOCK begin statement (spectrum).
- IF (CHINL(1:5).EQ.'BLOCK') THEN
- MERR=0
- READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
-C...Check if another of this type of block was already read.
-C...(logarithmic interpolation not yet implemented, so duplicates always
-C...give errors)
- IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
- IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
- IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
- IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
- IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
- IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
- IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
- IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
- IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
- IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
- IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
- IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
- IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
- IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
- IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
- IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
- IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
-C...Check for new particles
- IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
- & THEN
- MSPC(19)=MSPC(19)+1
-C...Read PDG code
- READ(CHBLCK(9:60),*) KFQ
-
- DO 220 MQ=1,NQNUM
- IF (KQNUM(MQ,0).EQ.KFQ) THEN
- MERR=17
- GOTO 380
- ENDIF
- 220 CONTINUE
- IF (NHELLO.EQ.0) THEN
- WRITE(MSTU(11),5000) DOC
- NHELLO=1
- ENDIF
- WRITE(MSTU(11),'(A,I9,A,F12.3)')
- & ' * (PYSLHA:) Reading in '//CHBLCK(1:8)//
- & ' for KF =',KFQ
- NQNUM=NQNUM+1
- KQNUM(NQNUM,0)=KFQ
- MSPC(19)=MSPC(19)+1
- KCQ=PYCOMP(KFQ)
-C...Only read in new codes (also OK to overwrite if KF > 3000000)
- IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
- IF (KCQ.EQ.0) THEN
- DO 230 KCT=100,MSTU(6)
- IF(KCHG(KCT,4).GT.100) KCQ=KCT
- 230 CONTINUE
- KCQ=KCQ+1
- ENDIF
- KCC=KCQ
- KCHG(KCQ,4)=KFQ
-C...First write PDG code as name
- WRITE(CHTMP,*) KFQ
- WRITE(CHTMP,'(A)') CHTMP(2:10)
-C...Then look for real name
- IBEG=9
- 240 IBEG=IBEG+1
- IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
- 250 IBEG=IBEG+1
- IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
- IEND=IBEG-1
- 260 IEND=IEND+1
- IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
- IF (IEND.LT.59) THEN
- READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
- IF (CHDUM.NE.' ') CHTMP=CHDUM
- ENDIF
- 270 READ(CHTMP,'(A)') CHAF(KCQ,1)
- MSTU(20)=0
-C...Set stable for now
- PMAS(KCQ,2)=1D-6
- MWID(KCQ)=0
- MDCY(KCQ,1)=0
- MDCY(KCQ,2)=0
- MDCY(KCQ,3)=0
- ELSE
- WRITE(MSTU(11),*)
- & '* (PYSLHA:) KF =',KFQ,' already exists: ',
- & CHAF(KCQ,1), '. Entry ignored.'
- MERR=7
- ENDIF
- ENDIF
-C...Finalize this line and read next.
- GOTO 380
-C...Check for DECAY begin statement (decays).
- ELSEIF (CHINL(1:3).EQ.'DEC') THEN
- MERR=0
- BRSUM=0D0
- CHBLCK='DECAY'
-C...Read KF code and WIDTH
- MPSIGN=1
- READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
- IF (KF.LE.0) THEN
- KF=-KF
- MPSIGN=-1
- ENDIF
-C...If this is not the KF we're looking for...
- IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
-C...Set block skip flag and read next line.
- MERR=16
- GOTO 380
- ELSE
-C...Check whether decay table for this particle already read in
- DO 280 IDECAY=1,NDECAY
- IF (KFDEC(IDECAY).EQ.KF) THEN
- MERR=16
- GOTO 380
- ENDIF
- 280 CONTINUE
- ENDIF
-
-C...Determine PYTHIA KC code of particle
- KCREP=0
- IF(KF.LE.100) THEN
- KCREP=KF
- ELSE
- DO 290 KCR=101,KCC
- IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
- 290 CONTINUE
- ENDIF
- KC=KCREP
- IF (KCREP.NE.0) THEN
-C...Particle is already known. Don't do anything yet.
- ELSE
-C... Add new particle. Actually, this should not happen.
-C... New particles should be added already when reading the spectrum
-C... information, so go under previously stable category.
- KCC=KCC+1
- KC=KCC
- ENDIF
-
- IF (WIDTH.LE.0D0) THEN
-C...Stable (i.e. LSP)
- WRITE(MSTU(11),*)
- & '* (PYSLHA:) Reading in SLHA stable particle ',
- & 'KF =',KF,': ',CHAF(KCREP,1)(1:16)
- IF (WIDTH.LT.0D0) THEN
- CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
- & ' zero !')
- WIDTH=0D0
- ENDIF
- PMAS(KC,2)=1D-6
- MWID(KC)=0
- MDCY(KC,1)=0
-C...Ignore any decay lines that may be present for this KF
- MERR=16
- MDCY(KC,2)=0
- MDCY(KC,3)=0
-C...Return ok
- IRETRN=0
- ENDIF
-C...Finalize and start reading in decay modes.
- GOTO 380
- ELSEIF (MOD(MERR,10).GE.6) THEN
-C...If ignore block flag set, skip directly to next line.
- GOTO 170
- ENDIF
-
-C...READ SPECTRUM
- IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
- IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
- & THEN
- READ(CHINL,*) INDX, IVAL
- IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
- IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
- IF (INDX.EQ.3) KCHG(KCQ,2)=0
- IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
- IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
- IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
- IF (INDX.EQ.4) THEN
- KCHG(KCQ,3)=IVAL
- IF (IVAL.EQ.1) THEN
- CHTMP=CHAF(KCQ,1)
- IF (CHTMP.EQ.' ') THEN
- WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
- WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
- ELSE
- ILAST=17
- 300 ILAST=ILAST-1
- IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
- IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
- CHTMP(ILAST:ILAST)='-'
- ELSE
- CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
- ENDIF
- CHAF(KCQ,2)=CHTMP
- ENDIF
- ENDIF
- ENDIF
- ELSE
- MERR=8
- ENDIF
- ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
-C...MASS: Mass spectrum
- IF (CHBLCK(1:4).EQ.'MASS') THEN
- READ(CHINL,*) KF, VAL
- MERR=1
- KC=0
- IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
-C...Read in masses for anything
- MERR=0
- KC=PYCOMP(KF)
-C...Don't read in masses for the light quarks
- IF (IABS(KF).LE.3) THEN
- WRITE(MSTU(11),'(A,I9,A,F12.3)')
- & ' * (PYSLHA:) Ignoring MASS entry for KF =',
- & KF
- MERR=1
- ENDIF
- IF (KC.NE.0) THEN
- MSPC(1)=MSPC(1)+1
- PMAS(KC,1) = ABS(VAL)
- IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
- WRITE(MSTU(11),'(A,I9,A,F12.3)')
- & ' * (PYSLHA:) Reading in MASS entry for KF =',
- & KF, ', pole mass =', VAL
- IRETRN=0
- ENDIF
-C... Signed masses
- IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
- IF (KF.EQ.1000022) SMZ(1)=VAL
- IF (KF.EQ.1000023) SMZ(2)=VAL
- IF (KF.EQ.1000025) SMZ(3)=VAL
- IF (KF.EQ.1000035) SMZ(4)=VAL
- IF (KF.EQ.1000024) SMW(1)=VAL
- IF (KF.EQ.1000037) SMW(2)=VAL
- ENDIF
- ELSEIF (MUPDA.EQ.5) THEN
- MERR=0
- ENDIF
-C... MODSEL: Model selection and global switches
- ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
- READ(CHINL,*) INDX, IVAL
- IF (INDX.LE.200.AND.INDX.GT.0) THEN
- IF (IMSS(1).EQ.0) IMSS(1)=11
- MODSEL(INDX)=IVAL
- MMOD(1)=MMOD(1)+1
- IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
-C... Switch on NMSSM
- WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
- IMSS(13)=MAX(1,IMSS(13))
-C... Add NMSSM states if not already done
-
- KFN=25
- KCN=KFN
- CHAF(KCN,1)='h_10'
- CHAF(KCN,2)=' '
-
- KFN=35
- KCN=KFN
- CHAF(KCN,1)='h_20'
- CHAF(KCN,2)=' '
-
- KFN=45
- KCN=KFN
- CHAF(KCN,1)='h_30'
- CHAF(KCN,2)=' '
-
- KFN=36
- KCN=KFN
- CHAF(KCN,1)='A_10'
- CHAF(KCN,2)=' '
-
- KFN=46
- KCN=KFN
- CHAF(KCN,1)='A_20'
- CHAF(KCN,2)=' '
-
- KFN=1000045
- KCN=PYCOMP(KFN)
- IF (KCN.EQ.0) THEN
- DO 310 KCT=100,MSTU(6)
- IF(KCHG(KCT,4).GT.100) KCN=KCT
- 310 CONTINUE
- KCN=KCN+1
- KCHG(KCN,4)=KFN
- MSTU(20)=0
- ENDIF
-C... Set stable for now
- PMAS(KCN,2)=1D-6
- MWID(KCN)=0
- MDCY(KCN,1)=0
- MDCY(KCN,2)=0
- MDCY(KCN,3)=0
- CHAF(KCN,1)='~chi_50'
- CHAF(KCN,2)=' '
- ENDIF
- ELSE
- MERR=1
- ENDIF
- ELSEIF (MUPDA.EQ.5) THEN
-C...If MUPDA = 5, skip all except MASS, return if MODSEL
- MERR=8
- ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
- & CHBLCK(1:8).EQ.'PARTICLE') THEN
-C...Don't print a warning for QNUMBERS when reading spectrum
- MERR=8
-C...MINPAR: Minimal model parameters
- ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
- READ(CHINL,*) INDX, VAL
- IF (INDX.LE.100.AND.INDX.GT.0) THEN
- PARMIN(INDX)=VAL
- MMOD(2)=MMOD(2)+1
- ELSE
- MERR=1
- ENDIF
- IF (MMOD(3).NE.0) THEN
- WRITE(MSTU(11),*)
- & '* (PYSLHA:) MINPAR should come before EXTPAR !'
- MERR=1
- ENDIF
-C...tan(beta)
- IF (INDX.EQ.3) RMSS(5)=VAL
-C...EXTPAR: non-minimal model parameters.
- ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
- IF (MMOD(1).NE.0) THEN
- READ(CHINL,*) INDX, VAL
- IF (INDX.LE.200.AND.INDX.GT.0) THEN
- PAREXT(INDX)=VAL
- MMOD(3)=MMOD(3)+1
- ELSE
- MERR=1
- ENDIF
- ELSE
- WRITE(MSTU(11),*)
- & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
- MERR=1
- ENDIF
-C...tan(beta)
- IF (INDX.EQ.25) RMSS(5)=VAL
- ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
- READ(CHINL,*) INDX, VAL
- IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
- MERR=1
- ELSEIF (INDX.EQ.4) THEN
- PMAS(PYCOMP(23),1)=VAL
- ELSEIF (INDX.EQ.6) THEN
- PMAS(PYCOMP(6),1)=VAL
- ENDIF
- ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
- $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
- $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
- $ THEN
-C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
- IM=0
- IF (CHBLCK(5:6).EQ.'IM') IM=1
- 320 READ(CHINL,*) INDX1, INDX2, VAL
- IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
- IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
- IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
- MSPC(2)=MSPC(2)+1
- ELSEIF (CHBLCK(1:1).EQ.'U') THEN
- IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
- IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
- MSPC(3)=MSPC(3)+1
- ELSEIF (CHBLCK(1:1).EQ.'V') THEN
- IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
- IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
- MSPC(4)=MSPC(4)+1
- ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
- $ .CHBLCK(1:4).EQ.'STAU') THEN
- IF (CHBLCK(1:4).EQ.'STOP') THEN
- KFSM=6
- ISPC=6
- ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
- KFSM=5
- ISPC=5
- ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
- KFSM=15
- ISPC=7
- ENDIF
-C...Set SFMIX element
- SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
- MSPC(ISPC)=MSPC(ISPC)+1
- ENDIF
-C...Running parameters
- ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
- READ(CHBLCK(8:25),*,ERR=620) Q
- READ(CHINL,*) INDX, VAL
- MSPC(8)=MSPC(8)+1
- IF (INDX.EQ.1) THEN
- RMSS(4) = VAL
- ELSE
- MERR=1
- MSPC(8)=MSPC(8)-1
- ENDIF
- ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
- READ(CHINL,*,ERR=630) VAL
- RMSS(18)= VAL
- MSPC(17)=MSPC(17)+1
-C...Higgs parameters set manually or with FeynHiggs.
- IMSS(4)=MAX(2,IMSS(4))
- ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
- & .CHBLCK(1:2).EQ.'AE') THEN
- READ(CHBLCK(9:26),*,ERR=620) Q
- READ(CHINL,*) INDX1, INDX2, VAL
- IF (CHBLCK(2:2).EQ.'U') THEN
- AU(INDX1,INDX2)=VAL
- IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
- MSPC(11)=MSPC(11)+1
- ELSEIF (CHBLCK(2:2).EQ.'D') THEN
- AD(INDX1,INDX2)=VAL
- IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
- MSPC(10)=MSPC(10)+1
- ELSEIF (CHBLCK(2:2).EQ.'E') THEN
- AE(INDX1,INDX2)=VAL
- IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
- MSPC(12)=MSPC(12)+1
- ELSE
- MERR=1
- ENDIF
- ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
- IF (MSPC(18).EQ.0) THEN
- READ(CHBLCK(9:25),*,ERR=620) Q
- RMSOFT(0)=Q
- ENDIF
- READ(CHINL,*) INDX, VAL
- RMSOFT(INDX)=VAL
- MSPC(18)=MSPC(18)+1
- ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
- MERR=8
- ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
- & .CHBLCK(1:2).EQ.'YE') THEN
- MERR=8
- ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
- READ(CHINL(1:6),*) INDX
- IT=0
- MIRD=0
- 330 IT=IT+1
- IF (CHINL(IT:IT).EQ.' ') GOTO 330
-C...Don't read index
- IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
- MIRD=1
- GOTO 330
- ENDIF
- IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
- IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
- ELSE
-C... Set unrecognized block flag.
- MERR=6
- ENDIF
-
-C...DECAY TABLES
-C...Read in decay information
- ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
-C...Read new decay chanel
- IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
- NDC=NDC+1
-C...Read in branching ratio and number of daughters for this mode.
- READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
- READ(CHINL(4:50),*,ERR=600) DUM, NDA
- IF (NDA.LE.5) THEN
- IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
- & '(PYSLHA:) Decay data arrays full by KF ='
- $ //CHAF(KC,1))
-C...If first decay channel, set decays start point in decay table
- IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
- IF (KFORIG.EQ.0) WRITE(MSTU(11),*)
- & '* (PYSLHA:) Reading in SLHA decay table for ',
- & 'KF =',KF,': ',CHAF(KCREP,1)(1:16)
-C...Set particle parameters (mass set when reading BLOCK MASS above)
- PMAS(KC,2)=WIDTH
- IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
- WRITE(MSTU(11),*)
- & '* Note: the Pythia gg->h/H/A cross section'//
- & ' is proportional to the h/H/A->gg width'
- ENDIF
- PMAS(KC,3)=0D0
- PMAS(KC,4)=PARU(3)*1D-12/WIDTH
- MWID(KC)=2
- MDCY(KC,1)=1
- MDCY(KC,2)=NDC
- MDCY(KC,3)=0
-C...Add to list of DECAY blocks currently read
- NDECAY=NDECAY+1
- KFDEC(NDECAY)=KF
-C...Return ok
- IRETRN=0
- ENDIF
-C... Count up number of decay modes for this particle
- MDCY(KC,3)=MDCY(KC,3)+1
-C... Read in decay daughters.
- READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
-C... Flip sign if reading antiparticle decays (if antipartner exists)
- DO 340 IDA=1,NDA
- IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
- & IDC(IDA)=MPSIGN*IDC(IDA)
- 340 CONTINUE
-C...Switch on decay channel, with products ordered in decreasing ABS(KF)
- MDME(NDC,1)=1
- IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
- BRSUM=BRSUM+ABS(BRAT(NDC))
- BRAT(NDC)=ABS(BRAT(NDC))
- 350 IFLIP=0
- DO 360 IDA=1,NDA-1
- IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
- ITMP=IDC(IDA)
- IDC(IDA)=IDC(IDA+1)
- IDC(IDA+1)=ITMP
- IFLIP=IFLIP+1
- ENDIF
- 360 CONTINUE
- IF (IFLIP.GT.0) GOTO 350
-C...Treat as ordinary decay, no fancy stuff.
- MDME(NDC,2)=0
- DO 370 IDA=1,5
- IF (IDA.LE.NDA) THEN
- KFDP(NDC,IDA)=IDC(IDA)
- ELSE
- KFDP(NDC,IDA)=0
- ENDIF
- 370 CONTINUE
-C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
-C & (KFDP(NDC,J),J=1,NDA)
- ELSE
- CALL PYERRM(7,'(PYSLHA:) Too many daughters on line'//
- & CHNLIN)
- MERR=11
- NDC=NDC-1
- ENDIF
- ELSEIF(CHINL(1:1).EQ.'+') THEN
- MERR=11
- ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
- MERR=16
- ELSE
- MERR=16
- ENDIF
- ENDIF
-C... Error check.
- 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
- WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
- & //CHINL(1:40)
- MERR=0
- ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
- WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
- & CHBLCK(1:MIN(INL,40))//'... on line'//CHNLIN
- ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
- WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
- & //CHBLCK(1:INL)//'... on line'//CHNLIN
- ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
- & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
- WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
- & //'... on line'//CHNLIN
- ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
- WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
- & /CHBLCK(1:INL)//'... on line'//CHNLIN
- ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
- WRITE (CHTMP,*) KF
- WRITE(MSTU(11),*)
- & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
- & CHTMP(1:9)//' on line'//CHNLIN
- ENDIF
-C...Iterate read loop
- GOTO 170
-C...Error catching
- 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
- & ', ignoring subsequent lines.'
- WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
- CHBLCK=' '
- GOTO 170
-C...End of read loop
- 400 CONTINUE
-C...Set flag that KC codes have been rearranged.
- MSTU(20)=0
- VERBOS=0
-
-C...Perform possible tests that new information is consistent.
- IF (MUPDA.EQ.1) THEN
- MSTU23=MSTU(23)
- MSTU27=MSTU(27)
-C...Check Z and top masses
- IF (ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0) THEN
- WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
- CALL PYERRM(19,'(PYSLHA:) note Z boson mass, M ='//CHTMP)
- ENDIF
- IF (ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0) THEN
- WRITE(CHTMP,*) PMAS(PYCOMP(6),1)
- CALL PYERRM(19,'(PYSLHA:) note top quark mass, M ='
- & //CHTMP//'GeV')
- ENDIF
-C...Check masses
- DO 410 ISUSY=1,37
- KF=KFSUSY(ISUSY)
-C...Don't complain about right-handed neutrinos
- IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
- & +16) GOTO 410
-C...Only check gravitino in GMSB scenarios
- IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
- KC=PYCOMP(KF)
- IF (PMAS(KC,1).EQ.0D0) THEN
- WRITE(CHTMP,*) KF
- CALL PYERRM(9
- & ,'(PYSLHA:) No mass information found for KF ='
- & //CHTMP)
- ENDIF
- 410 CONTINUE
-C...Check mixing matrices (MSSM only)
- IF (IMSS(13).EQ.0) THEN
- IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
- & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
- IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
- & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
- IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
- & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
- IF (MSPC(5).NE.4) CALL PYERRM(9
- & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
- IF (MSPC(6).NE.4) CALL PYERRM(9
- & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
- IF (MSPC(7).NE.4) CALL PYERRM(9
- & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
- IF (MSPC(8).LT.1) CALL PYERRM(9
- & ,'(PYSLHA:) Too few elements in HMIX')
- IF (MSPC(10).EQ.0) CALL PYERRM(9
- & ,'(PYSLHA:) Missing A_b trilinear coupling')
- IF (MSPC(11).EQ.0) CALL PYERRM(9
- & ,'(PYSLHA:) Missing A_t trilinear coupling')
- IF (MSPC(12).EQ.0) CALL PYERRM(9
- & ,'(PYSLHA:) Missing A_tau trilinear coupling')
- IF (MSPC(17).LT.1) CALL PYERRM(9
- & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
- ENDIF
-C...Check wavefunction normalizations.
-C...Sfermions
- DO 420 ISPC=5,7
- IF (MSPC(ISPC).EQ.4) THEN
- KFSM=ISPC
- IF (ISPC.EQ.7) KFSM=15
- CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
- & *SFMIX(KFSM,3))
- IF (ABS(1D0-CHECK).GT.1D-3) THEN
- KCSM=PYCOMP(KFSM)
- CALL PYERRM(17
- & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
- & //CHAF(KCSM,1))
- ENDIF
- ENDIF
- 420 CONTINUE
-C...Neutralinos + charginos
- DO 440 J=1,4
- CN1=0D0
- CN2=0D0
- CU1=0D0
- CU2=0D0
- CV1=0D0
- CV2=0D0
- DO 430 L=1,4
- CN1=CN1+ZMIX(J,L)**2
- CN2=CN2+ZMIX(L,J)**2
- IF (J.LE.2.AND.L.LE.2) THEN
- CU1=CU1+UMIX(J,L)**2
- CU2=CU2+UMIX(L,J)**2
- CV1=CV1+VMIX(J,L)**2
- CV2=CV2+VMIX(L,J)**2
- ENDIF
- 430 CONTINUE
-C...NMIX normalization
- IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
- & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
- CALL PYERRM(19,
- & '(PYSLHA:) NMIX: Inconsistent normalization.')
- WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
- ENDIF
-C...UMIX, VMIX normalizations
- IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
- IF (J.LE.2) THEN
- IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
- CALL PYERRM(19
- & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
- WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
- & CU2
- ENDIF
- IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
- CALL PYERRM(19,
- & '(PYSLHA:) VMIX: Inconsistent normalization.')
- WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
- & CV2
- ENDIF
- ENDIF
- ENDIF
- 440 CONTINUE
- IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
- WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
- & '* PYSLHA: No spectrum inconsistencies were found.'
- ELSE
- WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
- & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
- & ,' Warning: one or more (serious)'//
- & ' inconsistencies were found in the spectrum !'
- & ,' Read the error messages above and check your'//
- & ' input file.'
- ENDIF
-C...Increase precision in Higgs sector using FeynHiggs
- IF (IMSS(4).EQ.3) THEN
-C...FeynHiggs needs MSOFT.
- IERR=0
- IF (MSPC(18).EQ.0) THEN
- WRITE(MSTU(11),'(1x,"*"/1x,A/)')
- & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
- & ' Cannot call FeynHiggs.'
- IERR=-1
- ELSE
- WRITE(MSTU(11),'(1x,/1x,A/)')
- & '* (PYSLHA:) Now calling FeynHiggs.'
- CALL PYFEYN(IERR)
- IF (IERR.NE.0) IMSS(4)=2
- ENDIF
- ENDIF
- ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
- IBEG=1
- IF (KFORIG.NE.0) IBEG=NDECAY
- DO 490 IDECAY=IBEG,NDECAY
- KF = KFDEC(IDECAY)
- KC = PYCOMP(KF)
- WRITE(CHKF,8300) KF
- IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
- $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
- $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
- $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
- $ //CHKF)
- BRSUM=0D0
- BROPN=0D0
- DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
- IF(MDME(IDA,2).GT.80) GOTO 460
- KQ=KCHG(KC,1)
- PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
- MERR=0
- DO 450 J=1,5
- KP=KFDP(IDA,J)
- IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
- IF(KP.EQ.81) KQ=0
- ELSEIF(PYCOMP(KP).EQ.0) THEN
- MERR=3
- ELSE
- KQ=KQ-PYCHGE(KP)
- KPC=PYCOMP(KP)
- PMS=PMS-PMAS(KPC,1)
- IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
- & PMAS(KPC,3))
- ENDIF
- 450 CONTINUE
- IF(KQ.NE.0) MERR=MAX(2,MERR)
- IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
- & MERR=MAX(1,MERR)
- IF(MERR.EQ.3) CALL PYERRM(17,
- & '(PYSLHA:) Unknown particle code in decay of KF ='
- $ //CHKF)
- IF(MERR.EQ.2) CALL PYERRM(17,
- & '(PYSLHA:) Charge not conserved in decay of KF ='
- $ //CHKF)
- IF(MERR.EQ.1) CALL PYERRM(7,
- & '(PYSLHA:) Kinematically unallowed decay of KF ='
- $ //CHKF)
- BRSUM=BRSUM+BRAT(IDA)
- IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
- 460 CONTINUE
-C...Check branching ratio sum.
- IF (BROPN.LE.0D0) THEN
-C...If zero, set stable.
- WRITE(CHTMP,8500) BROPN
- CALL PYERRM(7
- & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
- & CHTMP(9:16)//'. Changed to stable.')
- PMAS(KC,2)=1D-6
- MWID(KC)=0
-C...If BR's > 1, rescale.
- ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
- WRITE(CHTMP,8500) BRSUM
- IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
- & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
- & ' ; sum was'//CHTMP(9:16)//'.')
- FAC=1D0/BRSUM
- DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
- IF(MDME(IDA,2).GT.80) GOTO 470
- BRAT(IDA)=FAC*BRAT(IDA)
- 470 CONTINUE
- ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
-C...If BR's < 1, insert dummy mode for proper cross section rescaling.
- WRITE(CHTMP,8500) BRSUM
- IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
- & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
- & CHTMP(9:16)//'. Dummy mode will be inserted.')
-C...Move table and insert dummy mode
- DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
- NDC=NDC+1
- BRAT(NDC)=BRAT(IDA)
- KFDP(NDC,1)=KFDP(IDA,1)
- KFDP(NDC,2)=KFDP(IDA,2)
- KFDP(NDC,3)=KFDP(IDA,3)
- KFDP(NDC,4)=KFDP(IDA,4)
- KFDP(NDC,5)=KFDP(IDA,5)
- MDME(NDC,1)=MDME(IDA,1)
- 480 CONTINUE
- NDC=NDC+1
- BRAT(NDC)=1D0-BRSUM
- KFDP(NDC,1)=0
- KFDP(NDC,2)=0
- KFDP(NDC,3)=0
- KFDP(NDC,4)=0
- KFDP(NDC,5)=0
- MDME(NDC,1)=0
- BRSUM=1D0
-C...Update MDCY
- MDCY(KC,3)=MDCY(KC,3)+1
- MDCY(KC,2)=NDC-MDCY(KC,3)+1
- ENDIF
- 490 CONTINUE
- ENDIF
-
-
-C...WRITE SPECTRUM ON SLHA FILE
- ELSEIF(MUPDA.EQ.3) THEN
-C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
- IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
- MODSEL(1)=1
- PARMIN(1)=RMSS(8)
- PARMIN(2)=RMSS(1)
- PARMIN(3)=RMSS(5)
- PARMIN(4)=SIGN(1D0,RMSS(4))
- PARMIN(5)=RMSS(36)
- ENDIF
-C...Write spectrum
- WRITE(LFN,7000) 'SLHA MSSM spectrum'
- WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
- & // ' P. Skands.'
- WRITE(LFN,7010) 'MODSEL', 'Model selection'
- WRITE(LFN,7110) 1, MODSEL(1)
- WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
- IF (MODSEL(1).EQ.1) THEN
- WRITE(LFN,7210) 1, PARMIN(1), 'm0'
- WRITE(LFN,7210) 2, PARMIN(2), 'm12'
- WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
- WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
- WRITE(LFN,7210) 5, PARMIN(5), 'a0'
- ELSEIF(MODSEL(2).EQ.2) THEN
- WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
- WRITE(LFN,7210) 2, PARMIN(2), 'M'
- WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
- WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
- WRITE(LFN,7210) 5, PARMIN(5), 'N5'
- WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
- ENDIF
- WRITE(LFN,7000) ' '
- WRITE(LFN,7010) 'MASS', 'Mass spectrum'
- DO 500 I=1,36
- KF=KFSUSY(I)
- KC=PYCOMP(KF)
- IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
- KFSM=KF-KSUSY1
- IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
- IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
- IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
- IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
- IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
- IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
- IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
- ELSE
- WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
- ENDIF
- 500 CONTINUE
-C...SUSY scale
- RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
- WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
- WRITE(LFN,7210) 1, RMSS(4),'mu'
- WRITE(LFN,7010) 'ALPHA',' '
- WRITE(LFN,7210) 1, RMSS(18), 'alpha'
- WRITE(LFN,7020) 'AU',RMSUSY
- WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
- WRITE(LFN,7020) 'AD',RMSUSY
- WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
- WRITE(LFN,7020) 'AE',RMSUSY
- WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
- WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
- WRITE(LFN,7410) 1, 1, SFMIX(6,1)
- WRITE(LFN,7410) 1, 2, SFMIX(6,2)
- WRITE(LFN,7410) 2, 1, SFMIX(6,3)
- WRITE(LFN,7410) 2, 2, SFMIX(6,4)
- WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
- WRITE(LFN,7410) 1, 1, SFMIX(5,1)
- WRITE(LFN,7410) 1, 2, SFMIX(5,2)
- WRITE(LFN,7410) 2, 1, SFMIX(5,3)
- WRITE(LFN,7410) 2, 2, SFMIX(5,4)
- WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
- WRITE(LFN,7410) 1, 1, SFMIX(15,1)
- WRITE(LFN,7410) 1, 2, SFMIX(15,2)
- WRITE(LFN,7410) 2, 1, SFMIX(15,3)
- WRITE(LFN,7410) 2, 2, SFMIX(15,4)
- WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
- DO 520 I1=1,4
- DO 510 I2=1,4
- WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
- 510 CONTINUE
- 520 CONTINUE
- WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
- DO 540 I1=1,2
- DO 530 I2=1,2
- WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
- 530 CONTINUE
- 540 CONTINUE
- WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
- DO 560 I1=1,2
- DO 550 I2=1,2
- WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
- 550 CONTINUE
- 560 CONTINUE
- WRITE(LFN,7010) 'SPINFO'
- IF (IMSS(1).EQ.2) THEN
- CPRO(1)='PYTHIA'
- CVER(1)='6.4'
- ELSEIF (IMSS(1).EQ.12) THEN
- ISAVER=VISAJE()
- CPRO(1)='ISASUSY'
- CVER(1)=ISAVER(1:12)
- ENDIF
- WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
- WRITE(LFN,7310) 2, CVER(1), 'Version number'
- ENDIF
-
-C...Print user information about spectrum
- IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
- IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
- & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
- IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
- IF (MUPDA.EQ.1) THEN
- WRITE(MSTU(11),5020) LFN
- ELSE
- WRITE(MSTU(11),5010) LFN
- ENDIF
-
- WRITE(MSTU(11),5400)
- WRITE(MSTU(11),5500) 'Pole masses'
- WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
- $ ,(RMFUN(KSUSY2+IP),IP=1,6)
- WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
- $ ,(RMFUN(KSUSY2+IP),IP=11,16)
- IF (IMSS(13).EQ.0) THEN
- WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
- $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
- $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
- WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
- & CHAF(37,1), ' ', ' ',' ',' ',
- & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
- ELSEIF (IMSS(13).EQ.1) THEN
- KF1=KSUSY1+21
- KF2=KSUSY1+22
- KF3=KSUSY1+23
- KF4=KSUSY1+25
- KF5=KSUSY1+35
- KF6=KSUSY1+45
- KF7=KSUSY1+24
- KF8=KSUSY1+37
- WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
- & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
- & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
- & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
- & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
- & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
- WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
- & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
- & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
- & RMFUN(37)
- ENDIF
- WRITE(MSTU(11),5400)
- WRITE(MSTU(11),5500) 'Mixing structure'
- WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
- WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
- & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
- WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
- & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
- & ),(SFMIX(15,J),J=3,4)
- WRITE(MSTU(11),5400)
- WRITE(MSTU(11),5500) 'Couplings'
- WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
- WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
- WRITE(MSTU(11),5400)
- WRITE(MSTU(11),6500)
-
- ENDIF
-
-C...Only rewind when reading
- IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
-
- 9999 RETURN
-
-C...Serious error catching
- 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
- write(*,*) CHINL(1:80)
- CALL PYSTOP(106)
- 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
- WRITE(*,*) CHINL(1:72)
- CALL PYSTOP(106)
- 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
- WRITE(*,*) CHINL(1:80)
- CALL PYSTOP(106)
- 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
- WRITE(*,*) CHINL(1:80)
- 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
- CALL PYSTOP(106)
- 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
- WRITE(*,*) CHINL(1:80)
- CALL PYSTOP(106)
-
- 8300 FORMAT(I9)
- 8500 FORMAT(F16.5)
-
-C...Formats for user information printout.
- 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.10: SUSY/BSM SPECTRUM '
- & ,'INTERFACE',1x,17('*')/1x,'*',2x
- & ,'PYSLHA: Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
- 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
- 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
- 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
- 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
- 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
- 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
- & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
- 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
- & ,'----------------')
- 5400 FORMAT(1x,'*',1x,A)
- 5500 FORMAT(1x,'*',1x,A,':')
- 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
- & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
- 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
- & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
- & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
- 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
- & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
- & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
- 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
- & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
- & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
- 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
- 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
- & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
- & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
- & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
- & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
- & ,1x,F6.3,1x),'|')
- 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
- & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
- & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
- & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
- & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
- 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
- & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
- & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
- & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
- & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
- & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
- & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
- 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
- & ,'A_tau = ',F8.2)
- 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
- & ,' mu = ',F8.2)
- 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
-
-C...Format to use for comments
- 7000 FORMAT('# ',A)
-C...Format to use for block statements
- 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
- 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
-C...Indexed Int
- 7110 FORMAT(1x,I4,1x,I4,3x,'#')
-C...Non-Indexed Double
- 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
-C...Indexed Double
- 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
-C...Long Indexed Double (PDG + double)
- 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
-C...Indexed Char(12)
- 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
-C...Single matrix
- 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
-C...Double Matrix
- 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
-C...Write Decay Table
- 7500 FORMAT('Decay',1x,I9,1x,'WIDTH=',1P,E16.8,0P,3x,'#',1x,A)
- 7510 FORMAT(4x,I5,1x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),
- & 3x,'#',1x,A)
-
- END
-
-
-C*********************************************************************
-
-C...PYAPPS
-C...Uses approximate analytical formulae to determine the full set of
-C...MSSM parameters from SUGRA input.
-C...See M. Drees and S.P. Martin, hep-ph/9504124
-
- SUBROUTINE PYAPPS
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
-
- WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
- &' not intended for serious physics studies'
- IMSS(5)=0
- IMSS(8)=0
- XMT=PMAS(6,1)
- XMZ2=PMAS(23,1)**2
- XMW2=PMAS(24,1)**2
- TANB=RMSS(5)
- BETA=ATAN(TANB)
- XW=PARU(102)
- XMG=RMSS(1)
- XMG2=XMG*XMG
- XM0=RMSS(8)
- XM02=XM0*XM0
-C...Temporary sign change for AT. Others unchanged.
- AT=-RMSS(16)
- RMSS(15)=RMSS(16)
- RMSS(17)=RMSS(16)
- SINB=TANB/SQRT(TANB**2+1D0)
- COSB=SINB/TANB
-
- DTERM=XMZ2*COS(2D0*BETA)
- XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
- XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
- RMSS(6)=XMEL
- RMSS(7)=XMER
- XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
- XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
- XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
- XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
- DO 100 I=1,5,2
- PMAS(PYCOMP(KSUSY1+I),1)=XMDL
- PMAS(PYCOMP(KSUSY2+I),1)=XMDR
- PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
- PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
- 100 CONTINUE
- XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
- IF(XARG.LT.0D0) THEN
- WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
- & ' FROM THE SUM RULE. '
- WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
- RETURN
- ELSE
- XARG=SQRT(XARG)
- ENDIF
- DO 110 I=11,15,2
- PMAS(PYCOMP(KSUSY1+I),1)=XMEL
- PMAS(PYCOMP(KSUSY2+I),1)=XMER
- PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
- PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
- 110 CONTINUE
- RMT=PYMRUN(6,PMAS(6,1)**2)
- XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
- &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
- RMB=PYMRUN(5,PMAS(6,1)**2)
- XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
- &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
- XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
- ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
- &SINB)**2)
- RMSS(16)=-ATP
- XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
- &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
- XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
- XMU=SIGN(SQRT(XMU2),RMSS(4))
- RMSS(4)=XMU
- IF(XMA2.GT.0D0) THEN
- RMSS(19)=SQRT(XMA2)
- ELSE
- WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
- CALL PYSTOP(102)
- ENDIF
- ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
- IF(ARG.GT.0D0) THEN
- RMSS(14)=SQRT(ARG)
- ELSE
- WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
- CALL PYSTOP(102)
- ENDIF
- ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
- IF(ARG.GT.0D0) THEN
- RMSS(13)=SQRT(ARG)
- ELSE
- WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
- CALL PYSTOP(102)
- ENDIF
- ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
- IF(ARG.GT.0D0) THEN
- RMSS(10)=SQRT(ARG)
- ELSE
- RMSS(10)=-SQRT(-ARG)
- ENDIF
- ARG=PYRNMQ(2,-2D0*XTOP/3D0)
- IF(ARG.GT.0D0) THEN
- RMSS(12)=SQRT(ARG)
- ELSE
- RMSS(12)=-SQRT(-ARG)
- ENDIF
- ARG=PYRNMQ(3,-2D0*XBOT/3D0)
- IF(ARG.GT.0D0) THEN
- RMSS(11)=SQRT(ARG)
- ELSE
- RMSS(11)=-SQRT(-ARG)
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSUGI
-C...Interface to ISASUSY version 7.71.
-C...Warning: this interface should not be used with earlier versions
-C...of ISASUSY, since common block incompatibilities may then arise.
-C...Calls SUGRA (in ISAJET) to perform RGE evolution.
-C...Then converts to Gunion-Haber conventions.
-
- SUBROUTINE PYSUGI
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
-
- INTEGER PYK,PYCHGE,PYCOMP
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-
-C...Date of Change
- CHARACTER DOC*11
- PARAMETER (DOC='01 May 2006')
-
-C...ISASUGRA Input:
- REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
-C...XISAIN contains the MSSMi inputs in natural order.
- COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
- $XAMIN(7)
- REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
- SAVE /SUGXIN/
-C...ISASUGRA Output
- CHARACTER*40 ISAVER,VISAJE
- REAL SUPER
- COMMON /SSPAR/ SUPER(72)
- COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
- $FBGUT,FTAGUT,FNGUT
- REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
- COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
- $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
- $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
- $VUMT,VDMT,ASMTP,ASMSS,M3Q
- REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
- $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
- $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
- INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
- INTEGER IALLOW
- SAVE /SUGMG/,/SSPAR/
-C SUPER: Filled by ISASUGRA.
-C SUPER(1) = mass of ~g
-C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
-C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
-C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
-C ,~tau_2
-C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
-C SUPER(29) = Higgsino mass = - mu
-C SUPER(30) = ratio v2/v1 of vev's
-C SUPER(31:34) = Signed neutralino masses
-C SUPER(35:50) = Neutralino mixing matrix
-C SUPER(51:52) = Signed chargino masses
-C SUPER(53:54) = Chargino left, right mixing angles
-C SUPER(55:58) = mass of h0, H0, A0, H+
-C SUPER(59) = Higgs mixing angle alpha
-C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
-C SUPER(66) = Gravitino mass
-C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
-C SUPER(70) = b-Yukawa at mA scale (not used)
-C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
-C GSS: Filled by ISASUGRA
-C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
-C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
-C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
-C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
-C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
-C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
-C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
-C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
-C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
-C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
-C GSS(31) = log(vuq)
-C MSS: Filled by ISASUGRA
-C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
-C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
-C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
-C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
-C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
-C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
-C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
-C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
-C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
-C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
-C MSS(31) = ha0 MSS(32) = h+
-C Unification, filled by ISASUGRA if applicable.
-C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
-
-C...SPYTHIA Input/Output
- INTEGER IMSS
- DOUBLE PRECISION RMSS
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
-C...SLHA Input/Output
- COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
- & AU(3,3),AD(3,3),AE(3,3)
-C...PYTHIA common blocks
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
-
- SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
- INTEGER IMODEL
- REAL M0,MHF,A0,MT
- CHARACTER*20 CHMOD(5)
- CHARACTER*32 FNAME
-
- COMMON /SUGNU/ XNUSUG(18)
- REAL XNUSUG
- SAVE /SUGNU/
-
- DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
- & 'truly unified SUGRA', 'non-minimal GMSB'/
-
-C...Start by checking for incompatibilities/inconsistencies:
- DO 100 ICHK=2,9
- IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
- WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
- & ,' option not used by PYSUGI'
- ENDIF
- 100 CONTINUE
-C...ISAJET works with REAL numbers.
- MZERO=REAL(RMSS(8))
- MHLF=REAL(RMSS(1))
- AZERO=REAL(RMSS(16))
- TANB=REAL(RMSS(5))
- SGNMU=REAL(RMSS(4))
- MTOP=REAL(PMAS(6,1))
- IMODEL=0
- IF (IMSS(1).EQ.12) THEN
- IMODEL=1
- GOTO 130
- ELSEIF(IMSS(1).EQ.13) THEN
-C...Read from isajet par file in IMSS(20)
- LFN=IMSS(20)
-C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
- IF (LFN.EQ.0) THEN
- WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
- GOTO 9999
- ENDIF
- WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
-CMrenna change to allow any susy model
- WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
- WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
- WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
- WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
- & ' gauge couplings:'
- WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
- READ(LFN,*) IMODEL
- IF (IMODEL.EQ.4) THEN
- IAL3UN=1
- IMODEL=1
- ENDIF
- IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
- WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
- & //' sgn(mu), M_t:'
- READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
- IF (IMODEL.EQ.3) THEN
- IMODEL=1
- 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
- & //' 0 to continue:'
- WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
- WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
- WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
- WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
- & //' generation masses'
- WRITE(MSTU(11),*)
- & ' NUSUG5 = GUT scale 3rd generation masses'
- READ(LFN,*) INUSUG
- IF (INUSUG.EQ.0) THEN
- GOTO 120
- ELSEIF (INUSUG.EQ.1) THEN
- WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
- READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
- IF (XNUSUG(3).LE.0.) THEN
- WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
- CALL PYSTOP(109)
- END IF
- ELSEIF (INUSUG.EQ.2) THEN
- WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
- READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
- ELSEIF (INUSUG.EQ.3) THEN
- WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
- READ(LFN,*) XNUSUG(7),XNUSUG(8)
- ELSEIF (INUSUG.EQ.4) THEN
- WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
- & //' M(ur), M(el), M(er):'
- READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
- & XNUSUG(10),XNUSUG(9)
- ELSEIF (INUSUG.EQ.5) THEN
- WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
- & //' M(Ll), M(Lr):'
- READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
- & XNUSUG(15),XNUSUG(14)
- ENDIF
- GOTO 110
- ENDIF
- ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
- IMSS(11)=1
- WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
- & ,' sgn(mu), M_t, C_gv:'
- READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
- XGMIN(7)=XCMGV
- XGMIN(8)=1.
-C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
- AMPL=2.4D18
- AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
- IF (IMODEL.EQ.5) THEN
- IMODEL=2
- WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
- & ,' masses at M_mes'
- WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
- & ,' shifts at M_mes'
- WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
- & ' Y at M_mes'
- WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
- & ,'SU(2),SU(3)'
- WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
- & ,' n5_2, n5_3'
- READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
- $ XGMIN(13),XGMIN(14)
- ENDIF
- ELSE
- WRITE(MSTU(11),*) 'Invalid model choice.'
- GOTO 9999
- ENDIF
- ENDIF
-
- 120 MZERO=M0
- MHLF=MHF
- AZERO=A0
-C TANB=REAL(RMSS(5))
-C SGNMU=REAL(RMSS(4))
- MTOP=MT
-
-C...Initialize MSSM parameter array
- 130 DO 140 IPAR=1,72
- SUPER(IPAR)=0.0
- 140 CONTINUE
-C...Call ISASUGRA
- CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
-C...Check whether ISASUSY thought the model was OK.
- IF (NOGOOD.NE.0) THEN
- IF (NOGOOD.EQ.1) CALL PYERRM(26
- & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
- IF (NOGOOD.EQ.2) CALL PYERRM(26
- & ,'(PYSUGI:) SUSY parameters give no EWSB.')
- IF (NOGOOD.EQ.3) CALL PYERRM(26
- & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
- IF (NOGOOD.EQ.4) CALL PYERRM(26
- & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
- IF (NOGOOD.EQ.7) CALL PYERRM(26
- & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
- IF (NOGOOD.EQ.8) CALL PYERRM(26
- & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
-C...Give warning, but don't stop, if LSP not ~chi_10.
- IF (NOGOOD.EQ.5) CALL PYERRM(16
- & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
- ENDIF
-C...Warn about possible GUT scale tachyons.
- IF (ITACHY.NE.0) CALL PYERRM(16,
- & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
-C...Finalize spectrum (last iteration)
-C...(Thanks to A. Raklev for pointing this out.)
-C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
- CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
- $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
- $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
- $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
- $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
- $ MTOP,IALLOW,1)
-
-C...M1, M2, M3.
- RMSS(1)=dble(GSS(7))
- RMSS(2)=dble(GSS(8))
- RMSS(3)=dble(GSS(9))
- RMSOFT(1)=dble(GSS(7))
- RMSOFT(2)=dble(GSS(8))
- RMSOFT(3)=dble(GSS(9))
-C...Mu = - Higgsino mass.
- RMSS(4)=-SUPER(29)
- RMSS(5)=TANB
-C...Slepton and squark masses. 2 first generations.
- RMSS(6)=0.5*(SUPER(18)+SUPER(20))
- RMSS(7)=0.5*(SUPER(19)+SUPER(21))
- RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
- RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
-C...Third generation.
- RMSS(10)=0.5*(SUPER(14)+SUPER(10))
- RMSS(11)=SUPER(11)
- RMSS(12)=SUPER(15)
- RMSS(13)=SUPER(22)
- RMSS(14)=SUPER(23)
-C...SLHA: store exact soft spectrum in RMSOFT
- RMSOFT(31)=SUPER(18)
- RMSOFT(32)=SUPER(20)
- RMSOFT(33)=SUPER(22)
- RMSOFT(34)=SUPER(19)
- RMSOFT(35)=SUPER(21)
- RMSOFT(36)=SUPER(23)
- RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
- RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
- RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
- RMSOFT(44)=SUPER(3)
- RMSOFT(45)=SUPER(9)
- RMSOFT(46)=SUPER(15)
- RMSOFT(47)=SUPER(5)
- RMSOFT(48)=SUPER(7)
- RMSOFT(49)=SUPER(11)
-
-C...~b, ~t, and ~tau trilinear couplings and mixing angles.
- RMSS(15)=SUPER(62)
- RMSS(16)=SUPER(60)
- RMSS(17)=SUPER(64)
- RMSS(26)=SUPER(63)
- RMSS(27)=SUPER(61)
- RMSS(28)=SUPER(65)
-C...SLHA trilinears
- DO 142 K1=1,3
- DO 141 K2=1,3
- AE(K1,K2)=0D0
- AU(K1,K2)=0D0
- AD(K1,K2)=0D0
- 141 CONTINUE
- 142 CONTINUE
- AE(3,3)=SUPER(64)
- AU(3,3)=SUPER(60)
- AD(3,3)=SUPER(62)
-C...Higgs mixing angle alpha (Gunion-Haber convention).
- RMSS(18)=-SUPER(59)
-C...A0 mass.
- RMSS(19)=SUPER(57)
-C...GUT scale coupling
- RMSS(20)=AGUTSS
-C...Gravitino mass (for future compatibility)
- RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
-
-C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
-C...Higgs sector.
- PMAS(PYCOMP(25),1)=ABS(SUPER(55))
- PMAS(PYCOMP(35),1)=ABS(SUPER(56))
- PMAS(PYCOMP(36),1)=ABS(SUPER(57))
- PMAS(PYCOMP(37),1)=ABS(SUPER(58))
-C...Gluino.
- PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
-C...Squarks and Sleptons.
- DO 150 ILR=1,2
- ILRM=ILR-1
- PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
- PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
- PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
- PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
- PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
- PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
- PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
- PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
- PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
- 150 CONTINUE
- PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
- PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
- PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
-C...Neutralinos.
- PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
- PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
- PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
- PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
-C...Signed masses (extra minus from going to G-H convention).
- SMZ(1)=-SUPER(31)
- SMZ(2)=-SUPER(32)
- SMZ(3)=-SUPER(33)
- SMZ(4)=-SUPER(34)
-C...Charginos
- PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
- PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
-C...Signed masses (extra minus from going to G-H convention).
- SMW(1)=-SUPER(51)
- SMW(2)=-SUPER(52)
-
-C... Neutralino Mixing.
- DO 160 IN=1,4
- ZMIX(IN,1)= SUPER(38+4*(IN-1))
- ZMIX(IN,2)= SUPER(37+4*(IN-1))
- ZMIX(IN,3)=-SUPER(36+4*(IN-1))
- ZMIX(IN,4)=-SUPER(35+4*(IN-1))
- 160 CONTINUE
-C...Chargino Mixing (PYTHIA same angle as HERWIG).
- THX=1D0
- THY=1D0
- IF (SUPER(53).GT.0) THX=-1D0
- IF (SUPER(54).GT.0) THY=-1D0
- UMIX(1,1) = -SIN(SUPER(53))
- UMIX(1,2) = -COS(SUPER(53))
- UMIX(2,1) = -THX*COS(SUPER(53))
- UMIX(2,2) = THX*SIN(SUPER(53))
- VMIX(1,1) = -SIN(SUPER(54))
- VMIX(1,2) = -COS(SUPER(54))
- VMIX(2,1) = -THY*COS(SUPER(54))
- VMIX(2,2) = THY*SIN(SUPER(54))
-C...Sfermion mixing (PYTHIA same angle as ISAJET)
- SFMIX(5,1)=COS(SUPER(63))
- SFMIX(5,2)=SIN(SUPER(63))
- SFMIX(5,3)=-SIN(SUPER(63))
- SFMIX(5,4)=COS(SUPER(63))
- SFMIX(6,1)=COS(SUPER(61))
- SFMIX(6,2)=SIN(SUPER(61))
- SFMIX(6,3)=-SIN(SUPER(61))
- SFMIX(6,4)=COS(SUPER(61))
- SFMIX(15,1)=COS(SUPER(65))
- SFMIX(15,2)=SIN(SUPER(65))
- SFMIX(15,3)=-SIN(SUPER(65))
- SFMIX(15,4)=COS(SUPER(65))
-
- IF (MSTP(122).NE.0) THEN
-C...Print a few lines to make the user know what's happening
- ISAVER=VISAJE()
- WRITE(MSTU(11),5000) DOC, ISAVER
- WRITE(MSTU(11),5100)
- IF (IMODEL.EQ.1) THEN
- WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
- & MTOP
- WRITE(MSTU(11),5300)
- ENDIF
- WRITE(MSTU(11),5500) 'Pole masses'
- WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
- WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
- & ,(SUPER(IP),IP=19,25,2)
- WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
- & ,IP=1,2)
- WRITE(MSTU(11),5400)
- WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
- WRITE(MSTU(11),5400)
- WRITE(MSTU(11),5500) 'EW scale mixing structure'
- WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
- WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
- & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
- WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
- & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
- & ),(SFMIX(15,J),J=3,4)
- WRITE(MSTU(11),5400)
- WRITE(MSTU(11),6450) RMSS(18)
- WRITE(MSTU(11),5400)
- WRITE(MSTU(11),5500) 'Couplings'
- WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
- WRITE(MSTU(11),5400)
- ENDIF
-
-C...Call FeynHiggs to improve Higgs sector if requested
- IF (IMSS(4).EQ.3) THEN
- IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
- & ' (PYSUGI:) Now calling FeynHiggs.'
- CALL PYFEYN(IERR)
- IF (IERR.EQ.0) THEN
- IMSS(4)=2
- IF (MSTP(122).NE.0) THEN
- WRITE(MSTU(11),5400)
- WRITE(MSTU(11),5500)
- & 'Corrected Higgs masses and mixing'
- WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
- & PMAS(37,1)
- WRITE(MSTU(11),6450) RMSS(18)
- WRITE(MSTU(11),5400)
- ENDIF
- ENDIF
- ENDIF
-
- IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
-
-C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
-C...output by ISASUSY.
- IMSS(4)=MAX(2,IMSS(4))
-
- 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
- & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
- & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
- 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
- 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
- & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
- 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
- & ,'----------------')
- 5400 FORMAT(1x,'*',1x,A)
- 5500 FORMAT(1x,'*',1x,A,':')
- 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
- & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
- 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
- & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
- & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
- & ,1x))
- 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
- & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
- & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
- & .2,1x))
- 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
- & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
- & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
- 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
- & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
- 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
- & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
- 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
- & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
- & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
- & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
- & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
- & ,1x,F6.3,1x),'|')
- 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
- & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
- & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
- & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
- & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
- 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
- & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
- & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
- & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
- & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
- & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
- & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
- 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
- & ,4x,'Alpha_GUT = ',F8.2)
- 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
- 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
-
- 9999 RETURN
- END
-
-C*********************************************************************
-
-C...PYFEYN
-C...Interface to FeynHiggs for MSSM Higgs sector.
-C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
-C...P. Skands
-
- SUBROUTINE PYFEYN(IERR)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
-C...SUSY blocks
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
-C...FeynHiggs variables
- DOUBLE PRECISION RMHIGG(4)
- DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
- DOUBLE COMPLEX DMU,
- & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
- & DM1, DM2, DM3
-C...SLHA Common Block
- COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
- & AU(3,3),AD(3,3),AE(3,3)
- SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
-
- IERR=0
- CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
- IF (IERR.NE.0) THEN
- CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
- & //'Will not use FeynHiggs for this run.')
- RETURN
- ENDIF
- Q=RMSOFT(0)
- DMB=PMAS(5,1)
- DMT=PMAS(6,1)
- DMZ=PMAS(23,1)
- DMW=PMAS(24,1)
- DMA=PMAS(36,1)
- DM1=RMSOFT(1)
- DM2=RMSOFT(2)
- DM3=RMSOFT(3)
- DTANB=RMSS(5)
- DMU=RMSS(4)
- DM3SL=RMSOFT(33)
- DM3SE=RMSOFT(36)
- DM3SQ=RMSOFT(43)
- DM3SU=RMSOFT(46)
- DM3SD=RMSOFT(49)
- DM2SL=RMSOFT(32)
- DM2SE=RMSOFT(35)
- DM2SQ=RMSOFT(42)
- DM2SU=RMSOFT(45)
- DM2SD=RMSOFT(48)
- DM1SL=RMSOFT(31)
- DM1SE=RMSOFT(34)
- DM1SQ=RMSOFT(41)
- DM1SU=RMSOFT(44)
- DM1SD=RMSOFT(47)
- AE33=AE(3,3)
- AE22=AE(2,2)
- AE11=AE(1,1)
- AU33=AU(3,3)
- AU22=AU(2,2)
- AU11=AU(1,1)
- AD33=AD(3,3)
- AD22=AD(2,2)
- AD11=AD(1,1)
- CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
- & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
- & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
- & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
- & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
- & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
- IF (IERR.NE.0) THEN
- CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
- & //' Will not use FeynHiggs for this run.')
- RETURN
- ENDIF
-C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
- SAEFF=0D0
- CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
- IF (IERR.NE.0) THEN
- CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
- & 'GSCORR. Will not use FeynHiggs for this run.')
- RETURN
- ENDIF
- ALPHA = ASIN(DBLE(SAEFF))
- R=RMSS(18)/ALPHA
- IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
- CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
- WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
- WRITE(MSTU(11),*) ' New Alpha:', ALPHA
- ENDIF
- IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
- & 1.15D0*PMAS(25,1)) THEN
- CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
- WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
- WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
- ENDIF
- RMSS(18)=ALPHA
- PMAS(25,1)=RMHIGG(1)
- PMAS(35,1)=RMHIGG(2)
- PMAS(36,1)=RMHIGG(3)
- PMAS(37,1)=RMHIGG(4)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRNMQ
-C...Determines the running mass of Squarks.
-
- FUNCTION PYRNMQ(ID,DTERM)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblock.
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- SAVE /PYMSSM/
-
-C...Local variables.
- DOUBLE PRECISION PI,R
- DOUBLE PRECISION TOL
- DOUBLE PRECISION CI(3)
- EXTERNAL PYALPS
- DOUBLE PRECISION PYALPS
- DATA TOL/0.001D0/
- DATA PI,R/3.141592654D0,.61803399D0/
- DATA CI/0.47D0,0.07D0,0.02D0/
-
- C=1D0-R
- CA=CI(ID)
- AG=(0.71D0)**2/4D0/PI
- AG=RMSS(20)
- XM0=RMSS(8)
- XMG=RMSS(1)
- XM02=XM0*XM0
- XMG2=XMG*XMG
-
- AS=PYALPS(XM02+6D0*XMG2)
- CG=8D0/9D0*((AS/AG)**2-1D0)
- BX=XM02+(CA+CG)*XMG2+DTERM
- AX=MIN(50D0**2,0.5D0*BX)
- CX=MAX(2000D0**2,2D0*BX)
-
- X0=AX
- X3=CX
- IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
- X1=BX
- X2=BX+C*(CX-BX)
- ELSE
- X2=BX
- X1=BX-C*(BX-AX)
- ENDIF
- AS1=PYALPS(X1)
- CG=8D0/9D0*((AS1/AG)**2-1D0)
- F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
- AS2=PYALPS(X2)
- CG=8D0/9D0*((AS2/AG)**2-1D0)
- F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
- 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
- IF(F2.LT.F1) THEN
- X0=X1
- X1=X2
- X2=R*X1+C*X3
- F1=F2
- AS2=PYALPS(X2)
- CG=8D0/9D0*((AS2/AG)**2-1D0)
- F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
- ELSE
- X3=X2
- X2=X1
- X1=R*X2+C*X0
- F2=F1
- AS1=PYALPS(X1)
- CG=8D0/9D0*((AS1/AG)**2-1D0)
- F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
- ENDIF
- GOTO 100
- ENDIF
- IF(F1.LT.F2) THEN
- PYRNMQ=X1
- XMIN=X1
- ELSE
- PYRNMQ=X2
- XMIN=X2
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYTHRG
-C...Calculates the mass eigenstates of the third generation sfermions.
-C...Created: 5-31-96
-
- SUBROUTINE PYTHRG
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
-
-C...Local variables.
- DOUBLE PRECISION BETA
- DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
- DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
- DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
- DOUBLE PRECISION ATR,AMQR,AMQL
- INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
- INTEGER IF,I,J,II,JJ,IT,L
- LOGICAL DTERM
- DATA SMALL/1D-3/
- DATA ID1/10,10,13/
- DATA ID2/5,6,15/
- DATA ID3/15,16,17/
- DATA ID4/11,12,14/
- DATA DTERM/.TRUE./
-
- XMZ2=PMAS(23,1)**2
- XMW2=PMAS(24,1)**2
- TANB=RMSS(5)
- XMU=-RMSS(4)
- BETA=ATAN(TANB)
- COS2B=COS(2D0*BETA)
-
-C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
-
- IOPT=IMSS(5)
- IF(IOPT.EQ.1) THEN
- CTT=DCOS(RMSS(27))
- CTT2=CTT**2
- STT=DSIN(RMSS(27))
- STT2=STT**2
- XM12=RMSS(10)**2
- XM22=RMSS(12)**2
- XMQL2=CTT2*XM12+STT2*XM22
- XMQR2=STT2*XM12+CTT2*XM22
- XMF2=PYMRUN(6,PMAS(6,1)**2)**2
- ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
- RMSS(16)=ATOP
-C......SUBTRACT OUT D-TERM AND FERMION MASS
- XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
- XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
- IF(XMQL2.GE.0D0) THEN
- RMSS(10)=SQRT(XMQL2)
- ELSE
- RMSS(10)=-SQRT(-XMQL2)
- ENDIF
- IF(XMQR2.GE.0D0) THEN
- RMSS(12)=SQRT(XMQR2)
- ELSE
- RMSS(12)=-SQRT(-XMQR2)
- ENDIF
-
-C SAME FOR BOTTOM SQUARK
- CTT=DCOS(RMSS(26))
- CTT2=CTT**2
- STT=DSIN(RMSS(26))
- STT2=STT**2
- XM22=RMSS(11)**2
- XMF2=PYMRUN(5,PMAS(6,1)**2)**2
- XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
- IF(ABS(CTT).GE..9999D0) THEN
- ABOT=-XMU*TANB
- XMQR2=RMSS(11)**2
- ELSEIF(ABS(CTT).LE.1D-4) THEN
- ABOT=-XMU*TANB
- XMQR2=RMSS(11)**2
- ELSE
- XM12=(XMQL2-STT2*XM22)/CTT2
- XMQR2=STT2*XM12+CTT2*XM22
- ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
- ENDIF
- RMSS(15)=ABOT
-C......SUBTRACT OUT D-TERM AND FERMION MASS
- XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
- IF(XMQR2.GE.0D0) THEN
- RMSS(11)=SQRT(XMQR2)
- ELSE
- RMSS(11)=-SQRT(-XMQR2)
- ENDIF
-C SAME FOR TAU SLEPTON
- CTT=DCOS(RMSS(28))
- CTT2=CTT**2
- STT=DSIN(RMSS(28))
- STT2=STT**2
- XM12=RMSS(13)**2
- XM22=RMSS(14)**2
- XMQL2=CTT2*XM12+STT2*XM22
- XMQR2=STT2*XM12+CTT2*XM22
- XMFR=PMAS(15,1)
- XMF2=XMFR**2
- ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
- RMSS(17)=ATAU
-C......SUBTRACT OUT D-TERM AND FERMION MASS
- XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
- XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
- IF(XMQL2.GE.0D0) THEN
- RMSS(13)=SQRT(XMQL2)
- ELSE
- RMSS(13)=-SQRT(-XMQL2)
- ENDIF
- IF(XMQR2.GE.0D0) THEN
- RMSS(14)=SQRT(XMQR2)
- ELSE
- RMSS(14)=-SQRT(-XMQR2)
- ENDIF
- ENDIF
- DO 170 L=1,3
- AMQL=RMSS(ID1(L))
- IF(AMQL.LT.0D0) THEN
- XMQL2=-AMQL**2
- ELSE
- XMQL2=AMQL**2
- ENDIF
- ATR=RMSS(ID3(L))
- AMQR=RMSS(ID4(L))
- IF(AMQR.LT.0D0) THEN
- XMQR2=-AMQR**2
- ELSE
- XMQR2=AMQR**2
- ENDIF
- IF=ID2(L)
- XMF=PYMRUN(IF,PMAS(6,1)**2)
- XMF2=XMF**2
- AM2(1,1)=XMQL2+XMF2
- AM2(2,2)=XMQR2+XMF2
- IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
- IF(DTERM) THEN
- IF(L.EQ.1) THEN
- AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
- AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
- AM2(1,2)=XMF*(ATR+XMU*TANB)
- ELSEIF(L.EQ.2) THEN
- AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
- AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
- AM2(1,2)=XMF*(ATR+XMU/TANB)
- ELSEIF(L.EQ.3) THEN
- IF(IMSS(8).EQ.1) THEN
- AM2(1,1)=RMSS(6)**2
- AM2(2,2)=RMSS(7)**2
- AM2(1,2)=0D0
- RMSS(13)=RMSS(6)
- RMSS(14)=RMSS(7)
- ELSE
- AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
- AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
- AM2(1,2)=XMF*(ATR+XMU*TANB)
- ENDIF
- ENDIF
- ENDIF
- AM2(2,1)=AM2(1,2)
- DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
- IF(DETM.LT.0D0) THEN
- WRITE(MSTU(11),*) ID2(L),DETM,AM2
- CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
- ENDIF
- SAME=0.5D0*(AM2(1,1)+AM2(2,2))
- DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
- XMF12=SAME-DIFF
- XMF22=SAME+DIFF
- IT=0
- IF(XMF22-XMF12.GT.0D0) THEN
- RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
- RT(2,2) = RT(1,1)
- RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
- & AM2(1,2)/(XMF22-XMF12))
- RT(2,1) = -RT(1,2)
- ELSE
- RT(1,1) = 1D0
- RT(2,2) = RT(1,1)
- RT(1,2) = 0D0
- RT(2,1) = -RT(1,2)
- ENDIF
- 100 CONTINUE
- IT=IT+1
-
- DO 140 I=1,2
- DO 130 JJ=1,2
- DI(I,JJ)=0D0
- DO 120 II=1,2
- DO 110 J=1,2
- DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
- 110 CONTINUE
- 120 CONTINUE
- 130 CONTINUE
- 140 CONTINUE
-
- IF(DI(1,1).GT.DI(2,2)) THEN
- WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
- WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
- WRITE(MSTU(11),*) AM2
- WRITE(MSTU(11),*) DI
- WRITE(MSTU(11),*) RT
- DI(1,1)=-RT(2,1)
- DI(2,2)=RT(1,2)
- DI(1,2)=-RT(2,2)
- DI(2,1)=RT(1,1)
- DO 160 I=1,2
- DO 150 J=1,2
- RT(I,J)=DI(I,J)
- 150 CONTINUE
- 160 CONTINUE
- GOTO 100
- ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
- WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
- & ' OFF DIAGONAL ELEMENTS '
- WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
- WRITE(MSTU(11),*) DI
- WRITE(MSTU(11),*) ' ROTATION = ',RT
-C...STOP
- ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
- WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
- & ' NEGATIVE MASSES '
- CALL PYSTOP(111)
- ENDIF
- PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
- PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
- SFMIX(IF,1)=RT(1,1)
- SFMIX(IF,2)=RT(1,2)
- SFMIX(IF,3)=RT(2,1)
- SFMIX(IF,4)=RT(2,2)
- 170 CONTINUE
-
-C.....TAU SNEUTRINO MASS...L=3
-
- XARG=AM2(1,1)+XMW2*COS2B
- IF(XARG.LT.0D0) THEN
- WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
- & ' FROM THE SUM RULE. '
- WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
- RETURN
- ELSE
- PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
- ENDIF
-
- RETURN
- END
-C*********************************************************************
-
-C...PYINOM
-C...Finds the mass eigenstates and mixing matrices for neutralinos
-C...and charginos.
-
- SUBROUTINE PYINOM
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
-
-C...Local variables.
- DOUBLE PRECISION XMW,XMZ,XM(4)
- DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
- DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
- DOUBLE PRECISION COSW,SINW
- DOUBLE PRECISION XMU
- DOUBLE PRECISION TANB,COSB,SINB
- DOUBLE PRECISION XM1,XM2,XM3,BETA
- DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
- DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
- DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
- DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
- DOUBLE PRECISION PYALPS,PYALEM
- DOUBLE PRECISION PYRNM3
- COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
- INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
- DATA KFNCHI/1000022,1000023,1000025,1000035/
-
- IOPT=IMSS(2)
- IF(IMSS(1).EQ.2) THEN
- IOPT=1
- ENDIF
-C...M1, M2, AND M3 ARE INDEPENDENT
- IF(IOPT.EQ.0) THEN
- XM1=RMSS(1)
- XM2=RMSS(2)
- XM3=RMSS(3)
- ELSEIF(IOPT.GE.1) THEN
- Q2=PMAS(23,1)**2
- AEM=PYALEM(Q2)
- A2=AEM/PARU(102)
- A1=AEM/(1D0-PARU(102))
- XM1=RMSS(1)
- XM2=RMSS(2)
- IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
- IF(IOPT.EQ.1) THEN
- XM2=XM1*A2/A1*3D0/5D0
- RMSS(2)=XM2
- ELSEIF(IOPT.EQ.3) THEN
- XM1=XM2*5D0/3D0*A1/A2
- RMSS(1)=XM1
- ENDIF
- XM3=PYRNM3(XM2/A2)
- RMSS(3)=XM3
- IF(XM3.LE.0D0) THEN
- WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
- CALL PYSTOP(105)
- ENDIF
- ENDIF
-
-C...GLUINO MASS
- IF(IMSS(3).EQ.1) THEN
- PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
- ELSE
- AQ=0D0
- DO 110 I=1,4
- DO 100 ILR=1,2
- RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
- AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
- & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
- 100 CONTINUE
- 110 CONTINUE
-
- DO 130 I=5,6
- DO 120 ILR=1,2
- RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
- RM2=PMAS(I,1)**2/XM3**2
- ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
- IF(ARG.GE.0D0) THEN
- X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
- AX0=ABS(X0)
- X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
- AX1=ABS(X1)
- IF(X0.EQ.1D0) THEN
- AT=-1D0
- BT=0.25D0
- ELSEIF(X0.EQ.0D0) THEN
- AT=0D0
- BT=-0.25D0
- ELSE
- AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
- & 0.5D0*X0**2*LOG(AX0)
- BT=(-1D0-2D0*X0)/4D0
- ENDIF
- IF(X1.EQ.1D0) THEN
- AT=-1D0+AT
- BT=0.25D0+BT
- ELSEIF(X1.EQ.0D0) THEN
- AT=0D0+AT
- BT=-0.25D0+BT
- ELSE
- AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
- & X1**2*LOG(AX1)+AT
- BT=(-1D0-2D0*X1)/4D0+BT
- ENDIF
- AQ=AQ+AT+BT
- ELSE
- X0=0.5D0*(1D0+RM2-RM1)
- Y0=-0.5D0*SQRT(-ARG)
- AMGX0=SQRT(X0**2+Y0**2)
- AM1X0=SQRT((1D0-X0)**2+Y0**2)
- ARGX0=ATAN2(-X0,-Y0)
- AR1X0=ATAN2(1D0-X0,Y0)
- X1=X0
- Y1=-Y0
- AMGX1=AMGX0
- AM1X1=AM1X0
- ARGX1=ATAN2(-X1,-Y1)
- AR1X1=ATAN2(1D0-X1,Y1)
- AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
- & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
- BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
- AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
- & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
- BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
- AQ=AQ+AT+BT
- ENDIF
- 120 CONTINUE
- 130 CONTINUE
- PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
- & /(2D0*PARU(2))*(15D0+AQ))
- ENDIF
-
-C...NEUTRALINO MASSES
- DO 150 I=1,4
- DO 140 J=1,4
- AI(I,J)=0D0
- 140 CONTINUE
- 150 CONTINUE
- XMZ=PMAS(23,1)/100D0
- XMW=PMAS(24,1)/100D0
- XMU=RMSS(4)/100D0
- SINW=SQRT(PARU(102))
- COSW=SQRT(1D0-PARU(102))
- TANB=RMSS(5)
- BETA=ATAN(TANB)
- COSB=COS(BETA)
- SINB=TANB*COSB
-
- XM2=XM2/100D0
- XM1=XM1/100D0
-
-
-C... Definitions:
-C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
-C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
- AR(1,1) = XM1*COS(RMSS(30))
- AI(1,1) = XM1*SIN(RMSS(30))
- AR(2,2) = XM2*COS(RMSS(31))
- AI(2,2) = XM2*SIN(RMSS(31))
- AR(3,3) = 0D0
- AR(4,4) = 0D0
- AR(1,2) = 0D0
- AR(2,1) = 0D0
- AR(1,3) = -XMZ*SINW*COSB
- AR(3,1) = AR(1,3)
- AR(1,4) = XMZ*SINW*SINB
- AR(4,1) = AR(1,4)
- AR(2,3) = XMZ*COSW*COSB
- AR(3,2) = AR(2,3)
- AR(2,4) = -XMZ*COSW*SINB
- AR(4,2) = AR(2,4)
- AR(3,4) = -XMU*COS(RMSS(33))
- AI(3,4) = -XMU*SIN(RMSS(33))
- AR(4,3) = -XMU*COS(RMSS(33))
- AI(4,3) = -XMU*SIN(RMSS(33))
-C CALL PYEIG4(AR,WR,ZR)
- CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
- IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
- & 'PROBLEM WITH PYEICG IN PYINOM ')
- DO 160 I=1,4
- INDEX(I)=I
- XM(I)=ABS(WR(I))
- 160 CONTINUE
- DO 180 I=2,4
- K=I
- DO 170 J=I-1,1,-1
- IF(XM(K).LT.XM(J)) THEN
- ITMP=INDEX(J)
- XTMP=XM(J)
- INDEX(J)=INDEX(K)
- XM(J)=XM(K)
- INDEX(K)=ITMP
- XM(K)=XTMP
- K=K-1
- ELSE
- GOTO 180
- ENDIF
- 170 CONTINUE
- 180 CONTINUE
-
-
- DO 210 I=1,4
- K=INDEX(I)
- SMZ(I)=WR(K)*100D0
- PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
- S=0D0
- DO 190 J=1,4
- S=S+ZR(J,K)**2+ZI(J,K)**2
- 190 CONTINUE
- DO 200 J=1,4
- ZMIX(I,J)=ZR(J,K)/SQRT(S)
- ZMIXI(I,J)=ZI(J,K)/SQRT(S)
- IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
- IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
- 200 CONTINUE
- 210 CONTINUE
-
-C...CHARGINO MASSES
-C.....Find eigenvectors of X X^*
- DO I=1,4
- DO J=1,4
- AR(I,J)=0D0
- AI(I,J)=0D0
- ENDDO
- ENDDO
- AI(1,1) = 0D0
- AI(2,2) = 0D0
- AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
- AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
- AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
- &XMU*COS(RMSS(33))*SINB)
- AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
- &XMU*SIN(RMSS(33))*SINB)
- AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
- &XMU*COS(RMSS(33))*SINB)
- AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
- &XMU*SIN(RMSS(33))*SINB)
- CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
- IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
- & 'PROBLEM WITH PYEICG IN PYINOM ')
- INDEX(1)=1
- INDEX(2)=2
- IF(WR(2).LT.WR(1)) THEN
- INDEX(1)=2
- INDEX(2)=1
- ENDIF
-
-
- DO 240 I=1,2
- K=INDEX(I)
- SMW(I)=SQRT(WR(K))*100D0
- S=0D0
- DO 220 J=1,2
- S=S+ZR(J,K)**2+ZI(J,K)**2
- 220 CONTINUE
- DO 230 J=1,2
- UMIX(I,J)=ZR(J,K)/SQRT(S)
- UMIXI(I,J)=-ZI(J,K)/SQRT(S)
- IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
- IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
- 230 CONTINUE
- 240 CONTINUE
-C...Force chargino mass > neutralino mass
- IFRC=0
- IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
- CALL PYERRM(18,'(PYINOM:) '//
- & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
- SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
- IFRC=1
- ENDIF
- PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
- PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
-
-C.....Find eigenvectors of X^* X
- DO I=1,4
- DO J=1,4
- AR(I,J)=0D0
- AI(I,J)=0D0
- ZR(I,J)=0D0
- ZI(I,J)=0D0
- ENDDO
- ENDDO
- AI(1,1) = 0D0
- AI(2,2) = 0D0
- AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
- AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
- AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
- &XMU*COS(RMSS(33))*COSB)
- AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
- &XMU*SIN(RMSS(33))*COSB)
- AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
- &XMU*COS(RMSS(33))*COSB)
- AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
- &XMU*SIN(RMSS(33))*COSB)
- CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
- IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
- & 'PROBLEM WITH PYEICG IN PYINOM ')
- INDEX(1)=1
- INDEX(2)=2
- IF(WR(2).LT.WR(1)) THEN
- INDEX(1)=2
- INDEX(2)=1
- ENDIF
-
- SIMAG=0D0
- DO 270 I=1,2
- K=INDEX(I)
- S=0D0
- DO 250 J=1,2
- S=S+ZR(J,K)**2+ZI(J,K)**2
- SIMAG=SIMAG+ZI(J,K)**2
- 250 CONTINUE
- DO 260 J=1,2
- VMIX(I,J)=ZR(J,K)/SQRT(S)
- VMIXI(I,J)=-ZI(J,K)/SQRT(S)
- IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
- IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
- 260 CONTINUE
- 270 CONTINUE
-
-C.....Simplify if no phases
- IF(SIMAG.LT.1D-6) THEN
- AR(1,1) = XM2*COS(RMSS(31))
- AR(2,2) = XMU*COS(RMSS(33))
- AR(1,2) = SQRT(2D0)*XMW*SINB
- AR(2,1) = SQRT(2D0)*XMW*COSB
- IKNT=0
- 300 CONTINUE
- DO I=1,2
- DO J=1,2
- ZR(I,J)=0D0
- ENDDO
- ENDDO
-
- DO I=1,2
- DO J=1,2
- DO K=1,2
- DO L=1,2
- ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
- ENDDO
- ENDDO
- ENDDO
- ENDDO
- VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
- VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
- VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
- VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
- IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
- CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
- ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
- IKNT=IKNT+1
- GOTO 300
- ENDIF
-C.....Must deal with phases
- ELSE
- CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
- CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
- CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
- CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
-
- IKNT=0
- 310 CONTINUE
- DO I=1,2
- DO J=1,2
- CAI(I,J)=CMPLX(0D0,0D0)
- ENDDO
- ENDDO
-
- DO I=1,2
- DO J=1,2
- DO K=1,2
- DO L=1,2
- CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
- & CMPLX(VMIX(J,L),VMIXI(J,L))
- ENDDO
- ENDDO
- ENDDO
- ENDDO
-
- CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
- CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
- TEMPR=VMIX(1,1)
- TEMPI=VMIXI(1,1)
- VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
- VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
- TEMPR=VMIX(1,2)
- TEMPI=VMIXI(1,2)
- VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
- VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
- TEMPR=VMIX(2,1)
- TEMPI=VMIXI(2,1)
- VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
- VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
- TEMPR=VMIX(2,2)
- TEMPI=VMIXI(2,2)
- VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
- VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
- IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
- CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
- ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
- & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
- IKNT=IKNT+1
- GOTO 310
- ENDIF
- ENDIF
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRNM3
-C...Calculates the running of M3, the SU(3) gluino mass parameter.
-
- FUNCTION PYRNM3(RGUT)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...Local variables.
- DOUBLE PRECISION R
- DOUBLE PRECISION TOL
- EXTERNAL PYALPS
- DOUBLE PRECISION PYALPS
- DATA TOL/0.001D0/
- DATA R/0.61803399D0/
-
- C=1D0-R
-
- BX=RGUT*PYALPS(RGUT**2)
- AX=MIN(50D0,BX*0.5D0)
- CX=MAX(2000D0,2D0*BX)
-
- X0=AX
- X3=CX
- IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
- X1=BX
- X2=BX+C*(CX-BX)
- ELSE
- X2=BX
- X1=BX-C*(BX-AX)
- ENDIF
- AS1=PYALPS(X1**2)
- F1=ABS(X1-RGUT*AS1)
- AS2=PYALPS(X2**2)
- F2=ABS(X2-RGUT*AS2)
- 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
- IF(F2.LT.F1) THEN
- X0=X1
- X1=X2
- X2=R*X1+C*X3
- F1=F2
- AS2=PYALPS(X2**2)
- F2=ABS(X2-RGUT*AS2)
- ELSE
- X3=X2
- X2=X1
- X1=R*X2+C*X0
- F2=F1
- AS1=PYALPS(X1**2)
- F1=ABS(X1-RGUT*AS1)
- ENDIF
- GOTO 100
- ENDIF
- IF(F1.LT.F2) THEN
- PYRNM3=X1
- XMIN=X1
- ELSE
- PYRNM3=X2
- XMIN=X2
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYEIG4
-C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
-C...Specific application: mixing in neutralino sector.
-
- SUBROUTINE PYEIG4(A,W,Z)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...Arrays: in call and local.
- DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
-
-C...Coefficients of fourth-degree equation from matrix.
-C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
- B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
- B2=0D0
- DO 110 I=1,3
- DO 100 J=I+1,4
- B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
- 100 CONTINUE
- 110 CONTINUE
- B1=0D0
- B0=0D0
- DO 120 I=1,4
- I1=MOD(I,4)+1
- I2=MOD(I+1,4)+1
- I3=MOD(I+2,4)+1
- B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
- & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
- & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
- B0=B0+(-1D0)**(I+1)*A(1,I)*(
- & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
- & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
- & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
- 120 CONTINUE
-
-C...Coefficients of third-degree equation needed for
-C...separation into two second-degree equations.
-C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
- C2=-B2
- C1=B1*B3-4D0*B0
- C0=-B1**2-B0*B3**2+4D0*B0*B2
- CQ=C1/3D0-C2**2/9D0
- CR=C1*C2/6D0-C0/2D0-C2**3/27D0
- CQR=CQ**3+CR**2
-
-C...Cases with one or three real roots.
- IF(CQR.GE.0D0) THEN
- S1=(CR+SQRT(CQR))**(1D0/3D0)
- S2=(CR-SQRT(CQR))**(1D0/3D0)
- U=S1+S2-C2/3D0
- ELSE
- SABS=SQRT(-CQ)
- THE=ACOS(CR/SABS**3)/3D0
- SRE=SABS*COS(THE)
- U=2D0*SRE-C2/3D0
- ENDIF
-
-C...Find and solve two second-degree equations.
- P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
- P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
- Q1=U/2D0+SQRT(U**2/4D0-B0)
- Q2=U/2D0-SQRT(U**2/4D0-B0)
- IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
- QSAV=Q1
- Q1=Q2
- Q2=QSAV
- ENDIF
- X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
- X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
- X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
- X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
-
-C...Order eigenvalues in asceding mass.
- W(1)=X(1)
- DO 150 I1=2,4
- DO 130 I2=I1-1,1,-1
- IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
- W(I2+1)=W(I2)
- 130 CONTINUE
- 140 W(I2+1)=X(I1)
- 150 CONTINUE
-
-C...Find equation system for eigenvectors.
- DO 250 I=1,4
- DO 170 J1=1,4
- D(J1,J1)=A(J1,J1)-W(I)
- DO 160 J2=J1+1,4
- D(J1,J2)=A(J1,J2)
- D(J2,J1)=A(J2,J1)
- 160 CONTINUE
- 170 CONTINUE
-
-C...Find largest element in matrix.
- DAMAX=0D0
- DO 190 J1=1,4
- DO 180 J2=1,4
- IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
- JA=J1
- JB=J2
- DAMAX=ABS(D(J1,J2))
- 180 CONTINUE
- 190 CONTINUE
-
-C...Subtract others by multiple of row selected above.
- DAMAX=0D0
- DO 210 J3=JA+1,JA+3
- J1=J3-4*((J3-1)/4)
- RL=D(J1,JB)/D(JA,JB)
- DO 200 J2=1,4
- D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
- IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
- JC=J1
- JD=J2
- DAMAX=ABS(D(J1,J2))
- 200 CONTINUE
- 210 CONTINUE
-
-C...Do one more subtraction of a row.
- DAMAX=0D0
- DO 230 J3=JC+1,JC+3
- J1=J3-4*((J3-1)/4)
- IF(J1.EQ.JA) GOTO 230
- RL=D(J1,JD)/D(JC,JD)
- DO 220 J2=1,4
- IF(J2.EQ.JB) GOTO 220
- D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
- IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
- JE=J1
- DAMAX=ABS(D(J1,J2))
- 220 CONTINUE
- 230 CONTINUE
-
-C...Construct unnormalized eigenvector.
- JF1=JD+1-4*(JD/4)
- JF2=JD+2-4*((JD+1)/4)
- IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
- IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
- E(JF1)=-D(JE,JF2)
- E(JF2)=D(JE,JF1)
- E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
- E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
- & D(JA,JB)
-
-C...Normalize and fill in final array.
- EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
- SGN=(-1D0)**INT(PYR(0)+0.5D0)
- DO 240 J=1,4
- Z(I,J)=SGN*E(J)/EA
- 240 CONTINUE
- 250 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYHGGM
-C...Determines the Higgs boson mass spectrum using several inputs.
-
- SUBROUTINE PYHGGM(ALPHA)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
-
-C...Local variables.
- DOUBLE PRECISION AT,AB,XMU,TANB
- DOUBLE PRECISION ALPHA
- INTEGER IHOPT
- DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
- DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
- DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
- DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
-
- IHOPT=IMSS(4)
- IF(IHOPT.EQ.2) THEN
- ALPHA=RMSS(18)
- RETURN
- ENDIF
- AT=RMSS(16)
- AB=RMSS(15)
- DMGL=RMSS(3)
- XMU=RMSS(4)
- TANB=RMSS(5)
-
- DMA=RMSS(19)
- DTANB=TANB
- DMQ=RMSS(10)
- DMUR=RMSS(12)
- DMDR=RMSS(11)
- DMTOP=PMAS(6,1)
- DMC=PMAS(PYCOMP(KSUSY1+37),1)
- DAU=AT
- DAD=AB
- DMU=XMU
- RMSS(40)=0D0
- RMSS(41)=0D0
-
- IF(IHOPT.EQ.0) THEN
- CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
- & DMHCH,DSA,DCA,DTANBA)
- ELSEIF(IHOPT.EQ.1) THEN
- CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
- & DMHCH,DSA,DCA,DTANBA)
- CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
- & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
- & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
- RMSS(40)=DDT
- RMSS(41)=DDB
- DMH=DMHP
- DHM=DHMP
- DMA=DAMP
- IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
- WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
- WRITE(MSTU(11),*) ' STOP1 MASSES = ',
- & PMAS(PYCOMP(1000006),1),DSTOP2
- ENDIF
- IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
- WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
- WRITE(MSTU(11),*) ' STOP2 MASSES = ',
- & PMAS(PYCOMP(2000006),1),DSTOP1
- ENDIF
- IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
- WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
- WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
- & PMAS(PYCOMP(1000005),1),DSBOT2
- ENDIF
- IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
- WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
- WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
- & PMAS(PYCOMP(2000005),1),DSBOT1
- ENDIF
-
- ELSEIF (IHOPT.EQ.3) THEN
-c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
-C...Currently only available for SLHA spectrum read-in.
- IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
- CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
- & //' spectrum, change IMSS(1) or IMSS(4) option.')
- ENDIF
- ALPHA=RMSS(18)
- RETURN
- ENDIF
-
- ALPHA=ACOS(DCA)
-
- PMAS(25,1)=DMH
- PMAS(35,1)=DHM
- PMAS(36,1)=DMA
- PMAS(37,1)=DMHCH
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSUBH
-C...This routine computes the renormalization group improved
-C...values of Higgs masses and couplings in the MSSM.
-
-C...Program based on the work by M. Carena, J.R. Espinosa,
-c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
-
-C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
-C...All masses in GeV units. MA is the CP-odd Higgs mass,
-C...MTOP is the physical top mass, MQ and MUR are the soft
-C...supersymmetry breaking mass parameters of left handed
-C...and right handed stops respectively, AU and AD are the
-C...stop and sbottom trilinear soft breaking terms,
-C...respectively, and MU is the supersymmetric
-C...Higgs mass parameter. We use the conventions from
-C...the physics report of Haber and Kane: left right
-C...stop mixing term proportional to (AU - MU/TANB)
-C...We use as input TANB defined at the scale MTOP
-
-C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
-C...where MH and HM are the lightest and heaviest CP-even
-C...Higgs masses, MHCH is the charged Higgs mass and
-C...ALPHA is the Higgs mixing angle
-C...TANBA is the angle TANB at the CP-odd Higgs mass scale
-
-C...Range of validity:
-C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
-C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
-C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
-C...are the sbottom mass eigenvalues, respectively. This
-C...range automatically excludes the existence of tachyons.
-C...For the charged Higgs mass computation, the method is
-C...valid if
-C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
-C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
-C...where M_SUSY**2 is the average of the squared stop mass
-C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
-C...masses have been assumed to be of order of the stop ones
-C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
-
- SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
- &XMHCH,SA,CA,TANBA)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYHTRI/HHH(7)
- SAVE /PYDAT1/,/PYDAT2/
-
-C...Local variables.
- DOUBLE PRECISION PYALEM,PYALPS
- DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
- DOUBLE PRECISION XMHCH,SA,CA
- DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
- DOUBLE PRECISION Q02
- DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
- DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
- DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
- DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
- DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
- DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
- DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
- DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
-
- XMZ = PMAS(23,1)
- Q02=XMZ**2
- AEM=PYALEM(Q02)
- ALP1=AEM/(1D0-PARU(102))
- ALP2=AEM/PARU(102)
- ALPH3Z=PYALPS(Q02)
-
- ALP1 = 0.0101D0
- ALP2 = 0.0337D0
- ALPH3Z = 0.12D0
-
- V = 174.1D0
- PI = PARU(1)
- TANBA = TANB
- TANBT = TANB
-
-C...MBOTTOM(MTOP) = 3. GEV
- XMB = PYMRUN(5,XMTOP**2)
- ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
- &LOG(XMTOP**2/XMZ**2))
-
-C...RMTOP= RUNNING TOP QUARK MASS
- RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
- XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
- T = LOG(XMS**2/XMTOP**2)
- SINB = TANB/((1D0 + TANB**2)**0.5D0)
- COSB = SINB/TANB
-C...IF(MA.LE.XMTOP) TANBA = TANBT
- IF(XMA.GT.XMTOP)
- &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
- &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
- &LOG(XMA**2/XMTOP**2))
-
- SINBT = TANBT/SQRT(1D0 + TANBT**2)
- COSBT = 1D0/SQRT(1D0 + TANBT**2)
-C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
- G1 = SQRT(ALP1*4D0*PI)
- G2 = SQRT(ALP2*4D0*PI)
- G3 = SQRT(ALP3*4D0*PI)
- HU = RMTOP/V/SINBT
- HD = XMB/V/COSBT
- HU2=HU*HU
- HD2=HD*HD
- HU4=HU2*HU2
- HD4=HD2*HD2
- AU2=AU**2
- AD2=AD**2
- XMS2=XMS**2
- XMS3=XMS**3
- XMS4=XMS2*XMS2
- XMU2=XMU*XMU
- PI2=PI*PI
-
- XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
- XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
- AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
- &+ 3D0*(AU + AD)**2/XMS2)/6D0
- XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
- &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
- &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
- &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
- &- 16D0*G3**2) *T/16D0/PI2)
- XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
- &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
- &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
- &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
- &- 16D0*G3**2) *T/16D0/PI2)
- XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
- &(HU2 + HD2)*T/16D0/PI2)
- &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
- &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
- &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
- &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
- &- 16D0*G3**2) *T/16D0/PI2)
- &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
- &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
- &- 16D0*G3**2) *T/16D0/PI2)
- XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
- &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
- &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
- &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
- &XMS4)*
- &(1+ (6D0*HU2 -2D0* HD2
- &- 16D0*G3**2) *T/16D0/PI2)
- &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
- &XMS4)*
- &(1+ (6D0*HD2 -2D0* HU2/2D0
- &- 16D0*G3**2) *T/16D0/PI2)
- XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
- &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
- &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
- &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
- XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
- &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
- &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
- &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
- XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
- &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
- &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
- &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
- HHH(1)=XLAM1
- HHH(2)=XLAM2
- HHH(3)=XLAM3
- HHH(4)=XLAM4
- HHH(5)=XLAM5
- HHH(6)=XLAM6
- HHH(7)=XLAM7
- TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
- &2D0* XLAM6*SINBT*COSBT
- &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
- &+ XLAM5*COSBT**2)
- DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
- &XLAM6*COSBT**2
- &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
- &2D0* XLAM6* COSBT*SINBT
- &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
- &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
- &((XLAM1* COSBT**2 +2D0*
- &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
- &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
- &*SINBT**2
- &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
- &+ XLAM4) + XLAM6*COSBT**2
- &+ XLAM7* SINBT**2))
-
- XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
- XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
- XHM = SQRT(XHM2)
- XMH = SQRT(XMH2)
- XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
- XMHCH = SQRT(XMHCH2)
-
- SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
- &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
- &XLAM6* COSBT*SINBT
- &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
- &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
- &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
- &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
-
- COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
- &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
- &XMA**2*SINBT*COSBT))/2D0**0.5D0/
- &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
- &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
- &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
- &XLAM6* COSBT*SINBT
- &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
- &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
- &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
-
- SA = -SINALP
- CA = -COSALP
-
- 100 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYPOLE
-C...This subroutine computes the CP-even higgs and CP-odd pole
-c...Higgs masses and mixing angles.
-
-C...Program based on the work by M. Carena, M. Quiros
-C...and C.E.M. Wagner, "Effective potential methods and
-C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
-
-C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
-C...AT,AB,MU
-C...where MCHI is the largest chargino mass, MA is the running
-C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
-C...expectaion values at the scale MTOP, MQ is the third generation
-C...left handed squark mass parameter, MUR is the third generation
-C...right handed stop mass parameter, MDR is the third generation
-C...right handed sbottom mass parameter, MTOP is the pole top quark
-C...mass; AT,AB are the soft supersymmetry breaking trilinear
-C...couplings of the stop and sbottoms, respectively, and MU is the
-C...supersymmetric mass parameter
-
-C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
-C...Higgses whose pole mass is computed. If IHIGGS=0 only running
-C...masses are given, what makes the running of the program
-c...much faster and it is quite generally a good approximation
-c...(for a theoretical discussion see ref. above). If IHIGGS=1,
-C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
-c...and if IHIGGS=3, then h,H,A polarizations are computed
-
-C...Output: MH and MHP which are the lightest CP-even Higgs running
-C...and pole masses, respectively; HM and HMP are the heaviest CP-even
-C...Higgs running and pole masses, repectively; SA and CA are the
-C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
-C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
-C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
-C...the value of TANB at the CP-odd Higgs mass scale
-
-C...This subroutine makes use of CERN library subroutine
-C...integration package, which makes the computation of the
-C...pole Higgs masses somewhat faster. We thank P. Janot for this
-C...improvement. Those who are not able to call the CERN
-C...libraries, please use the subroutine SUBHPOLE2.F, which
-C...although somewhat slower, gives identical results
-
- SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
- &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-
-C...Parameters.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...Local variables.
- DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
- &SSBOT2(2),B(2,2),COUPB(2,2),
- &HCOUPT(2,2),HCOUPB(2,2),
- &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
-
- DELTA(1,1) = 1D0
- DELTA(2,2) = 1D0
- DELTA(1,2) = 0D0
- DELTA(2,1) = 0D0
- V = 174.1D0
- XMZ=91.18D0
- PI=PARU(1)
- RXMT=PYMRUN(6,XMT**2)
- CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
- &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
-
- SINB = TANB/(TANB**2+1D0)**0.5D0
- COSB = 1D0/(TANB**2+1D0)**0.5D0
- COS2B = SINB**2 - COSB**2
- SINBPA = SINB*CA + COSB*SA
- COSBPA = COSB*CA - SINB*SA
- RMBOT = PYMRUN(5,XMT**2)
- XMQ2 = XMQ**2
- XMUR2 = XMUR**2
- IF(XMUR.LT.0D0) XMUR2=-XMUR2
- XMDR2 = XMDR**2
- XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
- XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
- IF(XMST11.LT.0D0) GOTO 500
- IF(XMST22.LT.0D0) GOTO 500
- XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
- XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
- IF(XMSB11.LT.0D0) GOTO 500
- IF(XMSB22.LT.0D0) GOTO 500
-C WMST11 = RXMT**2 + XMQ2
-C WMST22 = RXMT**2 + XMUR2
- XMST12 = RXMT*(AT - XMU/TANB)
- XMSB12 = RMBOT*(AB - XMU*TANB)
-
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C...STOP EIGENVALUES CALCULATION
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-
- STOP12 = 0.5D0*(XMST11+XMST22) +
- &0.5D0*((XMST11+XMST22)**2 -
- &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
- STOP22 = 0.5D0*(XMST11+XMST22) -
- &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
- &XMST12**2))**0.5D0
-
- IF(STOP22.LT.0D0) GOTO 500
- SSTOP2(1) = STOP12
- SSTOP2(2) = STOP22
- STOP1 = STOP12**0.5D0
- STOP2 = STOP22**0.5D0
-C STOP1W = STOP1
-C STOP2W = STOP2
-
- IF(XMST12.EQ.0D0) XST11 = 1D0
- IF(XMST12.EQ.0D0) XST12 = 0D0
- IF(XMST12.EQ.0D0) XST21 = 0D0
- IF(XMST12.EQ.0D0) XST22 = 1D0
-
- IF(XMST12.EQ.0D0) GOTO 110
-
- 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
- XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
- XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
- XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
-
- 110 T(1,1) = XST11
- T(2,2) = XST22
- T(1,2) = XST12
- T(2,1) = XST21
-
- SBOT12 = 0.5D0*(XMSB11+XMSB22) +
- &0.5D0*((XMSB11+XMSB22)**2 -
- &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
- SBOT22 = 0.5D0*(XMSB11+XMSB22) -
- &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
- &XMSB12**2))**0.5D0
- IF(SBOT22.LT.0D0) GOTO 500
- SBOT1 = SBOT12**0.5D0
- SBOT2 = SBOT22**0.5D0
-
- SSBOT2(1) = SBOT12
- SSBOT2(2) = SBOT22
-
- IF(XMSB12.EQ.0D0) XSB11 = 1D0
- IF(XMSB12.EQ.0D0) XSB12 = 0D0
- IF(XMSB12.EQ.0D0) XSB21 = 0D0
- IF(XMSB12.EQ.0D0) XSB22 = 1D0
-
- IF(XMSB12.EQ.0D0) GOTO 130
-
- 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
- XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
- XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
- XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
-
- 130 B(1,1) = XSB11
- B(2,2) = XSB22
- B(1,2) = XSB12
- B(2,1) = XSB21
-
-
- SINT = 0.2320D0
- SQR = DSQRT(2D0)
- VP = 174.1D0*SQR
-
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C...STARTING OF LIGHT HIGGS
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-
- IF(IHIGGS.EQ.0) GOTO 490
-
- DO 150 I = 1,2
- DO 140 J = 1,2
- COUPT(I,J) =
- & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
- & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
- & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
- & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
- & T(1,J)*T(2,I))
- 140 CONTINUE
- 150 CONTINUE
-
-
- DO 170 I = 1,2
- DO 160 J = 1,2
- COUPB(I,J) =
- & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
- & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
- & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
- & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
- & B(1,J)*B(2,I))
- 160 CONTINUE
- 170 CONTINUE
-
- PRUN = XMH
- EPS = 1D-4*PRUN
- ITER = 0
- 180 ITER = ITER + 1
- DO 230 I3 = 1,3
-
- PR(I3)=PRUN+(I3-2)*EPS/2
- P2=PR(I3)**2
- POLT = 0D0
- DO 200 I = 1,2
- DO 190 J = 1,2
- POLT = POLT + COUPT(I,J)**2*3D0*
- & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
- 190 CONTINUE
- 200 CONTINUE
-
- POLB = 0D0
- DO 220 I = 1,2
- DO 210 J = 1,2
- POLB = POLB + COUPB(I,J)**2*3D0*
- & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
- 210 CONTINUE
- 220 CONTINUE
-C RXMT2 = RXMT**2
- XMT2=XMT**2
-
- POLTT =
- & 3D0*RXMT**2/8D0/PI**2/ V **2*
- & CA**2/SINB**2 *
- & (-2D0*XMT**2+0.5D0*P2)*
- & PYFINT(P2,XMT2,XMT2)
-
- POL = POLT + POLB + POLTT
- POLAR(I3) = P2 - XMH**2 - POL
- 230 CONTINUE
- DERIV = (POLAR(3)-POLAR(1))/EPS
- DRUN = - POLAR(2)/DERIV
- PRUN = PRUN + DRUN
- P2 = PRUN**2
- IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
- GOTO 180
- 240 CONTINUE
-
- XMHP = DSQRT(P2)
-
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C...END OF LIGHT HIGGS
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-
- 250 IF(IHIGGS.EQ.1) GOTO 490
-
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C... STARTING OF HEAVY HIGGS
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-
- DO 270 I = 1,2
- DO 260 J = 1,2
- HCOUPT(I,J) =
- & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
- & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
- & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
- & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
- & T(1,J)*T(2,I))
- 260 CONTINUE
- 270 CONTINUE
-
- DO 290 I = 1,2
- DO 280 J = 1,2
- HCOUPB(I,J) =
- & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
- & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
- & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
- & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
- & B(1,J)*B(2,I))
- HCOUPB(I,J)=0D0
- 280 CONTINUE
- 290 CONTINUE
-
- PRUN = HM
- EPS = 1D-4*PRUN
- ITER = 0
- 300 ITER = ITER + 1
- DO 350 I3 = 1,3
- PR(I3)=PRUN+(I3-2)*EPS/2
- HP2=PR(I3)**2
-
- HPOLT = 0D0
- DO 320 I = 1,2
- DO 310 J = 1,2
- HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
- & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
- 310 CONTINUE
- 320 CONTINUE
-
- HPOLB = 0D0
- DO 340 I = 1,2
- DO 330 J = 1,2
- HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
- & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
- 330 CONTINUE
- 340 CONTINUE
-
-C RXMT2 = RXMT**2
- XMT2 = XMT**2
-
- HPOLTT =
- & 3D0*RXMT**2/8D0/PI**2/ V **2*
- & SA**2/SINB**2 *
- & (-2D0*XMT**2+0.5D0*HP2)*
- & PYFINT(HP2,XMT2,XMT2)
-
- HPOL = HPOLT + HPOLB + HPOLTT
- POLAR(I3) =HP2-HM**2-HPOL
- 350 CONTINUE
- DERIV = (POLAR(3)-POLAR(1))/EPS
- DRUN = - POLAR(2)/DERIV
- PRUN = PRUN + DRUN
- HP2 = PRUN**2
- IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
- GOTO 300
- 360 CONTINUE
-
-
- 370 CONTINUE
- HMP = HP2**0.5D0
-
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C... END OF HEAVY HIGGS
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-
- IF(IHIGGS.EQ.2) GOTO 490
-
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C...BEGINNING OF PSEUDOSCALAR HIGGS
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-
- DO 390 I = 1,2
- DO 380 J = 1,2
- ACOUPT(I,J) =
- & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
- & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
- 380 CONTINUE
- 390 CONTINUE
- DO 410 I = 1,2
- DO 400 J = 1,2
- ACOUPB(I,J) =
- & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
- & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
- 400 CONTINUE
- 410 CONTINUE
-
- PRUN = XMA
- EPS = 1D-4*PRUN
- ITER = 0
- 420 ITER = ITER + 1
- DO 470 I3 = 1,3
- PR(I3)=PRUN+(I3-2)*EPS/2
- AP2=PR(I3)**2
- APOLT = 0D0
- DO 440 I = 1,2
- DO 430 J = 1,2
- APOLT = APOLT + ACOUPT(I,J)**2*3D0*
- & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
- 430 CONTINUE
- 440 CONTINUE
- APOLB = 0D0
- DO 460 I = 1,2
- DO 450 J = 1,2
- APOLB = APOLB + ACOUPB(I,J)**2*3D0*
- & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
- 450 CONTINUE
- 460 CONTINUE
-C RXMT2 = RXMT**2
- XMT2=XMT**2
- APOLTT =
- & 3D0*RXMT**2/8D0/PI**2/ V **2*
- & COSB**2/SINB**2 *
- & (-0.5D0*AP2)*
- & PYFINT(AP2,XMT2,XMT2)
- APOL = APOLT + APOLB + APOLTT
- POLAR(I3) = AP2 - XMA**2 -APOL
- 470 CONTINUE
- DERIV = (POLAR(3)-POLAR(1))/EPS
- DRUN = - POLAR(2)/DERIV
- PRUN = PRUN + DRUN
- AP2 = PRUN**2
- IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
- GOTO 420
- 480 CONTINUE
-
- AMP = DSQRT(AP2)
-
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C...END OF PSEUDOSCALAR HIGGS
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-
- IF(IHIGGS.EQ.3) GOTO 490
-
- 490 CONTINUE
- RETURN
- 500 CONTINUE
- WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
- WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
- WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
- WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
- CALL PYSTOP(107)
- END
-
-C*********************************************************************
-
-C...PYRGHM
-C...Auxiliary to PYPOLE.
-
- SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
- * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
- IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
- DIMENSION VH(2,2),M2(2,2),M2P(2,2)
-C...Parameters.
- INTEGER MSTU,MSTJ
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-
- MZ = 91.18D0
- PI = PARU(1)
- V = 174.1D0
- ALPHA1 = 0.0101D0
- ALPHA2 = 0.0337D0
- ALPHA3Z = 0.12D0
- TANBA = TANB
- TANBT = TANB
-C MBOTTOM(MTOP) = 3. GEV
- MB = PYMRUN(5,MTOP**2)
- ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
- *LOG(MTOP**2/MZ**2))
-C RMTOP= RUNNING TOP QUARK MASS
- RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
- TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
- TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
- TD = LOG((MD**2 + MTOP**2)/MTOP**2)
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C
-C NEW DEFINITION, TGLU.
-C
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
- TGLU = LOG(MGLU**2/MTOP**2)
- SINB = TANB/DSQRT(1D0 + TANB**2)
- COSB = SINB/TANB
- IF(MA.GT.MTOP)
- *TANBA = TANB*(1D0-3D0/32D0/PI**2*
- *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
- *LOG(MA**2/MTOP**2))
- IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
- SINB = TANBT/SQRT(1D0 + TANBT**2)
- COSB = 1D0/DSQRT(1D0 + TANBT**2)
- G1 = SQRT(ALPHA1*4D0*PI)
- G2 = SQRT(ALPHA2*4D0*PI)
- G3 = SQRT(ALPHA3*4D0*PI)
- HU = RMTOP/V/SINB
- HD = MB/V/COSB
- CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
- *SBOT1,SBOT2,DELTAMT,DELTAMB)
- IF(MQ.GT.MUR) TP = TQ - TU
- IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
- IF(MQ.GT.MUR) TDP = TU
- IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
- IF(MQ.GT.MD) TPD = TQ - TD
- IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
- IF(MQ.GT.MD) TDPD = TD
- IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
-
- IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
- IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
- * HD**2*(G1**2/3D0+G2**2)*TPD
-
- IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
- IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
- * HU**2*(-G1**2/3D0+G2**2)*TP
-
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C
-C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
-C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
-C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
-C TWO STOPS.
-C
-C
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-
- DLAMBDAP2 = 0D0
- IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
- IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
- DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
- ENDIF
-
- IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
- DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
- ENDIF
-
- IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
- DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
- ENDIF
-
- IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
- DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
- ENDIF
-
- IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
- DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
- ENDIF
-
- IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
- DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
- ENDIF
- ENDIF
- DLAMBDA3 = 0D0
- DLAMBDA4 = 0D0
- IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
- IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
- *(G2**2-G1**2/3D0)*TPD
- IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
- *1D0/16D0/PI**2*G1**2*HU**2*TP
- IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
- * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
- IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
- IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
- *HD**2*TPD
- LAMBDA1 = ((G1**2 + G2**2)/4D0)*
- * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
- *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
- *+ (3D0*HD**2/2D0 + HU**2/2D0
- *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
- *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
- *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
- LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
- *(TP + TDP)/8D0/PI**2)
- *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
- *+ (3D0*HU**2/2D0 + HD**2/2D0
- *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
- *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
- *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
- LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
- *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
- *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
- LAMBDA4 = (- G2**2/2D0)*(1D0
- *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
- *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
-
- LAMBDA5 = 0D0
- LAMBDA6 = 0D0
- LAMBDA7 = 0D0
-
- M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
- *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
-
- M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
- *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
- M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
- *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
-
- M2(2,1) = M2(1,2)
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-
- MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
-
- IF(MCHI.GT.MSSUSY) GOTO 100
- IF(MCHI.LT.MTOP) MCHI=MTOP
-
- TCHAR=LOG(MSSUSY**2/MCHI**2)
-
- DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
- DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
- *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
-
- DELTAM112=2D0*DELTAL12*V**2*COSB**2
- DELTAM222=2D0*DELTAL12*V**2*SINB**2
- DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
-
- M2(1,1)=M2(1,1)+DELTAM112
- M2(2,2)=M2(2,2)+DELTAM222
- M2(1,2)=M2(1,2)+DELTAM122
- M2(2,1)=M2(2,1)+DELTAM122
-
- 100 CONTINUE
-
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-CCC END OF CHARGINOS/NEUTRALINOS
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-
- DO 120 I = 1,2
- DO 110 J = 1,2
- M2P(I,J) = M2(I,J) + VH(I,J)
- 110 CONTINUE
- 120 CONTINUE
- TRM2P = M2P(1,1) + M2P(2,2)
- DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
- MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
- HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
- HMP = DSQRT(HM2P)
- MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
- MCH=DSQRT(MCH2)
- IF(MH2P.LT.0.) GOTO 130
- MHP = SQRT(MH2P)
- SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
- COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
- IF(COS2ALPHA.GE.0.) THEN
- ALPHA = ASIN(SIN2ALPHA)/2D0
- ELSE
- ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
- ENDIF
- SA = SIN(ALPHA)
- CA = COS(ALPHA)
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C
-C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
-C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
-C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
-C
-C
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
- SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
- CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
- 130 CONTINUE
- RETURN
- END
-
-C*********************************************************************
-
-C...PYGFXX
-C...Auxiliary to PYRGHM.
-
- SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
- * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
- IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
- DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
-C...Commonblocks.
- INTEGER MSTU,MSTJ,KCHG
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYDAT1/,/PYDAT2/
-
- G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
-
- T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
- * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
-
- IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
- MQ2 = MQ**2
- MUR2 = MUR**2
- MD2 = MD**2
- TANBA = TANB
- SINBA = TANBA/DSQRT(TANBA**2+1D0)
- COSBA = SINBA/TANBA
-
- SINB = TANB/DSQRT(TANB**2+1D0)
- COSB = SINB/TANB
-
- PI = PARU(1)
- MZ = PMAS(23,1)
- MW = PMAS(24,1)
- SW = 1D0-MW**2/MZ**2
- V = 174.1D0
-
- ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
- G2 = DSQRT(0.0336D0*4D0*PI)
- G1 = DSQRT(0.0101D0*4D0*PI)
-
- IF(MQ.GT.MUR) MST = MQ
- IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
-
- MSUSYT = DSQRT(MST**2 + MTOP**2)
-
- IF(MQ.GT.MD) MSB = MQ
- IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
-
- MB = PYMRUN(5,MSB**2)
- MSUSYB = DSQRT(MSB**2 + MB**2)
- TT = LOG(MSUSYT**2/MTOP**2)
- TB = LOG(MSUSYB**2/MTOP**2)
-
- RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
- HT = RMTOP/(V*SINB)
- HTST = RMTOP/V
- HB = MB/V/COSB
- G32 = ALPHA3*4D0*PI
- BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
- BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
- AL2 = 3D0/8D0/PI**2*HT**2
-C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
-C ALST = 3./8./PI**2*HTST**2
- AL1 = 3D0/8D0/PI**2*HB**2
-
- AL(1,1) = AL1
- AL(1,2) = (AL2+AL1)/2D0
- AL(2,1) = (AL2+AL1)/2D0
- AL(2,2) = AL2
-
- IF(MA.GT.MTOP) THEN
- VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
- * LOG(MTOP**2/MA**2))
- H1I = VI* COSBA
- H2I = VI*SINBA
- H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
- H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
- H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
- H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
- ELSE
- VI = V
- H1I = VI*COSB
- H2I = VI*SINB
- H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
- H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
- H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
- H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
- ENDIF
-
- TANBST = H2T/H1T
- SINBT = TANBST/DSQRT(1D0+TANBST**2)
-
- TANBSB = H2B/H1B
- SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
- COSBB = SINBB/TANBSB
-
- DELTAMT = 0D0
- DELTAMB = 0D0
-
- MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
- MTOP2 = DSQRT(MTOP4)
- MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
- * /(1D0+DELTAMB)**4
- MBOT2 = DSQRT(MBOT4)
-
- STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
- * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
- * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
- * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
- STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
- * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
- * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
- * MQ2 - MUR2)**2*0.25D0
- * + MTOP2*(AT-XMU/TANBST)**2)
- IF(STOP22.LT.0.) GOTO 120
- SBOT12 = (MQ2 + MD2)*.5D0
- * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
- * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
- * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
- SBOT22 = (MQ2 + MD2)*.5D0
- * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
- * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
- * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
- IF(SBOT22.LT.0.) SBOT22 = 10000D0
-
- STOP1 = DSQRT(STOP12)
- STOP2 = DSQRT(STOP22)
- SBOT1 = DSQRT(SBOT12)
- SBOT2 = DSQRT(SBOT22)
-
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C
-C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
-C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
-C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
-C INDUCED CORRECTIONS.
-C
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-
- X=SBOT1
- Y=SBOT2
- Z=XMGL
- IF(X.EQ.Y) X = X - 0.00001D0
- IF(X.EQ.Z) X = X - 0.00002D0
- IF(Y.EQ.Z) Y = Y - 0.00003D0
-
- T1=T(X,Y,Z)
- X=STOP1
- Y=STOP2
- Z=XMU
- IF(X.EQ.Y) X = X - 0.00001D0
- IF(X.EQ.Z) X = X - 0.00002D0
- IF(Y.EQ.Z) Y = Y - 0.00003D0
- T2=T(X,Y,Z)
- DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
- * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
- X=STOP1
- Y=STOP2
- Z=XMGL
- IF(X.EQ.Y) X = X - 0.00001D0
- IF(X.EQ.Z) X = X - 0.00002D0
- IF(Y.EQ.Z) Y = Y - 0.00003D0
- T3=T(X,Y,Z)
- DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
-
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-C
-C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
-C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
-C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
-C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
-C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
-C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
-C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
-C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
-C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
-C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
-C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
-C
-C
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-
- MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
- MTOP2 = DSQRT(MTOP4)
- MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
- * /(1D0+DELTAMB)**4
- MBOT2 = DSQRT(MBOT4)
-
- STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
- * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
- * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
- * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
- STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
- * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
- * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
- * MQ2 - MUR2)**2*0.25D0
- * + MTOP2*(AT-XMU/TANBST)**2)
-
- IF(STOP22.LT.0.) GOTO 120
- SBOT12 = (MQ2 + MD2)*.5D0
- * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
- * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
- * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
- SBOT22 = (MQ2 + MD2)*.5D0
- * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
- * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
- * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
- IF(SBOT22.LT.0.) GOTO 120
-
-
- STOP1 = DSQRT(STOP12)
- STOP2 = DSQRT(STOP22)
- SBOT1 = DSQRT(SBOT12)
- SBOT2 = DSQRT(SBOT22)
-
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-CCC D-TERMS
-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
- STW=SW
-
- F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
- * LOG(STOP1/STOP2)
- * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
- * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
-
- F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
- * LOG(SBOT1/SBOT2)
- * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
- * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
-
- F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
- * (-.5D0*LOG(STOP12/STOP22)
- * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
- * G(STOP12,STOP22))
-
- F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
- * (.5D0*LOG(SBOT12/SBOT22)
- * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
- * G(SBOT12,SBOT22))
-
- VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
- * (MQ2+MBOT2)/(MD2+MBOT2))
- * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
- * LOG(SBOT1**2/SBOT2**2)) +
- * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
- * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
-
- VH3T(1,1) =
- * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
- * -STOP2**2))**2*G(STOP12,STOP22)
-
- VH3B(1,1)=VH3B(1,1)+
- * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
-
- VH3T(1,1) = VH3T(1,1) +
- * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
-
- VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
- * (MQ2+MTOP2)/(MUR2+MTOP2))
- * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
- * LOG(STOP1**2/STOP2**2)) +
- * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
- * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
-
- VH3B(2,2) =
- * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
- * -SBOT2**2))**2*G(SBOT12,SBOT22)
-
- VH3T(2,2)=VH3T(2,2)+
- * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
- VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
- VH3T(1,2) = -
- * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
- * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
- * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
-
- VH3B(1,2) =
- * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
- * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
- * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
-
-
- VH3T(1,2)=VH3T(1,2) +
- *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
-
- VH3B(1,2)=VH3B(1,2) +
- *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
-
- VH3T(2,1) = VH3T(1,2)
- VH3B(2,1) = VH3B(1,2)
-
-C TQ = LOG((MQ2 + MTOP2)/MTOP2)
-C TU = LOG((MUR2+MTOP2)/MTOP2)
-C TQD = LOG((MQ2 + MB**2)/MB**2)
-C TD = LOG((MD2+MB**2)/MB**2)
-
- DO 110 I = 1,2
- DO 100 J = 1,2
- VH(I,J) =
- * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
- * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
- * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
- * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
- 100 CONTINUE
- 110 CONTINUE
-
- GOTO 150
- 120 DO 140 I =1,2
- DO 130 J = 1,2
- VH(I,J) = -1D15
- 130 CONTINUE
- 140 CONTINUE
-
-
- 150 RETURN
- END
-
-
-
-
-
-C*********************************************************************
-
-C...PYFINT
-C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
-
- FUNCTION PYFINT(A,B,C)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblock.
- COMMON/PYINTS/XXM(20)
- SAVE/PYINTS/
-
-C...Local variables.
- EXTERNAL PYFISB
- DOUBLE PRECISION PYFISB
-
- XXM(1)=A
- XXM(2)=B
- XXM(3)=C
- XLO=0D0
- XHI=1D0
- PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYFISB
-C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
-
- FUNCTION PYFISB(X)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblock.
- COMMON/PYINTS/XXM(20)
- SAVE/PYINTS/
-
- PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
- &(X*(XXM(2)-XXM(3))+XXM(3)))
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSFDC
-C...Calculates decays of sfermions.
-
- SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
-
-C...Local variables.
- COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
- COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
- INTEGER KFIN,KCIN
- DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
- DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
- DOUBLE PRECISION PYLAMF,XL
- DOUBLE PRECISION TANW,XW,AEM,C1,AS
- DOUBLE PRECISION AL,AR,BL,BR
- DOUBLE PRECISION CH1,CH2,CH3,CH4
- DOUBLE PRECISION XMBOT,XMTOP
- DOUBLE PRECISION XLAM(0:400)
- INTEGER IDLAM(400,3)
- INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
- DOUBLE PRECISION SR2
- DOUBLE PRECISION CBETA,SBETA
- DOUBLE PRECISION CW
- DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
- DOUBLE PRECISION COSA,SINA,TANB
- DOUBLE PRECISION PYALEM,PI,PYALPS,EI
- DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
- INTEGER IG,KF1,KF2
- INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
- DATA IGG/23,25,35,36/
- DATA PI/3.141592654D0/
- DATA SR2/1.4142136D0/
- DATA KFNCHI/1000022,1000023,1000025,1000035/
- DATA KFCCHI/1000024,1000037/
-
-C...COUNT THE NUMBER OF DECAY MODES
- LKNT=0
-
-C...NO NU_R DECAYS
- IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
- &KFIN.EQ.KSUSY2+16) RETURN
-
- XMW=PMAS(24,1)
- XMW2=XMW**2
- XMZ=PMAS(23,1)
- XW=PARU(102)
- TANW = SQRT(XW/(1D0-XW))
- CW=SQRT(1D0-XW)
-
- DO 110 I=1,4
- DO 100 J=1,4
- ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
- 100 CONTINUE
- 110 CONTINUE
- DO 130 I=1,2
- DO 120 J=1,2
- VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
- UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
- 120 CONTINUE
- 130 CONTINUE
-
-C...KCIN
- KCIN=PYCOMP(KFIN)
-C...ILR is 1 for left and 2 for right.
- ILR=KFIN/KSUSY1
-C...IFL is matching non-SUSY flavour.
- IFL=MOD(KFIN,KSUSY1)
-C...IDU is weak isospin, 1 for down and 2 for up.
- IDU=2-MOD(IFL,2)
-
- XMI=PMAS(KCIN,1)
- XMI2=XMI**2
- AEM=PYALEM(XMI2)
- AS =PYALPS(XMI2)
- C1=AEM/XW
- XMI3=XMI**3
- EI=KCHG(IFL,1)/3D0
-
- XMBOT=PYMRUN(5,XMI2)
- XMTOP=PYMRUN(6,XMI2)
-
- TANB=RMSS(5)
- BETA=ATAN(TANB)
- ALFA=RMSS(18)
- CBETA=COS(BETA)
- SBETA=TANB*CBETA
- SINA=SIN(ALFA)
- COSA=COS(ALFA)
- XMU=-RMSS(4)
- ATRIT=RMSS(16)
- ATRIB=RMSS(15)
- ATRIL=RMSS(17)
-
-C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
-
- IF(IMSS(11).EQ.1) THEN
- XMP=RMSS(29)
- IDG=39+KSUSY1
- XMGR=PMAS(PYCOMP(IDG),1)
- XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
- IF(IFL.EQ.5) THEN
- XMF=XMBOT
- ELSEIF(IFL.EQ.6) THEN
- XMF=XMTOP
- ELSE
- XMF=PMAS(IFL,1)
- ENDIF
- IF(XMI.GT.XMGR+XMF) THEN
- LKNT=LKNT+1
- IDLAM(LKNT,1)=IDG
- IDLAM(LKNT,2)=IFL
- IDLAM(LKNT,3)=0
- XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
- ENDIF
- ENDIF
-
-C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
-
-C...CHARGED DECAYS:
- DO 140 IX=1,2
-C...DI -> U CHI1-,CHI2-
- IF(IDU.EQ.1) THEN
- XMFP=PMAS(IFL+1,1)
- XMF =PMAS(IFL,1)
-C...UI -> D CHI1+,CHI2+
- ELSE
- XMFP=PMAS(IFL-1,1)
- XMF =PMAS(IFL,1)
- ENDIF
- XMJ=SMW(IX)
- AXMJ=ABS(XMJ)
- IF(XMI.GE.AXMJ+XMFP) THEN
- XMA2=XMJ**2
- XMB2=XMFP**2
- IF(IDU.EQ.2) THEN
- IF(IFL.EQ.6) THEN
- XMFP=XMBOT
- XMF =XMTOP
- ELSEIF(IFL.LT.6) THEN
- XMF=0D0
- XMFP=0D0
- ENDIF
- CBL=VMIXC(IX,1)
- CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
- CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
- CAR=0D0
- ELSE
- IF(IFL.EQ.5) THEN
- XMF =XMBOT
- XMFP=XMTOP
- ELSEIF(IFL.LT.5) THEN
- XMF=0D0
- XMFP=0D0
- ENDIF
- CBL=UMIXC(IX,1)
- CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
- CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
- CAR=0D0
- ENDIF
-
- CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
- CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
- CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
- CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
- CAL=CALP
- CBL=CBLP
- CAR=CARP
- CBR=CBRP
-
-C...F1 -> F` CHI
- IF(ILR.EQ.1) THEN
- CA=CAL
- CB=CBL
-C...F2 -> F` CHI
- ELSE
- CA=CAR
- CB=CBR
- ENDIF
- LKNT=LKNT+1
- XL=PYLAMF(XMI2,XMA2,XMB2)
-C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
- XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
- & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
- IDLAM(LKNT,3)=0
- IF(IDU.EQ.1) THEN
- IDLAM(LKNT,1)=-KFCCHI(IX)
- IDLAM(LKNT,2)=IFL+1
- ELSE
- IDLAM(LKNT,1)=KFCCHI(IX)
- IDLAM(LKNT,2)=IFL-1
- ENDIF
- ENDIF
- 140 CONTINUE
-
-C...NEUTRAL DECAYS
- DO 150 IX=1,4
-C...DI -> D CHI10
- XMF=PMAS(IFL,1)
- XMJ=SMZ(IX)
- AXMJ=ABS(XMJ)
- IF(XMI.GE.AXMJ+XMF) THEN
- XMA2=XMJ**2
- XMB2=XMF**2
- IF(IDU.EQ.1) THEN
- IF(IFL.EQ.5) THEN
- XMF=XMBOT
- ELSEIF(IFL.LT.5) THEN
- XMF=0D0
- ENDIF
- CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
- CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
- CAR=-2D0*EI*TANW*ZMIXC(IX,1)
- CBR=CAL
- ELSE
- IF(IFL.EQ.6) THEN
- XMF=XMTOP
- ELSEIF(IFL.LT.5) THEN
- XMF=0D0
- ENDIF
- CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
- CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
- CAR=-2D0*EI*TANW*ZMIXC(IX,1)
- CBR=CAL
- ENDIF
-
- CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
- CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
- CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
- CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
- CAL=CALP
- CBL=CBLP
- CAR=CARP
- CBR=CBRP
-
-C...F1 -> F CHI
- IF(ILR.EQ.1) THEN
- CA=CAL
- CB=CBL
-C...F2 -> F CHI
- ELSE
- CA=CAR
- CB=CBR
- ENDIF
- LKNT=LKNT+1
- XL=PYLAMF(XMI2,XMA2,XMB2)
-C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
- XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
- & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
- IDLAM(LKNT,1)=KFNCHI(IX)
- IDLAM(LKNT,2)=IFL
- IDLAM(LKNT,3)=0
- ENDIF
- 150 CONTINUE
-
-C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
-C...IG=23,25,35,36
- DO 160 II=1,4
- IG=IGG(II)
- IF(ILR.EQ.1) GOTO 160
- XMB=PMAS(IG,1)
- XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
- IF(XMI.LT.XMSF1+XMB) GOTO 160
- IF(IG.EQ.23) THEN
- BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
- BR=EI*XW/CW
- BLR=0D0
- ELSEIF(IG.EQ.25) THEN
- IF(IFL.EQ.5) THEN
- XMF=XMBOT
- ELSEIF(IFL.EQ.6) THEN
- XMF=XMTOP
- ELSEIF(IFL.LT.5) THEN
- XMF=0D0
- ELSE
- XMF=PMAS(IFL,1)
- ENDIF
- IF(IDU.EQ.2) THEN
- GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
- & XMF**2/XMW*COSA/SBETA
- GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
- & XMF**2/XMW*COSA/SBETA
- ELSE
- GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
- & XMF**2/XMW*(-SINA)/CBETA
- GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
- & XMF**2/XMW*(-SINA)/CBETA
- ENDIF
- IF(IFL.EQ.5) THEN
- AT=ATRIB
- ELSEIF(IFL.EQ.6) THEN
- AT=ATRIT
- ELSEIF(IFL.EQ.15) THEN
- AT=ATRIL
- ELSE
- AT=0D0
- ENDIF
-C.........need to complexify
- IF(IDU.EQ.2) THEN
- GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
- & AT*COSA)
- ELSE
- GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
- & AT*SINA)
- ENDIF
- BL=GHLL
- BR=GHRR
- BLR=-GHLR
- ELSEIF(IG.EQ.35) THEN
- IF(IFL.EQ.5) THEN
- XMF=XMBOT
- ELSEIF(IFL.EQ.6) THEN
- XMF=XMTOP
- ELSEIF(IFL.LT.5) THEN
- XMF=0D0
- ELSE
- XMF=PMAS(IFL,1)
- ENDIF
- IF(IDU.EQ.2) THEN
- GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
- & XMF**2/XMW*SINA/SBETA
- GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
- & XMF**2/XMW*SINA/SBETA
- ELSE
- GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
- & XMF**2/XMW*COSA/CBETA
- GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
- & XMF**2/XMW*COSA/CBETA
- ENDIF
- IF(IFL.EQ.5) THEN
- AT=ATRIB
- ELSEIF(IFL.EQ.6) THEN
- AT=ATRIT
- ELSEIF(IFL.EQ.15) THEN
- AT=ATRIL
- ELSE
- AT=0D0
- ENDIF
-C.........Need to complexify
- IF(IDU.EQ.2) THEN
- GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
- & AT*SINA)
- ELSE
- GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
- & AT*COSA)
- ENDIF
- BL=GHLL
- BR=GHRR
- BLR=GHLR
- ELSEIF(IG.EQ.36) THEN
- GHLL=0D0
- GHRR=0D0
- IF(IFL.EQ.5) THEN
- XMF=XMBOT
- ELSEIF(IFL.EQ.6) THEN
- XMF=XMTOP
- ELSEIF(IFL.LT.5) THEN
- XMF=0D0
- ELSE
- XMF=PMAS(IFL,1)
- ENDIF
- IF(IFL.EQ.5) THEN
- AT=ATRIB
- ELSEIF(IFL.EQ.6) THEN
- AT=ATRIT
- ELSEIF(IFL.EQ.15) THEN
- AT=ATRIL
- ELSE
- AT=0D0
- ENDIF
-C.........Need to complexify
- IF(IDU.EQ.2) THEN
- GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
- ELSE
- GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
- ENDIF
- BL=GHLL
- BR=GHRR
- BLR=GHLR
- ENDIF
- AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
- & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
- & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
- XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
- LKNT=LKNT+1
- IF(IG.EQ.23) THEN
- XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
- ELSE
- XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
- ENDIF
- IDLAM(LKNT,3)=0
- IDLAM(LKNT,1)=KFIN-KSUSY1
- IDLAM(LKNT,2)=IG
- 160 CONTINUE
-
-C...SF -> SF' + W
- XMB=PMAS(24,1)
- IF(MOD(IFL,2).EQ.0) THEN
- KF1=KSUSY1+IFL-1
- ELSE
- KF1=KSUSY1+IFL+1
- ENDIF
- KF2=KF1+KSUSY1
- XMSF1=PMAS(PYCOMP(KF1),1)
- XMSF2=PMAS(PYCOMP(KF2),1)
- IF(XMI.GT.XMB+XMSF1) THEN
- IF(MOD(IFL,2).EQ.0) THEN
- IF(ILR.EQ.1) THEN
- AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
- ELSE
- AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
- ENDIF
- ELSE
- IF(ILR.EQ.1) THEN
- AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
- ELSE
- AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
- ENDIF
- ENDIF
- XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
- LKNT=LKNT+1
- XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
- IDLAM(LKNT,3)=0
- IDLAM(LKNT,1)=KF1
- IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
- ENDIF
- IF(XMI.GT.XMB+XMSF2) THEN
- IF(MOD(IFL,2).EQ.0) THEN
- IF(ILR.EQ.1) THEN
- AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
- ELSE
- AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
- ENDIF
- ELSE
- IF(ILR.EQ.1) THEN
- AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
- ELSE
- AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
- ENDIF
- ENDIF
- XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
- LKNT=LKNT+1
- XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
- IDLAM(LKNT,3)=0
- IDLAM(LKNT,1)=KF2
- IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
- ENDIF
-
-C...SF -> SF' + HC
- XMB=PMAS(37,1)
- IF(MOD(IFL,2).EQ.0) THEN
- KF1=KSUSY1+IFL-1
- ELSE
- KF1=KSUSY1+IFL+1
- ENDIF
- KF2=KF1+KSUSY1
- XMSF1=PMAS(PYCOMP(KF1),1)
- XMSF2=PMAS(PYCOMP(KF2),1)
- IF(XMI.GT.XMB+XMSF1) THEN
- XMF=0D0
- XMFP=0D0
- AT=0D0
- AB=0D0
- IF(MOD(IFL,2).EQ.0) THEN
-C...T1-> B1 HC
- IF(ILR.EQ.1) THEN
- CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
- CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
- CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
- CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
-C...T2-> B1 HC
- ELSE
- CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
- CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
- CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
- CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
- ENDIF
- IF(IFL.EQ.6) THEN
- XMF=XMTOP
- XMFP=XMBOT
- AT=ATRIT
- AB=ATRIB
- ENDIF
- ELSE
-C...B1 -> T1 HC
- IF(ILR.EQ.1) THEN
- CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
- CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
- CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
- CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
-C...B2-> T1 HC
- ELSE
- CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
- CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
- CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
- CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
- ENDIF
- IF(IFL.EQ.5) THEN
- XMF=XMTOP
- XMFP=XMBOT
- AT=ATRIT
- AB=ATRIB
- ENDIF
- ENDIF
- XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
- LKNT=LKNT+1
-C.......Need to complexify
- AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
- & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
- & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
- XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
- IDLAM(LKNT,3)=0
- IDLAM(LKNT,1)=KF1
- IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
- ENDIF
- IF(XMI.GT.XMB+XMSF2) THEN
- XMF=0D0
- XMFP=0D0
- AT=0D0
- AB=0D0
- IF(MOD(IFL,2).EQ.0) THEN
-C...T1-> B2 HC
- IF(ILR.EQ.1) THEN
- CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
- CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
- CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
- CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
-C...T2-> B2 HC
- ELSE
- CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
- CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
- CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
- CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
- ENDIF
- IF(IFL.EQ.6) THEN
- XMF=XMTOP
- XMFP=XMBOT
- AT=ATRIT
- AB=ATRIB
- ENDIF
- ELSE
-C...B1 -> T2 HC
- IF(ILR.EQ.1) THEN
- CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
- CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
- CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
- CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
-C...B2-> T2 HC
- ELSE
- CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
- CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
- CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
- CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
- ENDIF
- IF(IFL.EQ.5) THEN
- XMF=XMTOP
- XMFP=XMBOT
- AT=ATRIT
- AB=ATRIB
- ENDIF
- ENDIF
- XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
- LKNT=LKNT+1
-C.......Need to complexify
- AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
- & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
- & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
- XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
- IDLAM(LKNT,3)=0
- IDLAM(LKNT,1)=KF2
- IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
- ENDIF
-
-C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
-
- IF(IFL.LE.6) THEN
- XMFP=0D0
- XMF=0D0
- IF(IFL.EQ.6) XMF=PMAS(6,1)
- IF(IFL.EQ.5) XMF=PMAS(5,1)
- XMJ=PMAS(PYCOMP(KSUSY1+21),1)
- AXMJ=ABS(XMJ)
- IF(XMI.GE.AXMJ+XMF) THEN
- AL=-SFMIX(IFL,3)
- BL=SFMIX(IFL,1)
- AR=-SFMIX(IFL,4)
- BR=SFMIX(IFL,2)
-C...F1 -> F CHI
- IF(ILR.EQ.1) THEN
- XCA=AL
- XCB=BL
-C...F2 -> F CHI
- ELSE
- XCA=AR
- XCB=BR
- ENDIF
- LKNT=LKNT+1
- XMA2=XMJ**2
- XMB2=XMF**2
- XL=PYLAMF(XMI2,XMA2,XMB2)
- XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
- & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
- IDLAM(LKNT,1)=KSUSY1+21
- IDLAM(LKNT,2)=IFL
- IDLAM(LKNT,3)=0
- ENDIF
- ENDIF
-
-C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
- IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
- &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
-C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
-C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
-C...M*M = C1**2 * G**2/(16PI**2)
-C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
- LKNT=LKNT+1
- XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
- XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
- IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
- IDLAM(LKNT,1)=KSUSY1+22
- IDLAM(LKNT,2)=4
- IDLAM(LKNT,3)=0
- ENDIF
-
-C...R-violating sfermion decays (SKANDS).
- CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
-
- IKNT=LKNT
- XLAM(0)=0D0
- DO 170 I=1,IKNT
- IF(XLAM(I).LT.0D0) XLAM(I)=0D0
- XLAM(0)=XLAM(0)+XLAM(I)
- 170 CONTINUE
- IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYGLUI
-C...Calculates gluino decay modes.
-
- SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
-CC &SFMIX(16,4),
-C COMMON/PYINTS/XXM(20)
- COMPLEX*16 CXC
- COMMON/PYINTC/XXC(10),CXC(8)
- SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
-
-C...Local variables
- COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
- DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
- DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
- DOUBLE PRECISION PYLAMF,XL
- DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
- DOUBLE PRECISION CA,CB,AL,AR,BL,BR
- DOUBLE PRECISION XLAM(0:400)
- INTEGER IDLAM(400,3)
- INTEGER LKNT,IX,ILR,I,IKNT,IFL
- DOUBLE PRECISION SR2
- DOUBLE PRECISION GAM
- DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
- EXTERNAL PYGAUS,PYXXZ6
- DOUBLE PRECISION PYGAUS,PYXXZ6
- DOUBLE PRECISION PREC
- INTEGER KFNCHI(4),KFCCHI(2)
- DATA PI/3.141592654D0/
- DATA SR2/1.4142136D0/
- DATA PREC/1D-2/
- DATA KFNCHI/1000022,1000023,1000025,1000035/
- DATA KFCCHI/1000024,1000037/
-
-C...COUNT THE NUMBER OF DECAY MODES
- LKNT=0
- IF(KFIN.NE.KSUSY1+21) RETURN
- KCIN=PYCOMP(KFIN)
-
- XW=PARU(102)
- TANW = SQRT(XW/(1D0-XW))
-
- XMI=PMAS(KCIN,1)
- AXMI=ABS(XMI)
- XMI2=XMI**2
- AEM=PYALEM(XMI2)
- AS =PYALPS(XMI2)
- C1=AEM/XW
- XMI3=AXMI**3
-
- XMI=SIGN(XMI,RMSS(3))
-
-C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
-
- IF(IMSS(11).EQ.1) THEN
- XMP=RMSS(29)
- IDG=39+KSUSY1
- XMGR=PMAS(PYCOMP(IDG),1)
- XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
- IF(AXMI.GT.XMGR) THEN
- LKNT=LKNT+1
- IDLAM(LKNT,1)=IDG
- IDLAM(LKNT,2)=21
- IDLAM(LKNT,3)=0
- XLAM(LKNT)=XFAC
- ENDIF
- ENDIF
-
-C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
-
- DO 110 IFL=1,6
- DO 100 ILR=1,2
- XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
- AXMJ=ABS(XMJ)
- XMF=PMAS(IFL,1)
- IF(AXMI.GE.AXMJ+XMF) THEN
-C...Minus sign difference from gluino-quark-squark feynman rules
- AL=SFMIX(IFL,1)
- BL=-SFMIX(IFL,3)
- AR=SFMIX(IFL,2)
- BR=-SFMIX(IFL,4)
-C...F1 -> F CHI
- IF(ILR.EQ.1) THEN
- CA=AL
- CB=BL
-C...F2 -> F CHI
- ELSE
- CA=AR
- CB=BR
- ENDIF
- LKNT=LKNT+1
- XMA2=XMJ**2
- XMB2=XMF**2
- XL=PYLAMF(XMI2,XMA2,XMB2)
- XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
- & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
- IDLAM(LKNT,1)=ILR*KSUSY1+IFL
- IDLAM(LKNT,2)=-IFL
- IDLAM(LKNT,3)=0
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3)=0
- ENDIF
- 100 CONTINUE
- 110 CONTINUE
-
-C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
-C...GLUINO -> NI Q QBAR
- DO 170 IX=1,4
- XMJ=SMZ(IX)
- AXMJ=ABS(XMJ)
- IF(AXMI.GE.AXMJ) THEN
- DO 120 I=1,4
- ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
- 120 CONTINUE
- OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
- ORPP=DCONJG(OLPP)
- XXC(1)=0D0
- XXC(2)=XMJ
- XXC(3)=0D0
- XXC(4)=XMI
- IA=1
- XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
- XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
- XXC(7)=XXC(5)
- XXC(8)=XXC(6)
- XXC(9)=1D6
- XXC(10)=0D0
- EI=KCHG(IA,1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
- GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
- CXC(1)=0D0
- CXC(2)=-GLIJ
- CXC(3)=0D0
- CXC(4)=DCONJG(GLIJ)
- CXC(5)=0D0
- CXC(6)=GRIJ
- CXC(7)=0D0
- CXC(8)=-DCONJG(GRIJ)
- S12MIN=0D0
- S12MAX=(AXMI-AXMJ)**2
- IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
- IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
- IDLAM(LKNT,1)=KFNCHI(IX)
- IDLAM(LKNT,2)=1
- IDLAM(LKNT,3)=-1
- ENDIF
- IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KFNCHI(IX)
- IDLAM(LKNT,2)=3
- IDLAM(LKNT,3)=-3
- ENDIF
- 130 CONTINUE
- IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
- PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
- IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
- GOTO 140
- ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
- PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
- ENDIF
- CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
- LKNT=LKNT+1
- XLAM(LKNT)=GAM
- IDLAM(LKNT,1)=KFNCHI(IX)
- IDLAM(LKNT,2)=5
- IDLAM(LKNT,3)=-5
- PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
- ENDIF
-C...U-TYPE QUARKS
- 140 CONTINUE
- IA=2
- XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
- XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
-C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
- XXC(7)=XXC(5)
- XXC(8)=XXC(6)
- EI=KCHG(IA,1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
- GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
- CXC(2)=-GLIJ
- CXC(4)=DCONJG(GLIJ)
- CXC(6)=GRIJ
- CXC(8)=-DCONJG(GRIJ)
- IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
- IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
- IDLAM(LKNT,1)=KFNCHI(IX)
- IDLAM(LKNT,2)=2
- IDLAM(LKNT,3)=-2
- ENDIF
- IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KFNCHI(IX)
- IDLAM(LKNT,2)=4
- IDLAM(LKNT,3)=-4
- ENDIF
- 150 CONTINUE
-C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
-C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
- XMF=PMAS(6,1)
- IF(AXMI.GE.AXMJ+2D0*XMF) THEN
- PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
- IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
- GOTO 160
- ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
- PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
- ENDIF
- CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
- LKNT=LKNT+1
- XLAM(LKNT)=GAM
- IDLAM(LKNT,1)=KFNCHI(IX)
- IDLAM(LKNT,2)=6
- IDLAM(LKNT,3)=-6
- PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
- ENDIF
- 160 CONTINUE
- ENDIF
- 170 CONTINUE
-
-C...GLUINO -> CI Q QBAR'
- DO 210 IX=1,2
- XMJ=SMW(IX)
- AXMJ=ABS(XMJ)
- IF(AXMI.GE.AXMJ) THEN
- DO 180 I=1,2
- VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
- UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
- 180 CONTINUE
- S12MIN=0D0
- S12MAX=(AXMI-AXMJ)**2
- XXC(1)=0D0
- XXC(2)=XMJ
- XXC(3)=0D0
- XXC(4)=XMI
- XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
- XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
- XXC(9)=1D6
- XXC(10)=0D0
- OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
- ORPP=DCONJG(OLPP)
- CXC(1)=DCMPLX(0D0,0D0)
- CXC(3)=DCMPLX(0D0,0D0)
- CXC(5)=DCMPLX(0D0,0D0)
- CXC(7)=DCMPLX(0D0,0D0)
- CXC(2)=UMIXC(IX,1)*OLPP/SR2
- CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
- CXC(6)=DCMPLX(0D0,0D0)
- CXC(8)=DCMPLX(0D0,0D0)
- IF(XXC(5).LT.AXMI) THEN
- XXC(5)=1D6
- ELSEIF(XXC(6).LT.AXMI) THEN
- XXC(6)=1D6
- ENDIF
- XXC(7)=XXC(6)
- XXC(8)=XXC(5)
- IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
- IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
- IDLAM(LKNT,1)=KFCCHI(IX)
- IDLAM(LKNT,2)=1
- IDLAM(LKNT,3)=-2
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
- ENDIF
- IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KFCCHI(IX)
- IDLAM(LKNT,2)=3
- IDLAM(LKNT,3)=-4
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
- ENDIF
- 190 CONTINUE
-
- XMF=PMAS(6,1)
- XMFP=PMAS(5,1)
- IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
- IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
- $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
- PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
- PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
- PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
- PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
- IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
- IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
- IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
- IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
- CALL PYTBBC(IX,100,XMI,GAM)
- LKNT=LKNT+1
- XLAM(LKNT)=GAM
- IDLAM(LKNT,1)=KFCCHI(IX)
- IDLAM(LKNT,2)=5
- IDLAM(LKNT,3)=-6
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
- PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
- PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
- PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
- PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
- ENDIF
- 200 CONTINUE
- ENDIF
- 210 CONTINUE
-
-C...R-parity violating (3-body) decays.
- CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
-
- IKNT=LKNT
- XLAM(0)=0D0
- DO 220 I=1,IKNT
- IF(XLAM(I).LT.0D0) XLAM(I)=0D0
- XLAM(0)=XLAM(0)+XLAM(I)
- 220 CONTINUE
- IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
-
- RETURN
- END
-
-
-C*********************************************************************
-
-C...PYTBBN
-C...Calculates the three-body decay of gluinos into
-C...neutralinos and third generation fermions.
-
- SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
-
-C...Local variables.
- EXTERNAL PYSIMP,PYLAMF
- DOUBLE PRECISION PYSIMP,PYLAMF
- INTEGER LIN,NN
- DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
- DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
- DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
- DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
- DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
- DOUBLE PRECISION XLN1,XLN2,B1,B2
- DOUBLE PRECISION E,XMGLU,GAM
- DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
- SAVE HRB,HLB,FLB,FRB
- DOUBLE PRECISION ALPHAW,ALPHAS
- DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
- SAVE HLT,HRT,FLT,FRT
- DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
- SAVE AMN,AN,ZN
- DOUBLE PRECISION AMBOT,SINC,COSC
- DOUBLE PRECISION AMTOP,SINA,COSA
- DOUBLE PRECISION SINW,COSW,TANW
- DOUBLE PRECISION ROT1(4,4)
- LOGICAL IFIRST
- SAVE IFIRST
- DATA IFIRST/.TRUE./
-
- TANB=RMSS(5)
- SINB=TANB/SQRT(1D0+TANB**2)
- COSB=SINB/TANB
- XW=PARU(102)
- SINW=SQRT(XW)
- COSW=SQRT(1D0-XW)
- TANW=SINW/COSW
- AMW=PMAS(24,1)
- COSC=SFMIX(5,1)
- SINC=SFMIX(5,3)
- COSA=SFMIX(6,1)
- SINA=SFMIX(6,3)
- AMBOT=PYMRUN(5,XMGLU**2)
- AMTOP=PYMRUN(6,XMGLU**2)
- W2=SQRT(2D0)
- FAKT1=AMBOT/W2/AMW/COSB
- FAKT2=AMTOP/W2/AMW/SINB
- IF(IFIRST) THEN
- DO 110 II=1,4
- AMN(II)=SMZ(II)
- DO 100 J=1,4
- ROT1(II,J)=0D0
- AN(II,J)=0D0
- 100 CONTINUE
- 110 CONTINUE
- ROT1(1,1)=COSW
- ROT1(1,2)=-SINW
- ROT1(2,1)=-ROT1(1,2)
- ROT1(2,2)=ROT1(1,1)
- ROT1(3,3)=COSB
- ROT1(3,4)=SINB
- ROT1(4,3)=-ROT1(3,4)
- ROT1(4,4)=ROT1(3,3)
- DO 140 II=1,4
- DO 130 J=1,4
- DO 120 JJ=1,4
- AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
- 120 CONTINUE
- 130 CONTINUE
- 140 CONTINUE
- DO 150 J=1,4
- ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
- ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
- ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
- & XW)*AN(J,2)/COSW
- HRT(J)=ZN(1)*COSA-ZN(3)*SINA
- HLT(J)=ZN(1)*COSA+ZN(2)*SINA
- FLT(J)=ZN(3)*COSA+ZN(1)*SINA
- FRT(J)=ZN(2)*COSA-ZN(1)*SINA
-C FLU(J)=ZN(3)
-C FRU(J)=ZN(2)
- ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
- ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
- ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
- HRB(J)=ZN(1)*COSC-ZN(3)*SINC
- HLB(J)=ZN(1)*COSC+ZN(2)*SINC
- FLB(J)=ZN(3)*COSC+ZN(1)*SINC
- FRB(J)=ZN(2)*COSC-ZN(1)*SINC
-C FLD(J)=ZN(3)
-C FRD(J)=ZN(2)
- 150 CONTINUE
-C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
-C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
-C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
-C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
- IFIRST=.FALSE.
- ENDIF
-
- IF(NINT(3D0*E).EQ.2) THEN
- HL=HLT(I)
- HR=HRT(I)
- FL=FLT(I)
- FR=FRT(I)
- COSD=SFMIX(6,1)
- SIND=SFMIX(6,3)
- XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
- XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
- XM=PMAS(6,1)
- ELSE
- HL=HLB(I)
- HR=HRB(I)
- FL=FLB(I)
- FR=FRB(I)
- COSD=SFMIX(5,1)
- SIND=SFMIX(5,3)
- XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
- XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
- XM=PMAS(5,1)
- ENDIF
- COSD2=COSD*COSD
- SIND2=SIND*SIND
- COS2D=COSD2-SIND2
- SIN2D=SIND*COSD*2D0
- HL2=HL*HL
- HR2=HR*HR
- FL2=FL*FL
- FR2=FR*FR
- FF=FL*FR
- HH=HL*HR
- HFL=HL*FL
- HFR=HR*FR
- HRFL=HR*FL
- HLFR=HL*FR
- XM2=XM*XM
- XMG=XMGLU
- XMG2=XMG*XMG
- ALPHAW=PYALEM(XMG2)
- ALPHAS=PYALPS(XMG2)
- XMR=AMN(I)
- XMR2=XMR*XMR
- XMQ4=XMG*XM2*XMR
- XM24=(XMG2+XM2)*(XM2+XMR2)
- SMIN=4D0*XM2
- SMAX=(XMG-ABS(XMR))**2
- XMQA=XMG2+2D0*XM2+XMR2
- DO 170 LIN=1,NN-1
- SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
- GRS=SBAR-XMQA
- W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
- W=DSQRT(W)
- XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
- XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
- B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
- B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
- G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
- & +2D0*(FF*SIND2-HH*COSD2))*W
- G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
- & +4D0*HFL*XM*XMR)*XLN1
- & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
- & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
- & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
- & +8D0*HFL*XMQ4*SIN2D)*B1
- G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
- & +4D0*HFR*XMR*XM)*XLN2
- & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
- & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
- & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
- & -8D0*HFR*XMQ4*SIN2D)*B2
- G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
- & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
- & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
- & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
- & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
- G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
- & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
- & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
- G(5)=(2D0*(HH*COSD2-FF*SIND2)
- & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
- & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
- & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
- & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
- & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
- & +COS2D*XM*(SBAR+XMG2-XMR2))
- & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
- & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
- G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
- & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
- & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
- & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
- & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
- SUMME(LIN)=0D0
- DO 160 J=0,6
- SUMME(LIN)=SUMME(LIN)+G(J)
- 160 CONTINUE
- 170 CONTINUE
- SUMME(0)=0D0
- SUMME(NN)=0D0
- GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
- &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYTBBC
-C...Calculates the three-body decay of gluinos into
-C...charginos and third generation fermions.
-
- SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
-
-C...Local variables.
- EXTERNAL PYSIMP,PYLAMF
- DOUBLE PRECISION PYSIMP,PYLAMF
- INTEGER I,NN,LIN
- DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
- DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
- DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
- DOUBLE PRECISION SUMME(0:100),A(4,8)
- DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
- DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
- DOUBLE PRECISION XMGLU,GAM
- DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
- &DDD(2),EEE(2),FFF(2)
- SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
- DOUBLE PRECISION ALPHAW,ALPHAS
- DOUBLE PRECISION AMC(2)
- SAVE AMC
- DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
- DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
- SAVE AMSB,AMST
- LOGICAL IFIRST
- SAVE IFIRST
- DATA IFIRST/.TRUE./
-
- TANB=RMSS(5)
- SINB=TANB/SQRT(1D0+TANB**2)
- COSB=SINB/TANB
- XW=PARU(102)
- AMW=PMAS(24,1)
- COSC=SFMIX(5,1)
- SINC=SFMIX(5,3)
- COSA=SFMIX(6,1)
- SINA=SFMIX(6,3)
- AMBOT=PYMRUN(5,XMGLU**2)
- AMTOP=PYMRUN(6,XMGLU**2)
- W2=SQRT(2D0)
- AMW=PMAS(24,1)
- FAKT1=AMBOT/W2/AMW/COSB
- FAKT2=AMTOP/W2/AMW/SINB
- IF(IFIRST) THEN
- AMC(1)=SMW(1)
- AMC(2)=SMW(2)
- DO 100 JJ=1,2
- CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
- EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
- DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
- FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
- XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
- AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
- XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
- BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
- 100 CONTINUE
- AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
- AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
- AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
- AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
- IFIRST=.FALSE.
- ENDIF
-
- ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
- ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
- VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
- VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
-
- COS2A=COSA**2-SINA**2
- SIN2A=SINA*COSA*2D0
- COS2C=COSC**2-SINC**2
- SIN2C=SINC*COSC*2D0
-
- XMG=XMGLU
- XMT=PMAS(6,1)
- XMB=PMAS(5,1)
- XMR=AMC(I)
- XMG2=XMG*XMG
- ALPHAW=PYALEM(XMG2)
- ALPHAS=PYALPS(XMG2)
- XMT2=XMT*XMT
- XMB2=XMB*XMB
- XMR2=XMR*XMR
- XMQ2=XMG2+XMT2+XMB2+XMR2
- XMQ4=XMG*XMT*XMB*XMR
- XMQ3=XMG2*XMR2+XMT2*XMB2
- XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
- XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
-
- XMST(1)=AMST(1)*AMST(1)
- XMST(2)=AMST(1)*AMST(1)
- XMST(3)=AMST(2)*AMST(2)
- XMST(4)=AMST(2)*AMST(2)
- XMSB(1)=AMSB(1)*AMSB(1)
- XMSB(2)=AMSB(2)*AMSB(2)
- XMSB(3)=AMSB(1)*AMSB(1)
- XMSB(4)=AMSB(2)*AMSB(2)
-
- A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
- A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
- A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
- A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
- A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
- A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
- A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
- A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
-
- A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
- A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
- A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
- A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
- A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
- A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
- A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
- A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
-
- A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
- A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
- A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
- A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
- A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
- A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
- A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
- A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
-
- A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
- A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
- A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
- A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
- A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
- A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
- A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
- A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
-
- SMAX=(XMG-ABS(XMR))**2
- SMIN=(XMB+XMT)**2+0.1D0
-
- DO 120 LIN=0,NN-1
- SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
- AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
- GRS=SBAR-XMQ2
- W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
- W=DSQRT(W)/2D0/SBAR
- ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
- ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
- ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
- ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
- SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
- & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
- & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
- & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
- & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
- & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
- & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
- SUMME(LIN)=SUMME(LIN)-ULR(2)*W
- & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
- & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
- & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
- & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
- & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
- & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
- & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
- SUMME(LIN)=SUMME(LIN)-VLR(1)*W
- & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
- & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
- & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
- & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
- & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
- & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
- & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
- SUMME(LIN)=SUMME(LIN)-VLR(2)*W
- & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
- & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
- & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
- & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
- & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
- & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
- & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
- SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
- & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
- & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
- & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
- SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
- & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
- & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
- & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
- DO 110 J=1,4
- SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
- & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
- & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
- & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
- & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
- & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
- & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
- & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
- & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
- & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
- & -A(J,6)*(XMG2+XMR2-SBAR)
- & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
- & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
- & /(GRS+XMSB(J)+XMST(J))
- 110 CONTINUE
- 120 CONTINUE
- SUMME(NN)=0D0
- GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
- &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYNJDC
-C...Calculates decay widths for the neutralinos (admixtures of
-C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
-
-C...Input: KCIN = KF code for particle
-C...Output: XLAM = widths
-C... IDLAM = KF codes for decay particles
-C... IKNT = number of decay channels defined
-C...AUTHOR: STEPHEN MRENNA
-C...Last change:
-C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
-C...when CHIGAMMA .NE. 0
-C...10 FEB 96: Calculate this decay for small tan(beta)
-
- SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
-c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
-c &SFMIX(16,4)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
-C COMMON/PYINTS/XXM(20)
- COMPLEX*16 CXC
- COMMON/PYINTC/XXC(10),CXC(8)
- SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
-
-C...Local variables.
- COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
- COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
- INTEGER KFIN
- DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
- &XMZ,XMZ2,AXMJ,AXMI
- DOUBLE PRECISION S12MIN,S12MAX
- DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
- DOUBLE PRECISION PYLAMF,XL
- DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
- DOUBLE PRECISION PYX2XH,PYX2XG
- DOUBLE PRECISION XLAM(0:400)
- INTEGER IDLAM(400,3)
- INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
- INTEGER ITH(3),KF1,KF2
- INTEGER ITHC
- DOUBLE PRECISION DH(3),EH(3)
- DOUBLE PRECISION SR2
- DOUBLE PRECISION CBETA,SBETA
- DOUBLE PRECISION GAMCON,XMT1,XMT2
- DOUBLE PRECISION PYALEM,PI,PYALPS
- DOUBLE PRECISION RAT1,RAT2
- DOUBLE PRECISION T3T,FCOL
- DOUBLE PRECISION ALFA,BETA,TANB
- DOUBLE PRECISION PYXXGA
- EXTERNAL PYGAUS,PYXXZ6
- DOUBLE PRECISION PYGAUS,PYXXZ6
- DOUBLE PRECISION PREC
- INTEGER KFNCHI(4),KFCCHI(2)
- DATA ITH/25,35,36/
- DATA ITHC/37/
- DATA PREC/1D-2/
- DATA PI/3.141592654D0/
- DATA SR2/1.4142136D0/
- DATA KFNCHI/1000022,1000023,1000025,1000035/
- DATA KFCCHI/1000024,1000037/
-
-C...COUNT THE NUMBER OF DECAY MODES
- LKNT=0
-
- XMW=PMAS(24,1)
- XMW2=XMW**2
- XMZ=PMAS(23,1)
- XMZ2=XMZ**2
- XW=1D0-XMW2/XMZ2
- XW1=1D0-XW
- TANW = SQRT(XW/XW1)
-
-C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
- IX=1
- IF(KFIN.EQ.KFNCHI(2)) IX=2
- IF(KFIN.EQ.KFNCHI(3)) IX=3
- IF(KFIN.EQ.KFNCHI(4)) IX=4
-
- XMI=SMZ(IX)
- XMI2=XMI**2
- AXMI=ABS(XMI)
- AEM=PYALEM(XMI2)
- AS =PYALPS(XMI2)
- C1=AEM/XW
- XMI3=ABS(XMI**3)
-
- TANB=RMSS(5)
- BETA=ATAN(TANB)
- ALFA=RMSS(18)
- CBETA=COS(BETA)
- SBETA=TANB*CBETA
- CALFA=COS(ALFA)
- SALFA=SIN(ALFA)
-
- DO 110 I=1,4
- DO 100 J=1,4
- ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
- 100 CONTINUE
- 110 CONTINUE
- DO 130 I=1,2
- DO 120 J=1,2
- VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
- UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
- 120 CONTINUE
- 130 CONTINUE
-
-C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
- IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
-
-C...FORCE CHI0_2 -> CHI0_1 + GAMMA
- IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
- XMJ=SMZ(1)
- AXMJ=ABS(XMJ)
- LKNT=LKNT+1
- GAMCON=AEM**3/8D0/PI/XMW2/XW
- XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
- XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
- XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
- IDLAM(LKNT,1)=KSUSY1+22
- IDLAM(LKNT,2)=22
- IDLAM(LKNT,3)=0
- WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
- GOTO 340
- ENDIF
-
-C...GRAVITINO DECAY MODES
-
- IF(IMSS(11).EQ.1) THEN
- XMP=RMSS(29)
- IDG=39+KSUSY1
- XMGR=PMAS(PYCOMP(IDG),1)
- SINW=SQRT(XW)
- COSW=SQRT(1D0-XW)
- XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
- IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
- LKNT=LKNT+1
- IDLAM(LKNT,1)=IDG
- IDLAM(LKNT,2)=22
- IDLAM(LKNT,3)=0
- XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
- ENDIF
- IF(AXMI.GT.XMGR+XMZ) THEN
- LKNT=LKNT+1
- IDLAM(LKNT,1)=IDG
- IDLAM(LKNT,2)=23
- IDLAM(LKNT,3)=0
- XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
- $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
- & (1D0-XMZ2/XMI2)**4
- ENDIF
- IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
- LKNT=LKNT+1
- IDLAM(LKNT,1)=IDG
- IDLAM(LKNT,2)=25
- IDLAM(LKNT,3)=0
- XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
- $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
- ENDIF
- IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
- LKNT=LKNT+1
- IDLAM(LKNT,1)=IDG
- IDLAM(LKNT,2)=35
- IDLAM(LKNT,3)=0
- XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
- $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
- ENDIF
- IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
- LKNT=LKNT+1
- IDLAM(LKNT,1)=IDG
- IDLAM(LKNT,2)=36
- IDLAM(LKNT,3)=0
- XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
- $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
- ENDIF
- IF(IX.EQ.1) GOTO 300
- ENDIF
-
- DO 220 IJ=1,IX-1
- XMJ=SMZ(IJ)
- AXMJ=ABS(XMJ)
- XMJ2=XMJ**2
-
-C...CHI0_I -> CHI0_J + GAMMA
- IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
- RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
- RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
- RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
- RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
- IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
- & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
- LKNT=LKNT+1
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=22
- IDLAM(LKNT,3)=0
- GAMCON=AEM**3/8D0/PI/XMW2/XW
- XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
- XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
- XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
- ENDIF
- ENDIF
-
-C...CHI0_I -> CHI0_J + Z0
- IF(AXMI.GE.AXMJ+XMZ) THEN
- LKNT=LKNT+1
- OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
- & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
- ORPP=-DCONJG(OLPP)
- GX2=ABS(OLPP)**2+ABS(ORPP)**2
- GLR=DBLE(OLPP*DCONJG(ORPP))
- XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=23
- IDLAM(LKNT,3)=0
- ELSEIF(AXMI.GE.AXMJ) THEN
- XXC(1)=0D0
- XXC(2)=XMJ
- XXC(3)=0D0
- XXC(4)=XMI
- XXC(9)=XMZ
- XXC(10)=PMAS(23,2)
- OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
- & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
- ORPP=DCONJG(OLPP)
-C...CHARGED LEPTONS
- FID=11
- XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
- XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
- EI=KCHG(FID,1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
- & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
- GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
- CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
- CXC(2)=-GLIJ
- CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
- CXC(4)=DCONJG(GLIJ)
- CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
- CXC(6)=GRIJ
- CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
- CXC(8)=-DCONJG(GRIJ)
- S12MIN=0D0
- S12MAX=(AXMI-AXMJ)**2
- IF( XXC(5).LT.AXMI ) THEN
- XXC(5)=1D6
- ENDIF
- IF(XXC(6).LT.AXMI ) THEN
- XXC(6)=1D6
- ENDIF
- XXC(7)=XXC(5)
- XXC(8)=XXC(6)
-
- IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=FID
- IDLAM(LKNT,3)=-FID
- IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=13
- IDLAM(LKNT,3)=-13
- ENDIF
- ENDIF
- 140 CONTINUE
- IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
- XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
- XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
- ELSE
- XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
- XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
- ENDIF
- IF( XXC(5).LT.AXMI ) THEN
- XXC(5)=1D6
- ENDIF
- IF(XXC(6).LT.AXMI ) THEN
- XXC(6)=1D6
- ENDIF
- XXC(7)=XXC(5)
- XXC(8)=XXC(6)
-
- IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=15
- IDLAM(LKNT,3)=-15
- ENDIF
-
-C...NEUTRINOS
- 150 CONTINUE
- FID=12
- XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
- XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
- EI=KCHG(FID,1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
- & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
- GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
- CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
- CXC(2)=-GLIJ
- CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
- CXC(4)=DCONJG(GLIJ)
- CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
- CXC(6)=GRIJ
- CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
- CXC(8)=-DCONJG(GRIJ)
- S12MIN=0D0
- S12MAX=(AXMI-AXMJ)**2
- IF( XXC(5).LT.AXMI ) THEN
- XXC(5)=1D6
- ENDIF
- IF( XXC(6).LT.AXMI ) THEN
- XXC(6)=1D6
- ENDIF
- XXC(7)=XXC(5)
- XXC(8)=XXC(6)
-
- LKNT=LKNT+1
- XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=12
- IDLAM(LKNT,3)=-12
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=14
- IDLAM(LKNT,3)=-14
- 160 CONTINUE
-
- IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
- & THEN
- XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
- IF( XXC(5).LT.AXMI ) THEN
- XXC(5)=1D6
- ENDIF
- XXC(7)=XXC(5)
- LKNT=LKNT+1
- XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
- ELSE
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- ENDIF
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=16
- IDLAM(LKNT,3)=-16
-C...D-TYPE QUARKS
- 170 CONTINUE
- FID=1
- XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
- XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
- EI=KCHG(FID,1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
- & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
- GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
- CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
- CXC(2)=-GLIJ
- CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
- CXC(4)=DCONJG(GLIJ)
- CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
- CXC(6)=GRIJ
- CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
- CXC(8)=-DCONJG(GRIJ)
- S12MIN=0D0
- S12MAX=(AXMI-AXMJ)**2
- IF( XXC(5).LT.AXMI ) THEN
- XXC(5)=1D6
- ENDIF
- IF( XXC(6).LT.AXMI ) THEN
- XXC(6)=1D6
- ENDIF
- XXC(7)=XXC(5)
- XXC(8)=XXC(6)
-
- IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=1
- IDLAM(LKNT,3)=-1
- IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=3
- IDLAM(LKNT,3)=-3
- ENDIF
- ENDIF
- 180 CONTINUE
- IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
- XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
- XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
- ELSE
- XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
- XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
- ENDIF
- IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
- IF(XXC(5).LT.AXMI) THEN
- XXC(5)=1D6
- ELSEIF(XXC(6).LT.AXMI) THEN
- XXC(6)=1D6
- ENDIF
- XXC(7)=XXC(5)
- XXC(8)=XXC(6)
- IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=5
- IDLAM(LKNT,3)=-5
- ENDIF
-
-C...U-TYPE QUARKS
- 190 CONTINUE
- FID=2
- XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
- XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
- EI=KCHG(FID,1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
- & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
- GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
- CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
- CXC(2)=-GLIJ
- CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
- CXC(4)=DCONJG(GLIJ)
- CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
- CXC(6)=GRIJ
- CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
- CXC(8)=-DCONJG(GRIJ)
-
- IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
- IF(XXC(5).LT.AXMI) THEN
- XXC(5)=1D6
- ELSEIF(XXC(6).LT.AXMI) THEN
- XXC(6)=1D6
- ENDIF
- XXC(7)=XXC(5)
- XXC(8)=XXC(6)
-
- IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=2
- IDLAM(LKNT,3)=-2
- IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=4
- IDLAM(LKNT,3)=-4
- ENDIF
- ENDIF
- 200 CONTINUE
- ENDIF
-
-C...CHI0_I -> CHI0_J + H0_K
- EH(1)=SIN(ALFA)
- EH(2)=COS(ALFA)
- EH(3)=-SIN(BETA)
- DH(1)=COS(ALFA)
- DH(2)=-SIN(ALFA)
- DH(3)=COS(BETA)
- QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
- & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
- & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
- & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
- RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
- & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
- & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
- & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
- DO 210 IH=1,3
- XMH=PMAS(ITH(IH),1)
- XMH2=XMH**2
- IF(AXMI.GE.AXMJ+XMH) THEN
- LKNT=LKNT+1
- XL=PYLAMF(XMI2,XMJ2,XMH2)
- F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
- F12K=F21K
-C...SIGN OF MASSES I,J
- XMK=XMJ
- IF(IH.EQ.3) XMK=-XMK
- GX2=ABS(F21K)**2+ABS(F12K)**2
- GLR=DBLE(F21K*DCONJG(F12K))
- XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=ITH(IH)
- IDLAM(LKNT,3)=0
- ENDIF
- 210 CONTINUE
- 220 CONTINUE
-
-C...CHI0_I -> CHI+_J + W-
- DO 260 IJ=1,2
- XMJ=SMW(IJ)
- AXMJ=ABS(XMJ)
- XMJ2=XMJ**2
- IF(AXMI.GE.AXMJ+XMW) THEN
- LKNT=LKNT+1
- CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
- & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
- CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
- & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
- GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
- GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
- XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
- IDLAM(LKNT,1)=KFCCHI(IJ)
- IDLAM(LKNT,2)=-24
- IDLAM(LKNT,3)=0
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=-KFCCHI(IJ)
- IDLAM(LKNT,2)=24
- IDLAM(LKNT,3)=0
- ELSEIF(AXMI.GE.AXMJ) THEN
- S12MIN=0D0
- S12MAX=(AXMI-AXMJ)**2
- RT2I = 1D0/SQRT(2D0)
- CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
- & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
- CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
- & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
- CXC(5)=DCMPLX(0D0,0D0)
- CXC(7)=DCMPLX(0D0,0D0)
- IA=11
- JA=12
- EI=KCHG(IA,1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- EJ=KCHG(JA,1)/3D0
- T3J=SIGN(1D0,EJ+1D-6)/2D0
- CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
- & TANW+ZMIXC(IX,2)*T3J)*RT2I
- CXC(4)=-DCONJG(UMIXC(IJ,1))*(
- & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
- CXC(6)=DCMPLX(0D0,0D0)
- CXC(8)=DCMPLX(0D0,0D0)
- XXC(1)=0D0
- XXC(2)=XMJ
- XXC(3)=0D0
- XXC(4)=XMI
- XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
- XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
- XXC(9)=PMAS(24,1)
- XXC(10)=PMAS(24,2)
- IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
- IF(XXC(5).LT.AXMI) THEN
- XXC(5)=1D6
- ELSEIF(XXC(6).LT.AXMI) THEN
- XXC(6)=1D6
- ENDIF
- XXC(7)=XXC(6)
- XXC(8)=XXC(5)
- IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
- IDLAM(LKNT,1)=KFCCHI(IJ)
- IDLAM(LKNT,2)=11
- IDLAM(LKNT,3)=-12
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
- IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KFCCHI(IJ)
- IDLAM(LKNT,2)=13
- IDLAM(LKNT,3)=-14
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
- ENDIF
- ENDIF
- 230 CONTINUE
- IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
- XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
- XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
- ELSE
- XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
- XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
- ENDIF
- IF(XXC(5).LT.AXMI) THEN
- XXC(5)=1D6
- ENDIF
- IF(XXC(6).LT.AXMI) THEN
- XXC(6)=1D6
- ENDIF
- XXC(7)=XXC(6)
- XXC(8)=XXC(5)
- IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KFCCHI(IJ)
- IDLAM(LKNT,2)=15
- IDLAM(LKNT,3)=-16
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
- ENDIF
-
-C...NOW, DO THE QUARKS
- 240 CONTINUE
- IA=1
- JA=2
- EI=KCHG(IA,1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- EJ=KCHG(JA,1)/3D0
- T3J=SIGN(1D0,EJ+1D-6)/2D0
- CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
- & TANW+ZMIXC(IX,2)*T3J)
- CXC(4)=-DCONJG(UMIXC(IJ,1))*(
- & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
- XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
- XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
- IF(XXC(5).LT.AXMI) THEN
- XXC(5)=1D6
- ENDIF
- IF(XXC(6).LT.AXMI) THEN
- XXC(6)=1D6
- ENDIF
- XXC(7)=XXC(6)
- XXC(8)=XXC(5)
- IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
- IDLAM(LKNT,1)=KFCCHI(IJ)
- IDLAM(LKNT,2)=1
- IDLAM(LKNT,3)=-2
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
- IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KFCCHI(IJ)
- IDLAM(LKNT,2)=3
- IDLAM(LKNT,3)=-4
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
- ENDIF
- ENDIF
- 250 CONTINUE
- ENDIF
- 260 CONTINUE
- 270 CONTINUE
-
-C...CHI0_I -> CHI+_I + H-
- DO 280 IJ=1,2
- XMJ=SMW(IJ)
- AXMJ=ABS(XMJ)
- XMJ2=XMJ**2
- XMHP=PMAS(ITHC,1)
- IF(AXMI.GE.AXMJ+XMHP) THEN
- LKNT=LKNT+1
- OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
- & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
- ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
- & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
- & UMIXC(IJ,2)/SR2)
- GX2=ABS(OLPP)**2+ABS(ORPP)**2
- GLR=DBLE(OLPP*DCONJG(ORPP))
- XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
- IDLAM(LKNT,1)=KFCCHI(IJ)
- IDLAM(LKNT,2)=-ITHC
- IDLAM(LKNT,3)=0
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
- ELSE
-
- ENDIF
- 280 CONTINUE
-
-C...2-BODY DECAYS TO FERMION SFERMION
- DO 290 J=1,16
- IF(J.GE.7.AND.J.LE.10) GOTO 290
- KF1=KSUSY1+J
- KF2=KSUSY2+J
- XMSF1=PMAS(PYCOMP(KF1),1)
- XMSF2=PMAS(PYCOMP(KF2),1)
- XMF=PMAS(J,1)
- IF(J.LE.6) THEN
- FCOL=3D0
- ELSE
- FCOL=1D0
- ENDIF
-
- EI=KCHG(J,1)/3D0
- T3T=SIGN(1D0,EI)
- IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
- IF(MOD(J,2).EQ.0) THEN
- CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
- CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
- CAR=-2D0*EI*TANW*ZMIXC(IX,1)
- CBR=CAL
- ELSE
- CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
- CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
- CAR=-2D0*EI*TANW*ZMIXC(IX,1)
- CBR=CAL
- ENDIF
-
-C...D~ D_L
- IF(AXMI.GE.XMF+XMSF1) THEN
- LKNT=LKNT+1
- XMA2=XMSF1**2
- XMB2=XMF**2
- XL=PYLAMF(XMI2,XMA2,XMB2)
- CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
- CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
- XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
- & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
- IDLAM(LKNT,1)=KF1
- IDLAM(LKNT,2)=-J
- IDLAM(LKNT,3)=0
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3)=0
- ENDIF
-
-C...D~ D_R
- IF(AXMI.GE.XMF+XMSF2) THEN
- LKNT=LKNT+1
- XMA2=XMSF2**2
- XMB2=XMF**2
- CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
- CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
- XL=PYLAMF(XMI2,XMA2,XMB2)
- XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
- & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
- IDLAM(LKNT,1)=KF2
- IDLAM(LKNT,2)=-J
- IDLAM(LKNT,3)=0
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3)=0
- ENDIF
- 290 CONTINUE
- 300 CONTINUE
-C...3-BODY DECAY TO Q Q~ GLUINO
- XMJ=PMAS(PYCOMP(KSUSY1+21),1)
- IF(AXMI.GE.XMJ) THEN
- RT2I = 1D0/SQRT(2D0)
- OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
- ORPP=DCONJG(OLPP)
- AXMJ=ABS(XMJ)
- XXC(1)=0D0
- XXC(2)=XMJ
- XXC(3)=0D0
- XXC(4)=XMI
- FID=1
- XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
- XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
- IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
- XXC(7)=XXC(5)
- XXC(8)=XXC(6)
- XXC(9)=1D6
- XXC(10)=0D0
- EI=KCHG(FID,1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
- GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
- CXC(1)=0D0
- CXC(2)=-GLIJ
- CXC(3)=0D0
- CXC(4)=DCONJG(GLIJ)
- CXC(5)=0D0
- CXC(6)=GRIJ
- CXC(7)=0D0
- CXC(8)=-DCONJG(GRIJ)
- S12MIN=0D0
- S12MAX=(AXMI-AXMJ)**2
-C...ALL QUARKS BUT T
- IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
- IDLAM(LKNT,1)=KSUSY1+21
- IDLAM(LKNT,2)=1
- IDLAM(LKNT,3)=-1
- IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KSUSY1+21
- IDLAM(LKNT,2)=3
- IDLAM(LKNT,3)=-3
- ENDIF
- ENDIF
- 310 CONTINUE
- IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
- XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
- XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
- ELSE
- XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
- XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
- ENDIF
- IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
- XXC(7)=XXC(5)
- XXC(8)=XXC(6)
- IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
- IDLAM(LKNT,1)=KSUSY1+21
- IDLAM(LKNT,2)=5
- IDLAM(LKNT,3)=-5
- ENDIF
-C...U-TYPE QUARKS
- 320 CONTINUE
- FID=2
- XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
- XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
- IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
- XXC(7)=XXC(5)
- XXC(8)=XXC(6)
- EI=KCHG(FID,1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
- GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
- CXC(2)=-GLIJ
- CXC(4)=DCONJG(GLIJ)
- CXC(6)=GRIJ
- CXC(8)=-DCONJG(GRIJ)
- IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
- IDLAM(LKNT,1)=KSUSY1+21
- IDLAM(LKNT,2)=2
- IDLAM(LKNT,3)=-2
- IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KSUSY1+21
- IDLAM(LKNT,2)=4
- IDLAM(LKNT,3)=-4
- ENDIF
- ENDIF
- 330 CONTINUE
- ENDIF
-
-C...R-violating decay modes (SKANDS).
- CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
-
- 340 IKNT=LKNT
- XLAM(0)=0D0
- DO 350 I=1,IKNT
- IF(XLAM(I).LT.0D0) XLAM(I)=0D0
- XLAM(0)=XLAM(0)+XLAM(I)
- 350 CONTINUE
- IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYCJDC
-C...Calculate decay widths for the charginos (admixtures of
-C...charged Wino and charged Higgsino.
-
-C...Input: KCIN = KF code for particle
-C...Output: XLAM = widths
-C... IDLAM = KF codes for decay particles
-C... IKNT = number of decay channels defined
-C...AUTHOR: STEPHEN MRENNA
-C...Last change:
-C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
-C...when CHIENU .NE. 0
-
- SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
-CC &SFMIX(16,4),
-C COMMON/PYINTS/XXM(20)
- COMPLEX*16 CXC
- COMMON/PYINTC/XXC(10),CXC(8)
- SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
-
-C...Local variables
- COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
- COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
- INTEGER KFIN,KCIN
- DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
- &XMZ,XMZ2,AXMJ,AXMI
- DOUBLE PRECISION S12MIN,S12MAX
- DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
- DOUBLE PRECISION PYLAMF,XL
- DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
- DOUBLE PRECISION PYX2XH,PYX2XG
- DOUBLE PRECISION XLAM(0:400)
- INTEGER IDLAM(400,3)
- INTEGER LKNT,IX,IH,J,IJ,I,IKNT
- INTEGER ITH(3)
- INTEGER ITHC
- DOUBLE PRECISION ETAH(3),DH(3),EH(3)
- DOUBLE PRECISION SR2
- DOUBLE PRECISION CBETA,SBETA,TANB
-
- DOUBLE PRECISION PYALEM,PI,PYALPS
- DOUBLE PRECISION FCOL
- INTEGER KF1,KF2,ISF
- INTEGER KFNCHI(4),KFCCHI(2)
-
- DOUBLE PRECISION TEMP
- EXTERNAL PYGAUS,PYXXZ6
- DOUBLE PRECISION PYGAUS,PYXXZ6
- DOUBLE PRECISION PREC
- DATA ITH/25,35,36/
- DATA ITHC/37/
- DATA ETAH/1D0,1D0,-1D0/
- DATA SR2/1.4142136D0/
- DATA PI/3.141592654D0/
- DATA PREC/1D-2/
- DATA KFNCHI/1000022,1000023,1000025,1000035/
- DATA KFCCHI/1000024,1000037/
-
-C...COUNT THE NUMBER OF DECAY MODES
- LKNT=0
- XMW=PMAS(24,1)
- XMW2=XMW**2
- XMZ=PMAS(23,1)
- XMZ2=XMZ**2
- XW=1D0-XMW2/XMZ2
- XW1=1D0-XW
- TANW = SQRT(XW/XW1)
-
-C...1 OR 2 DEPENDING ON CHARGINO TYPE
- IX=1
- IF(KFIN.EQ.KFCCHI(2)) IX=2
- KCIN=PYCOMP(KFIN)
-
- XMI=SMW(IX)
- XMI2=XMI**2
- AXMI=ABS(XMI)
- AEM=PYALEM(XMI2)
- AS =PYALPS(XMI2)
- C1=AEM/XW
- XMI3=ABS(XMI**3)
- TANB=RMSS(5)
- BETA=ATAN(TANB)
- CBETA=COS(BETA)
- SBETA=TANB*CBETA
- ALFA=RMSS(18)
-
- DO 110 I=1,2
- DO 100 J=1,2
- VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
- UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
- 100 CONTINUE
- 110 CONTINUE
-
-C...GRAVITINO DECAY MODES
-
- IF(IMSS(11).EQ.1) THEN
- XMP=RMSS(29)
- IDG=39+KSUSY1
- XMGR=PMAS(PYCOMP(IDG),1)
-C SINW=SQRT(XW)
-C COSW=SQRT(1D0-XW)
- XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
- IF(AXMI.GT.XMGR+XMW) THEN
- LKNT=LKNT+1
- IDLAM(LKNT,1)=IDG
- IDLAM(LKNT,2)=24
- IDLAM(LKNT,3)=0
- XLAM(LKNT)=XFAC*(
- & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
- & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
- & (1D0-XMW2/XMI2)**4
- ENDIF
- IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
- LKNT=LKNT+1
- IDLAM(LKNT,1)=IDG
- IDLAM(LKNT,2)=37
- IDLAM(LKNT,3)=0
- XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
- & (ABS(UMIXC(IX,2))*SBETA)**2))
- & *(1D0-PMAS(37,1)**2/XMI2)**4
- ENDIF
- ENDIF
-
-C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
- IF(IX.EQ.1) GOTO 170
- XMJ=SMW(1)
- AXMJ=ABS(XMJ)
- XMJ2=XMJ**2
-
-C...CHI_2+ -> CHI_1+ + Z0
- IF(AXMI.GE.AXMJ+XMZ) THEN
- LKNT=LKNT+1
- IJ=1
- OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
- & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
- ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
- & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
- GX2=ABS(OLPP)**2+ABS(ORPP)**2
- GLR=DBLE(OLPP*DCONJG(ORPP))
- XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
- IDLAM(LKNT,1)=KFCCHI(1)
- IDLAM(LKNT,2)=23
- IDLAM(LKNT,3)=0
-
-C...CHARGED LEPTONS
- ELSEIF(AXMI.GE.AXMJ) THEN
- S12MIN=0D0
- S12MAX=(AXMI-AXMJ)**2
- IA=11
- JA=12
- EI=KCHG(IABS(IA),1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- XXC(1)=0D0
- XXC(2)=XMJ
- XXC(3)=0D0
- XXC(4)=XMI
- XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
- XXC(6)=1D6
- XXC(9)=PMAS(23,1)
- XXC(10)=PMAS(23,2)
- IJ=1
- OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
- & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
- ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
- & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
- CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
- CXC(2)=DCMPLX(0D0,0D0)
- CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
- CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
- CXC(5)=-DCMPLX(EI/XW1)*ORPP
- CXC(6)=DCMPLX(0D0,0D0)
- CXC(7)=-DCMPLX(EI/XW1)*OLPP
- CXC(8)=DCMPLX(0D0,0D0)
- IF( XXC(5).LT.AXMI ) THEN
- XXC(5)=1D6
- ENDIF
- XXC(7)=XXC(5)
- XXC(8)=XXC(6)
- IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
- IDLAM(LKNT,1)=KFCCHI(1)
- IDLAM(LKNT,2)=11
- IDLAM(LKNT,3)=-11
- IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KFCCHI(1)
- IDLAM(LKNT,2)=13
- IDLAM(LKNT,3)=-13
- ENDIF
- IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KFCCHI(1)
- IDLAM(LKNT,2)=15
- IDLAM(LKNT,3)=-15
- ENDIF
- ENDIF
-
-C...NEUTRINOS
- 120 CONTINUE
- IA=12
- JA=11
- EI=KCHG(IABS(IA),1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
- XXC(6)=1D6
- CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
- CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
- CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
- CXC(5)=-DCMPLX(EI/XW1)*ORPP
- CXC(7)=-DCMPLX(EI/XW1)*OLPP
- IF( XXC(5).LT.AXMI ) THEN
- XXC(5)=1D6
- ENDIF
- XXC(7)=XXC(5)
- XXC(8)=XXC(6)
- IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
- IDLAM(LKNT,1)=KFCCHI(1)
- IDLAM(LKNT,2)=12
- IDLAM(LKNT,3)=-12
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KFCCHI(1)
- IDLAM(LKNT,2)=14
- IDLAM(LKNT,3)=-14
- ENDIF
- IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
- IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
- XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
- ELSE
- XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
- ENDIF
- IF( XXC(5).LT.AXMI ) THEN
- XXC(5)=1D6
- ENDIF
- XXC(7)=XXC(5)
- LKNT=LKNT+1
- XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
- IDLAM(LKNT,1)=KFCCHI(1)
- IDLAM(LKNT,2)=16
- IDLAM(LKNT,3)=-16
- ENDIF
-
-C...D-TYPE QUARKS
- 130 CONTINUE
- IA=1
- JA=2
- EI=KCHG(IABS(IA),1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
- XXC(6)=1D6
- CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
- CXC(2)=DCMPLX(0D0,0D0)
- CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
- CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
- CXC(5)=-DCMPLX(EI/XW1)*ORPP
- CXC(6)=DCMPLX(0D0,0D0)
- CXC(7)=-DCMPLX(EI/XW1)*OLPP
- CXC(8)=DCMPLX(0D0,0D0)
- IF( XXC(5).LT.AXMI ) THEN
- XXC(5)=1D6
- ENDIF
- XXC(7)=XXC(5)
- XXC(8)=XXC(6)
- IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
- IDLAM(LKNT,1)=KFCCHI(1)
- IDLAM(LKNT,2)=1
- IDLAM(LKNT,3)=-1
- IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KFCCHI(1)
- IDLAM(LKNT,2)=3
- IDLAM(LKNT,3)=-3
- ENDIF
- ENDIF
- IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
- IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
- XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
- ELSE
- XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
- ENDIF
- IF( XXC(5).LT.AXMI ) THEN
- XXC(5)=1D6
- ENDIF
- XXC(7)=XXC(5)
- LKNT=LKNT+1
- XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
- IDLAM(LKNT,1)=KFCCHI(1)
- IDLAM(LKNT,2)=5
- IDLAM(LKNT,3)=-5
- ENDIF
-
-C...U-TYPE QUARKS
- 140 CONTINUE
- IA=2
- JA=1
- EI=KCHG(IABS(IA),1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
- XXC(6)=1D6
- CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
- CXC(2)=DCMPLX(0D0,0D0)
- CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
- CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
- CXC(5)=-DCMPLX(EI/XW1)*ORPP
- CXC(6)=DCMPLX(0D0,0D0)
- CXC(7)=-DCMPLX(EI/XW1)*OLPP
- CXC(8)=DCMPLX(0D0,0D0)
- IF( XXC(5).LT.AXMI ) THEN
- XXC(5)=1D6
- ENDIF
- XXC(7)=XXC(5)
- XXC(8)=XXC(6)
- IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
- IDLAM(LKNT,1)=KFCCHI(1)
- IDLAM(LKNT,2)=2
- IDLAM(LKNT,3)=-2
- IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KFCCHI(1)
- IDLAM(LKNT,2)=4
- IDLAM(LKNT,3)=-4
- ENDIF
- ENDIF
- 150 CONTINUE
- ENDIF
-
-C...CHI_2+ -> CHI_1+ + H0_K
- EH(2)=COS(ALFA)
- EH(1)=SIN(ALFA)
- EH(3)=-SBETA
- DH(2)=-SIN(ALFA)
- DH(1)=COS(ALFA)
- DH(3)=COS(BETA)
- DO 160 IH=1,3
- XMH=PMAS(ITH(IH),1)
- XMH2=XMH**2
-C...NO 3-BODY OPTION
- IF(AXMI.GE.AXMJ+XMH) THEN
- LKNT=LKNT+1
- XL=PYLAMF(XMI2,XMJ2,XMH2)
- OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
- & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
- ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
- & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
- XMK=XMJ*ETAH(IH)
- GX2=ABS(OLPP)**2+ABS(ORPP)**2
- GLR=DBLE(OLPP*DCONJG(ORPP))
- XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
- IDLAM(LKNT,1)=KFCCHI(1)
- IDLAM(LKNT,2)=ITH(IH)
- IDLAM(LKNT,3)=0
- ENDIF
- 160 CONTINUE
-
-C...CHI1 JUMPS TO HERE
- 170 CONTINUE
-
-C...CHI+_I -> CHI0_J + W+
- DO 220 IJ=1,4
- XMJ=SMZ(IJ)
- AXMJ=ABS(XMJ)
- XMJ2=XMJ**2
- IF(AXMI.GE.AXMJ+XMW) THEN
- LKNT=LKNT+1
- DO 180 I=1,4
- ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
- 180 CONTINUE
- CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
- & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
- CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
- & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
- GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
- GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
- XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=24
- IDLAM(LKNT,3)=0
-C...LEPTONS
- ELSEIF(AXMI.GE.AXMJ) THEN
- S12MIN=0D0
- S12MAX=(AXMI-AXMJ)**2
- DO 190 I=1,4
- ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
- 190 CONTINUE
- CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
- & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
- CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
- & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
- CXC(5)=DCMPLX(0D0,0D0)
- CXC(7)=DCMPLX(0D0,0D0)
- IA=11
- JA=12
- EI=KCHG(IA,1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- EJ=KCHG(JA,1)/3D0
- T3J=SIGN(1D0,EJ+1D-6)/2D0
- CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
- & TANW+ZMIXC(IJ,2)*T3J)/SR2
- CXC(4)=-DCONJG(UMIXC(IX,1))*(
- & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
- CXC(6)=DCMPLX(0D0,0D0)
- CXC(8)=DCMPLX(0D0,0D0)
- XXC(1)=0D0
- XXC(2)=XMJ
- XXC(3)=0D0
- XXC(4)=XMI
- XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
- XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
- XXC(9)=PMAS(24,1)
- XXC(10)=PMAS(24,2)
-CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
- IF(XXC(5).LT.AXMI) THEN
- XXC(5)=1D6
- ELSEIF(XXC(6).LT.AXMI) THEN
- XXC(6)=1D6
- ENDIF
- XXC(7)=XXC(6)
- XXC(8)=XXC(5)
-C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
-C...--> 1/(16PI)/M**3*(AEM/XW)**2
- IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
- LKNT=LKNT+1
- TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
- XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=-11
- IDLAM(LKNT,3)=12
-C...ONLY DECAY CHI+1 -> E+ NU_E
- IF( IMSS(12).NE. 0 ) GOTO 260
- IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=-13
- IDLAM(LKNT,3)=14
- ENDIF
- ENDIF
- IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
- LKNT=LKNT+1
- IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
- XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
- ELSE
- XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
- ENDIF
- XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
- IF(XXC(5).LT.AXMI) THEN
- XXC(5)=1D6
- ELSEIF(XXC(6).LT.AXMI) THEN
- XXC(6)=1D6
- ENDIF
- XXC(7)=XXC(6)
- XXC(8)=XXC(5)
- TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
- XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=-15
- IDLAM(LKNT,3)=16
- ENDIF
-
-C...NOW, DO THE QUARKS
- 200 CONTINUE
- IA=1
- JA=2
- EI=KCHG(IA,1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- EJ=KCHG(JA,1)/3D0
- T3J=SIGN(1D0,EJ+1D-6)/2D0
- CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
- & TANW+ZMIXC(IJ,2)*T3J)
- CXC(4)=-DCONJG(UMIXC(IX,1))*(
- & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
- XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
- XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
- IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
- IF(XXC(5).LT.AXMI) THEN
- XXC(5)=1D6
- ENDIF
- IF(XXC(6).LT.AXMI) THEN
- XXC(6)=1D6
- ENDIF
- XXC(7)=XXC(6)
- XXC(8)=XXC(5)
- IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=-1
- IDLAM(LKNT,3)=2
- IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=-3
- IDLAM(LKNT,3)=4
- ENDIF
- ENDIF
- 210 CONTINUE
- ENDIF
- 220 CONTINUE
-
-C...CHI+_I -> CHI0_J + H+
- DO 230 IJ=1,4
- XMJ=SMZ(IJ)
- AXMJ=ABS(XMJ)
- XMJ2=XMJ**2
- XMHP=PMAS(ITHC,1)
- IF(AXMI.GE.AXMJ+XMHP) THEN
- LKNT=LKNT+1
- OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
- & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
- ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
- & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
- & UMIXC(IX,2)/SR2)
- GX2=ABS(OLPP)**2+ABS(ORPP)**2
- GLR=DBLE(OLPP*DCONJG(ORPP))
- XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=ITHC
- IDLAM(LKNT,3)=0
- ELSE
-
- ENDIF
- 230 CONTINUE
-
-C...2-BODY DECAYS TO FERMION SFERMION
- DO 240 J=1,16
- IF(J.GE.7.AND.J.LE.10) GOTO 240
- IF(MOD(J,2).EQ.0) THEN
- KF1=KSUSY1+J-1
- ELSE
- KF1=KSUSY1+J+1
- ENDIF
- KF2=KF1+KSUSY1
- XMSF1=PMAS(PYCOMP(KF1),1)
- XMSF2=PMAS(PYCOMP(KF2),1)
- XMF=PMAS(J,1)
- IF(J.LE.6) THEN
- FCOL=3D0
- ELSE
- FCOL=1D0
- ENDIF
-
-C...U~ D_L
- IF(MOD(J,2).EQ.0) THEN
- XMFP=PMAS(J-1,1)
- CAL=UMIXC(IX,1)
- CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
- CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
- CBR=0D0
- ISF=J-1
- ELSE
- XMFP=PMAS(J+1,1)
- CAL=VMIXC(IX,1)
- CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
- CBR=0D0
- CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
- ISF=J+1
- ENDIF
-
-C...~U_L D
- IF(AXMI.GE.XMF+XMSF1) THEN
- LKNT=LKNT+1
- XMA2=XMSF1**2
- XMB2=XMF**2
- XL=PYLAMF(XMI2,XMA2,XMB2)
- CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
- CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
- XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
- & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
- IDLAM(LKNT,3)=0
- IF(MOD(J,2).EQ.0) THEN
- IDLAM(LKNT,1)=-KF1
- IDLAM(LKNT,2)=J
- ELSE
- IDLAM(LKNT,1)=KF1
- IDLAM(LKNT,2)=-J
- ENDIF
- ENDIF
-
-C...U~ D_R
- IF(AXMI.GE.XMF+XMSF2) THEN
- LKNT=LKNT+1
- XMA2=XMSF2**2
- XMB2=XMF**2
- CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
- CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
- XL=PYLAMF(XMI2,XMA2,XMB2)
- XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
- & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
- IDLAM(LKNT,3)=0
- IF(MOD(J,2).EQ.0) THEN
- IDLAM(LKNT,1)=-KF2
- IDLAM(LKNT,2)=J
- ELSE
- IDLAM(LKNT,1)=KF2
- IDLAM(LKNT,2)=-J
- ENDIF
- ENDIF
- 240 CONTINUE
-
-C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
-C...A 2-BODY -- 2-BODY CHAIN
- XMJ=PMAS(PYCOMP(KSUSY1+21),1)
- IF(AXMI.GE.XMJ) THEN
- AXMJ=ABS(XMJ)
- S12MIN=0D0
- S12MAX=(AXMI-AXMJ)**2
- XXC(1)=0D0
- XXC(2)=XMJ
- XXC(3)=0D0
- XXC(4)=XMI
- XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
- XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
- XXC(9)=1D6
- XXC(10)=0D0
- OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
- ORPP=DCONJG(OLPP)
- CXC(1)=DCMPLX(0D0,0D0)
- CXC(3)=DCMPLX(0D0,0D0)
- CXC(5)=DCMPLX(0D0,0D0)
- CXC(7)=DCMPLX(0D0,0D0)
- CXC(2)=UMIXC(IX,1)*OLPP/SR2
- CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
- CXC(6)=DCMPLX(0D0,0D0)
- CXC(8)=DCMPLX(0D0,0D0)
- IF(XXC(5).LT.AXMI) THEN
- XXC(5)=1D6
- ELSEIF(XXC(6).LT.AXMI) THEN
- XXC(6)=1D6
- ENDIF
- XXC(7)=XXC(6)
- XXC(8)=XXC(5)
- IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
- IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
- & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
- IDLAM(LKNT,1)=KSUSY1+21
- IDLAM(LKNT,2)=-1
- IDLAM(LKNT,3)=2
- IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=XLAM(LKNT-1)
- IDLAM(LKNT,1)=KSUSY1+21
- IDLAM(LKNT,2)=-3
- IDLAM(LKNT,3)=4
- ENDIF
- ENDIF
- 250 CONTINUE
- ENDIF
-
-C...R-violating decay modes (SKANDS).
- CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
-
- 260 IKNT=LKNT
- XLAM(0)=0D0
- DO 270 I=1,IKNT
- XLAM(0)=XLAM(0)+XLAM(I)
- IF(XLAM(I).LT.0D0) THEN
- WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
- & (IDLAM(I,J),J=1,3)
- XLAM(I)=0D0
- ENDIF
- 270 CONTINUE
- IF(XLAM(0).EQ.0D0) THEN
- XLAM(0)=1D-6
- WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
- WRITE(MSTU(11),*) LKNT
- WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYXXZ6
-C...Used in the calculation of inoi -> inoj + f + ~f.
-
- FUNCTION PYXXZ6(X)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
-C COMMON/PYINTS/XXM(20)
- COMPLEX*16 CXC
- COMMON/PYINTC/XXC(10),CXC(8)
- SAVE /PYDAT1/,/PYINTC/
-
-C...Local variables.
- COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
- DOUBLE PRECISION PYXXZ6,X
- DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
- DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
- DOUBLE PRECISION SIJ
- DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
- DOUBLE PRECISION OL2
- DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
- INTEGER I
-
-C...Statement functions.
-C...Integral from x to y of (t-a)(b-t) dt.
- TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
-C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
- TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
- &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
-C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
- TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
- &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
-C...Integral from x to y of (t-a)/(b-t) dt.
- UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
-C...Integral from x to y of 1/(t-a) dt.
- TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
-
- XM12=XXC(1)**2
- XM22=XXC(2)**2
- XM32=XXC(3)**2
- S=XXC(4)**2
- S13=X
-
- S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
- S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
- &( (X-XM22-S)**2 -4D0*XM22*S ) )
-
- S23MIN=(S23AVE-S23DEL)
- S23MAX=(S23AVE+S23DEL)
-
- XMSD1=XXC(5)**2
- XMSD2=XXC(7)**2
- XMSU1=XXC(6)**2
- XMSU2=XXC(8)**2
-
- XMV=XXC(9)
- XMG=XXC(10)
- QLLS=CXC(1)
- QLLU=CXC(2)
- QLRS=CXC(3)
- QLRT=CXC(4)
- QRLS=CXC(5)
- QRLT=CXC(6)
- QRRS=CXC(7)
- QRRU=CXC(8)
- WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
- SIJ=2D0*XXC(2)*XXC(4)*S13
- IF(XMV.LE.1000D0) THEN
- OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
- OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
- WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
- & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
- IF(XXC(5).LE.10000D0) THEN
- WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
- & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
- & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
- & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
- & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
- & *(S13-XMV**2)/WPROP2
- ELSE
- WFL1=0D0
- ENDIF
-
- IF(XXC(6).LE.10000D0) THEN
- WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
- & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
- & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
- & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
- & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
- & *(S13-XMV**2)/WPROP2
- ELSE
- WFL2=0D0
- ENDIF
- ELSE
- WW=0D0
- WFL1=0D0
- WFL2=0D0
- ENDIF
- IF(XXC(5).LE.10000D0) THEN
- WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
- & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
- & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
- & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
- ELSE
- WF1=0D0
- ENDIF
- IF(XXC(6).LE.10000D0) THEN
- WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
- & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
- & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
- & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
- ELSE
- WF2=0D0
- ENDIF
-
- PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
-
- IF(PYXXZ6.LT.0D0) THEN
- WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
- WRITE(MSTU(11),*) (XXC(I),I=1,5)
- WRITE(MSTU(11),*) (XXC(I),I=6,10)
- WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
- WRITE(MSTU(11),*) S23MIN,S23MAX
- PYXXZ6=0D0
- ENDIF
-
- RETURN
- END
-
-
-C*********************************************************************
-
-C...PYXXGA
-C...Calculates chi0_i -> chi0_j + gamma.
-
- FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...Local variables.
- DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
- DOUBLE PRECISION F1,F2
-
- F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
- F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
- PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
- PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYX2XG
-C...Calculates the decay rate for ino -> ino + gauge boson.
-
- FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...Local variables.
- DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
- DOUBLE PRECISION XL,PYLAMF,C1
- DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
-
- XMI2=XM1**2
- XMI3=ABS(XM1**3)
- XMJ2=XM2**2
- XMV2=XM3**2
- XL=PYLAMF(XMI2,XMJ2,XMV2)
- PYX2XG=C1/8D0/XMI3*SQRT(XL)
- &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
- &12D0*GLR*XM1*XM2*XMV2)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYX2XH
-C...Calculates the decay rate for ino -> ino + H.
-
- FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...Local variables.
- DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
- DOUBLE PRECISION XL,PYLAMF,C1
- DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
-
- XMI2=XM1**2
- XMI3=ABS(XM1**3)
- XMJ2=XM2**2
- XMV2=XM3**2
- XL=PYLAMF(XMI2,XMJ2,XMV2)
- PYX2XH=C1/8D0/XMI3*SQRT(XL)
- &*(GX2*(XMI2+XMJ2-XMV2)+
- &4D0*GLR*XM1*XM2)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYHEXT
-C...Calculates the non-standard decay modes of the Higgs boson.
-C...
-C...Author: Stephen Mrenna
-C...Last Update: April 2001
-C......Allow complex values for Z,U, and V
-
- SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
-
-C...Local variables.
- COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
- COMPLEX*16 QIJ,RIJ,F21K,F12K
- INTEGER KFIN
- DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
- DOUBLE PRECISION XMI2,XMI3,XMJ2
- DOUBLE PRECISION PYLAMF,XL,CF,EI
- INTEGER IDU,IFL
- DOUBLE PRECISION TANW,XW,AEM,C1,AS
- DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
- DOUBLE PRECISION XLAM(0:400)
- INTEGER IDLAM(400,3)
- INTEGER LKNT,IH,J,IJ,I,IKNT,IK
- INTEGER ITH(4)
- INTEGER KFNCHI(4),KFCCHI(2)
- DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
- DOUBLE PRECISION SR2
- DOUBLE PRECISION BETA,ALFA
- DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
- DOUBLE PRECISION PYALEM
- DOUBLE PRECISION AL,AR,ALR
- DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
- DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
- DOUBLE PRECISION XMJL,XMJR,XM1,XM2
- DATA ITH/25,35,36,37/
- DATA ETAH/1D0,1D0,-1D0/
- DATA SR2/1.4142136D0/
- DATA KFNCHI/1000022,1000023,1000025,1000035/
- DATA KFCCHI/1000024,1000037/
-
-C...COUNT THE NUMBER OF DECAY MODES
- LKNT=IKNT
-
- XMW=PMAS(24,1)
- XMW2=XMW**2
- XMZ=PMAS(23,1)
- XW=PARU(102)
- TANW = SQRT(XW/(1D0-XW))
- CW=SQRT(1D0-XW)
-
-C...1 - 4 DEPENDING ON Higgs species.
- IH=1
- IF(KFIN.EQ.ITH(2)) IH=2
- IF(KFIN.EQ.ITH(3)) IH=3
- IF(KFIN.EQ.ITH(4)) IH=4
-
- XMI=PMAS(KFIN,1)
- XMI2=XMI**2
- AXMI=ABS(XMI)
- AEM=PYALEM(XMI2)
- C1=AEM/XW
- XMI3=ABS(XMI**3)
-
- TANB=RMSS(5)
- BETA=ATAN(TANB)
- CBETA=COS(BETA)
- SBETA=TANB*CBETA
- ALFA=RMSS(18)
- COSA=COS(ALFA)
- SINA=SIN(ALFA)
- ATRIT=RMSS(16)
- ATRIB=RMSS(15)
- ATRIL=RMSS(17)
- XMUZ=-RMSS(4)
-
- DO 110 I=1,4
- DO 100 J=1,4
- ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
- 100 CONTINUE
- 110 CONTINUE
- DO 130 I=1,2
- DO 120 J=1,2
- VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
- UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
- 120 CONTINUE
- 130 CONTINUE
-
-
- IF(IH.EQ.4) GOTO 220
-
-C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
-C...H0_K -> CHI0_I + CHI0_J
- EH(2)=SINA
- EH(1)=COSA
- EH(3)=CBETA
- DH(2)=COSA
- DH(1)=-SINA
- DH(3)=SBETA
- DO 150 IJ=1,4
- XMJ=SMZ(IJ)
- AXMJ=ABS(XMJ)
- DO 140 IK=1,IJ
- XMK=SMZ(IK)
- AXMK=ABS(XMK)
- IF(AXMI.GE.AXMJ+AXMK) THEN
- LKNT=LKNT+1
- QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
- & ZMIXC(IJ,3)*ZMIXC(IK,2)-
- & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
- & ZMIXC(IJ,3)*ZMIXC(IK,1))
- RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
- & ZMIXC(IJ,4)*ZMIXC(IK,2)-
- & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
- & ZMIXC(IJ,4)*ZMIXC(IK,1))
- F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
- F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
-C...SIGN OF MASSES I,J
- XML=XMK*ETAH(IH)
- GX2=ABS(F12K)**2+ABS(F21K)**2
- GLR=DBLE(F12K*DCONJG(F21K))
- XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
- IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=KFNCHI(IK)
- IDLAM(LKNT,3)=0
- ENDIF
- 140 CONTINUE
- 150 CONTINUE
-
-C...H0_K -> CHI+_I CHI-_J
- DO 170 IJ=1,2
- XMJ=SMW(IJ)
- AXMJ=ABS(XMJ)
- DO 160 IK=1,2
- XMK=SMW(IK)
- AXMK=ABS(XMK)
- IF(AXMI.GE.AXMJ+AXMK) THEN
- LKNT=LKNT+1
- OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
- & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
- ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
- & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
- GX2=ABS(OLPP)**2+ABS(ORPP)**2
- GLR=DBLE(OLPP*DCONJG(ORPP))
- XML=XMK*ETAH(IH)
- XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
- IDLAM(LKNT,1)=KFCCHI(IJ)
- IDLAM(LKNT,2)=-KFCCHI(IK)
- IDLAM(LKNT,3)=0
- ENDIF
- 160 CONTINUE
- 170 CONTINUE
-
-C...HIGGS TO SFERMION SFERMION
- DO 200 IFL=1,16
- IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
- IJ=KSUSY1+IFL
- XMJL=PMAS(PYCOMP(IJ),1)
- XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
- IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
- XMJ=XMJL
- XMJ2=XMJ**2
- XL=PYLAMF(XMI2,XMJ2,XMJ2)
- XMF=PMAS(IFL,1)
- EI=KCHG(IFL,1)/3D0
- IDU=2-MOD(IFL,2)
-
- IF(IH.EQ.1) THEN
- IF(IDU.EQ.1) THEN
- GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
- & XMF**2/XMW*SINA/CBETA
- GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
- & XMF**2/XMW*SINA/CBETA
- IF(IFL.EQ.5) THEN
- GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
- & ATRIB*SINA)
- ELSEIF(IFL.EQ.15) THEN
- GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
- & ATRIL*SINA)
- ELSE
- GHLR=0D0
- ENDIF
- ELSE
- GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
- & XMF**2/XMW*COSA/SBETA
- GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
- & XMF**2/XMW*COSA/SBETA
- IF(IFL.EQ.6) THEN
- GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
- & ATRIT*COSA)
- ELSE
- GHLR=0D0
- ENDIF
- ENDIF
-
- ELSEIF(IH.EQ.2) THEN
- IF(IDU.EQ.1) THEN
- GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
- & XMF**2/XMW*COSA/CBETA
- GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
- & XMF**2/XMW*COSA/CBETA
- IF(IFL.EQ.5) THEN
- GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
- & ATRIB*COSA)
- ELSEIF(IFL.EQ.15) THEN
- GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
- & ATRIL*COSA)
- ELSE
- GHLR=0D0
- ENDIF
- ELSE
- GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
- & XMF**2/XMW*SINA/SBETA
- GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
- & XMF**2/XMW*SINA/SBETA
- IF(IFL.EQ.6) THEN
- GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
- & ATRIT*SINA)
- ELSE
- GHLR=0D0
- ENDIF
- ENDIF
-
- ELSEIF(IH.EQ.3) THEN
- GHLL=0D0
- GHRR=0D0
- GHLR=0D0
- IF(IDU.EQ.1) THEN
- IF(IFL.EQ.5) THEN
- GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
- ELSEIF(IFL.EQ.15) THEN
- GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
- ENDIF
- ELSE
- IF(IFL.EQ.6) THEN
- GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
- ENDIF
- ENDIF
- ENDIF
- IF(IH.EQ.3) GOTO 180
-
- AL=SFMIX(IFL,1)**2
- AR=SFMIX(IFL,2)**2
- ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
- IF(IFL.LE.6) THEN
- CF=3D0
- ELSE
- CF=1D0
- ENDIF
-
- IF(AXMI.GE.2D0*XMJ) THEN
- LKNT=LKNT+1
- XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
- & (GHLL*AL+GHRR*AR
- & +2D0*GHLR*ALR)**2
- IDLAM(LKNT,1)=IJ
- IDLAM(LKNT,2)=-IJ
- IDLAM(LKNT,3)=0
- ENDIF
-
- IF(AXMI.GE.2D0*XMJR) THEN
- LKNT=LKNT+1
- AL=SFMIX(IFL,3)**2
- AR=SFMIX(IFL,4)**2
- ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
- XMJ=XMJR
- XMJ2=XMJ**2
- XL=PYLAMF(XMI2,XMJ2,XMJ2)
- XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
- & (GHLL*AL+GHRR*AR
- & +2D0*GHLR*ALR)**2
- IDLAM(LKNT,1)=IJ+KSUSY1
- IDLAM(LKNT,2)=-(IJ+KSUSY1)
- IDLAM(LKNT,3)=0
- ENDIF
- 180 CONTINUE
-
- IF(AXMI.GE.XMJL+XMJR) THEN
- LKNT=LKNT+1
- AL=SFMIX(IFL,1)*SFMIX(IFL,3)
- AR=SFMIX(IFL,2)*SFMIX(IFL,4)
- ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
- XMJ=XMJR
- XMJ2=XMJ**2
- XL=PYLAMF(XMI2,XMJ2,XMJL**2)
- XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
- & (GHLL*AL+GHRR*AR)**2
- IDLAM(LKNT,1)=IJ
- IDLAM(LKNT,2)=-(IJ+KSUSY1)
- IDLAM(LKNT,3)=0
- LKNT=LKNT+1
- IDLAM(LKNT,1)=-IJ
- IDLAM(LKNT,2)=IJ+KSUSY1
- IDLAM(LKNT,3)=0
- XLAM(LKNT)=XLAM(LKNT-1)
- ENDIF
- ENDIF
- 190 CONTINUE
- 200 CONTINUE
- 210 CONTINUE
-
- GOTO 270
- 220 CONTINUE
-
-C...H+ -> CHI+_I + CHI0_J
- DO 240 IJ=1,4
- XMJ=SMZ(IJ)
- AXMJ=ABS(XMJ)
- XMJ2=XMJ**2
- DO 230 IK=1,2
- XMK=SMW(IK)
- AXMK=ABS(XMK)
- IF(AXMI.GE.AXMJ+AXMK) THEN
- LKNT=LKNT+1
- OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
- & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
- ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
- & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
- GX2=ABS(OLPP)**2+ABS(ORPP)**2
- GLR=DBLE(OLPP*DCONJG(ORPP))
- XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
- IDLAM(LKNT,1)=KFNCHI(IJ)
- IDLAM(LKNT,2)=KFCCHI(IK)
- IDLAM(LKNT,3)=0
- ENDIF
- 230 CONTINUE
- 240 CONTINUE
-
- GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
- GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
- AL=0D0
- AR=0D0
- CF=3D0
-
-C...H+ -> T_1 B_1~
- XM1=PMAS(PYCOMP(KSUSY1+6),1)
- XM2=PMAS(PYCOMP(KSUSY1+5),1)
- IF(XMI.GE.XM1+XM2) THEN
- XL=PYLAMF(XMI2,XM1**2,XM2**2)
- LKNT=LKNT+1
- XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
- & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
- IDLAM(LKNT,1)=KSUSY1+6
- IDLAM(LKNT,2)=-(KSUSY1+5)
- IDLAM(LKNT,3)=0
- ENDIF
-
-C...H+ -> T_2 B_1~
- XM1=PMAS(PYCOMP(KSUSY2+6),1)
- XM2=PMAS(PYCOMP(KSUSY1+5),1)
- IF(XMI.GE.XM1+XM2) THEN
- XL=PYLAMF(XMI2,XM1**2,XM2**2)
- LKNT=LKNT+1
- XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
- & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
- IDLAM(LKNT,1)=KSUSY2+6
- IDLAM(LKNT,2)=-(KSUSY1+5)
- IDLAM(LKNT,3)=0
- ENDIF
-
-C...H+ -> T_1 B_2~
- XM1=PMAS(PYCOMP(KSUSY1+6),1)
- XM2=PMAS(PYCOMP(KSUSY2+5),1)
- IF(XMI.GE.XM1+XM2) THEN
- XL=PYLAMF(XMI2,XM1**2,XM2**2)
- LKNT=LKNT+1
- XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
- & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
- IDLAM(LKNT,1)=KSUSY1+6
- IDLAM(LKNT,2)=-(KSUSY2+5)
- IDLAM(LKNT,3)=0
- ENDIF
-
-C...H+ -> T_2 B_2~
- XM1=PMAS(PYCOMP(KSUSY2+6),1)
- XM2=PMAS(PYCOMP(KSUSY2+5),1)
- IF(XMI.GE.XM1+XM2) THEN
- XL=PYLAMF(XMI2,XM1**2,XM2**2)
- LKNT=LKNT+1
- XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
- & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
- IDLAM(LKNT,1)=KSUSY2+6
- IDLAM(LKNT,2)=-(KSUSY2+5)
- IDLAM(LKNT,3)=0
- ENDIF
-
-C...H+ -> UL DL~
- GL=-XMW/SR2*SIN(2D0*BETA)
- DO 250 IJ=1,3,2
- XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
- XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
- IF(XMI.GE.XM1+XM2) THEN
- XL=PYLAMF(XMI2,XM1**2,XM2**2)
- LKNT=LKNT+1
- XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
- IDLAM(LKNT,1)=-(KSUSY1+IJ)
- IDLAM(LKNT,2)=KSUSY1+IJ+1
- IDLAM(LKNT,3)=0
- ENDIF
- 250 CONTINUE
-
-C...H+ -> EL~ NUL
- CF=1D0
- DO 260 IJ=11,13,2
- XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
- XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
- IF(XMI.GE.XM1+XM2) THEN
- XL=PYLAMF(XMI2,XM1**2,XM2**2)
- LKNT=LKNT+1
- XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
- IDLAM(LKNT,1)=-(KSUSY1+IJ)
- IDLAM(LKNT,2)=KSUSY1+IJ+1
- IDLAM(LKNT,3)=0
- ENDIF
- 260 CONTINUE
-
-C...H+ -> TAU1 NUTAUL
- XM1=PMAS(PYCOMP(KSUSY1+15),1)
- XM2=PMAS(PYCOMP(KSUSY1+16),1)
- IF(XMI.GE.XM1+XM2) THEN
- XL=PYLAMF(XMI2,XM1**2,XM2**2)
- LKNT=LKNT+1
- XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
- IDLAM(LKNT,1)=-(KSUSY1+15)
- IDLAM(LKNT,2)= KSUSY1+16
- IDLAM(LKNT,3)=0
- ENDIF
-
-C...H+ -> TAU2 NUTAUL
- XM1=PMAS(PYCOMP(KSUSY2+15),1)
- XM2=PMAS(PYCOMP(KSUSY1+16),1)
- IF(XMI.GE.XM1+XM2) THEN
- XL=PYLAMF(XMI2,XM1**2,XM2**2)
- LKNT=LKNT+1
- XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
- IDLAM(LKNT,1)=-(KSUSY2+15)
- IDLAM(LKNT,2)= KSUSY1+16
- IDLAM(LKNT,3)=0
- ENDIF
-
- 270 CONTINUE
- IKNT=LKNT
- XLAM(0)=0D0
- DO 280 I=1,IKNT
- IF(XLAM(I).LE.0D0) XLAM(I)=0D0
- XLAM(0)=XLAM(0)+XLAM(I)
- 280 CONTINUE
- IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYH2XX
-C...Calculates the decay rate for a Higgs to an ino pair.
-
- FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-
-C...Local variables.
- DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
- DOUBLE PRECISION XL,PYLAMF,C1
- DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
-
- XMI2=XM1**2
- XMI3=ABS(XM1**3)
- XMJ2=XM2**2
- XMK2=XM3**2
- XL=PYLAMF(XMI2,XMJ2,XMK2)
- PYH2XX=C1/4D0/XMI3*SQRT(XL)
- &*(GX2*(XMI2-XMJ2-XMK2)-
- &4D0*GLR*XM3*XM2)
- IF(PYH2XX.LT.0D0) PYH2XX=0D0
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYGAUS
-C...Integration by adaptive Gaussian quadrature.
-C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
-
- FUNCTION PYGAUS(F, A, B, EPS)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...Local declarations.
- EXTERNAL F
- DOUBLE PRECISION F,W(12), X(12)
- DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
- DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
- DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
- DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
- DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
- DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
- DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
- DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
- DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
- DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
- DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
- DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
-
-C...The Gaussian quadrature algorithm.
- H = 0D0
- IF(B .EQ. A) GOTO 140
- CONST = 5D-3 / ABS(B-A)
- BB = A
- 100 CONTINUE
- AA = BB
- BB = B
- 110 CONTINUE
- C1 = 0.5D0*(BB+AA)
- C2 = 0.5D0*(BB-AA)
- S8 = 0D0
- DO 120 I = 1, 4
- U = C2*X(I)
- S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
- 120 CONTINUE
- S16 = 0D0
- DO 130 I = 5, 12
- U = C2*X(I)
- S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
- 130 CONTINUE
- S16 = C2*S16
- IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
- H = H + S16
- IF(BB .NE. B) GOTO 100
- ELSE
- BB = C1
- IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
- H = 0D0
- CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
- GOTO 140
- ENDIF
- 140 CONTINUE
- PYGAUS = H
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYGAU2
-C...Integration by adaptive Gaussian quadrature.
-C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
-C...Carbon copy of PYGAUS, but avoids having to use it recursively.
-
- FUNCTION PYGAU2(F, A, B, EPS)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...Local declarations.
- EXTERNAL F
- DOUBLE PRECISION F,W(12), X(12)
- DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
- DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
- DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
- DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
- DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
- DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
- DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
- DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
- DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
- DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
- DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
- DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
-
-C...The Gaussian quadrature algorithm.
- H = 0D0
- IF(B .EQ. A) GOTO 140
- CONST = 5D-3 / ABS(B-A)
- BB = A
- 100 CONTINUE
- AA = BB
- BB = B
- 110 CONTINUE
- C1 = 0.5D0*(BB+AA)
- C2 = 0.5D0*(BB-AA)
- S8 = 0D0
- DO 120 I = 1, 4
- U = C2*X(I)
- S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
- 120 CONTINUE
- S16 = 0D0
- DO 130 I = 5, 12
- U = C2*X(I)
- S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
- 130 CONTINUE
- S16 = C2*S16
- IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
- H = H + S16
- IF(BB .NE. B) GOTO 100
- ELSE
- BB = C1
- IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
- H = 0D0
- CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
- GOTO 140
- ENDIF
- 140 CONTINUE
- PYGAU2 = H
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSIMP
-C...Simpson formula for an integral.
-
- FUNCTION PYSIMP(Y,X0,X1,N)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...Local variables.
- DOUBLE PRECISION Y,X0,X1,H,S
- DIMENSION Y(0:N)
-
- S=0D0
- H=(X1-X0)/N
- DO 100 I=0,N-2,2
- S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
- 100 CONTINUE
- PYSIMP=S*H/3D0
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYLAMF
-C...The standard lambda function.
-
- FUNCTION PYLAMF(X,Y,Z)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...Local variables.
- DOUBLE PRECISION PYLAMF,X,Y,Z
-
- PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
- IF(PYLAMF.LT.0D0) PYLAMF=0D0
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYTBDY
-C...Generates 3-body decays of gauginos.
-
- SUBROUTINE PYTBDY(IDIN)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
-C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
-C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
-C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
-
-C...Local variables.
- DOUBLE PRECISION XM(5)
- COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
- COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
- COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
- DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
- DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
- DOUBLE PRECISION CPHI1,SPHI1
- DOUBLE PRECISION S23DEL,EPS
- DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
- PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
- DOUBLE PRECISION F1,F2,X0,X1,X2,X3
- INTEGER INOID(4)
- DATA INOID/22,23,25,35/
- DATA EPS/1D-6/
-
- ID=IDIN
- ISKIP=1
- XM(1)=P(N+1,5)
- XM(2)=P(N+2,5)
- XM(3)=P(N+3,5)
- XM(5)=P(ID,5)
-
-C...GENERATE S12
- S12MIN=(XM(1)+XM(2))**2
- S12MAX=(XM(5)-XM(3))**2
- YJACO1=S12MAX-S12MIN
-
-C...Initialize some parameters
- XW=PARU(102)
- XW1=1D0-XW
- TANW=SQRT(XW/XW1)
- IZID1=0
- IWID1=0
- IZID2=0
- IWID2=0
-
- IA=K(N+2,2)
- JA=K(N+3,2)
-
-C...Mrenna: check that we are indeed decaying a SUSY particle
- IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
-
- ELSE
- DO 100 I1=1,4
- IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
- IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
- 100 CONTINUE
- IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
- IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
- IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
- IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
- ZM12=XM(5)**2
- ZM22=XM(1)**2
- EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
- T3I=SIGN(1D0,EI+1D-6)/2D0
- ENDIF
-
- IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
- ISKIP=0
- ELSEIF(IZID1*IZID2.NE.0) THEN
- SQMZ=PMAS(23,1)**2
- GMMZ=PMAS(23,1)*PMAS(23,2)
- DO 110 I=1,4
- ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
- ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
- 110 CONTINUE
- OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
- & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
- ORPP=DCONJG(OLPP)
- XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
- XLR2=XLL2
- XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
- XRL2=XRR2
- GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
- & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
- GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
- XM1M2=SMZ(IZID1)*SMZ(IZID2)
- QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
- QLLU=-GLIJ
- QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
- QLRT=DCONJG(GLIJ)
- QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
- QRLT=GRIJ
- QRRS=DCMPLX((EI*XW)/XW1)*ORPP
- QRRU=-DCONJG(GRIJ)
- ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
- IF(IZID1.NE.0) THEN
- XM1M2=SMZ(IZID1)*SMW(IWID2)
- IZID1=IWID2
- IZID2=IZID1
- ELSE
- XM1M2=SMZ(IZID2)*SMW(IWID1)
- IZID1=IWID1
- ENDIF
- RT2I = 1D0/SQRT(2D0)
- SQMZ=PMAS(24,1)**2
- GMMZ=PMAS(24,1)*PMAS(24,2)
- DO 120 I=1,2
- VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
- UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
- 120 CONTINUE
- DO 130 I=1,4
- ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
- 130 CONTINUE
- QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
- & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
- QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
- & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
- EJ=KCHG(IABS(JA),1)/3D0
- T3J=SIGN(1D0,EJ+1D-6)/2D0
- QRLS=DCMPLX(0D0,0D0)
- QRLT=QRLS
- QRRS=QRLS
- QRRU=QRLS
- XRR2=1D6**2
- XRL2=XRR2
- XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
- XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
- IF(MOD(IA,2).EQ.0) THEN
- QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
- & TANW+ZMIXC(IZID2,2)*T3I)
- QLRT=-DCONJG(UMIXC(IZID1,1))*(
- & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
- ELSE
- QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
- & TANW+ZMIXC(IZID2,2)*T3J)
- QLRT=-DCONJG(UMIXC(IZID1,1))*(
- & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
- ENDIF
- ELSEIF(IWID1*IWID2.NE.0) THEN
- IZID1=IWID1
- IZID2=IWID2
- XM1M2=SMW(IWID1)*SMW(IWID2)
- SQMZ=PMAS(23,1)**2
- GMMZ=PMAS(23,1)*PMAS(23,2)
- DO 140 I=1,2
- VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
- UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
- VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
- UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
- 140 CONTINUE
- OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
- & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
- ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
- & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
- QRLS=-DCMPLX(EI/XW1)*ORPP
- QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
- QRRS=-DCMPLX(EI/XW1)*OLPP
- QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
- IF(MOD(IA,2).EQ.0) THEN
- XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
- QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
- ELSE
- XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
- QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
- ENDIF
- ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
- &THEN
- ISKIP=0
- ELSE
- ISKIP=0
- ENDIF
-
- IF(ISKIP.NE.0) THEN
- WTMAX=0D0
- DO 160 KT=1,100
- S12=S12MIN+YJACO1*(KT-1)/99
- S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
- & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
- S23DF1=(S12-XM(2)**2-XM(1)**2)**2
- & -(2D0*XM(1)*XM(2))**2
- S23DF2=(S12-XM(3)**2-XM(5)**2)**2
- & -(2D0*XM(3)*XM(5))**2
- S23DF1=S23DF1*EPS
- S23DF2=S23DF2*EPS
- S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
- S23DEL=S23DEL/EPS
- S23MIN=S23AVE-S23DEL
- S23MAX=S23AVE+S23DEL
- YJACO2=S23MAX-S23MIN
- TH=S12
- DO 150 KS=1,100
- S23=S23MIN+YJACO2*(KS-1)/99
- SH=S23
- UH=ZM12+ZM22-SH-TH
- WU2 = (UH-ZM12)*(UH-ZM22)
- WT2 = (TH-ZM12)*(TH-ZM22)
- WS2 = XM1M2*SH
- PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
- PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
- QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
- QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
- QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
- QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
- WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
- & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
- & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
- IF(WT0.GT.WTMAX) WTMAX=WT0
- 150 CONTINUE
- 160 CONTINUE
-
- WTMAX=WTMAX*1.05D0
- ENDIF
-
-C...FIND S12*
- AX=S12MIN
- CX=S12MAX
- BX=S12MIN+0.5D0*YJACO1
- X0=AX
- X3=CX
- IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
- X1=BX
- X2=BX+C*(CX-BX)
- ELSE
- X2=BX
- X1=BX-C*(BX-AX)
- ENDIF
-
-C...SOLVE FOR F1 AND F2
- S23DF1=(X1-XM(2)**2-XM(1)**2)**2
- &-(2D0*XM(1)*XM(2))**2
- S23DF2=(X1-XM(3)**2-XM(5)**2)**2
- &-(2D0*XM(3)*XM(5))**2
- S23DF1=S23DF1*EPS
- S23DF2=S23DF2*EPS
- S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
- F1=-2D0*S23DEL/EPS
- S23DF1=(X2-XM(2)**2-XM(1)**2)**2
- &-(2D0*XM(1)*XM(2))**2
- S23DF2=(X2-XM(3)**2-XM(5)**2)**2
- &-(2D0*XM(3)*XM(5))**2
- S23DF1=S23DF1*EPS
- S23DF2=S23DF2*EPS
- S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
- F2=-2D0*S23DEL/EPS
-
- 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
-C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
- IF(F2.LE.F1)THEN
- X0=X1
- X1=X2
- X2=R*X1+C*X3
- F1=F2
- S23DF1=(X2-XM(2)**2-XM(1)**2)**2
- & -(2D0*XM(1)*XM(2))**2
- S23DF2=(X2-XM(3)**2-XM(5)**2)**2
- & -(2D0*XM(3)*XM(5))**2
- S23DF1=S23DF1*EPS
- S23DF2=S23DF2*EPS
- S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
- F2=-2D0*S23DEL/EPS
- ELSE
- X3=X2
- X2=X1
- X1=R*X2+C*X0
- F2=F1
- S23DF1=(X1-XM(2)**2-XM(1)**2)**2
- & -(2D0*XM(1)*XM(2))**2
- S23DF2=(X1-XM(3)**2-XM(5)**2)**2
- & -(2D0*XM(3)*XM(5))**2
- S23DF1=S23DF1*EPS
- S23DF2=S23DF2*EPS
- S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
- F1=-2D0*S23DEL/EPS
- ENDIF
- GOTO 170
- ENDIF
-C...WE WANT THE MAXIMUM, NOT THE MINIMUM
- IF(F1.LT.F2)THEN
- GOLDEN=-F1
- XMIN=X1
- ELSE
- GOLDEN=-F2
- XMIN=X2
- ENDIF
-
- IKNT=0
- 180 S12=S12MIN+PYR(0)*YJACO1
- IKNT=IKNT+1
-C...GENERATE S23
- S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
- &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
- S23DF1=(S12-XM(2)**2-XM(1)**2)**2
- &-(2D0*XM(1)*XM(2))**2
- S23DF2=(S12-XM(3)**2-XM(5)**2)**2
- &-(2D0*XM(3)*XM(5))**2
- S23DF1=S23DF1*EPS
- S23DF2=S23DF2*EPS
- S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
- S23DEL=S23DEL/EPS
- S23MIN=S23AVE-S23DEL
- S23MAX=S23AVE+S23DEL
- YJACO2=S23MAX-S23MIN
- S23=S23MIN+PYR(0)*YJACO2
-
-C...CHECK THE SAMPLING
- IF(IKNT.GT.100) THEN
- WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
- GOTO 190
- ENDIF
- IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
-
- IF(ISKIP.EQ.0) GOTO 190
-
- SH=S23
- TH=S12
- UH=ZM12+ZM22-SH-TH
-
- WU2 = (UH-ZM12)*(UH-ZM22)
- WT2 = (TH-ZM12)*(TH-ZM22)
- WS2 = XM1M2*SH
- PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
- PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
-
- QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
- QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
- QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
- QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
-c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
-c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
-c &/DCMPLX(TH-XML2)
-c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
-c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
-c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
- WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
- &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
- &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
-
- IF(WT.LT.PYR(0)*WTMAX) GOTO 180
- IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
-
- 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
- D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
- D2=XM(5)-D1-D3
- P1=SQRT(D1*D1-XM(1)**2)
- P2=SQRT(D2*D2-XM(2)**2)
- P3=SQRT(D3*D3-XM(3)**2)
- CTHE1=2D0*PYR(0)-1D0
- ANG1=2D0*PYR(0)*PARU(1)
- CPHI1=COS(ANG1)
- SPHI1=SIN(ANG1)
- ARG=1D0-CTHE1**2
- IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
- STHE1=SQRT(ARG)
- P(N+1,1)=P1*STHE1*CPHI1
- P(N+1,2)=P1*STHE1*SPHI1
- P(N+1,3)=P1*CTHE1
- P(N+1,4)=D1
-
-C...GET CPHI3
- ANG3=2D0*PYR(0)*PARU(1)
- CPHI3=COS(ANG3)
- SPHI3=SIN(ANG3)
- CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
- ARG=1D0-CTHE3**2
- IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
- STHE3=SQRT(ARG)
- P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
- &+P3*STHE3*SPHI3*SPHI1
- &+P3*CTHE3*STHE1*CPHI1
- P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
- &-P3*STHE3*SPHI3*CPHI1
- &+P3*CTHE3*STHE1*SPHI1
- P(N+3,3)=P3*STHE3*CPHI3*STHE1
- &+P3*CTHE3*CTHE1
- P(N+3,4)=D3
-
- DO 200 I=1,3
- P(N+2,I)=-P(N+1,I)-P(N+3,I)
- 200 CONTINUE
- P(N+2,4)=D2
-
- RETURN
- END
-
-
-C*********************************************************************
-
-C...PYTECM
-C...Finds the s-hat dependent eigenvalues of the inverse propagator
-C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
-C...phase space generation. Extended to include techni-a meson, and
-C...to return the width.
-
- SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
- SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
-
-C...Local variables.
- DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
- &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
- &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
- INTEGER i,j,ierr
-
- SH=SMIN
- SHR=SQRT(SH)
- AEM=PYALEM(SH)
-
- SINW=MIN(SQRT(PARU(102)),1D0)
- COSW=SQRT(1D0-SINW**2)
- TANW=SINW/COSW
- CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
- QUPD=2D0*RTCM(2)-1D0
-
- ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
- FAR=SQRT(AEM/ALPRHT)
- FAO=FAR*QUPD
- FZR=FAR*CT2W
- FZO=-FAO*TANW
- FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
- FWR=FAR/(2D0*SINW)
- FWX=-FWR/RTCM(47)
-
- DO 110 I=1,5
- DO 100 J=1,5
- AT(I,J)=0D0
- 100 CONTINUE
- 110 CONTINUE
-
-C...NC
- IF(IOPT.EQ.1) THEN
- AR(1,1) = SH
- AR(2,2) = SH-PMAS(23,1)**2
- AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
- AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
- AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
- AR(1,2) = 0D0
- AR(2,1) = 0D0
- AR(1,3) = SH*FAR
- AR(3,1) = AR(1,3)
- AR(1,4) = SH*FAO
- AR(4,1) = AR(1,4)
- AR(2,3) = SH*FZR
- AR(3,2) = AR(2,3)
- AR(2,4) = SH*FZO
- AR(4,2) = AR(2,4)
- AR(3,4) = 0D0
- AR(4,3) = 0D0
- AR(2,5) = SH*FZX
- AR(5,2) = AR(2,5)
- AR(1,5) = 0D0
- AR(5,1) = AR(1,5)
- AR(3,5) = 0D0
- AR(5,3) = AR(3,5)
- AR(4,5) = 0D0
- AR(5,4) = AR(4,5)
- CALL PYWIDT(23,SH,WDTP,WDTE)
- AT(2,2) = WDTP(0)*SHR
- CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
- AT(3,3) = WDTP(0)*SHR
- CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
- AT(4,4) = WDTP(0)*SHR
- CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
- AT(5,5) = WDTP(0)*SHR
- IDIM=5
-C...CC
- ELSE
- AR(1,1) = SH-PMAS(24,1)**2
- AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
- AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
- AR(1,2) = SH*FWR
- AR(2,1) = AR(1,2)
- AR(1,3) = SH*FWX
- AR(3,1) = AR(1,3)
- AR(2,3) = 0D0
- AR(3,2) = 0D0
- CALL PYWIDT(24,SH,WDTP,WDTE)
- AT(1,1) = WDTP(0)*SHR
- CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
- AT(2,2) = WDTP(0)*SHR
- CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
- AT(3,3) = WDTP(0)*SHR
- IDIM=3
- ENDIF
- CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
-
- IMIN=1
- SXMN=1D20
- DO 120 I=1,IDIM
- WX(I)=SQRT(ABS(SH-WR(I)))
- WR(I)=ABS(WR(I))
- IF(WR(I).LT.SXMN) THEN
- SXMN=WR(I)
- IMIN=I
- ENDIF
- 120 CONTINUE
- SMOU=WX(IMIN)**2
- WIDO=WI(IMIN)/SHR
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYEIGC
-C...Finds eigenvalues of a general complex matrix
-C
-C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
-C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
-C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
-C OF A COMPLEX GENERAL MATRIX.
-C
-C ON INPUT
-C
-C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
-C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
-C DIMENSION STATEMENT.
-C
-C N IS THE ORDER OF THE MATRIX A=(AR,AI).
-C
-C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
-C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
-C
-C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
-C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
-C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
-C
-C ON OUTPUT
-C
-C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
-C RESPECTIVELY, OF THE EIGENVALUES.
-C
-C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
-C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
-C
-C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
-C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
-C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
-C
-C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
-C
-C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
-C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
-C
-C THIS VERSION DATED AUGUST 1983.
-C
-
- SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
-
- INTEGER N,NM,IS1,IS2,IERR,MATZ
- DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
- X FV1(5),FV2(5),FV3(5)
- IF (N .LE. NM) GOTO 100
- IERR = 10 * N
- GOTO 120
-C
- 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
- CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
- IF (MATZ .NE. 0) GOTO 110
-C .......... FIND EIGENVALUES ONLY ..........
- CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
- GOTO 120
-C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
- 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
- IF (IERR .NE. 0) GOTO 120
- CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
- 120 RETURN
- END
-
-C*********************************************************************
-
-C...PYCMQR
-C...Auxiliary to PYEICG.
-C
-C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
-C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
-C AND WILKINSON.
-C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
-C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
-C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
-C
-C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
-C UPPER HESSENBERG MATRIX BY THE QR METHOD.
-C
-C ON INPUT
-C
-C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
-C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
-C DIMENSION STATEMENT.
-C
-C N IS THE ORDER OF THE MATRIX.
-C
-C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
-C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
-C SET LOW=1, IGH=N.
-C
-C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
-C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
-C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
-C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
-C THE REDUCTION BY CORTH, IF PERFORMED.
-C
-C ON OUTPUT
-C
-C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
-C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
-C CALLING COMQR IF SUBSEQUENT CALCULATION OF
-C EIGENVECTORS IS TO BE PERFORMED.
-C
-C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
-C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
-C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
-C FOR INDICES IERR+1,...,N.
-C
-C IERR IS SET TO
-C ZERO FOR NORMAL RETURN,
-C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
-C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
-C
-C CALLS PYCDIV FOR COMPLEX DIVISION.
-C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
-C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
-C
-C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
-C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
-C
-C THIS VERSION DATED AUGUST 1983.
-C
-
- SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
-
- INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
- DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
- DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
- X PYTHAG
-
- IERR = 0
- IF (LOW .EQ. IGH) GOTO 130
-C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
- L = LOW + 1
-C
- DO 120 I = L, IGH
- LL = MIN0(I+1,IGH)
- IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
- NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
- YR = HR(I,I-1) / NORM
- YI = HI(I,I-1) / NORM
- HR(I,I-1) = NORM
- HI(I,I-1) = 0.0D0
-C
- DO 100 J = I, IGH
- SI = YR * HI(I,J) - YI * HR(I,J)
- HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
- HI(I,J) = SI
- 100 CONTINUE
-C
- DO 110 J = LOW, LL
- SI = YR * HI(J,I) + YI * HR(J,I)
- HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
- HI(J,I) = SI
- 110 CONTINUE
-C
- 120 CONTINUE
-C .......... STORE ROOTS ISOLATED BY CBAL ..........
- 130 DO 140 I = 1, N
- IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
- WR(I) = HR(I,I)
- WI(I) = HI(I,I)
- 140 CONTINUE
-C
- EN = IGH
- TR = 0.0D0
- TI = 0.0D0
- ITN = 30*N
-C .......... SEARCH FOR NEXT EIGENVALUE ..........
- 150 IF (EN .LT. LOW) GOTO 320
- ITS = 0
- ENM1 = EN - 1
-C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
-C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
- 160 DO 170 LL = LOW, EN
- L = EN + LOW - LL
- IF (L .EQ. LOW) GOTO 180
- TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
- X + DABS(HR(L,L)) + DABS(HI(L,L))
- TST2 = TST1 + DABS(HR(L,L-1))
- IF (TST2 .EQ. TST1) GOTO 180
- 170 CONTINUE
-C .......... FORM SHIFT ..........
- 180 IF (L .EQ. EN) GOTO 300
- IF (ITN .EQ. 0) GOTO 310
- IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
- SR = HR(EN,EN)
- SI = HI(EN,EN)
- XR = HR(ENM1,EN) * HR(EN,ENM1)
- XI = HI(ENM1,EN) * HR(EN,ENM1)
- IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
- YR = (HR(ENM1,ENM1) - SR) / 2.0D0
- YI = (HI(ENM1,ENM1) - SI) / 2.0D0
- CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
- IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
- ZZR = -ZZR
- ZZI = -ZZI
- 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
- SR = SR - XR
- SI = SI - XI
- GOTO 210
-C .......... FORM EXCEPTIONAL SHIFT ..........
- 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
- SI = 0.0D0
-C
- 210 DO 220 I = LOW, EN
- HR(I,I) = HR(I,I) - SR
- HI(I,I) = HI(I,I) - SI
- 220 CONTINUE
-C
- TR = TR + SR
- TI = TI + SI
- ITS = ITS + 1
- ITN = ITN - 1
-C .......... REDUCE TO TRIANGLE (ROWS) ..........
- LP1 = L + 1
-C
- DO 240 I = LP1, EN
- SR = HR(I,I-1)
- HR(I,I-1) = 0.0D0
- NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
- XR = HR(I-1,I-1) / NORM
- WR(I-1) = XR
- XI = HI(I-1,I-1) / NORM
- WI(I-1) = XI
- HR(I-1,I-1) = NORM
- HI(I-1,I-1) = 0.0D0
- HI(I,I-1) = SR / NORM
-C
- DO 230 J = I, EN
- YR = HR(I-1,J)
- YI = HI(I-1,J)
- ZZR = HR(I,J)
- ZZI = HI(I,J)
- HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
- HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
- HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
- HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
- 230 CONTINUE
-C
- 240 CONTINUE
-C
- SI = HI(EN,EN)
- IF (SI .EQ. 0.0D0) GOTO 250
- NORM = PYTHAG(HR(EN,EN),SI)
- SR = HR(EN,EN) / NORM
- SI = SI / NORM
- HR(EN,EN) = NORM
- HI(EN,EN) = 0.0D0
-C .......... INVERSE OPERATION (COLUMNS) ..........
- 250 DO 280 J = LP1, EN
- XR = WR(J-1)
- XI = WI(J-1)
-C
- DO 270 I = L, J
- YR = HR(I,J-1)
- YI = 0.0D0
- ZZR = HR(I,J)
- ZZI = HI(I,J)
- IF (I .EQ. J) GOTO 260
- YI = HI(I,J-1)
- HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
- 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
- HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
- HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
- 270 CONTINUE
-C
- 280 CONTINUE
-C
- IF (SI .EQ. 0.0D0) GOTO 160
-C
- DO 290 I = L, EN
- YR = HR(I,EN)
- YI = HI(I,EN)
- HR(I,EN) = SR * YR - SI * YI
- HI(I,EN) = SR * YI + SI * YR
- 290 CONTINUE
-C
- GOTO 160
-C .......... A ROOT FOUND ..........
- 300 WR(EN) = HR(EN,EN) + TR
- WI(EN) = HI(EN,EN) + TI
- EN = ENM1
- GOTO 150
-C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
-C CONVERGED AFTER 30*N ITERATIONS ..........
- 310 IERR = EN
- 320 RETURN
- END
-
-C*********************************************************************
-
-C...PYCMQ2
-C...Auxiliary to PYEICG.
-C
-C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
-C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
-C AND WILKINSON.
-C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
-C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
-C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
-C
-C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
-C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
-C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
-C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
-C THIS GENERAL MATRIX TO HESSENBERG FORM.
-C
-C ON INPUT
-C
-C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
-C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
-C DIMENSION STATEMENT.
-C
-C N IS THE ORDER OF THE MATRIX.
-C
-C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
-C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
-C SET LOW=1, IGH=N.
-C
-C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
-C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
-C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
-C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
-C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
-C
-C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
-C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
-C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
-C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
-C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
-C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
-C ARBITRARY.
-C
-C ON OUTPUT
-C
-C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
-C HAVE BEEN DESTROYED.
-C
-C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
-C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
-C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
-C FOR INDICES IERR+1,...,N.
-C
-C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
-C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
-C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
-C THE EIGENVECTORS HAS BEEN FOUND.
-C
-C IERR IS SET TO
-C ZERO FOR NORMAL RETURN,
-C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
-C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
-C
-C CALLS PYCDIV FOR COMPLEX DIVISION.
-C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
-C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
-C
-C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
-C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
-C
-C THIS VERSION DATED OCTOBER 1989.
-C
-C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
-C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
-C
-
- SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
-
- INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
- X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
- DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
- X ORTR(5),ORTI(5)
- DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
- X PYTHAG
-
- IERR = 0
-C .......... INITIALIZE EIGENVECTOR MATRIX ..........
- DO 110 J = 1, N
-C
- DO 100 I = 1, N
- ZR(I,J) = 0.0D0
- ZI(I,J) = 0.0D0
- 100 CONTINUE
- ZR(J,J) = 1.0D0
- 110 CONTINUE
-C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
-C FROM THE INFORMATION LEFT BY CORTH ..........
- IEND = IGH - LOW - 1
- IF (IEND.LT.0) GOTO 220
- IF (IEND.EQ.0) GOTO 170
-C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
- DO 160 II = 1, IEND
- I = IGH - II
- IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
- IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
-C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
- NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
- IP1 = I + 1
-C
- DO 120 K = IP1, IGH
- ORTR(K) = HR(K,I-1)
- ORTI(K) = HI(K,I-1)
- 120 CONTINUE
-C
- DO 150 J = I, IGH
- SR = 0.0D0
- SI = 0.0D0
-C
- DO 130 K = I, IGH
- SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
- SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
- 130 CONTINUE
-C
- SR = SR / NORM
- SI = SI / NORM
-C
- DO 140 K = I, IGH
- ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
- ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
- 140 CONTINUE
-C
- 150 CONTINUE
-C
- 160 CONTINUE
-C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
- 170 L = LOW + 1
-C
- DO 210 I = L, IGH
- LL = MIN0(I+1,IGH)
- IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
- NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
- YR = HR(I,I-1) / NORM
- YI = HI(I,I-1) / NORM
- HR(I,I-1) = NORM
- HI(I,I-1) = 0.0D0
-C
- DO 180 J = I, N
- SI = YR * HI(I,J) - YI * HR(I,J)
- HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
- HI(I,J) = SI
- 180 CONTINUE
-C
- DO 190 J = 1, LL
- SI = YR * HI(J,I) + YI * HR(J,I)
- HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
- HI(J,I) = SI
- 190 CONTINUE
-C
- DO 200 J = LOW, IGH
- SI = YR * ZI(J,I) + YI * ZR(J,I)
- ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
- ZI(J,I) = SI
- 200 CONTINUE
-C
- 210 CONTINUE
-C .......... STORE ROOTS ISOLATED BY CBAL ..........
- 220 DO 230 I = 1, N
- IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
- WR(I) = HR(I,I)
- WI(I) = HI(I,I)
- 230 CONTINUE
-C
- EN = IGH
- TR = 0.0D0
- TI = 0.0D0
- ITN = 30*N
-C .......... SEARCH FOR NEXT EIGENVALUE ..........
- 240 IF (EN .LT. LOW) GOTO 430
- ITS = 0
- ENM1 = EN - 1
-C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
-C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
- 250 DO 260 LL = LOW, EN
- L = EN + LOW - LL
- IF (L .EQ. LOW) GOTO 270
- TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
- X + DABS(HR(L,L)) + DABS(HI(L,L))
- TST2 = TST1 + DABS(HR(L,L-1))
- IF (TST2 .EQ. TST1) GOTO 270
- 260 CONTINUE
-C .......... FORM SHIFT ..........
- 270 IF (L .EQ. EN) GOTO 420
- IF (ITN .EQ. 0) GOTO 550
- IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
- SR = HR(EN,EN)
- SI = HI(EN,EN)
- XR = HR(ENM1,EN) * HR(EN,ENM1)
- XI = HI(ENM1,EN) * HR(EN,ENM1)
- IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
- YR = (HR(ENM1,ENM1) - SR) / 2.0D0
- YI = (HI(ENM1,ENM1) - SI) / 2.0D0
- CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
- IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
- ZZR = -ZZR
- ZZI = -ZZI
- 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
- SR = SR - XR
- SI = SI - XI
- GOTO 300
-C .......... FORM EXCEPTIONAL SHIFT ..........
- 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
- SI = 0.0D0
-C
- 300 DO 310 I = LOW, EN
- HR(I,I) = HR(I,I) - SR
- HI(I,I) = HI(I,I) - SI
- 310 CONTINUE
-C
- TR = TR + SR
- TI = TI + SI
- ITS = ITS + 1
- ITN = ITN - 1
-C .......... REDUCE TO TRIANGLE (ROWS) ..........
- LP1 = L + 1
-C
- DO 330 I = LP1, EN
- SR = HR(I,I-1)
- HR(I,I-1) = 0.0D0
- NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
- XR = HR(I-1,I-1) / NORM
- WR(I-1) = XR
- XI = HI(I-1,I-1) / NORM
- WI(I-1) = XI
- HR(I-1,I-1) = NORM
- HI(I-1,I-1) = 0.0D0
- HI(I,I-1) = SR / NORM
-C
- DO 320 J = I, N
- YR = HR(I-1,J)
- YI = HI(I-1,J)
- ZZR = HR(I,J)
- ZZI = HI(I,J)
- HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
- HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
- HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
- HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
- 320 CONTINUE
-C
- 330 CONTINUE
-C
- SI = HI(EN,EN)
- IF (SI .EQ. 0.0D0) GOTO 350
- NORM = PYTHAG(HR(EN,EN),SI)
- SR = HR(EN,EN) / NORM
- SI = SI / NORM
- HR(EN,EN) = NORM
- HI(EN,EN) = 0.0D0
- IF (EN .EQ. N) GOTO 350
- IP1 = EN + 1
-C
- DO 340 J = IP1, N
- YR = HR(EN,J)
- YI = HI(EN,J)
- HR(EN,J) = SR * YR + SI * YI
- HI(EN,J) = SR * YI - SI * YR
- 340 CONTINUE
-C .......... INVERSE OPERATION (COLUMNS) ..........
- 350 DO 390 J = LP1, EN
- XR = WR(J-1)
- XI = WI(J-1)
-C
- DO 370 I = 1, J
- YR = HR(I,J-1)
- YI = 0.0D0
- ZZR = HR(I,J)
- ZZI = HI(I,J)
- IF (I .EQ. J) GOTO 360
- YI = HI(I,J-1)
- HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
- 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
- HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
- HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
- 370 CONTINUE
-C
- DO 380 I = LOW, IGH
- YR = ZR(I,J-1)
- YI = ZI(I,J-1)
- ZZR = ZR(I,J)
- ZZI = ZI(I,J)
- ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
- ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
- ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
- ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
- 380 CONTINUE
-C
- 390 CONTINUE
-C
- IF (SI .EQ. 0.0D0) GOTO 250
-C
- DO 400 I = 1, EN
- YR = HR(I,EN)
- YI = HI(I,EN)
- HR(I,EN) = SR * YR - SI * YI
- HI(I,EN) = SR * YI + SI * YR
- 400 CONTINUE
-C
- DO 410 I = LOW, IGH
- YR = ZR(I,EN)
- YI = ZI(I,EN)
- ZR(I,EN) = SR * YR - SI * YI
- ZI(I,EN) = SR * YI + SI * YR
- 410 CONTINUE
-C
- GOTO 250
-C .......... A ROOT FOUND ..........
- 420 HR(EN,EN) = HR(EN,EN) + TR
- WR(EN) = HR(EN,EN)
- HI(EN,EN) = HI(EN,EN) + TI
- WI(EN) = HI(EN,EN)
- EN = ENM1
- GOTO 240
-C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
-C VECTORS OF UPPER TRIANGULAR FORM ..........
- 430 NORM = 0.0D0
-C
- DO 440 I = 1, N
-C
- DO 440 J = I, N
- TR = DABS(HR(I,J)) + DABS(HI(I,J))
- IF (TR .GT. NORM) NORM = TR
- 440 CONTINUE
-C
- IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
-C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
- DO 500 NN = 2, N
- EN = N + 2 - NN
- XR = WR(EN)
- XI = WI(EN)
- HR(EN,EN) = 1.0D0
- HI(EN,EN) = 0.0D0
- ENM1 = EN - 1
-C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
- DO 490 II = 1, ENM1
- I = EN - II
- ZZR = 0.0D0
- ZZI = 0.0D0
- IP1 = I + 1
-C
- DO 450 J = IP1, EN
- ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
- ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
- 450 CONTINUE
-C
- YR = XR - WR(I)
- YI = XI - WI(I)
- IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
- TST1 = NORM
- YR = TST1
- 460 YR = 0.01D0 * YR
- TST2 = NORM + YR
- IF (TST2 .GT. TST1) GOTO 460
- 470 CONTINUE
- CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
-C .......... OVERFLOW CONTROL ..........
- TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
- IF (TR .EQ. 0.0D0) GOTO 490
- TST1 = TR
- TST2 = TST1 + 1.0D0/TST1
- IF (TST2 .GT. TST1) GOTO 490
- DO 480 J = I, EN
- HR(J,EN) = HR(J,EN)/TR
- HI(J,EN) = HI(J,EN)/TR
- 480 CONTINUE
-C
- 490 CONTINUE
-C
- 500 CONTINUE
-C .......... END BACKSUBSTITUTION ..........
-C .......... VECTORS OF ISOLATED ROOTS ..........
- DO 520 I = 1, N
- IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
-C
- DO 510 J = I, N
- ZR(I,J) = HR(I,J)
- ZI(I,J) = HI(I,J)
- 510 CONTINUE
-C
- 520 CONTINUE
-C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
-C VECTORS OF ORIGINAL FULL MATRIX.
-C FOR J=N STEP -1 UNTIL LOW DO -- ..........
- DO 540 JJ = LOW, N
- J = N + LOW - JJ
- M = MIN0(J,IGH)
-C
- DO 540 I = LOW, IGH
- ZZR = 0.0D0
- ZZI = 0.0D0
-C
- DO 530 K = LOW, M
- ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
- ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
- 530 CONTINUE
-C
- ZR(I,J) = ZZR
- ZI(I,J) = ZZI
- 540 CONTINUE
-C
- GOTO 560
-C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
-C CONVERGED AFTER 30*N ITERATIONS ..........
- 550 IERR = EN
- 560 RETURN
- END
-
-C*********************************************************************
-
-C...PYCDIV
-C...Auxiliary to PYCMQR
-C
-C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
-C
-
- SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
-
- DOUBLE PRECISION AR,AI,BR,BI,CR,CI
- DOUBLE PRECISION S,ARS,AIS,BRS,BIS
-
- S = DABS(BR) + DABS(BI)
- ARS = AR/S
- AIS = AI/S
- BRS = BR/S
- BIS = BI/S
- S = BRS**2 + BIS**2
- CR = (ARS*BRS + AIS*BIS)/S
- CI = (AIS*BRS - ARS*BIS)/S
- RETURN
- END
-
-C*********************************************************************
-
-C...PYCSRT
-C...Auxiliary to PYCMQR
-C
-C (YR,YI) = COMPLEX DSQRT(XR,XI)
-C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
-C
-
- SUBROUTINE PYCSRT(XR,XI,YR,YI)
-
- DOUBLE PRECISION XR,XI,YR,YI
- DOUBLE PRECISION S,TR,TI,PYTHAG
-
- TR = XR
- TI = XI
- S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
- IF (TR .GE. 0.0D0) YR = S
- IF (TI .LT. 0.0D0) S = -S
- IF (TR .LE. 0.0D0) YI = S
- IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
- IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
- RETURN
- END
-
- DOUBLE PRECISION FUNCTION PYTHAG(A,B)
- DOUBLE PRECISION A,B
-C
-C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
-C
- DOUBLE PRECISION P,R,S,T,U
- P = DMAX1(DABS(A),DABS(B))
- IF (P .EQ. 0.0D0) GOTO 110
- R = (DMIN1(DABS(A),DABS(B))/P)**2
- 100 CONTINUE
- T = 4.0D0 + R
- IF (T .EQ. 4.0D0) GOTO 110
- S = R/T
- U = 1.0D0 + 2.0D0*S
- P = U*P
- R = (S/U)**2 * R
- GOTO 100
- 110 PYTHAG = P
- RETURN
- END
-
-C*********************************************************************
-
-C...PYCBAL
-C...Auxiliary to PYEICG
-C
-C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
-C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
-C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
-C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
-C
-C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
-C EIGENVALUES WHENEVER POSSIBLE.
-C
-C ON INPUT
-C
-C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
-C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
-C DIMENSION STATEMENT.
-C
-C N IS THE ORDER OF THE MATRIX.
-C
-C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
-C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
-C
-C ON OUTPUT
-C
-C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
-C RESPECTIVELY, OF THE BALANCED MATRIX.
-C
-C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
-C ARE EQUAL TO ZERO IF
-C (1) I IS GREATER THAN J AND
-C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
-C
-C SCALE CONTAINS INFORMATION DETERMINING THE
-C PERMUTATIONS AND SCALING FACTORS USED.
-C
-C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
-C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
-C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
-C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
-C SCALE(J) = P(J), FOR J = 1,...,LOW-1
-C = D(J,J) J = LOW,...,IGH
-C = P(J) J = IGH+1,...,N.
-C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
-C THEN 1 TO LOW-1.
-C
-C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
-C
-C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
-C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
-C K,L HAVE BEEN REVERSED.)
-C
-C ARITHMETIC IS REAL THROUGHOUT.
-C
-C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
-C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
-C
-C THIS VERSION DATED AUGUST 1983.
-C
-
- SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
-
- INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
- DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
- DOUBLE PRECISION C,F,G,R,S,B2,RADIX
- LOGICAL NOCONV
-
- RADIX = 16.0D0
-C
- B2 = RADIX * RADIX
- K = 1
- L = N
- GOTO 150
-C .......... IN-LINE PROCEDURE FOR ROW AND
-C COLUMN EXCHANGE ..........
- 100 SCALE(M) = J
- IF (J .EQ. M) GOTO 130
-C
- DO 110 I = 1, L
- F = AR(I,J)
- AR(I,J) = AR(I,M)
- AR(I,M) = F
- F = AI(I,J)
- AI(I,J) = AI(I,M)
- AI(I,M) = F
- 110 CONTINUE
-C
- DO 120 I = K, N
- F = AR(J,I)
- AR(J,I) = AR(M,I)
- AR(M,I) = F
- F = AI(J,I)
- AI(J,I) = AI(M,I)
- AI(M,I) = F
- 120 CONTINUE
-C
- 130 IF(IEXC.EQ.1) GOTO 140
- IF(IEXC.EQ.2) GOTO 180
-C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
-C AND PUSH THEM DOWN ..........
- 140 IF (L .EQ. 1) GOTO 320
- L = L - 1
-C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
- 150 DO 170 JJ = 1, L
- J = L + 1 - JJ
-C
- DO 160 I = 1, L
- IF (I .EQ. J) GOTO 160
- IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
- 160 CONTINUE
-C
- M = L
- IEXC = 1
- GOTO 100
- 170 CONTINUE
-C
- GOTO 190
-C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
-C AND PUSH THEM LEFT ..........
- 180 K = K + 1
-C
- 190 DO 210 J = K, L
-C
- DO 200 I = K, L
- IF (I .EQ. J) GOTO 200
- IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
- 200 CONTINUE
-C
- M = K
- IEXC = 2
- GOTO 100
- 210 CONTINUE
-C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
- DO 220 I = K, L
- 220 SCALE(I) = 1.0D0
-C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
- 230 NOCONV = .FALSE.
-C
- DO 310 I = K, L
- C = 0.0D0
- R = 0.0D0
-C
- DO 240 J = K, L
- IF (J .EQ. I) GOTO 240
- C = C + DABS(AR(J,I)) + DABS(AI(J,I))
- R = R + DABS(AR(I,J)) + DABS(AI(I,J))
- 240 CONTINUE
-C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
- IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
- G = R / RADIX
- F = 1.0D0
- S = C + R
- 250 IF (C .GE. G) GOTO 260
- F = F * RADIX
- C = C * B2
- GOTO 250
- 260 G = R * RADIX
- 270 IF (C .LT. G) GOTO 280
- F = F / RADIX
- C = C / B2
- GOTO 270
-C .......... NOW BALANCE ..........
- 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
- G = 1.0D0 / F
- SCALE(I) = SCALE(I) * F
- NOCONV = .TRUE.
-C
- DO 290 J = K, N
- AR(I,J) = AR(I,J) * G
- AI(I,J) = AI(I,J) * G
- 290 CONTINUE
-C
- DO 300 J = 1, L
- AR(J,I) = AR(J,I) * F
- AI(J,I) = AI(J,I) * F
- 300 CONTINUE
-C
- 310 CONTINUE
-C
- IF (NOCONV) GOTO 230
-C
- 320 LOW = K
- IGH = L
- RETURN
- END
-
-C*********************************************************************
-
-C...PYCBA2
-C...Auxiliary to PYEICG.
-C
-C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
-C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
-C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
-C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
-C
-C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
-C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
-C BALANCED MATRIX DETERMINED BY CBAL.
-C
-C ON INPUT
-C
-C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
-C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
-C DIMENSION STATEMENT.
-C
-C N IS THE ORDER OF THE MATRIX.
-C
-C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
-C
-C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
-C AND SCALING FACTORS USED BY CBAL.
-C
-C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
-C
-C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
-C RESPECTIVELY, OF THE EIGENVECTORS TO BE
-C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
-C
-C ON OUTPUT
-C
-C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
-C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
-C IN THEIR FIRST M COLUMNS.
-C
-C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
-C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
-C
-C THIS VERSION DATED AUGUST 1983.
-C
-
- SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
-
- INTEGER I,J,K,M,N,II,NM,IGH,LOW
- DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
- DOUBLE PRECISION S
-
- IF (M .EQ. 0) GOTO 150
- IF (IGH .EQ. LOW) GOTO 120
-C
- DO 110 I = LOW, IGH
- S = SCALE(I)
-C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
-C IF THE FOREGOING STATEMENT IS REPLACED BY
-C S=1.0D0/SCALE(I). ..........
- DO 100 J = 1, M
- ZR(I,J) = ZR(I,J) * S
- ZI(I,J) = ZI(I,J) * S
- 100 CONTINUE
-C
- 110 CONTINUE
-C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
-C IGH+1 STEP 1 UNTIL N DO -- ..........
- 120 DO 140 II = 1, N
- I = II
- IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
- IF (I .LT. LOW) I = LOW - II
- K = SCALE(I)
- IF (K .EQ. I) GOTO 140
-C
- DO 130 J = 1, M
- S = ZR(I,J)
- ZR(I,J) = ZR(K,J)
- ZR(K,J) = S
- S = ZI(I,J)
- ZI(I,J) = ZI(K,J)
- ZI(K,J) = S
- 130 CONTINUE
-C
- 140 CONTINUE
-C
- 150 RETURN
- END
-
-C*********************************************************************
-
-C...PYCRTH
-C...Auxiliary to PYEICG.
-C
-C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
-C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
-C BY MARTIN AND WILKINSON.
-C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
-C
-C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
-C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
-C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
-C UNITARY SIMILARITY TRANSFORMATIONS.
-C
-C ON INPUT
-C
-C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
-C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
-C DIMENSION STATEMENT.
-C
-C N IS THE ORDER OF THE MATRIX.
-C
-C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
-C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
-C SET LOW=1, IGH=N.
-C
-C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
-C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
-C
-C ON OUTPUT
-C
-C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
-C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
-C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
-C IS STORED IN THE REMAINING TRIANGLES UNDER THE
-C HESSENBERG MATRIX.
-C
-C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
-C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
-C
-C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
-C
-C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
-C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
-C
-C THIS VERSION DATED AUGUST 1983.
-C
-
- SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
-
- INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
- DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
- DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
-
- LA = IGH - 1
- KP1 = LOW + 1
- IF (LA .LT. KP1) GOTO 210
-C
- DO 200 M = KP1, LA
- H = 0.0D0
- ORTR(M) = 0.0D0
- ORTI(M) = 0.0D0
- SCALE = 0.0D0
-C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
- DO 100 I = M, IGH
- 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
-C
- IF (SCALE .EQ. 0.0D0) GOTO 200
- MP = M + IGH
-C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
- DO 110 II = M, IGH
- I = MP - II
- ORTR(I) = AR(I,M-1) / SCALE
- ORTI(I) = AI(I,M-1) / SCALE
- H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
- 110 CONTINUE
-C
- G = DSQRT(H)
- F = PYTHAG(ORTR(M),ORTI(M))
- IF (F .EQ. 0.0D0) GOTO 120
- H = H + F * G
- G = G / F
- ORTR(M) = (1.0D0 + G) * ORTR(M)
- ORTI(M) = (1.0D0 + G) * ORTI(M)
- GOTO 130
-C
- 120 ORTR(M) = G
- AR(M,M-1) = SCALE
-C .......... FORM (I-(U*UT)/H) * A ..........
- 130 DO 160 J = M, N
- FR = 0.0D0
- FI = 0.0D0
-C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
- DO 140 II = M, IGH
- I = MP - II
- FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
- FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
- 140 CONTINUE
-C
- FR = FR / H
- FI = FI / H
-C
- DO 150 I = M, IGH
- AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
- AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
- 150 CONTINUE
-C
- 160 CONTINUE
-C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
- DO 190 I = 1, IGH
- FR = 0.0D0
- FI = 0.0D0
-C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
- DO 170 JJ = M, IGH
- J = MP - JJ
- FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
- FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
- 170 CONTINUE
-C
- FR = FR / H
- FI = FI / H
-C
- DO 180 J = M, IGH
- AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
- AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
- 180 CONTINUE
-C
- 190 CONTINUE
-C
- ORTR(M) = SCALE * ORTR(M)
- ORTI(M) = SCALE * ORTI(M)
- AR(M,M-1) = -G * AR(M,M-1)
- AI(M,M-1) = -G * AI(M,M-1)
- 200 CONTINUE
-C
- 210 RETURN
- END
-
-C*********************************************************************
-
-C...PYLDCM
-C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
-C...processes.
-
- SUBROUTINE PYLDCM(A,N,NP,INDX,D)
- IMPLICIT NONE
- INTEGER N,NP,INDX(N)
- REAL*8 D,TINY
- COMPLEX*16 A(NP,NP)
- PARAMETER (TINY=1.0D-20)
- INTEGER I,IMAX,J,K
- REAL*8 AAMAX,VV(6),DUM
- COMPLEX*16 SUM,DUMC
-
- D=1D0
- DO 110 I=1,N
- AAMAX=0D0
- DO 100 J=1,N
- IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
- 100 CONTINUE
- IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
- VV(I)=1D0/AAMAX
- 110 CONTINUE
- DO 180 J=1,N
- DO 130 I=1,J-1
- SUM=A(I,J)
- DO 120 K=1,I-1
- SUM=SUM-A(I,K)*A(K,J)
- 120 CONTINUE
- A(I,J)=SUM
- 130 CONTINUE
- AAMAX=0D0
- DO 150 I=J,N
- SUM=A(I,J)
- DO 140 K=1,J-1
- SUM=SUM-A(I,K)*A(K,J)
- 140 CONTINUE
- A(I,J)=SUM
- DUM=VV(I)*ABS(SUM)
- IF (DUM.GE.AAMAX) THEN
- IMAX=I
- AAMAX=DUM
- ENDIF
- 150 CONTINUE
- IF (J.NE.IMAX)THEN
- DO 160 K=1,N
- DUMC=A(IMAX,K)
- A(IMAX,K)=A(J,K)
- A(J,K)=DUMC
- 160 CONTINUE
- D=-D
- VV(IMAX)=VV(J)
- ENDIF
- INDX(J)=IMAX
- IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
- IF(J.NE.N)THEN
- DO 170 I=J+1,N
- A(I,J)=A(I,J)/A(J,J)
- 170 CONTINUE
- ENDIF
- 180 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYBKSB
-C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
-C...processes.
-
- SUBROUTINE PYBKSB(A,N,NP,INDX,B)
- IMPLICIT NONE
- INTEGER N,NP,INDX(N)
- COMPLEX*16 A(NP,NP),B(N)
- INTEGER I,II,J,LL
- COMPLEX*16 SUM
-
- II=0
- DO 110 I=1,N
- LL=INDX(I)
- SUM=B(LL)
- B(LL)=B(I)
- IF (II.NE.0)THEN
- DO 100 J=II,I-1
- SUM=SUM-A(I,J)*B(J)
- 100 CONTINUE
- ELSE IF (ABS(SUM).NE.0D0) THEN
- II=I
- ENDIF
- B(I)=SUM
- 110 CONTINUE
- DO 130 I=N,1,-1
- SUM=B(I)
- DO 120 J=I+1,N
- SUM=SUM-A(I,J)*B(J)
- 120 CONTINUE
- B(I)=SUM/A(I,I)
- 130 CONTINUE
- RETURN
- END
-
-C***********************************************************************
-
-C...PYWIDX
-C...Calculates full and partial widths of resonances.
-C....copy of PYWIDT, used for techniparticle widths
-
- SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
- &/PYINT4/,/PYMSSM/,/PYTCSM/
-C...Local arrays and saved variables.
- DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
- &WID2SV(3,2)
- SAVE MOFSV,WIDWSV,WID2SV
- DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
-
-C...Compressed code and sign; mass.
- KFLA=IABS(KFLR)
- KFLS=ISIGN(1,KFLR)
- KC=PYCOMP(KFLA)
- SHR=SQRT(SH)
- PMR=PMAS(KC,1)
-
-C...Reset width information.
- DO I=0,400
- WDTP(I)=0D0
- ENDDO
-
-C...Common electroweak and strong constants.
- XW=PARU(102)
- XWV=XW
- IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
- XW1=1D0-XW
- AEM=PYALEM(SH)
- IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
- AS=PYALPS(SH)
- RADC=1D0+AS/PARU(1)
-
- IF(KFLA.EQ.23) THEN
-C...Z0:
- XWC=1D0/(16D0*XW*XW1)
- FAC=(AEM*XWC/3D0)*SHR
- 120 CONTINUE
- DO 130 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 130
- RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
- IF(I.LE.8) THEN
-C...Z0 -> q + qbar
- EF=KCHG(I,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- FCOF=3D0*RADC
- IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
- ELSEIF(I.LE.16) THEN
-C...Z0 -> l+ + l-, nu + nubar
- EF=KCHG(I+2,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*XWV
- FCOF=1D0
- ENDIF
- BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
- WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
- & BE34
- WDTP(0)=WDTP(0)+WDTP(I)
- 130 CONTINUE
-
-
- ELSEIF(KFLA.EQ.24) THEN
-C...W+/-:
- FAC=(AEM/(24D0*XW))*SHR
- DO 140 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 140
- RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
- RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
- IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
- WID2=1D0
- IF(I.LE.16) THEN
-C...W+/- -> q + qbar'
- FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
- ELSEIF(I.LE.20) THEN
-C...W+/- -> l+/- + nu
- FCOF=1D0
- ENDIF
- WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
- & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
- WDTP(0)=WDTP(0)+WDTP(I)
- 140 CONTINUE
-
-C.....V8 -> quark anti-quark
- ELSEIF(KFLA.EQ.KTECHN+100021) THEN
- FAC=AS/6D0*SHR
- TANT3=RTCM(21)
- IF(ITCM(2).EQ.0) THEN
- IMDL=1
- ELSEIF(ITCM(2).EQ.1) THEN
- IMDL=2
- ENDIF
- DO 150 I=1,MDCY(KC,3)
- IDC=I+MDCY(KC,2)-1
- IF(MDME(IDC,1).LT.0) GOTO 150
- PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
- RM1=PM1**2/SH
- IF(RM1.GT.0.25D0) GOTO 150
- WID2=1D0
- IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
- FMIX=1D0/TANT3**2
- ELSE
- FMIX=TANT3**2
- ENDIF
- WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
- IF(I.EQ.6) WID2=WIDS(6,1)
- WDTP(0)=WDTP(0)+WDTP(I)
- 150 CONTINUE
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRVSF
-C...Calculates R-violating decays of sfermions.
-C...P. Z. Skands
-
- SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
-C...Local variables.
- DOUBLE PRECISION XLAM(0:400)
- INTEGER IDLAM(400,3), PYCOMP
- SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
-
-C...IS R-VIOLATION ON ?
- IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
-C...Mass eigenstate counter
- ICNT=INT(KFIN/KSUSY1)
-C...SM KF code of SUSY particle
- KFSM=KFIN-ICNT*KSUSY1
-C...Squared Sparticle Mass
- SM=PMAS(PYCOMP(KFIN),1)**2
-C... Squared mass of top quark
- SMT=PMAS(PYCOMP(6),1)**2
-C...IS L-VIOLATION ON ?
- IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
-C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
- IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
- & THEN
- K=INT((KFSM-9)/2)
- DO 110 I=1,3
- DO 100 J=1,3
- IF(I.NE.J) THEN
-C...~e,~mu,~tau -> nu_I + lepton-_J
- LKNT = LKNT+1
- IDLAM(LKNT,1)= 12 +2*(I-1)
- IDLAM(LKNT,2)= 11 +2*(J-1)
- IDLAM(LKNT,3)= 0
- XLAM(LKNT)=0D0
- RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
- IF (IMSS(51).NE.0) XLAM(LKNT) =
- & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
- ENDIF
- 100 CONTINUE
- 110 CONTINUE
-C...~e,~mu,~tau -> nu_Ibar + lepton-_K
- J=INT((KFSM-9)/2)
- DO 130 I=1,3
- IF(I.NE.J) THEN
- DO 120 K=1,3
- LKNT = LKNT+1
- IDLAM(LKNT,1)=-12 -2*(I-1)
- IDLAM(LKNT,2)= 11 +2*(K-1)
- IDLAM(LKNT,3)= 0
- XLAM(LKNT)=0D0
- RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
- IF (IMSS(51).NE.0) XLAM(LKNT) =
- & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
- 120 CONTINUE
- ENDIF
- 130 CONTINUE
-C...~e,~mu,~tau -> u_Jbar + d_K
- I=INT((KFSM-9)/2)
- DO 150 J=1,3
- DO 140 K=1,3
- LKNT = LKNT+1
- IDLAM(LKNT,1)=-2 -2*(J-1)
- IDLAM(LKNT,2)= 1 +2*(K-1)
- IDLAM(LKNT,3)= 0
- XLAM(LKNT)=0
- IF (IMSS(52).NE.0) THEN
-C...Use massive top quark
- IF (IDLAM(LKNT,1).EQ.-6) THEN
- RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
- & * (SM-SMT)
- XLAM(LKNT) =
- & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
-C...If no top quark, all decay products massless
- ELSE
- RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
- XLAM(LKNT) =
- & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
- ENDIF
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
- ENDIF
- 140 CONTINUE
- 150 CONTINUE
- ENDIF
-C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
-C...No right-handed neutrinos
- IF(ICNT.EQ.1) THEN
- IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
- J=INT((KFSM-10)/2)
- DO 170 I=1,3
- DO 160 K=1,3
- IF (I.NE.J) THEN
-C...~nu_J -> lepton+_I + lepton-_K
- LKNT = LKNT+1
- IDLAM(LKNT,1)=-11 -2*(I-1)
- IDLAM(LKNT,2)= 11 +2*(K-1)
- IDLAM(LKNT,3)= 0
- XLAM(LKNT)=0D0
- RM2=RVLAM(I,J,K)**2 * SM
- IF (IMSS(51).NE.0) XLAM(LKNT) =
- & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
- ENDIF
- 160 CONTINUE
- 170 CONTINUE
-C...~nu_I -> dbar_J + d_K
- I=INT((KFSM-10)/2)
- DO 190 J=1,3
- DO 180 K=1,3
- LKNT = LKNT+1
- IDLAM(LKNT,1)=-1 -2*(J-1)
- IDLAM(LKNT,2)= 1 +2*(K-1)
- IDLAM(LKNT,3)= 0
- XLAM(LKNT)=0D0
- RM2=3*RVLAMP(I,J,K)**2 * SM
- IF (IMSS(52).NE.0) XLAM(LKNT) =
- & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
- 180 CONTINUE
- 190 CONTINUE
- ENDIF
- ENDIF
-C * SDOWN -> NU(BAR) + D and LEPTON- + U
- IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
- J=INT((KFSM+1)/2)
- DO 210 I=1,3
- DO 200 K=1,3
-C...~d_J -> nu_Ibar + d_K
- LKNT = LKNT+1
- IDLAM(LKNT,1)=-12 -2*(I-1)
- IDLAM(LKNT,2)= 1 +2*(K-1)
- IDLAM(LKNT,3)= 0
- XLAM(LKNT)=0D0
- RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
- IF (IMSS(52).NE.0) XLAM(LKNT) =
- & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
- 200 CONTINUE
- 210 CONTINUE
- K=INT((KFSM+1)/2)
- DO 240 I=1,3
- DO 230 J=1,3
-C...~d_K -> nu_I + d_J
- LKNT = LKNT+1
- IDLAM(LKNT,1)= 12 +2*(I-1)
- IDLAM(LKNT,2)= 1 +2*(J-1)
- IDLAM(LKNT,3)= 0
- XLAM(LKNT)=0D0
- RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
- IF (IMSS(52).NE.0) XLAM(LKNT) =
- & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
-C...~d_K -> lepton_I- + u_J
- 220 LKNT = LKNT+1
- IDLAM(LKNT,1)= 11 +2*(I-1)
- IDLAM(LKNT,2)= 2 +2*(J-1)
- IDLAM(LKNT,3)= 0
- XLAM(LKNT)=0D0
- IF (IMSS(52).NE.0) THEN
-C...Use massive top quark
- IF (IDLAM(LKNT,2).EQ.6) THEN
- RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
- XLAM(LKNT) =
- & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
-C...If no top quark, all decay products massless
- ELSE
- RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
- XLAM(LKNT) =
- & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
- ENDIF
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
- ENDIF
- 230 CONTINUE
- 240 CONTINUE
- ENDIF
-C * SUP -> LEPTON+ + D
- IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
- J=NINT(KFSM/2.)
- DO 260 I=1,3
- DO 250 K=1,3
-C...~u_J -> lepton_I+ + d_K
- LKNT = LKNT+1
- IDLAM(LKNT,1)=-11 -2*(I-1)
- IDLAM(LKNT,2)= 1 +2*(K-1)
- IDLAM(LKNT,3)= 0
- XLAM(LKNT)=0D0
- RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
- IF (IMSS(52).NE.0) XLAM(LKNT) =
- & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
- 250 CONTINUE
- 260 CONTINUE
- ENDIF
- ENDIF
-C...BARYON NUMBER VIOLATING DECAYS
- IF (IMSS(53).GE.1) THEN
-C * SUP -> DBAR + DBAR
- IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
- I = KFSM/2
- DO 280 J=1,3
- DO 270 K=1,3
-C...~u_I -> dbar_J + dbar_K
- IF (J.LT.K) THEN
-C...(anti-) symmetry J <-> K.
- LKNT = LKNT + 1
- IDLAM(LKNT,1) = -1 -2*(J-1)
- IDLAM(LKNT,2) = -1 -2*(K-1)
- IDLAM(LKNT,3) = 0
- XLAM(LKNT) = 0D0
- RM2 = 2.*(RVLAMB(I,J,K)**2)
- & * SFMIX(KFSM,2*ICNT)**2 * SM
- XLAM(LKNT) =
- & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT = LKNT-1
- ENDIF
- ENDIF
- 270 CONTINUE
- 280 CONTINUE
- ENDIF
-C * SDOWN -> UBAR + DBAR
- IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
- K=(KFSM+1)/2
- DO 300 I=1,3
- DO 290 J=1,3
-C...LAMB coupling antisymmetric in J and K.
- IF (J.NE.K) THEN
-C...~d_K -> ubar_I + dbar_K
- LKNT = LKNT + 1
- IDLAM(LKNT,1)= -2 -2*(I-1)
- IDLAM(LKNT,2)= -1 -2*(J-1)
- IDLAM(LKNT,3)= 0
- XLAM(LKNT)=0D0
-C...Use massive top quark
- IF (IDLAM(LKNT,1).EQ.-6) THEN
- RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
- & )
- XLAM(LKNT) =
- & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
-C...If no top quark, all decay products massless
- ELSE
- RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
- XLAM(LKNT) =
- & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
- ENDIF
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
- ENDIF
- 290 CONTINUE
- 300 CONTINUE
- ENDIF
- ENDIF
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRVNE
-C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
-C...P. Z. Skands
-
- SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
-C...Local variables.
- COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
- & ,DCMASS,KFR(3)
- DOUBLE PRECISION XLAM(0:400)
- DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
- INTEGER IDLAM(400,3), PYCOMP
- LOGICAL DCMASS
- SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
-
-C...R-VIOLATING DECAYS
- IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
- KFSM=KFIN-KSUSY1
- IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
-C...WHICH NEUTRALINO ?
- NCHI=1
- IF (KFSM.EQ.23) NCHI=2
- IF (KFSM.EQ.25) NCHI=3
- IF (KFSM.EQ.35) NCHI=4
-C...SIGN OF MASS (Opposite convention as HERWIG)
- ISM = 1
- IF (SMZ(NCHI).LT.0D0) ISM = -ISM
-
-C...Useful parameters for the calculation of the A and B constants.
- WMASS = PMAS(PYCOMP(24),1)
- ECHG = 2*SQRT(PARU(103)*PARU(1))
- COSB=1/(SQRT(1+RMSS(5)**2))
- SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
- COSW=SQRT(1-PARU(102))
- SINW=SQRT(PARU(102))
- GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
-C...Run quark masses to neutralino mass squared (for Higgs-type
-C...couplings)
- SQMCHI=PMAS(PYCOMP(KFIN),1)**2
- DO 100 I=1,6
- RMQ(I)=PYMRUN(I,SQMCHI)
- 100 CONTINUE
-C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
- DO 110 NCHJ=1,4
- ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
- ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
- ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
- ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
- 110 CONTINUE
- C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
- C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
- C2=ECHG*ZPMIX(NCHI,1)
- C3=GW*ZPMIX(NCHI,2)/COSW
- EU=2D0/3D0
- ED=-1D0/3D0
-C... AB(x,y,z):
-C x=1-2 : Select A or B constant (1:A ; 2:B)
-C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
-C 11-16:e,nu_e,mu,...)
-C z=1-2 : Mass eigenstate number
-C...CALCULATE COUPLINGS
- DO 120 I = 11,15,2
- CMS=PMAS(PYCOMP(I),1)
-C...Intermediate sleptons
- AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
- & *(C2-C3*SINW**2))
- AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
- & *(C2-C3*SINW**2))
- AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
- & **2))
- AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
- & **2))
-C...Inermediate sneutrinos
- AB(1,I+1,1)=0D0
- AB(2,I+1,1)=5D-1*C3
- AB(1,I+1,2)=0D0
- AB(2,I+1,2)=0D0
-C...Inermediate sdown
- J=I-10
- CMS=RMQ(J)
- AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
- & *ED*(C2-C3*SINW**2))
- AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
- & *ED*(C2-C3*SINW**2))
- AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
- & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
- AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
- & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
-C...Inermediate sup
- J=J+1
- CMS=RMQ(J)
- AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
- & *EU*(C2-C3*SINW**2))
- AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
- & *EU*(C2-C3*SINW**2))
- AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
- & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
- AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
- & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
- 120 CONTINUE
-
- IF (IMSS(51).GE.1) THEN
-C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
-C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
-C...STEP IN I,J,K USING SINGLE COUNTER
- DO 130 ISC=0,26
-C...LAMBDA COUPLING ASYM IN I,J
- IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
- LKNT = LKNT+1
- IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
- IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
- IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
- XLAM(LKNT) = 0D0
-C...Set coupling, and decay product masses on/off
- RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
- & ,MOD(ISC,3)+1)**2
- DCMASS=.FALSE.
- IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
- & DCMASS = .TRUE.
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1)=-IDLAM(LKNT,1)
- KFR(2)=-IDLAM(LKNT,2)
- KFR(3)=-IDLAM(LKNT,3)
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
- & IDLAM(LKNT,3),XLAM(LKNT))
- XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
-C...Charge conjugate mode.
- LKNT=LKNT+1
- IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
- XLAM(LKNT)=XLAM(LKNT-1)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-2
- ENDIF
- ENDIF
- 130 CONTINUE
- ENDIF
-
- IF (IMSS(52).GE.1) THEN
-C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
-C * CHI0 -> NUBAR_I + DBAR_J + D_K
- DO 140 ISC=0,26
- LKNT = LKNT+1
- IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
- IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
- IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
- XLAM(LKNT) = 0D0
-C...Set coupling, and decay product masses on/off
- RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
- & ,MOD(ISC,3)+1)**2
- DCMASS=.FALSE.
- IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
- & DCMASS = .TRUE.
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1)=-IDLAM(LKNT,1)
- KFR(2)=-IDLAM(LKNT,2)
- KFR(3)=-IDLAM(LKNT,3)
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
- & ,XLAM(LKNT))
- XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
-C...Charge conjugate mode.
- LKNT=LKNT+1
- IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
- XLAM(LKNT)=XLAM(LKNT-1)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-2
- ENDIF
-
-C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
- LKNT = LKNT+1
- IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
- IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
- IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
- XLAM(LKNT) = 0D0
-C...Set coupling, and decay product masses on/off
- RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
- & ,MOD(ISC,3)+1)**2
- DCMASS=.FALSE.
- IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
- & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1)=-IDLAM(LKNT,1)
- KFR(2)=-IDLAM(LKNT,2)
- KFR(3)=-IDLAM(LKNT,3)
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
- & ,XLAM(LKNT))
- XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
-C...Charge conjugate mode.
- LKNT=LKNT+1
- IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
- XLAM(LKNT)=XLAM(LKNT-1)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-2
- ENDIF
- 140 CONTINUE
- ENDIF
-
- IF (IMSS(53).GE.1) THEN
-C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
-C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
- DO 150 ISC=0,26
-C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
- IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
- LKNT = LKNT+1
- IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
- IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
- IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
- XLAM(LKNT) = 0D0
-C...Set coupling, and decay product masses on/off
- RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
- & +1,MOD(ISC,3)+1)**2
- DCMASS=.FALSE.
- IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
- & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = IDLAM(LKNT,1)
- KFR(2) = IDLAM(LKNT,2)
- KFR(3) = IDLAM(LKNT,3)
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
- & IDLAM(LKNT,3),XLAM(LKNT))
- XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
-C...Charge conjugate mode.
- LKNT=LKNT+1
- IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
- XLAM(LKNT)=XLAM(LKNT-1)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-2
- ENDIF
- ENDIF
- 150 CONTINUE
- ENDIF
- ENDIF
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRVCH
-C...Calculates R-violating chargino decay widths.
-C...P. Z. Skands
-
- SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
-C...Local variables.
- DOUBLE PRECISION XLAM(0:400)
- INTEGER IDLAM(400,3), PYCOMP
-C...Information from main routine to PYRVGW
- COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
- & ,DCMASS,KFR(3)
-C...Auxiliary variables needed for BV (RV Gauge STOre)
- COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
- & ,RVLJKI,RVLJIK
-C...Running quark masses
- DOUBLE PRECISION RMQ(6)
-C...Decay product masses on/off
- LOGICAL DCMASS
- SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
- & /RVGSTO/
-
-
-C...IF R-VIOLATION ON.
- IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
- KFSM=KFIN-KSUSY1
- IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
-C...WHICH CHARGINO ?
- NCHI = 1
- IF (KFSM.EQ.37) NCHI = 2
-
-C...Useful parameters for calculating the A and B constants.
-C...SIGN OF MASS (Opposite convention as HERWIG)
- ISM = 1
- IF (SMW(NCHI).LT.0D0) ISM = -1
- WMASS = PMAS(PYCOMP(24),1)
- COSB = 1/(SQRT(1+RMSS(5)**2))
- SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
- GW2 = 4*PARU(103)*PARU(1)/PARU(102)
- C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
- C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
- C2 = UMIX(NCHI,1)
- C3 = VMIX(NCHI,1)
-C...Running masses at Q^2=MCHI^2.
- SQMCHI = PMAS(PYCOMP(KFSM),1)**2
- DO 100 I=1,6
- RMQ(I)=PYMRUN(I,SQMCHI)
- 100 CONTINUE
-
-C... AB(x,y,z) coefficients:
-C x=1-2 : A or B coefficient (1:A ; 2:B)
-C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
-C 11-16:e,nu_e,mu,...)
-C z=1-2 : Mass eigenstate number
- DO 110 I = 11,15,2
-C...Intermediate sleptons
- AB(1,I,1) = 0D0
- AB(1,I,2) = 0D0
- AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
- & SFMIX(I,1)*C2
- AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
- & SFMIX(I,3)*C2
-C...Intermediate sneutrinos
- AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
- AB(1,I+1,2) = 0D0
- AB(2,I+1,1) = ISM*C3
- AB(2,I+1,2) = 0D0
-C...Intermediate sdown
- J=I-10
- AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
- AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
- AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
- AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
-C...Intermediate sup
- J=J+1
- AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
- AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
- AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
- AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
- 110 CONTINUE
-
-C...LLE TYPE R-VIOLATION
- IF (IMSS(51).GE.1) THEN
-C...LOOP OVER DECAY MODES
- DO 140 ISC=0,26
-
-C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
- IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
- LKNT = LKNT+1
- IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
- IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
- IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
- XLAM(LKNT) = 0D0
-C...Set coupling, and decay product masses on/off
- RVLAMC = GW2 * 5D-1 *
- & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
- & **2
- DCMASS=.FALSE.
- IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
-C...Resonance KF codes (1=I,2=J,3=K).
- KFR(1) = 0
- KFR(2) = 0
- KFR(3) = -IDLAM(LKNT,3)+1
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
- & IDLAM(LKNT,3),XLAM(LKNT))
- XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
-
-C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
- 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
- LKNT = LKNT+1
- IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
- IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
- IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
- XLAM(LKNT) = 0D0
-C...Set coupling, and decay product masses on/off
- RVLAMC = GW2 * 5D-1 *
- & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
-C...I,J SYMMETRY => FACTOR 2
- RVLAMC=2*RVLAMC
- DCMASS=.FALSE.
- IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1)=IDLAM(LKNT,1)-1
- KFR(2)=IDLAM(LKNT,2)-1
- KFR(3)=0
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
- & IDLAM(LKNT,3),XLAM(LKNT))
- XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
- 130 ENDIF
-
-C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
- LKNT = LKNT+1
- IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
- IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
- IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
- XLAM(LKNT) = 0D0
-C...Set coupling, and decay product masses on/off
- RVLAMC = GW2 * 5D-1 *
- & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
-C...I,J SYMMETRY => FACTOR 2
- RVLAMC=2*RVLAMC
- DCMASS=.FALSE.
- IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
- & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) =-IDLAM(LKNT,1)+1
- KFR(2) =-IDLAM(LKNT,2)+1
- KFR(3) = 0
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
- & IDLAM(LKNT,3),XLAM(LKNT))
- XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
- ENDIF
- 140 CONTINUE
- ENDIF
-
-C...LQD TYPE R-VIOLATION
- IF (IMSS(52).GE.1) THEN
-C...LOOP OVER DECAY MODES
- DO 180 ISC=0,26
-
-C...CHI+ -> NUBAR_I + DBAR_J + U_K
- LKNT = LKNT+1
- IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
- IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
- IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
- XLAM(LKNT) = 0D0
-C...Set coupling, and decay product masses on/off
- RVLAMC = 3. * GW2 * 5D-1 *
- & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
- DCMASS=.FALSE.
- IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
- & DCMASS = .TRUE.
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1)=0
- KFR(2)=0
- KFR(3)=-IDLAM(LKNT,3)+1
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
- & ,XLAM(LKNT))
- XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
-
-C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
- 150 LKNT = LKNT+1
- IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
- IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
- IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
- XLAM(LKNT) = 0D0
-C...Set coupling, and decay product masses on/off
- RVLAMC = 3. * GW2 * 5D-1 *
- & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
- DCMASS=.FALSE.
- IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
- & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1)=0
- KFR(2)=0
- KFR(3)=-IDLAM(LKNT,3)+1
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
- & ,XLAM(LKNT))
- XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
-
-C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
- 160 LKNT = LKNT+1
- IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
- IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
- IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
- XLAM(LKNT) = 0D0
-C...Set coupling, and decay product masses on/off
- RVLAMC = 3. * GW2 * 5D-1 *
- & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
- DCMASS = .FALSE.
- IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
- & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1)=-IDLAM(LKNT,1)+1
- KFR(2)=-IDLAM(LKNT,2)+1
- KFR(3)=0
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
- & ,XLAM(LKNT))
- XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
-
-C * CHI+ -> NU_I + U_J + DBAR_K.
- 170 LKNT = LKNT+1
- IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
- IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
- IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
- XLAM(LKNT) = 0D0
-C...Set coupling, and decay product masses on/off
- DCMASS = .FALSE.
- RVLAMC = 3. * GW2 * 5D-1 *
- & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
- IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
- & DCMASS = .TRUE.
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1)=IDLAM(LKNT,1)-1
- KFR(2)=IDLAM(LKNT,2)-1
- KFR(3)=0
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
- & ,XLAM(LKNT))
- XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
-
- 180 CONTINUE
- ENDIF
-
-C...UDD TYPE R-VIOLATION
-C...These decays need special treatment since more than one BV coupling
-C...contributes (with interference). Consider e.g. (symbolically)
-C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
-C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
-C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
-C...The problem is that a single call to PYRVGW would evaluate all
-C...these terms and sum them, but without the different couplings. The
-C...way out is to call PYRVGW three times, once for the first line, once
-C...for the second line, and then once for all the lines (it is
-C...impossible to get just the last line out) without multiplying by
-C...couplings. The last line is then obtained as the result of the third
-C...call minus the results of the two first calls. Each term is then
-C...multiplied by its respective coupling before the whole thing is
-C...summed up in XLAM.
-C...Note that with three interfering resonances, this procedure becomes
-C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
-
- IF (IMSS(53).GE.1) THEN
-C...LOOP OVER DECAY MODES
- DO 190 ISC=1,25
-
-C...CHI+ -> U_I + U_J + D_K
-C...Decay mode I<->J symmetric.
- IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
- LKNT = LKNT+1
- IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
- IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
- IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
- XLAM(LKNT) = 0D0
-C...Set coupling, and decay product masses on/off
- RVLAMC= 6. * GW2 * 5D-1
- RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
- & +1)
- RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
- & +1)
- IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
- & * RVLAMC
- DCMASS=.FALSE.
- IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
- & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = -IDLAM(LKNT,1)+1
- KFR(2) = 0
- KFR(3) = 0
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
- & IDLAM(LKNT,3),XRESI)
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = 0
- KFR(2) = -IDLAM(LKNT,2)+1
- KFR(3) = 0
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
- & IDLAM(LKNT,3),XRESJ)
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = -IDLAM(LKNT,1)+1
- KFR(2) = -IDLAM(LKNT,2)+1
- KFR(3) = 0
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
- & IDLAM(LKNT,3),XRESIJ)
- IF (ABS((XRESI+XRESJ)/XRESIJ-1.).GT.1D-4) THEN
- XRESIJ = XRESIJ-XRESI-XRESJ
- ELSE
- XRESIJ = 0D0
- ENDIF
-C...CALCULATE TOTAL WIDTH
- XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
- & + RVLJIK*RVLIJK * XRESIJ
- XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
- ENDIF
-C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
-C...Symmetry I<->J<->K.
- IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
- & .MOD(ISC,3)).AND.ISC.NE.13) THEN
- LKNT = LKNT+1
- IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
- IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
- IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
- XLAM(LKNT) = 0D0
-C...Set coupling, and decay product masses on/off
- RVLAMC = 6. * GW2 * 5D-1
- RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
- & +1)
- RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
- & +1)
- RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
- & +1)
- DCMASS = .FALSE.
- IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
- & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
-C...Collect symmetry factors
- IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
- & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
- & RVLAMC = 5D-1 * RVLAMC
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = IDLAM(LKNT,1)-1
- KFR(2) = 0
- KFR(3) = 0
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
- & IDLAM(LKNT,3),XRESI)
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = 0
- KFR(2) = IDLAM(LKNT,2)-1
- KFR(3) = 0
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
- & IDLAM(LKNT,3),XRESJ)
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = 0
- KFR(2) = 0
- KFR(3) = IDLAM(LKNT,3)-1
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
- & IDLAM(LKNT,3),XRESK)
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = IDLAM(LKNT,1)-1
- KFR(2) = IDLAM(LKNT,2)-1
- KFR(3) = 0
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
- & IDLAM(LKNT,3),XRESIJ)
- IF (ABS(XRESIJ/(XRESI+XRESJ)-1.).GT.1D-4) THEN
- XRESIJ = XRESI+XRESJ-XRESIJ
- ELSE
- XRESIJ = 0D0
- ENDIF
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = 0
- KFR(2) = IDLAM(LKNT,2)-1
- KFR(3) = IDLAM(LKNT,3)-1
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
- & IDLAM(LKNT,3),XRESJK)
- IF (ABS(XRESJK/(XRESJ+XRESK)-1.).GT.1D-4) THEN
- XRESJK = XRESJ+XRESK-XRESJK
- ELSE
- XRESJK = 0D0
- ENDIF
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = IDLAM(LKNT,1)-1
- KFR(2) = 0
- KFR(3) = IDLAM(LKNT,3)-1
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
- & IDLAM(LKNT,3),XRESIK)
- IF (ABS(XRESIK/(XRESI+XRESK)-1.).GT.1D-4) THEN
- XRESIK = XRESI+XRESK-XRESIK
- ELSE
- XRESIK = 0D0
- ENDIF
-C...CALCULATE TOTAL WIDTH
- XLAM(LKNT) =
- & RVLIJK**2 * XRESI
- & + RVLJKI**2 * XRESJ
- & + RVLKIJ**2 * XRESK
- & + RVLIJK*RVLJKI * XRESIJ
- & + RVLIJK*RVLKIJ * XRESIK
- & + RVLJKI*RVLKIJ * XRESJK
- XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-1
- ENDIF
- ENDIF
- 190 CONTINUE
- ENDIF
- ENDIF
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRVGL
-C...Calculates R-violating gluino decay widths.
-C...See BV part of PYRVCH for comments about the way the BV decay width
-C...is calculated. Same comments apply here.
-C...P. Z. Skands
-
- SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
-C...Local variables.
- DOUBLE PRECISION XLAM(0:400)
- INTEGER IDLAM(400,3), PYCOMP
-C...Information from main routine to PYRVGW
- COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
- & ,DCMASS,KFR(3)
-C...Auxiliary variables needed for BV (RV Gauge STOre)
- COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
- & ,RVLJKI,RVLJIK
-C...Running quark masses
- DOUBLE PRECISION RMQ(6)
-C...Decay product masses on/off
- LOGICAL DCMASS
- SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
- & /RVGSTO/
-
-C...IF LQD OR UDD TYPE R-VIOLATION ON.
- IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
- KFSM=KFIN-KSUSY1
-
-C... AB(x,y,z):
-C x=1-2 : Select A or B coupling (1:A ; 2:B)
-C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
-C 11-16:e,nu_e,mu,... not used here)
-C z=1-2 : Mass eigenstate number
- DO 100 I = 1,6
-C...A Couplings
- AB(1,I,1) = SFMIX(I,2)
- AB(1,I,2) = SFMIX(I,4)
-C...B Couplings
- AB(2,I,1) = -SFMIX(I,1)
- AB(2,I,2) = -SFMIX(I,3)
- 100 CONTINUE
- GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
-C...LQD DECAYS.
- IF (IMSS(52).GE.1) THEN
-C...STEP IN I,J,K USING SINGLE COUNTER
- DO 120 ISC=0,26
-C * GLUINO -> NUBAR_I + DBAR_J + D_K.
- LKNT = LKNT+1
- IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
- IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
- IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
- XLAM(LKNT)=0D0
-C...Set coupling, and decay product masses on/off
- RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
- & * 5D-1 * GSTR2
- DCMASS = .FALSE.
- IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = 0
- KFR(2) = -IDLAM(LKNT,2)
- KFR(3) = -IDLAM(LKNT,3)
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
- & ,XLAM(LKNT))
-C...Normalize
- XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
-C...Charge conjugate mode.
- 110 LKNT = LKNT+1
- IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
- XLAM(LKNT) = XLAM(LKNT-1)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-2
- ENDIF
-
-C * GLUINO -> LEPTON+_I + UBAR_J + D_K
- LKNT = LKNT+1
- IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
- IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
- IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
- XLAM(LKNT)=0D0
-C...Set coupling, and decay product masses on/off
- RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
- & **2* 5D-1 * GSTR2
- DCMASS = .FALSE.
- IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
- & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = 0
- KFR(2) = -IDLAM(LKNT,2)
- KFR(3) = -IDLAM(LKNT,3)
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
- & ,XLAM(LKNT))
- XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
-C...Charge conjugate mode.
- LKNT=LKNT+1
- IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
- IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
- IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
- XLAM(LKNT) = XLAM(LKNT-1)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-2
- ENDIF
-
- 120 CONTINUE
- ENDIF
-
-C...UDD DECAYS.
- IF (IMSS(53).GE.1) THEN
-C...STEP IN I,J,K USING SINGLE COUNTER
- DO 130 ISC=0,26
-C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
- IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
- LKNT = LKNT+1
- IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
- IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
- IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
- XLAM(LKNT)=0D0
-C...Set coupling, and decay product masses on/off. A factor of 2 for
-C...(N_C-1) has been used to cancel a factor 0.5.
- RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
- & **2 * GSTR2
- DCMASS = .FALSE.
- IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
- & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = IDLAM(LKNT,1)
- KFR(2) = 0
- KFR(3) = 0
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
- & ,XRESI)
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = 0
- KFR(2) = IDLAM(LKNT,2)
- KFR(3) = 0
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
- & ,XRESJ)
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = 0
- KFR(2) = 0
- KFR(3) = IDLAM(LKNT,3)
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
- & ,XRESK)
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = IDLAM(LKNT,1)
- KFR(2) = IDLAM(LKNT,2)
- KFR(3) = 0
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
- & ,XRESIJ)
-C...Calculate interference function. (Factor -1/2 to make up for factor
-C...-2 in PYRVGW.
- IF (ABS((XRESI+XRESJ)/XRESIJ-1D0).GT.1D-4) THEN
- XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
- ELSE
- XRESIJ = 0D0
- ENDIF
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = 0
- KFR(2) = IDLAM(LKNT,2)
- KFR(3) = IDLAM(LKNT,3)
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
- & ,XRESJK)
- IF (ABS((XRESJ+XRESK)/XRESJK-1).GT.1D-4) THEN
- XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
- ELSE
- XRESJK = 0D0
- ENDIF
-C...Resonance KF codes (1=I,2=J,3=K)
- KFR(1) = IDLAM(LKNT,1)
- KFR(2) = 0
- KFR(3) = IDLAM(LKNT,3)
-C...Calculate width.
- CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
- & ,XRESIK)
- IF (ABS((XRESI+XRESK)/XRESIK-1).GT.1D-4) THEN
- XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
- ELSE
- XRESIK = 0D0
- ENDIF
-C...Calculate total width (factor 1/2 from 1/(N_C-1))
- XLAM(LKNT) = XRESI + XRESJ + XRESK
- & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
-C...Normalize
- XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
-C...Charge conjugate mode.
- LKNT = LKNT+1
- IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
- IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
- IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
- XLAM(LKNT) = XLAM(LKNT-1)
-C...KINEMATICS CHECK
- IF (XLAM(LKNT).EQ.0D0) THEN
- LKNT=LKNT-2
- ENDIF
- ENDIF
- 130 CONTINUE
- ENDIF
- ENDIF
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRVSB
-C...Auxiliary function to PYRVSF for calculating R-Violating
-C...sfermion widths. Though the decay products are most often treated
-C...as massless in the calculation, the kinematical boundary of phase
-C...space is tested using the true masses.
-C...MODE = 1: All decay products massive
-C...MODE = 2: Decay product 1 massless
-C...MODE = 3: Decay product 2 massless
-C...MODE = 4: All decay products massless
-
- FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER (I-N)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYDAT1/,/PYDAT2/
- DOUBLE PRECISION SM(3)
- INTEGER PYCOMP, KC(3)
- KC(1)=PYCOMP(KFIN)
- KC(2)=PYCOMP(ID1)
- KC(3)=PYCOMP(ID2)
- SM(1)=PMAS(KC(1),1)**2
- SM(2)=PMAS(KC(2),1)**2
- SM(3)=PMAS(KC(3),1)**2
-C...Kinematics check
- IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
- PYRVSB=0D0
- RETURN
- ENDIF
-C...CM momenta squared
- IF (MODE.EQ.1) THEN
- P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
- & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
- ELSE IF (MODE.EQ.2) THEN
- P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
- ELSE IF (MODE.EQ.3) THEN
- P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
- ELSE
- P2CM=SM(1)/4.
- ENDIF
-C...Calculate Width
- PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRVGW
-C...Generalized Matrix Element for R-Violating 3-body widths.
-C...P. Z. Skands
- SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
-
- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
- IMPLICIT INTEGER (I-N)
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
- PARAMETER (EPS=1D-4)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
- & ,DCMASS,KFR(3)
- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
- & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
- DOUBLE PRECISION XLIM(3,3)
- INTEGER KC(0:3), PYCOMP
- LOGICAL DCMASS, DCHECK(6)
- SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
-
- XLAM = 0D0
-
- KC(0) = PYCOMP(KFIN)
- KC(1) = PYCOMP(ID1)
- KC(2) = PYCOMP(ID2)
- KC(3) = PYCOMP(ID3)
- RMS(0) = PMAS(KC(0),1)
- RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
- RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
- RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
-C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
- XLIM(1,1)=(RMS(1)+RMS(2))**2
- XLIM(1,2)=(RMS(0)-RMS(3))**2
- XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
- XLIM(2,1)=(RMS(2)+RMS(3))**2
- XLIM(2,2)=(RMS(0)-RMS(1))**2
- XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
- XLIM(3,1)=(RMS(1)+RMS(3))**2
- XLIM(3,2)=(RMS(0)-RMS(2))**2
- XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
-C...Check Phase Space
- IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
- RETURN
- ENDIF
-
-C...INITIALIZE RESONANCE INFORMATION
- DO 110 JRES = 1,3
- DO 100 IMASS = 1,2
- IRES = 2*(JRES-1)+IMASS
- INTRES(IRES,1) = 0
- DCHECK(IRES) =.FALSE.
-C...NO RIGHT-HANDED NEUTRINOS
- IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
- & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
- & .KFR(JRES).EQ.0) GOTO 100
- RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
- RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
- INTRES(IRES,1) = IABS(KFR(JRES))
- INTRES(IRES,2) = IMASS
- IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
- IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
- 100 CONTINUE
- 110 CONTINUE
-
-C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
-
-C...RESONANCE CONTRIBUTIONS
-C...(Only sum contributions where the resonance is off shell).
-C...Store whether diagram on/off in DCHECK.
-C...LOOP OVER MASS STATES
- DO 120 J=1,2
- IDR=J
- TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
- IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
- & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
- DCHECK(IDR) =.TRUE.
- XLAM = XLAM + TMIX * PYRVI1(2,3,1)
- ENDIF
-
- IDR=J+2
- TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
- IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
- & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
- DCHECK(IDR) =.TRUE.
- XLAM = XLAM + TMIX * PYRVI1(1,3,2)
- ENDIF
-
- IDR=J+4
- TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
- IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
- & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
- DCHECK(IDR) =.TRUE.
- XLAM = XLAM + TMIX * PYRVI1(1,2,3)
- ENDIF
- 120 CONTINUE
-C... L-R INTERFERENCES
-C... (Only add contributions where both contributing diagrams
-C... are non-resonant).
- IDR=1
- IF (DCHECK(1).AND.DCHECK(2)) THEN
-C...Bug corrected 11/12 2001. Skands.
- XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
- & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
- & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
- ENDIF
-
- IDR=3
- IF (DCHECK(3).AND.DCHECK(4)) THEN
- XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
- & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
- & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
- ENDIF
-
- IDR=5
- IF (DCHECK(5).AND.DCHECK(6)) THEN
- XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
- & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
- & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
- ENDIF
-C... TRUE INTERFERENCES
-C... (Only add contributions where both contributing diagrams
-C... are non-resonant).
- PREF=-2D0
- IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
- DO 140 IKR1 = 1,2
- DO 130 IKR2 = 1,2
- IDR = IKR1+2
- IDR2 = IKR2
- IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
- XLAM = XLAM + PREF*PYRVI3(1,3,2) *
- & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
- & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
- ENDIF
-
- IDR = IKR1+4
- IDR2 = IKR2
- IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
- XLAM = XLAM + PREF*PYRVI3(1,2,3) *
- & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
- & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
- ENDIF
-
- IDR = IKR1+4
- IDR2 = IKR2+2
- IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
- XLAM = XLAM + PREF*PYRVI3(2,1,3) *
- & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
- & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
- ENDIF
- 130 CONTINUE
- 140 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRVI1
-C...Function to integrate resonance contributions
-
- FUNCTION PYRVI1(ID1,ID2,ID3)
-
- IMPLICIT NONE
- DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
- DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
- INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
- LOGICAL MFLAG,DCMASS
- EXTERNAL PYRVG1,PYGAUS
- COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
- & ,DCMASS,KFR(3)
- COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
- SAVE/PYRVNV/,/PYRVPM/
-C...Initialize mass and width information
- PYRVI1 = 0D0
- RM(0) = RMS(0)
- RM(1) = RMS(ID1)
- RM(2) = RMS(ID2)
- RM(3) = RMS(ID3)
- RESM(1)= RES(IDR,1)
- RESW(1)= RES(IDR,2)
-C...A->B and B->A for antisparticles
- A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
- B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
-C...Integration boundaries and mass flag
- LO = (RM(1)+RM(2))**2
- HI = (RM(0)-RM(3))**2
- MFLAG = DCMASS
- PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRVI2
-C...Function to integrate L-R interference contributions
-
- FUNCTION PYRVI2(ID1,ID2,ID3)
-
- IMPLICIT NONE
- DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
- DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
- INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
- LOGICAL MFLAG,DCMASS
- EXTERNAL PYRVG2,PYGAUS
- COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
- & ,DCMASS,KFR(3)
- COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
- SAVE/PYRVNV/,/PYRVPM/
-C...Initialize mass and width information
- PYRVI2 = 0D0
- RM(0) = RMS(0)
- RM(1) = RMS(ID1)
- RM(2) = RMS(ID2)
- RM(3) = RMS(ID3)
- RESM(1)= RES(IDR,1)
- RESW(1)= RES(IDR,2)
- RESM(2)= RES(IDR+1,1)
- RESW(2)= RES(IDR+1,2)
-C...A->B and B->A for antisparticles
- A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
- B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
- A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
- B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
-C...Boundaries and mass flag
- LO = (RM(1)+RM(2))**2
- HI = (RM(0)-RM(3))**2
- MFLAG = DCMASS
- PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRVI3
-C...Function to integrate true interference contributions
-
- FUNCTION PYRVI3(ID1,ID2,ID3)
-
- IMPLICIT NONE
- DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
- DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
- INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
- LOGICAL MFLAG,DCMASS
- EXTERNAL PYRVG3,PYGAUS
- COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
- & ,DCMASS,KFR(3)
- COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
- SAVE/PYRVNV/,/PYRVPM/
-C...Initialize mass and width information
- PYRVI3 = 0D0
- RM(0) = RMS(0)
- RM(1) = RMS(ID1)
- RM(2) = RMS(ID2)
- RM(3) = RMS(ID3)
- RESM(1)= RES(IDR,1)
- RESW(1)= RES(IDR,2)
- RESM(2)= RES(IDR2,1)
- RESW(2)= RES(IDR2,2)
-C...A -> B and B -> A for antisparticles
- A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
- B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
- A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
- B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
-C...Boundaries and mass flag
- LO = (RM(1)+RM(2))**2
- HI = (RM(0)-RM(3))**2
- MFLAG = DCMASS
- PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRVG1
-C...Integrand for resonance contributions
-
- FUNCTION PYRVG1(X)
-
- IMPLICIT NONE
- COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
- DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
- DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
- LOGICAL MFLAG
- SAVE/PYRVPM/
- RVR = PYRVR(X,RESM(1),RESW(1))
- C1 = 2D0*SQRT(MAX(0D0,X))
- IF (.NOT.MFLAG) THEN
- E2 = X/C1
- E3 = (RM(0)**2-X)/C1
- DELTAY = 4D0*E2*E3
- PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
- ELSE
- E2 = (X-RM(1)**2+RM(2)**2)/C1
- E3 = (RM(0)**2-X-RM(3)**2)/C1
- SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
- SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
- DELTAY = 4D0*SR1*SR2
- A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
- A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
- PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
- ENDIF
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRVG2
-C...Integrand for L-R interference contributions
-
- FUNCTION PYRVG2(X)
-
- IMPLICIT NONE
- COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
- DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
- DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
- LOGICAL MFLAG
- SAVE/PYRVPM/
- C1 = 2D0*SQRT(MAX(0D0,X))
- RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
- IF (.NOT.MFLAG) THEN
- E2 = X/C1
- E3 = (RM(0)**2-X)/C1
- DELTAY = 4D0*E2*E3
- PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
- ELSE
- E2 = (X-RM(1)**2+RM(2)**2)/C1
- E3 = (RM(0)**2-X-RM(3)**2)/C1
- SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
- SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
- DELTAY = 4D0*SR1*SR2
- PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
- & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
- & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
- ENDIF
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRVG3
-C...Function to do Y integration over true interference contributions
-
- FUNCTION PYRVG3(X)
-
- IMPLICIT NONE
- COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
-C...Second Dalitz variable for PYRVG4
- COMMON/PYG2DX/X1
- DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
- DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
- DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
- LOGICAL MFLAG
- EXTERNAL PYGAU2,PYRVG4
- SAVE/PYRVPM/,/PYG2DX/
- PYRVG3=0D0
- C1=2D0*SQRT(MAX(1D-9,X))
- X1=X
- IF (.NOT.MFLAG) THEN
- E2 = X/C1
- E3 = (RM(0)**2-X)/C1
- YMIN = 0D0
- YMAX = 4D0*E2*E3
- ELSE
- E2 = (X-RM(1)**2+RM(2)**2)/C1
- E3 = (RM(0)**2-X-RM(3)**2)/C1
- SQ1 = (E2+E3)**2
- SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
- SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
- YMIN = SQ1-(SR1+SR2)**2
- YMAX = SQ1-(SR1-SR2)**2
- ENDIF
- PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRVG4
-C...Integrand for true intereference contributions
-
- FUNCTION PYRVG4(Y)
-
- IMPLICIT NONE
- COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
- COMMON/PYG2DX/X
- DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
- LOGICAL MFLAG
- SAVE /PYRVPM/,/PYG2DX/
- PYRVG4=0D0
- RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
- IF (.NOT.MFLAG) THEN
- PYRVG4 = RVS*B(1)*B(2)*X*Y
- ELSE
- PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
- & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
- & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
- & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
- ENDIF
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRVR
-C...Breit-Wigner for resonance contributions
-
- FUNCTION PYRVR(Mab2,RM,RW)
-
- IMPLICIT NONE
- DOUBLE PRECISION Mab2,RM,RW,PYRVR
- PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRVS
-C...Interference function
-
- FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
-
- IMPLICIT NONE
- DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
- PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
- & +W1*W2*M1*M2)
- RETURN
- END
-
-C*********************************************************************
-
-C...PY1ENT
-C...Stores one parton/particle in commonblock PYJETS.
-
- SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-
-C...Standard checks.
- MSTU(28)=0
- IF(MSTU(12).NE.12345) CALL PYLIST(0)
- IPA=MAX(1,IABS(IP))
- IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
- &'(PY1ENT:) writing outside PYJETS memory')
- KC=PYCOMP(KF)
- IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
-
-C...Find mass. Reset K, P and V vectors.
- PM=0D0
- IF(MSTU(10).EQ.1) PM=P(IPA,5)
- IF(MSTU(10).GE.2) PM=PYMASS(KF)
- DO 100 J=1,5
- K(IPA,J)=0
- P(IPA,J)=0D0
- V(IPA,J)=0D0
- 100 CONTINUE
-
-C...Store parton/particle in K and P vectors.
- K(IPA,1)=1
- IF(IP.LT.0) K(IPA,1)=2
- K(IPA,2)=KF
- P(IPA,5)=PM
- P(IPA,4)=MAX(PE,PM)
- PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
- P(IPA,1)=PA*SIN(THE)*COS(PHI)
- P(IPA,2)=PA*SIN(THE)*SIN(PHI)
- P(IPA,3)=PA*COS(THE)
-
-C...Set N. Optionally fragment/decay.
- N=IPA
- IF(IP.EQ.0) CALL PYEXEC
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PY2ENT
-C...Stores two partons/particles in their CM frame,
-C...with the first along the +z axis.
-
- SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-
-C...Standard checks.
- MSTU(28)=0
- IF(MSTU(12).NE.12345) CALL PYLIST(0)
- IPA=MAX(1,IABS(IP))
- IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
- &'(PY2ENT:) writing outside PYJETS memory')
- KC1=PYCOMP(KF1)
- KC2=PYCOMP(KF2)
- IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
- &'(PY2ENT:) unknown flavour code')
-
-C...Find masses. Reset K, P and V vectors.
- PM1=0D0
- IF(MSTU(10).EQ.1) PM1=P(IPA,5)
- IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
- PM2=0D0
- IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
- IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
- DO 110 I=IPA,IPA+1
- DO 100 J=1,5
- K(I,J)=0
- P(I,J)=0D0
- V(I,J)=0D0
- 100 CONTINUE
- 110 CONTINUE
-
-C...Check flavours.
- KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
- KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
- IF(MSTU(19).EQ.1) THEN
- MSTU(19)=0
- ELSE
- IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
- & '(PY2ENT:) unphysical flavour combination')
- ENDIF
- K(IPA,2)=KF1
- K(IPA+1,2)=KF2
-
-C...Store partons/particles in K vectors for normal case.
- IF(IP.GE.0) THEN
- K(IPA,1)=1
- IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
- K(IPA+1,1)=1
-
-C...Store partons in K vectors for parton shower evolution.
- ELSE
- K(IPA,1)=3
- K(IPA+1,1)=3
- K(IPA,4)=MSTU(5)*(IPA+1)
- K(IPA,5)=K(IPA,4)
- K(IPA+1,4)=MSTU(5)*IPA
- K(IPA+1,5)=K(IPA+1,4)
- ENDIF
-
-C...Check kinematics and store partons/particles in P vectors.
- IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
- &'(PY2ENT:) energy smaller than sum of masses')
- PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
- &(2D0*PECM)
- P(IPA,3)=PA
- P(IPA,4)=SQRT(PM1**2+PA**2)
- P(IPA,5)=PM1
- P(IPA+1,3)=-PA
- P(IPA+1,4)=SQRT(PM2**2+PA**2)
- P(IPA+1,5)=PM2
-
-C...Set N. Optionally fragment/decay.
- N=IPA+1
- IF(IP.EQ.0) CALL PYEXEC
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PY3ENT
-C...Stores three partons or particles in their CM frame,
-C...with the first along the +z axis and the third in the (x,z)
-C...plane with x > 0.
-
- SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-
-C...Standard checks.
- MSTU(28)=0
- IF(MSTU(12).NE.12345) CALL PYLIST(0)
- IPA=MAX(1,IABS(IP))
- IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
- &'(PY3ENT:) writing outside PYJETS memory')
- KC1=PYCOMP(KF1)
- KC2=PYCOMP(KF2)
- KC3=PYCOMP(KF3)
- IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
- &'(PY3ENT:) unknown flavour code')
-
-C...Find masses. Reset K, P and V vectors.
- PM1=0D0
- IF(MSTU(10).EQ.1) PM1=P(IPA,5)
- IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
- PM2=0D0
- IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
- IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
- PM3=0D0
- IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
- IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
- DO 110 I=IPA,IPA+2
- DO 100 J=1,5
- K(I,J)=0
- P(I,J)=0D0
- V(I,J)=0D0
- 100 CONTINUE
- 110 CONTINUE
-
-C...Check flavours.
- KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
- KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
- KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
- IF(MSTU(19).EQ.1) THEN
- MSTU(19)=0
- ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
- ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
- & KQ1+KQ3.EQ.4)) THEN
- ELSE
- CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
- ENDIF
- K(IPA,2)=KF1
- K(IPA+1,2)=KF2
- K(IPA+2,2)=KF3
-
-C...Store partons/particles in K vectors for normal case.
- IF(IP.GE.0) THEN
- K(IPA,1)=1
- IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
- K(IPA+1,1)=1
- IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
- K(IPA+2,1)=1
-
-C...Store partons in K vectors for parton shower evolution.
- ELSE
- K(IPA,1)=3
- K(IPA+1,1)=3
- K(IPA+2,1)=3
- KCS=4
- IF(KQ1.EQ.-1) KCS=5
- K(IPA,KCS)=MSTU(5)*(IPA+1)
- K(IPA,9-KCS)=MSTU(5)*(IPA+2)
- K(IPA+1,KCS)=MSTU(5)*(IPA+2)
- K(IPA+1,9-KCS)=MSTU(5)*IPA
- K(IPA+2,KCS)=MSTU(5)*IPA
- K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
- ENDIF
-
-C...Check kinematics.
- MKERR=0
- IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
- &0.5D0*X3*PECM.LE.PM3) MKERR=1
- PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
- PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
- PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
- CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
- CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
- IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
- CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
- IF(MKERR.NE.0) CALL PYERRM(13,
- &'(PY3ENT:) unphysical kinematical variable setup')
-
-C...Store partons/particles in P vectors.
- P(IPA,3)=PA1
- P(IPA,4)=SQRT(PA1**2+PM1**2)
- P(IPA,5)=PM1
- P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
- P(IPA+2,3)=PA3*CTHE3
- P(IPA+2,4)=SQRT(PA3**2+PM3**2)
- P(IPA+2,5)=PM3
- P(IPA+1,1)=-P(IPA+2,1)
- P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
- P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
- P(IPA+1,5)=PM2
-
-C...Set N. Optionally fragment/decay.
- N=IPA+2
- IF(IP.EQ.0) CALL PYEXEC
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PY4ENT
-C...Stores four partons or particles in their CM frame, with
-C...the first along the +z axis, the last in the xz plane with x > 0
-C...and the second having y < 0 and y > 0 with equal probability.
-
- SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-
-C...Standard checks.
- MSTU(28)=0
- IF(MSTU(12).NE.12345) CALL PYLIST(0)
- IPA=MAX(1,IABS(IP))
- IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
- &'(PY4ENT:) writing outside PYJETS momory')
- KC1=PYCOMP(KF1)
- KC2=PYCOMP(KF2)
- KC3=PYCOMP(KF3)
- KC4=PYCOMP(KF4)
- IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
- &'(PY4ENT:) unknown flavour code')
-
-C...Find masses. Reset K, P and V vectors.
- PM1=0D0
- IF(MSTU(10).EQ.1) PM1=P(IPA,5)
- IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
- PM2=0D0
- IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
- IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
- PM3=0D0
- IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
- IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
- PM4=0D0
- IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
- IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
- DO 110 I=IPA,IPA+3
- DO 100 J=1,5
- K(I,J)=0
- P(I,J)=0D0
- V(I,J)=0D0
- 100 CONTINUE
- 110 CONTINUE
-
-C...Check flavours.
- KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
- KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
- KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
- KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
- IF(MSTU(19).EQ.1) THEN
- MSTU(19)=0
- ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
- ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
- & KQ1+KQ4.EQ.4)) THEN
- ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
- & THEN
- ELSE
- CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
- ENDIF
- K(IPA,2)=KF1
- K(IPA+1,2)=KF2
- K(IPA+2,2)=KF3
- K(IPA+3,2)=KF4
-
-C...Store partons/particles in K vectors for normal case.
- IF(IP.GE.0) THEN
- K(IPA,1)=1
- IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
- K(IPA+1,1)=1
- IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
- & K(IPA+1,1)=2
- K(IPA+2,1)=1
- IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
- K(IPA+3,1)=1
-
-C...Store partons for parton shower evolution from q-g-g-qbar or
-C...g-g-g-g event.
- ELSEIF(KQ1+KQ2.NE.0) THEN
- K(IPA,1)=3
- K(IPA+1,1)=3
- K(IPA+2,1)=3
- K(IPA+3,1)=3
- KCS=4
- IF(KQ1.EQ.-1) KCS=5
- K(IPA,KCS)=MSTU(5)*(IPA+1)
- K(IPA,9-KCS)=MSTU(5)*(IPA+3)
- K(IPA+1,KCS)=MSTU(5)*(IPA+2)
- K(IPA+1,9-KCS)=MSTU(5)*IPA
- K(IPA+2,KCS)=MSTU(5)*(IPA+3)
- K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
- K(IPA+3,KCS)=MSTU(5)*IPA
- K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
-
-C...Store partons for parton shower evolution from q-qbar-q-qbar event.
- ELSE
- K(IPA,1)=3
- K(IPA+1,1)=3
- K(IPA+2,1)=3
- K(IPA+3,1)=3
- K(IPA,4)=MSTU(5)*(IPA+1)
- K(IPA,5)=K(IPA,4)
- K(IPA+1,4)=MSTU(5)*IPA
- K(IPA+1,5)=K(IPA+1,4)
- K(IPA+2,4)=MSTU(5)*(IPA+3)
- K(IPA+2,5)=K(IPA+2,4)
- K(IPA+3,4)=MSTU(5)*(IPA+2)
- K(IPA+3,5)=K(IPA+3,4)
- ENDIF
-
-C...Check kinematics.
- MKERR=0
- IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
- &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
- &MKERR=1
- PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
- PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
- PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
- X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
- CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
- IF(ABS(CTHE4).GE.1.002D0) MKERR=1
- CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
- STHE4=SQRT(1D0-CTHE4**2)
- CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
- IF(ABS(CTHE2).GE.1.002D0) MKERR=1
- CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
- STHE2=SQRT(1D0-CTHE2**2)
- CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
- &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
- IF(ABS(CPHI2).GE.1.05D0) MKERR=1
- CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
- IF(MKERR.EQ.1) CALL PYERRM(13,
- &'(PY4ENT:) unphysical kinematical variable setup')
-
-C...Store partons/particles in P vectors.
- P(IPA,3)=PA1
- P(IPA,4)=SQRT(PA1**2+PM1**2)
- P(IPA,5)=PM1
- P(IPA+3,1)=PA4*STHE4
- P(IPA+3,3)=PA4*CTHE4
- P(IPA+3,4)=SQRT(PA4**2+PM4**2)
- P(IPA+3,5)=PM4
- P(IPA+1,1)=PA2*STHE2*CPHI2
- P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
- P(IPA+1,3)=PA2*CTHE2
- P(IPA+1,4)=SQRT(PA2**2+PM2**2)
- P(IPA+1,5)=PM2
- P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
- P(IPA+2,2)=-P(IPA+1,2)
- P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
- P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
- P(IPA+2,5)=PM3
-
-C...Set N. Optionally fragment/decay.
- N=IPA+3
- IF(IP.EQ.0) CALL PYEXEC
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PY2FRM
-C...An interface from a two-fermion generator to include
-C...parton showers and hadronization.
-
- SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYJETS/,/PYDAT1/
-C...Local arrays.
- DIMENSION IJOIN(2),INTAU(2)
-
-C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
- IF(ICOM.EQ.0) THEN
- MSTU(28)=0
- CALL PYHEPC(2)
- ENDIF
-
-C...Loop through entries and pick up all final fermions/antifermions.
- I1=0
- I2=0
- DO 100 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
- KFA=IABS(K(I,2))
- IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
- IF(K(I,2).GT.0) THEN
- IF(I1.EQ.0) THEN
- I1=I
- ELSE
- CALL PYERRM(16,'(PY2FRM:) more than one fermion')
- ENDIF
- ELSE
- IF(I2.EQ.0) THEN
- I2=I
- ELSE
- CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
- ENDIF
- ENDIF
- ENDIF
- 100 CONTINUE
-
-C...Check that event is arranged according to conventions.
- IF(I1.EQ.0.OR.I2.EQ.0) THEN
- CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
- ENDIF
- IF(I2.LT.I1) THEN
- CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
- ENDIF
-
-C...Check whether fermion pair is quarks or leptons.
- IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
- IQL12=1
- ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
- IQL12=2
- ELSE
- CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
- ENDIF
-
-C...Decide whether to allow or not photon radiation in showers.
- MSTJ(41)=2
- IF(IRAD.EQ.0) MSTJ(41)=1
-
-C...Do colour joining and parton showers.
- IP1=I1
- IP2=I2
- IF(IQL12.EQ.1) THEN
- IJOIN(1)=IP1
- IJOIN(2)=IP2
- CALL PYJOIN(2,IJOIN)
- ENDIF
- IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
- PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
- & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
- if(parj(200).ne.1.) CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
- if(parj(200).eq.1.) CALL PYSHOWQ(IP1,IP2,SQRT(MAX(0D0,PM12S)))
- ENDIF
-
-C...Do fragmentation and decays. Possibly except tau decay.
- IF(ITAU.EQ.0) THEN
- NTAU=0
- DO 110 I=1,N
- IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
- NTAU=NTAU+1
- INTAU(NTAU)=I
- K(I,1)=11
- ENDIF
- 110 CONTINUE
- ENDIF
- CALL PYEXEC
- IF(ITAU.EQ.0) THEN
- DO 120 I=1,NTAU
- K(INTAU(I),1)=1
- 120 CONTINUE
- ENDIF
-
-C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
- IF(ICOM.EQ.0) THEN
- MSTU(28)=0
- CALL PYHEPC(1)
- ENDIF
-
- END
-
-C*********************************************************************
-
-C...PY4FRM
-C...An interface from a four-fermion generator to include
-C...parton showers and hadronization.
-
- SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
-C...Local arrays.
- DIMENSION IJOIN(2),INTAU(4)
-
-C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
- IF(ICOM.EQ.0) THEN
- MSTU(28)=0
- CALL PYHEPC(2)
- ENDIF
-
-C...Loop through entries and pick up all final fermions/antifermions.
- I1=0
- I2=0
- I3=0
- I4=0
- DO 100 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
- KFA=IABS(K(I,2))
- IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
- IF(K(I,2).GT.0) THEN
- IF(I1.EQ.0) THEN
- I1=I
- ELSEIF(I3.EQ.0) THEN
- I3=I
- ELSE
- CALL PYERRM(16,'(PY4FRM:) more than two fermions')
- ENDIF
- ELSE
- IF(I2.EQ.0) THEN
- I2=I
- ELSEIF(I4.EQ.0) THEN
- I4=I
- ELSE
- CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
- ENDIF
- ENDIF
- ENDIF
- 100 CONTINUE
-
-C...Check that event is arranged according to conventions.
- IF(I3.EQ.0.OR.I4.EQ.0) THEN
- CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
- ENDIF
- IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
- CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
- ENDIF
-
-C...Check which fermion pairs are quarks and which leptons.
- IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
- IQL12=1
- ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
- IQL12=2
- ELSE
- CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
- ENDIF
- IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
- IQL34=1
- ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
- IQL34=2
- ELSE
- CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
- ENDIF
-
-C...Decide whether to allow or not photon radiation in showers.
- MSTJ(41)=2
- IF(IRAD.EQ.0) MSTJ(41)=1
-
-C...Decide on dipole pairing.
- IP1=I1
- IP2=I2
- IP3=I3
- IP4=I4
- IF(IQL12.EQ.IQL34) THEN
- R1SQ=A1SQ
- R2SQ=A2SQ
- DELTA=ATOTSQ-A1SQ-A2SQ
- IF(ISTRAT.EQ.1) THEN
- IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
- IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
- ELSEIF(ISTRAT.EQ.2) THEN
- IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
- IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
- ENDIF
- IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
- IP2=I4
- IP4=I2
- ENDIF
- ENDIF
-
-C...If colour reconnection then bookkeep W+W- or Z0Z0
-C...and copy q qbar q qbar consecutively.
- IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
- K(N+1,1)=11
- K(N+1,3)=IP1
- K(N+1,4)=N+3
- K(N+1,5)=N+4
- K(N+2,1)=11
- K(N+2,3)=IP3
- K(N+2,4)=N+5
- K(N+2,5)=N+6
- IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
- K(N+1,2)=23
- K(N+2,2)=23
- MINT(1)=22
- ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
- K(N+1,2)=24
- K(N+2,2)=-24
- MINT(1)=25
- ELSE
- K(N+1,2)=-24
- K(N+2,2)=24
- MINT(1)=25
- ENDIF
- DO 110 J=1,5
- K(N+3,J)=K(IP1,J)
- K(N+4,J)=K(IP2,J)
- K(N+5,J)=K(IP3,J)
- K(N+6,J)=K(IP4,J)
- P(N+1,J)=P(IP1,J)+P(IP2,J)
- P(N+2,J)=P(IP3,J)+P(IP4,J)
- P(N+3,J)=P(IP1,J)
- P(N+4,J)=P(IP2,J)
- P(N+5,J)=P(IP3,J)
- P(N+6,J)=P(IP4,J)
- V(N+1,J)=V(IP1,J)
- V(N+2,J)=V(IP3,J)
- V(N+3,J)=V(IP1,J)
- V(N+4,J)=V(IP2,J)
- V(N+5,J)=V(IP3,J)
- V(N+6,J)=V(IP4,J)
- 110 CONTINUE
- P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
- & P(N+1,3)**2))
- P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
- & P(N+2,3)**2))
- K(N+3,3)=N+1
- K(N+4,3)=N+1
- K(N+5,3)=N+2
- K(N+6,3)=N+2
-C...Remove original q qbar q qbar and update counters.
- K(IP1,1)=K(IP1,1)+10
- K(IP2,1)=K(IP2,1)+10
- K(IP3,1)=K(IP3,1)+10
- K(IP4,1)=K(IP4,1)+10
- IW1=N+1
- IW2=N+2
- NSD1=N+2
- IP1=N+3
- IP2=N+4
- IP3=N+5
- IP4=N+6
- N=N+6
- ENDIF
-
-C...Do colour joinings and parton showers.
- IF(IQL12.EQ.1) THEN
- IJOIN(1)=IP1
- IJOIN(2)=IP2
- CALL PYJOIN(2,IJOIN)
- ENDIF
- IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
- PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
- & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
- if(parj(200).ne.1.) CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
- if(parj(200).eq.1.) CALL PYSHOWQ(IP1,IP2,SQRT(MAX(0D0,PM12S)))
- ENDIF
- NAFT1=N
- IF(IQL34.EQ.1) THEN
- IJOIN(1)=IP3
- IJOIN(2)=IP4
- CALL PYJOIN(2,IJOIN)
- ENDIF
- IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
- PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
- & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
- if(parj(200).ne.1.) CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
- if(parj(200).eq.1.) CALL PYSHOWQ(IP3,IP4,SQRT(MAX(0D0,PM34S)))
- ENDIF
-
-C...Optionally do colour reconnection.
- MINT(32)=0
- MSTI(32)=0
- IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
- CALL PYRECO(IW1,IW2,NSD1,NAFT1)
- MSTI(32)=MINT(32)
- ENDIF
-
-C...Do fragmentation and decays. Possibly except tau decay.
- IF(ITAU.EQ.0) THEN
- NTAU=0
- DO 120 I=1,N
- IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
- NTAU=NTAU+1
- INTAU(NTAU)=I
- K(I,1)=11
- ENDIF
- 120 CONTINUE
- ENDIF
- CALL PYEXEC
- IF(ITAU.EQ.0) THEN
- DO 130 I=1,NTAU
- K(INTAU(I),1)=1
- 130 CONTINUE
- ENDIF
-
-C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
- IF(ICOM.EQ.0) THEN
- MSTU(28)=0
- CALL PYHEPC(1)
- ENDIF
-
- END
-
-C*********************************************************************
-
-C...PY6FRM
-C...An interface from a six-fermion generator to include
-C...parton showers and hadronization.
-
- SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYJETS/,/PYDAT1/
-C...Local arrays.
- DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
-
-C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
- IF(ICOM.EQ.0) THEN
- MSTU(28)=0
- CALL PYHEPC(2)
- ENDIF
-
-C...Loop through entries and pick up all final fermions/antifermions.
- I1=0
- I2=0
- I3=0
- I4=0
- I5=0
- I6=0
- DO 100 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
- KFA=IABS(K(I,2))
- IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
- IF(K(I,2).GT.0) THEN
- IF(I1.EQ.0) THEN
- I1=I
- ELSEIF(I3.EQ.0) THEN
- I3=I
- ELSEIF(I5.EQ.0) THEN
- I5=I
- ELSE
- CALL PYERRM(16,'(PY6FRM:) more than three fermions')
- ENDIF
- ELSE
- IF(I2.EQ.0) THEN
- I2=I
- ELSEIF(I4.EQ.0) THEN
- I4=I
- ELSEIF(I6.EQ.0) THEN
- I6=I
- ELSE
- CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
- ENDIF
- ENDIF
- ENDIF
- 100 CONTINUE
-
-C...Check that event is arranged according to conventions.
- IF(I5.EQ.0.OR.I6.EQ.0) THEN
- CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
- ENDIF
- IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
- CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
- ENDIF
-
-C...Check which fermion pairs are quarks and which leptons.
- IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
- IQL12=1
- ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
- IQL12=2
- ELSE
- CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
- ENDIF
- IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
- IQL34=1
- ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
- IQL34=2
- ELSE
- CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
- ENDIF
- IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
- IQL56=1
- ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
- IQL56=2
- ELSE
- CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
- ENDIF
-
-C...Decide whether to allow or not photon radiation in showers.
- MSTJ(41)=2
- IF(IRAD.EQ.0) MSTJ(41)=1
-
-C...Allow dipole pairings only among leptons and quarks separately.
- P12D=P12
- P13D=0D0
- IF(IQL34.EQ.IQL56) P13D=P13
- P21D=0D0
- IF(IQL12.EQ.IQL34) P21D=P21
- P23D=0D0
- IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
- P31D=0D0
- IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
- P32D=0D0
- IF(IQL12.EQ.IQL56) P32D=P32
-
-C...Decide whether t+tbar.
- ITOP=0
- IF(PYR(0).LT.PTOP) THEN
- ITOP=1
-
-C...If t+tbar: reconstruct t's.
- IT=N+1
- ITB=N+2
- DO 110 J=1,5
- K(IT,J)=0
- K(ITB,J)=0
- P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
- P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
- V(IT,J)=0D0
- V(ITB,J)=0D0
- 110 CONTINUE
- K(IT,1)=1
- K(ITB,1)=1
- K(IT,2)=6
- K(ITB,2)=-6
- P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
- & P(IT,3)**2))
- P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
- & P(ITB,3)**2))
- N=N+2
-
-C...If t+tbar: colour join t's and let them shower.
- IJOIN(1)=IT
- IJOIN(2)=ITB
- CALL PYJOIN(2,IJOIN)
- PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
- & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
- if(parj(200).ne.1.) CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
- if(parj(200).eq.1.) CALL PYSHOWQ(IT,ITB,SQRT(MAX(0D0,PMTTS)))
-C...If t+tbar: pick up the t's after shower.
- ITNEW=IT
- ITBNEW=ITB
- DO 120 I=ITB+1,N
- IF(K(I,2).EQ.6) ITNEW=I
- IF(K(I,2).EQ.-6) ITBNEW=I
- 120 CONTINUE
-
-C...If t+tbar: loop over two top systems.
- DO 200 IT1=1,2
- IF(IT1.EQ.1) THEN
- ITO=IT
- ITN=ITNEW
- IBO=I1
- IW1=I3
- IW2=I4
- ELSE
- ITO=ITB
- ITN=ITBNEW
- IBO=I2
- IW1=I5
- IW2=I6
- ENDIF
- IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
- & '(PY6FRM:) not b in t decay')
-
-C...If t+tbar: find boost from original to new top frame.
- DO 130 J=1,3
- BETAO(J)=P(ITO,J)/P(ITO,4)
- BETAN(J)=P(ITN,J)/P(ITN,4)
- 130 CONTINUE
-
-C...If t+tbar: boost copy of b by t shower and connect it in colour.
- N=N+1
- IB=N
- K(IB,1)=3
- K(IB,2)=K(IBO,2)
- K(IB,3)=ITN
- DO 140 J=1,5
- P(IB,J)=P(IBO,J)
- V(IB,J)=0D0
- 140 CONTINUE
- CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
- CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
- K(IB,4)=MSTU(5)*ITN
- K(IB,5)=MSTU(5)*ITN
- K(ITN,4)=K(ITN,4)+IB
- K(ITN,5)=K(ITN,5)+IB
- K(ITN,1)=K(ITN,1)+10
- K(IBO,1)=K(IBO,1)+10
-
-C...If t+tbar: construct W recoiling against b.
- N=N+1
- IW=N
- DO 150 J=1,5
- K(IW,J)=0
- V(IW,J)=0D0
- 150 CONTINUE
- K(IW,1)=1
- KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
- IF(IABS(KCHW).EQ.3) THEN
- K(IW,2)=ISIGN(24,KCHW)
- ELSE
- CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
- ENDIF
- K(IW,3)=IW1
-
-C...If t+tbar: construct W momentum, including boost by t shower.
- DO 160 J=1,4
- P(IW,J)=P(IW1,J)+P(IW2,J)
- 160 CONTINUE
- P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
- & P(IW,3)**2))
- CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
- CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
-
-C...If t+tbar: boost b and W to top rest frame.
- DO 170 J=1,3
- BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
- 170 CONTINUE
- CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
- CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
-
-C...If t+tbar: let b shower and pick up modified W.
- PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
- & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
- if(parj(200).ne.1.) CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
- if(parj(200).eq.1.) CALL PYSHOWQ(IB,IW,SQRT(MAX(0D0,PMTS)))
- DO 180 I=IW,N
- IF(IABS(K(I,2)).EQ.24) IWM=I
- 180 CONTINUE
-
-C...If t+tbar: take copy of W decay products.
- DO 190 J=1,5
- K(N+1,J)=K(IW1,J)
- P(N+1,J)=P(IW1,J)
- V(N+1,J)=V(IW1,J)
- K(N+2,J)=K(IW2,J)
- P(N+2,J)=P(IW2,J)
- V(N+2,J)=V(IW2,J)
- 190 CONTINUE
- K(IW1,1)=K(IW1,1)+10
- K(IW2,1)=K(IW2,1)+10
- K(IWM,1)=K(IWM,1)+10
- K(IWM,4)=N+1
- K(IWM,5)=N+2
- K(N+1,3)=IWM
- K(N+2,3)=IWM
- IF(IT1.EQ.1) THEN
- I3=N+1
- I4=N+2
- ELSE
- I5=N+1
- I6=N+2
- ENDIF
- N=N+2
-
-C...If t+tbar: boost W decay products, first by effects of t shower,
-C...then by those of b shower. b and its shower simple boost back.
- CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
- CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
- CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
- CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
- & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
- CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
- & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
- CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
- CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
- 200 CONTINUE
- ENDIF
-
-C...Decide on dipole pairing.
- IP1=I1
- IP3=I3
- IP5=I5
- PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
- IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
- IP2=I2
- IP4=I4
- IP6=I6
- ELSEIF(PRN.LT.P12D+P13D) THEN
- IP2=I2
- IP4=I6
- IP6=I4
- ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
- IP2=I4
- IP4=I2
- IP6=I6
- ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
- IP2=I4
- IP4=I6
- IP6=I2
- ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
- IP2=I6
- IP4=I2
- IP6=I4
- ELSE
- IP2=I6
- IP4=I4
- IP6=I2
- ENDIF
-
-C...Do colour joinings and parton showers
-C...(except ones already made for t+tbar).
- IF(ITOP.EQ.0) THEN
- IF(IQL12.EQ.1) THEN
- IJOIN(1)=IP1
- IJOIN(2)=IP2
- CALL PYJOIN(2,IJOIN)
- ENDIF
- IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
- PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
- & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
- if(parj(200).ne.1.) CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
- if(parj(200).eq.1.) CALL PYSHOWQ(IP1,IP2,SQRT(MAX(0D0,PM12S)))
- ENDIF
- ENDIF
- IF(IQL34.EQ.1) THEN
- IJOIN(1)=IP3
- IJOIN(2)=IP4
- CALL PYJOIN(2,IJOIN)
- ENDIF
- IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
- PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
- & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
- if(parj(200).ne.1.) CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
- if(parj(200).eq.1.) CALL PYSHOWQ(IP3,IP4,SQRT(MAX(0D0,PM34S)))
- ENDIF
- IF(IQL56.EQ.1) THEN
- IJOIN(1)=IP5
- IJOIN(2)=IP6
- CALL PYJOIN(2,IJOIN)
- ENDIF
- IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
- PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
- & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
- if(parj(200).ne.1.) CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
- if(parj(200).eq.1.) CALL PYSHOWQ(IP5,IP6,SQRT(MAX(0D0,PM56S)))
- ENDIF
-
-C...Do fragmentation and decays. Possibly except tau decay.
- IF(ITAU.EQ.0) THEN
- NTAU=0
- DO 210 I=1,N
- IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
- NTAU=NTAU+1
- INTAU(NTAU)=I
- K(I,1)=11
- ENDIF
- 210 CONTINUE
- ENDIF
- CALL PYEXEC
- IF(ITAU.EQ.0) THEN
- DO 220 I=1,NTAU
- K(INTAU(I),1)=1
- 220 CONTINUE
- ENDIF
-
-C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
- IF(ICOM.EQ.0) THEN
- MSTU(28)=0
- CALL PYHEPC(1)
- ENDIF
-
- END
-
-C*********************************************************************
-
-C...PY4JET
-C...An interface from a four-parton generator to include
-C...parton showers and hadronization.
-
- SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYJETS/,/PYDAT1/
-C...Local arrays.
- DIMENSION IJOIN(2),PTOT(4),BETA(3)
-
-C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
- IF(ICOM.EQ.0) THEN
- MSTU(28)=0
- CALL PYHEPC(2)
- ENDIF
-
-C...Loop through entries and pick up all final partons.
- I1=0
- I2=0
- I3=0
- I4=0
- DO 100 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
- KFA=IABS(K(I,2))
- IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
- IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
- IF(I1.EQ.0) THEN
- I1=I
- ELSEIF(I3.EQ.0) THEN
- I3=I
- ELSE
- CALL PYERRM(16,'(PY4JET:) more than two quarks')
- ENDIF
- ELSEIF(K(I,2).LT.0) THEN
- IF(I2.EQ.0) THEN
- I2=I
- ELSEIF(I4.EQ.0) THEN
- I4=I
- ELSE
- CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
- ENDIF
- ELSE
- IF(I3.EQ.0) THEN
- I3=I
- ELSEIF(I4.EQ.0) THEN
- I4=I
- ELSE
- CALL PYERRM(16,'(PY4JET:) more than two gluons')
- ENDIF
- ENDIF
- ENDIF
- 100 CONTINUE
-
-C...Check that event is arranged according to conventions.
- IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
- CALL PYERRM(16,'(PY4JET:) event contains too few partons')
- ENDIF
- IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
- CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
- ENDIF
-
-C...Check whether second pair are quarks or gluons.
- IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
- IQG34=1
- ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
- IQG34=2
- ELSE
- CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
- ENDIF
-
-C...Boost partons to their cm frame.
- DO 110 J=1,4
- PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
- 110 CONTINUE
- ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
- DO 120 J=1,3
- BETA(J)=PTOT(J)/PTOT(4)
- 120 CONTINUE
- CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
- CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
- CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
- CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
- NSAV=N
-
-C...Decide and set up shower history for q qbar q' qbar' events.
- IF(IQG34.EQ.1) THEN
- W1=PY4JTW(0,I1,I3,I4)
- W2=PY4JTW(0,I2,I3,I4)
- IF(W1.GT.PYR(0)*(W1+W2)) THEN
- CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
- ELSE
- CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
- ENDIF
-
-C...Decide and set up shower history for q qbar g g events.
- ELSE
- W1=PY4JTW(I1,I3,I2,I4)
- W2=PY4JTW(I1,I4,I2,I3)
- W3=PY4JTW(0,I3,I1,I4)
- W4=PY4JTW(0,I4,I1,I3)
- W5=PY4JTW(0,I3,I2,I4)
- W6=PY4JTW(0,I4,I2,I3)
- W7=PY4JTW(0,I1,I3,I4)
- W8=PY4JTW(0,I2,I3,I4)
- WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
- IF(W1.GT.WR) THEN
- CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
- ELSEIF(W1+W2.GT.WR) THEN
- CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
- ELSEIF(W1+W2+W3.GT.WR) THEN
- CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
- ELSEIF(W1+W2+W3+W4.GT.WR) THEN
- CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
- ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
- CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
- ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
- CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
- ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
- CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
- ELSE
- CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
- ENDIF
- ENDIF
-
-C...Boost back original partons and mark them as deleted.
- CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
- CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
- CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
- CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
- K(I1,1)=K(I1,1)+10
- K(I2,1)=K(I2,1)+10
- K(I3,1)=K(I3,1)+10
- K(I4,1)=K(I4,1)+10
-
-C...Rotate shower initiating partons to be along z axis.
- PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
- CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
- THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
- CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
-
-C...Set up copy of shower initiating partons as on mass shell.
- DO 140 I=N+1,N+2
- DO 130 J=1,5
- K(I,J)=0
- P(I,J)=0D0
- V(I,J)=V(I1,J)
- 130 CONTINUE
- K(I,1)=1
- K(I,2)=K(I-6,2)
- 140 CONTINUE
- IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
- K(N+1,3)=I1
- P(N+1,5)=P(I1,5)
- K(N+2,3)=I2
- P(N+2,5)=P(I2,5)
- ELSE
- K(N+1,3)=I2
- P(N+1,5)=P(I2,5)
- K(N+2,3)=I1
- P(N+2,5)=P(I1,5)
- ENDIF
- PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
- &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
- P(N+1,3)=PABS
- P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
- P(N+2,3)=-PABS
- P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
- N=N+2
-
-C...Decide whether to allow or not photon radiation in showers.
-C...Connect up colours.
- MSTJ(41)=2
- IF(IRAD.EQ.0) MSTJ(41)=1
- IJOIN(1)=N-1
- IJOIN(2)=N
- CALL PYJOIN(2,IJOIN)
-
-C...Decide on maximum virtuality and do parton shower.
- IF(PMAX.LT.PARJ(82)) THEN
- PQMAX=QMAX
- ELSE
- PQMAX=PMAX
- ENDIF
- if(parj(200).ne.1.) CALL PYSHOW(NSAV+1,-100,PQMAX)
- if(parj(200).eq.1.) CALL PYSHOWQ(NSAV+1,-100,PQMAX)
-
-C...Rotate and boost back system.
- CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
-
-C...Do fragmentation and decays.
- CALL PYEXEC
-
-C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
- IF(ICOM.EQ.0) THEN
- MSTU(28)=0
- CALL PYHEPC(1)
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PY4JTW
-C...Auxiliary to PY4JET, to evaluate weight of configuration.
-
- FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- SAVE /PYJETS/
-
-C...First case: when both original partons radiate.
-C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
- IF(IA1.NE.0) THEN
- DO 100 J=1,4
- P(N+1,J)=P(IA1,J)+P(IA2,J)
- P(N+2,J)=P(IA3,J)+P(IA4,J)
- 100 CONTINUE
- P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
- & P(N+1,3)**2))
- P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
- & P(N+2,3)**2))
- Z1=P(IA1,4)/P(N+1,4)
- WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
- Z2=P(IA3,4)/P(N+2,4)
- WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
-
-C...Second case: when one original parton radiates to three.
-C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
- ELSE
- DO 110 J=1,4
- P(N+2,J)=P(IA3,J)+P(IA4,J)
- P(N+1,J)=P(N+2,J)+P(IA2,J)
- 110 CONTINUE
- P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
- & P(N+1,3)**2))
- P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
- & P(N+2,3)**2))
- IF(K(IA2,2).EQ.21) THEN
- Z1=P(N+2,4)/P(N+1,4)
- WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
- & P(IA3,5)**2)
- ELSE
- Z1=P(IA2,4)/P(N+1,4)
- WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
- & P(IA2,5)**2)
- ENDIF
- Z2=P(IA3,4)/P(N+2,4)
- IF(K(IA2,2).EQ.21) THEN
- WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
- & P(IA3,5)**2)
- ELSEIF(K(IA3,2).EQ.21) THEN
- WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
- ELSE
- WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
- ENDIF
- ENDIF
-
-C...Total weight.
- PY4JTW=WT1*WT2
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PY4JTS
-C...Auxiliary to PY4JET, to set up chosen configuration.
-
- SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- SAVE /PYJETS/
-
-C...Reset info.
- DO 110 I=N+1,N+6
- DO 100 J=1,5
- K(I,J)=0
- V(I,J)=V(IA2,J)
- 100 CONTINUE
- K(I,1)=16
- 110 CONTINUE
-
-C...First case: when both original partons radiate.
-C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
- IF(IA1.NE.0) THEN
-
-C...Set up flavour and history pointers for new partons.
- K(N+1,2)=K(IA1,2)
- K(N+2,2)=K(IA3,2)
- K(N+3,2)=K(IA1,2)
- K(N+4,2)=K(IA2,2)
- K(N+5,2)=K(IA3,2)
- K(N+6,2)=K(IA4,2)
- K(N+1,3)=IA1
- K(N+1,4)=N+3
- K(N+1,5)=N+4
- K(N+2,3)=IA3
- K(N+2,4)=N+5
- K(N+2,5)=N+6
- K(N+3,3)=N+1
- K(N+4,3)=N+1
- K(N+5,3)=N+2
- K(N+6,3)=N+2
-
-C...Set up momenta for new partons.
- DO 120 J=1,5
- P(N+1,J)=P(IA1,J)+P(IA2,J)
- P(N+2,J)=P(IA3,J)+P(IA4,J)
- P(N+3,J)=P(IA1,J)
- P(N+4,J)=P(IA2,J)
- P(N+5,J)=P(IA3,J)
- P(N+6,J)=P(IA4,J)
- 120 CONTINUE
- P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
- & P(N+1,3)**2))
- P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
- & P(N+2,3)**2))
- QMAX=MIN(P(N+1,5),P(N+2,5))
-
-C...Second case: q radiates twice.
-C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
-C...IA5=N+2 does not radiate.
- ELSEIF(K(IA2,2).EQ.21) THEN
-
-C...Set up flavour and history pointers for new partons.
- K(N+1,2)=K(IA3,2)
- K(N+2,2)=K(IA5,2)
- K(N+3,2)=K(IA3,2)
- K(N+4,2)=K(IA2,2)
- K(N+5,2)=K(IA3,2)
- K(N+6,2)=K(IA4,2)
- K(N+1,3)=IA3
- K(N+1,4)=N+3
- K(N+1,5)=N+4
- K(N+2,3)=IA5
- K(N+3,3)=N+1
- K(N+3,4)=N+5
- K(N+3,5)=N+6
- K(N+4,3)=N+1
- K(N+5,3)=N+3
- K(N+6,3)=N+3
-
-C...Set up momenta for new partons.
- DO 130 J=1,5
- P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
- P(N+2,J)=P(IA5,J)
- P(N+3,J)=P(IA3,J)+P(IA4,J)
- P(N+4,J)=P(IA2,J)
- P(N+5,J)=P(IA3,J)
- P(N+6,J)=P(IA4,J)
- 130 CONTINUE
- P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
- & P(N+1,3)**2))
- P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
- & P(N+3,3)**2))
- QMAX=P(N+3,5)
-
-C...Third case: q radiates g, g branches.
-C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
-C...IA5=N+2 does not radiate.
- ELSE
-
-C...Set up flavour and history pointers for new partons.
- K(N+1,2)=K(IA2,2)
- K(N+2,2)=K(IA5,2)
- K(N+3,2)=K(IA2,2)
- K(N+4,2)=21
- K(N+5,2)=K(IA3,2)
- K(N+6,2)=K(IA4,2)
- K(N+1,3)=IA2
- K(N+1,4)=N+3
- K(N+1,5)=N+4
- K(N+2,3)=IA5
- K(N+3,3)=N+1
- K(N+4,3)=N+1
- K(N+4,4)=N+5
- K(N+4,5)=N+6
- K(N+5,3)=N+4
- K(N+6,3)=N+4
-
-C...Set up momenta for new partons.
- DO 140 J=1,5
- P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
- P(N+2,J)=P(IA5,J)
- P(N+3,J)=P(IA2,J)
- P(N+4,J)=P(IA3,J)+P(IA4,J)
- P(N+5,J)=P(IA3,J)
- P(N+6,J)=P(IA4,J)
- 140 CONTINUE
- P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
- & P(N+1,3)**2))
- P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
- & P(N+4,3)**2))
- QMAX=P(N+4,5)
-
- ENDIF
- N=N+6
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYJOIN
-C...Connects a sequence of partons with colour flow indices,
-C...as required for subsequent shower evolution (or other operations).
-
- SUBROUTINE PYJOIN(NJOIN,IJOIN)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-C...Local array.
- DIMENSION IJOIN(*)
-
-C...Check that partons are of right types to be connected.
- IF(NJOIN.LT.2) GOTO 120
- KQSUM=0
- DO 100 IJN=1,NJOIN
- I=IJOIN(IJN)
- IF(I.LE.0.OR.I.GT.N) GOTO 120
- IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0) GOTO 120
- KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
- IF(KQ.EQ.0) GOTO 120
- IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
- IF(KQ.NE.2) KQSUM=KQSUM+KQ
- IF(IJN.EQ.1) KQS=KQ
- 100 CONTINUE
- IF(KQSUM.NE.0) GOTO 120
-
-C...Connect the partons sequentially (closing for gluon loop).
- KCS=(9-KQS)/2
- IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
- DO 110 IJN=1,NJOIN
- I=IJOIN(IJN)
- K(I,1)=3
- IF(IJN.NE.1) IP=IJOIN(IJN-1)
- IF(IJN.EQ.1) IP=IJOIN(NJOIN)
- IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
- IF(IJN.EQ.NJOIN) IN=IJOIN(1)
- K(I,KCS)=MSTU(5)*IN
- K(I,9-KCS)=MSTU(5)*IP
- IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
- IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
- 110 CONTINUE
-
-C...Error exit: no action taken.
- RETURN
- 120 CALL PYERRM(12,
- &'(PYJOIN:) given entries can not be joined by one string')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYGIVE
-C...Sets values of commonblock variables.
-
- SUBROUTINE PYGIVE(CHIN)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYDAT4/CHAF(500,2)
- CHARACTER CHAF*16
- COMMON/PYDATR/MRPY(6),RRPY(100)
- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
- COMMON/PYINT6/PROC(0:500)
- CHARACTER PROC*28
- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
- COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
- &XPDIR(-6:6)
- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
- COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
- COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
- &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
- &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/
-C...Local arrays and character variables.
- CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
- &CHNEW2*28,CHNAM*6,CHVAR(54)*6,CHALP(2)*26,CHIND*8,CHINI*10,
- &CHINR*16,CHDIG*10
- DIMENSION MSVAR(54,8)
-
-C...For each variable to be translated give: name,
-C...integer/real/character, no. of indices, lower&upper index bounds.
- DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
- &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
- &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
- &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
- &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
- &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
- &'ITCM','RTCM'/
- DATA ((MSVAR(I,J),J=1,8),I=1,54)/ 1,7*0, 1,2,1,4000,1,5,2*0,
- &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
- &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
- &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
- &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
- &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
- &1,1,1,6,4*0, 2,1,1,100,4*0,
- &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
- &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
- &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
- &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
- &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
- &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
- &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
- &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
- &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
- &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
- &1,1,0,99,4*0, 2,1,0,99,4*0/
- DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
- &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
-
-C...Length of character variable. Subdivide it into instructions.
- IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
- &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
- CHBIT=CHIN//' '
- LBIT=101
- 100 LBIT=LBIT-1
- IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
- LTOT=0
- DO 110 LCOM=1,LBIT
- IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
- LTOT=LTOT+1
- CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
- 110 CONTINUE
- LLOW=0
- 120 LHIG=LLOW+1
- 130 LHIG=LHIG+1
- IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
- LBIT=LHIG-LLOW-1
- CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
-
-C...Send off decay-mode on/off commands to PYONOF.
- IONOF=0
- DO 135 LDIG=1,10
- IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
- 135 CONTINUE
- IF(IONOF.EQ.1) THEN
- CALL PYONOF(CHIN)
- RETURN
- ENDIF
-
-C...Peel off any text following exclamation mark.
- LHIG2=LBIT
- DO 140 LLOW2=LHIG2,1,-1
- IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
- 140 CONTINUE
- IF(LBIT.EQ.0) RETURN
-
-C...Identify commonblock variable.
- LNAM=1
- 150 LNAM=LNAM+1
- IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
- &LNAM.LE.6) GOTO 150
- CHNAM=CHBIT(1:LNAM-1)//' '
- DO 170 LCOM=1,LNAM-1
- DO 160 LALP=1,26
- IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
- & CHALP(2)(LALP:LALP)
- 160 CONTINUE
- 170 CONTINUE
- IVAR=0
- DO 180 IV=1,54
- IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
- 180 CONTINUE
- IF(IVAR.EQ.0) THEN
- CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
- LLOW=LHIG
- IF(LLOW.LT.LTOT) GOTO 120
- RETURN
- ENDIF
-
-C...Identify any indices.
- I1=0
- I2=0
- I3=0
- NINDX=0
- IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
- LIND=LNAM
- 190 LIND=LIND+1
- IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
- CHIND=' '
- IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
- & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
- & IVAR.EQ.37)) THEN
- CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
- READ(CHIND,'(I8)') KF
- I1=PYCOMP(KF)
- ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
- & 'c') THEN
- CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
- & CHNAM)
- LLOW=LHIG
- IF(LLOW.LT.LTOT) GOTO 120
- RETURN
- ELSE
- CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
- READ(CHIND,'(I8)') I1
- ENDIF
- LNAM=LIND
- IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
- NINDX=1
- ENDIF
- IF(CHBIT(LNAM:LNAM).EQ.',') THEN
- LIND=LNAM
- 200 LIND=LIND+1
- IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
- CHIND=' '
- CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
- READ(CHIND,'(I8)') I2
- LNAM=LIND
- IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
- NINDX=2
- ENDIF
- IF(CHBIT(LNAM:LNAM).EQ.',') THEN
- LIND=LNAM
- 210 LIND=LIND+1
- IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
- CHIND=' '
- CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
- READ(CHIND,'(I8)') I3
- LNAM=LIND+1
- NINDX=3
- ENDIF
-
-C...Check that indices allowed.
- IERR=0
- IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
- IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
- &IERR=2
- IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
- &IERR=3
- IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
- &IERR=4
- IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
- IF(IERR.GE.1) THEN
- CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
- & CHBIT(1:LNAM-1))
- LLOW=LHIG
- IF(LLOW.LT.LTOT) GOTO 120
- RETURN
- ENDIF
-
-C...Save old value of variable.
- IF(IVAR.EQ.1) THEN
- IOLD=N
- ELSEIF(IVAR.EQ.2) THEN
- IOLD=K(I1,I2)
- ELSEIF(IVAR.EQ.3) THEN
- ROLD=P(I1,I2)
- ELSEIF(IVAR.EQ.4) THEN
- ROLD=V(I1,I2)
- ELSEIF(IVAR.EQ.5) THEN
- IOLD=MSTU(I1)
- ELSEIF(IVAR.EQ.6) THEN
- ROLD=PARU(I1)
- ELSEIF(IVAR.EQ.7) THEN
- IOLD=MSTJ(I1)
- ELSEIF(IVAR.EQ.8) THEN
- ROLD=PARJ(I1)
- ELSEIF(IVAR.EQ.9) THEN
- IOLD=KCHG(I1,I2)
- ELSEIF(IVAR.EQ.10) THEN
- ROLD=PMAS(I1,I2)
- ELSEIF(IVAR.EQ.11) THEN
- ROLD=PARF(I1)
- ELSEIF(IVAR.EQ.12) THEN
- ROLD=VCKM(I1,I2)
- ELSEIF(IVAR.EQ.13) THEN
- IOLD=MDCY(I1,I2)
- ELSEIF(IVAR.EQ.14) THEN
- IOLD=MDME(I1,I2)
- ELSEIF(IVAR.EQ.15) THEN
- ROLD=BRAT(I1)
- ELSEIF(IVAR.EQ.16) THEN
- IOLD=KFDP(I1,I2)
- ELSEIF(IVAR.EQ.17) THEN
- CHOLD=CHAF(I1,I2)(1:8)
- ELSEIF(IVAR.EQ.18) THEN
- IOLD=MRPY(I1)
- ELSEIF(IVAR.EQ.19) THEN
- ROLD=RRPY(I1)
- ELSEIF(IVAR.EQ.20) THEN
- IOLD=MSEL
- ELSEIF(IVAR.EQ.21) THEN
- IOLD=MSUB(I1)
- ELSEIF(IVAR.EQ.22) THEN
- IOLD=KFIN(I1,I2)
- ELSEIF(IVAR.EQ.23) THEN
- ROLD=CKIN(I1)
- ELSEIF(IVAR.EQ.24) THEN
- IOLD=MSTP(I1)
- ELSEIF(IVAR.EQ.25) THEN
- ROLD=PARP(I1)
- ELSEIF(IVAR.EQ.26) THEN
- IOLD=MSTI(I1)
- ELSEIF(IVAR.EQ.27) THEN
- ROLD=PARI(I1)
- ELSEIF(IVAR.EQ.28) THEN
- IOLD=MINT(I1)
- ELSEIF(IVAR.EQ.29) THEN
- ROLD=VINT(I1)
- ELSEIF(IVAR.EQ.30) THEN
- IOLD=ISET(I1)
- ELSEIF(IVAR.EQ.31) THEN
- IOLD=KFPR(I1,I2)
- ELSEIF(IVAR.EQ.32) THEN
- ROLD=COEF(I1,I2)
- ELSEIF(IVAR.EQ.33) THEN
- IOLD=ICOL(I1,I2,I3)
- ELSEIF(IVAR.EQ.34) THEN
- ROLD=XSFX(I1,I2)
- ELSEIF(IVAR.EQ.35) THEN
- IOLD=ISIG(I1,I2)
- ELSEIF(IVAR.EQ.36) THEN
- ROLD=SIGH(I1)
- ELSEIF(IVAR.EQ.37) THEN
- IOLD=MWID(I1)
- ELSEIF(IVAR.EQ.38) THEN
- ROLD=WIDS(I1,I2)
- ELSEIF(IVAR.EQ.39) THEN
- IOLD=NGEN(I1,I2)
- ELSEIF(IVAR.EQ.40) THEN
- ROLD=XSEC(I1,I2)
- ELSEIF(IVAR.EQ.41) THEN
- CHOLD2=PROC(I1)
- ELSEIF(IVAR.EQ.42) THEN
- ROLD=SIGT(I1,I2,I3)
- ELSEIF(IVAR.EQ.43) THEN
- ROLD=XPVMD(I1)
- ELSEIF(IVAR.EQ.44) THEN
- ROLD=XPANL(I1)
- ELSEIF(IVAR.EQ.45) THEN
- ROLD=XPANH(I1)
- ELSEIF(IVAR.EQ.46) THEN
- ROLD=XPBEH(I1)
- ELSEIF(IVAR.EQ.47) THEN
- ROLD=XPDIR(I1)
- ELSEIF(IVAR.EQ.48) THEN
- IOLD=IMSS(I1)
- ELSEIF(IVAR.EQ.49) THEN
- ROLD=RMSS(I1)
- ELSEIF(IVAR.EQ.50) THEN
- ROLD=RVLAM(I1,I2,I3)
- ELSEIF(IVAR.EQ.51) THEN
- ROLD=RVLAMP(I1,I2,I3)
- ELSEIF(IVAR.EQ.52) THEN
- ROLD=RVLAMB(I1,I2,I3)
- ELSEIF(IVAR.EQ.53) THEN
- IOLD=ITCM(I1)
- ELSEIF(IVAR.EQ.54) THEN
- ROLD=RTCM(I1)
- ENDIF
-
-C...Print current value of variable. Loop back.
- IF(LNAM.GE.LBIT) THEN
- CHBIT(LNAM:14)=' '
- CHBIT(15:60)=' has the value '
- IF(MSVAR(IVAR,1).EQ.1) THEN
- WRITE(CHBIT(51:60),'(I10)') IOLD
- ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
- WRITE(CHBIT(47:60),'(F14.5)') ROLD
- ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
- CHBIT(53:60)=CHOLD
- ELSE
- CHBIT(33:60)=CHOLD
- ENDIF
- IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
- LLOW=LHIG
- IF(LLOW.LT.LTOT) GOTO 120
- RETURN
- ENDIF
-
-C...Read in new variable value.
- IF(MSVAR(IVAR,1).EQ.1) THEN
- CHINI=' '
- CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
- READ(CHINI,'(I10)') INEW
- ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
- CHINR=' '
- CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
- READ(CHINR,*) RNEW
- ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
- CHNEW=CHBIT(LNAM+1:LBIT)//' '
- ELSE
- CHNEW2=CHBIT(LNAM+1:LBIT)//' '
- ENDIF
-
-C...Store new variable value.
- IF(IVAR.EQ.1) THEN
- N=INEW
- ELSEIF(IVAR.EQ.2) THEN
- K(I1,I2)=INEW
- ELSEIF(IVAR.EQ.3) THEN
- P(I1,I2)=RNEW
- ELSEIF(IVAR.EQ.4) THEN
- V(I1,I2)=RNEW
- ELSEIF(IVAR.EQ.5) THEN
- MSTU(I1)=INEW
- ELSEIF(IVAR.EQ.6) THEN
- PARU(I1)=RNEW
- ELSEIF(IVAR.EQ.7) THEN
- MSTJ(I1)=INEW
- ELSEIF(IVAR.EQ.8) THEN
- PARJ(I1)=RNEW
- ELSEIF(IVAR.EQ.9) THEN
- KCHG(I1,I2)=INEW
- ELSEIF(IVAR.EQ.10) THEN
- PMAS(I1,I2)=RNEW
- ELSEIF(IVAR.EQ.11) THEN
- PARF(I1)=RNEW
- ELSEIF(IVAR.EQ.12) THEN
- VCKM(I1,I2)=RNEW
- ELSEIF(IVAR.EQ.13) THEN
- MDCY(I1,I2)=INEW
- ELSEIF(IVAR.EQ.14) THEN
- MDME(I1,I2)=INEW
- ELSEIF(IVAR.EQ.15) THEN
- BRAT(I1)=RNEW
- ELSEIF(IVAR.EQ.16) THEN
- KFDP(I1,I2)=INEW
- ELSEIF(IVAR.EQ.17) THEN
- CHAF(I1,I2)=CHNEW
- ELSEIF(IVAR.EQ.18) THEN
- MRPY(I1)=INEW
- ELSEIF(IVAR.EQ.19) THEN
- RRPY(I1)=RNEW
- ELSEIF(IVAR.EQ.20) THEN
- MSEL=INEW
- ELSEIF(IVAR.EQ.21) THEN
- MSUB(I1)=INEW
- ELSEIF(IVAR.EQ.22) THEN
- KFIN(I1,I2)=INEW
- ELSEIF(IVAR.EQ.23) THEN
- CKIN(I1)=RNEW
- ELSEIF(IVAR.EQ.24) THEN
- MSTP(I1)=INEW
- ELSEIF(IVAR.EQ.25) THEN
- PARP(I1)=RNEW
- ELSEIF(IVAR.EQ.26) THEN
- MSTI(I1)=INEW
- ELSEIF(IVAR.EQ.27) THEN
- PARI(I1)=RNEW
- ELSEIF(IVAR.EQ.28) THEN
- MINT(I1)=INEW
- ELSEIF(IVAR.EQ.29) THEN
- VINT(I1)=RNEW
- ELSEIF(IVAR.EQ.30) THEN
- ISET(I1)=INEW
- ELSEIF(IVAR.EQ.31) THEN
- KFPR(I1,I2)=INEW
- ELSEIF(IVAR.EQ.32) THEN
- COEF(I1,I2)=RNEW
- ELSEIF(IVAR.EQ.33) THEN
- ICOL(I1,I2,I3)=INEW
- ELSEIF(IVAR.EQ.34) THEN
- XSFX(I1,I2)=RNEW
- ELSEIF(IVAR.EQ.35) THEN
- ISIG(I1,I2)=INEW
- ELSEIF(IVAR.EQ.36) THEN
- SIGH(I1)=RNEW
- ELSEIF(IVAR.EQ.37) THEN
- MWID(I1)=INEW
- ELSEIF(IVAR.EQ.38) THEN
- WIDS(I1,I2)=RNEW
- ELSEIF(IVAR.EQ.39) THEN
- NGEN(I1,I2)=INEW
- ELSEIF(IVAR.EQ.40) THEN
- XSEC(I1,I2)=RNEW
- ELSEIF(IVAR.EQ.41) THEN
- PROC(I1)=CHNEW2
- ELSEIF(IVAR.EQ.42) THEN
- SIGT(I1,I2,I3)=RNEW
- ELSEIF(IVAR.EQ.43) THEN
- XPVMD(I1)=RNEW
- ELSEIF(IVAR.EQ.44) THEN
- XPANL(I1)=RNEW
- ELSEIF(IVAR.EQ.45) THEN
- XPANH(I1)=RNEW
- ELSEIF(IVAR.EQ.46) THEN
- XPBEH(I1)=RNEW
- ELSEIF(IVAR.EQ.47) THEN
- XPDIR(I1)=RNEW
- ELSEIF(IVAR.EQ.48) THEN
- IMSS(I1)=INEW
- ELSEIF(IVAR.EQ.49) THEN
- RMSS(I1)=RNEW
- ELSEIF(IVAR.EQ.50) THEN
- RVLAM(I1,I2,I3)=RNEW
- ELSEIF(IVAR.EQ.51) THEN
- RVLAMP(I1,I2,I3)=RNEW
- ELSEIF(IVAR.EQ.52) THEN
- RVLAMB(I1,I2,I3)=RNEW
- ELSEIF(IVAR.EQ.53) THEN
- ITCM(I1)=INEW
- ELSEIF(IVAR.EQ.54) THEN
- RTCM(I1)=RNEW
- ENDIF
-
-C...Write old and new value. Loop back.
- CHBIT(LNAM:14)=' '
- CHBIT(15:60)=' changed from to '
- IF(MSVAR(IVAR,1).EQ.1) THEN
- WRITE(CHBIT(33:42),'(I10)') IOLD
- WRITE(CHBIT(51:60),'(I10)') INEW
- IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
- ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
- WRITE(CHBIT(29:42),'(F14.5)') ROLD
- WRITE(CHBIT(47:60),'(F14.5)') RNEW
- IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
- ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
- CHBIT(35:42)=CHOLD
- CHBIT(53:60)=CHNEW
- IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
- ELSE
- CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
- IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
- ENDIF
- LLOW=LHIG
- IF(LLOW.LT.LTOT) GOTO 120
-
-C...Format statement for output on unit MSTU(11) (by default 6).
- 5000 FORMAT(5X,A60)
- 5100 FORMAT(5X,A88)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYONOF
-C...Switches on and off decay channel by search for match.
-
- SUBROUTINE PYONOF(CHIN)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- SAVE /PYDAT1/,/PYDAT3/
-C...Local arrays and character variables.
- INTEGER KFCMP(10),KFTMP(10)
- CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
- &CHALP(2)*26
- DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
- &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
-
-C...Determine length of character variable.
- CHTMP=CHIN//' '
- LBEG=0
- 100 LBEG=LBEG+1
- IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
- LEND=LBEG-1
- 105 LEND=LEND+1
- IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
- 110 LEND=LEND-1
- IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
- LEN=1+LEND-LBEG
- CHFIX(1:LEN)=CHTMP(LBEG:LEND)
-
-C...Find colon separator and particle code.
- LCOLON=0
- 120 LCOLON=LCOLON+1
- IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
- CHCODE=' '
- CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
- READ(CHCODE,'(I8)',ERR=300) KF
- KC=PYCOMP(KF)
-
-C...Done if unknown code or no decay channels.
- IF(KC.EQ.0) THEN
- CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
- RETURN
- ENDIF
- IDCBEG=MDCY(KC,2)
- IDCLEN=MDCY(KC,3)
- IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
- CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
- RETURN
- ENDIF
-
-C...Find command name up to blank or equal sign.
- LSEP=LCOLON
- 130 LSEP=LSEP+1
- IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
- &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
- CHMODE=' '
- LMODE=LSEP-LCOLON-1
- CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
-
-C...Convert to uppercase.
- DO 150 LCOM=1,LMODE
- DO 140 LALP=1,26
- IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
- & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
- 140 CONTINUE
- 150 CONTINUE
-
-C...Identify command. Failed if not identified.
- MODE=0
- IF(CHMODE.EQ.'ALLOFF') MODE=1
- IF(CHMODE.EQ.'ALLON') MODE=2
- IF(CHMODE.EQ.'OFFIFANY') MODE=3
- IF(CHMODE.EQ.'ONIFANY') MODE=4
- IF(CHMODE.EQ.'OFFIFALL') MODE=5
- IF(CHMODE.EQ.'ONIFALL') MODE=6
- IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
- IF(CHMODE.EQ.'ONIFMATCH') MODE=8
- IF(MODE.EQ.0) THEN
- CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
- RETURN
- ENDIF
-
-C...Simple cases when all on or all off.
- IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
- WRITE(MSTU(11),1000) KF,CHMODE
- DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
- IF(MDME(IDC,1).LT.0) GOTO 160
- MDME(IDC,1)=MODE-1
- 160 CONTINUE
- RETURN
- ENDIF
-
-C...Identify matching list.
- NCMP=0
- LBEG=LSEP
- 170 LBEG=LBEG+1
- IF(LBEG.GT.LEN) GOTO 190
- IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
- &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
- LEND=LBEG-1
- 180 LEND=LEND+1
- IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
- &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
- IF(LEND.LT.LEN) LEND=LEND-1
- CHCODE=' '
- CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
- READ(CHCODE,'(I8)',ERR=300) KFREAD
- NCMP=NCMP+1
- KFCMP(NCMP)=IABS(KFREAD)
- LBEG=LEND
- IF(NCMP.LT.10) GOTO 170
- 190 CONTINUE
- WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
-
-C...Only one matching required.
- IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
- DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
- IF(MDME(IDC,1).LT.0) GOTO 220
- DO 210 IKF=1,5
- KFNOW=IABS(KFDP(IDC,IKF))
- IF(KFNOW.EQ.0) GOTO 210
- DO 200 ICMP=1,NCMP
- IF(KFCMP(ICMP).EQ.KFNOW) THEN
- MDME(IDC,1)=MODE-3
- GOTO 220
- ENDIF
- 200 CONTINUE
- 210 CONTINUE
- 220 CONTINUE
- RETURN
- ENDIF
-
-C...Multiple matchings required.
- DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
- IF(MDME(IDC,1).LT.0) GOTO 260
- NTMP=NCMP
- DO 230 ITMP=1,NTMP
- KFTMP(ITMP)=KFCMP(ITMP)
- 230 CONTINUE
- NFIN=0
- DO 250 IKF=1,5
- KFNOW=IABS(KFDP(IDC,IKF))
- IF(KFNOW.EQ.0) GOTO 250
- NFIN=NFIN+1
- DO 240 ITMP=1,NTMP
- IF(KFTMP(ITMP).EQ.KFNOW) THEN
- KFTMP(ITMP)=KFTMP(NTMP)
- NTMP=NTMP-1
- GOTO 250
- ENDIF
- 240 CONTINUE
- 250 CONTINUE
- IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
- IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
- & MDME(IDC,1)=MODE-7
- 260 CONTINUE
- RETURN
-
-C...Error exit for impossible read of particle code.
- 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
- &//CHCODE)
-
-C...Formats for output.
- 1000 FORMAT(' Decays for',I8,' set ',A10)
- 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
-
- RETURN
- END
-C*********************************************************************
-
-C...PYTUNE
-C...Presets for a few specific underlying-event and min-bias tunes
-C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
-C...others require particular versions of pythia (e.g. the SCI and GAL
-C...models). See below for details.
- SUBROUTINE PYTUNE(ITUNE)
-C
-C ITUNE NAME (detailed descriptions below)
-C 0 Default : No settings changed => linked Pythia version's defaults.
-C ====== Old UE, Q2-ordered showers ==========================================
-C 100 A : Rick Field's CDF Tune A
-C 101 AW : Rick Field's CDF Tune AW
-C 102 BW : Rick Field's CDF Tune BW
-C 103 DW : Rick Field's CDF Tune DW
-C 104 DWT : Rick Field's CDF Tune DW with slower UE energy scaling
-C 105 QW : Rick Field's CDF Tune QW (NB: needs CTEQ6.1M pdfs externally)
-C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune (ATLAS DC2 / Rome)
-C 107 ACR : Tune A modified with annealing CR
-C 108 D6 : Rick Field's CDF Tune D6 (NB: needs CTEQ6L pdfs externally)
-C 109 D6T : Rick Field's CDF Tune D6T (NB: needs CTEQ6L pdfs externally)
-C ====== Intermediate Models =================================================
-C 200 IM 1 : Intermediate model: new UE, Q2-ordered showers, annealing CR
-C 201 APT : Tune A modified to use pT-ordered final-state showers
-C ====== New UE, interleaved pT-ordered showers, annealing CR ================
-C 300 S0 : Sandhoff-Skands Tune 0
-C 301 S1 : Sandhoff-Skands Tune 1
-C 302 S2 : Sandhoff-Skands Tune 2
-C 303 S0A : S0 with "Tune A" UE energy scaling
-C 304 NOCR : New UE "best try" without colour reconnections
-C 305 Old : New UE, original (primitive) colour reconnections
-C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune (needs CTEQ6L externally)
-C ======= The Uppsala models =================================================
-C ( NB! must be run with special modified Pythia 6.215 version )
-C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
-C 400 GAL 0 : Generalized area-law model. Old parameters
-C 401 SCI 0 : Soft-Colour-Interaction model. Old parameters
-C 402 GAL 1 : Generalized area-law model. Tevatron MB retuned (Skands)
-C 403 SCI 1 : Soft-Colour-Interaction model. Tevatron MB retuned (Skands)
-C
-C More details;
-C
-C Quick Dictionary:
-C BE : Bose-Einstein
-C BR : Beam Remnants
-C CR : Colour Reconnections
-C HAD: Hadronization
-C ISR/FSR: Initial-State Radiation / Final-State Radiation
-C FSI: Final-State Interactions (=CR+BE)
-C MB : Minimum-bias
-C MI : Multiple Interactions
-C UE : Underlying Event
-C
-C A (100) and AW (101). Old UE model, Q2-ordered showers.
-C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
-C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
-C...Key feature: extensively compared to CDF data (R.D. Field).
-C...* Large starting scale for ISR (PARP(67)=4)
-C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
-C...* See: http://www.phys.ufl.edu/~rfield/cdf/
-C
-C BW (102). Old UE model, Q2-ordered showers.
-C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
-C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
-C...Key feature: extensively compared to CDF data (R.D. Field).
-C...NB: Can also be run with Pythia 6.2 or 6.312+
-C...* Small starting scale for ISR (PARP(67)=1)
-C...* BW has more radiation due to smaller mu_R choice in alpha_s.
-C...* See: http://www.phys.ufl.edu/~rfield/cdf/
-C
-C DW (103) and DWT (104). Old UE model, Q2-ordered showers.
-C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
-C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
-C...Key feature: extensively compared to CDF data (R.D. Field).
-C...NB: Can also be run with Pythia 6.2 or 6.312+
-C...* Intermediate starting scale for ISR (PARP(67)=2.5)
-C...* DWT has a different reference energy, the same as the "S" models
-C... below, leading to more UE activity at the LHC, but less at RHIC.
-C...* See: http://www.phys.ufl.edu/~rfield/cdf/
-C
-C QW (105). Old UE model, Q2-ordered showers.
-C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
-C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
-C...Key feature: uses CTEQ61 (external pdf library must be linked)
-C
-C ATLAS-DC2 (106). Old UE model, Q2-ordered showers.
-C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
-C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
-C...Key feature: tune used by the ATLAS collaboration.
-C
-C ACR (107). Old UE model, Q2-ordered showers, annealing CR.
-C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
-C...Key feature: Tune A modified to use annealing CR.
-C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
-C
-C D6 (108) and D6T (109). Old UE model, Q2-ordered showers, CTEQ6L PDF.
-C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
-C
-C...IM1 (200). Intermediate model, Q2-ordered showers.
-C...Key feature: new UE model with Q2-ordered showers and no interleaving.
-C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
-C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
-C
-C...APT (201). Old UE model, pT-ordered final-state showers
-C...Key feature: Rick Field's Tune A, but with new final-state showers
-C
-C S0 (300) and S0A (303). New UE model, pT-ordered showers.
-C...Key feature: large amount of multiple interactions
-C...* Somewhat faster than the other colour annealing scenarios.
-C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
-C... from Tune A, leading to less UE at the LHC, but more at RHIC.
-C...* Small amount of radiation.
-C...* Large amount of low-pT MI
-C...* Low degree of proton lumpiness (broad matter dist.)
-C...* CR Type S (driven by free triplets), of medium strength.
-C...* See: Pythia6402 update notes or later.
-C
-C S1 (301). New UE model, pT-ordered showers.
-C...Key feature: large amount of radiation.
-C...* Large amount of low-pT perturbative ISR
-C...* Large amount of FSR off ISR partons
-C...* Small amount of low-pT multiple interactions
-C...* Moderate degree of proton lumpiness
-C...* Least aggressive CR type (S+S Type I), but with large strength
-C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
-C
-C S2 (302). New UE model, pT-ordered showers.
-C...Key feature: very lumpy proton + gg string cluster formation allowed
-C...* Small amount of radiation
-C...* Moderate amount of low-pT MI
-C...* High degree of proton lumpiness (more spiky matter distribution)
-C...* Most aggressive CR type (S+S Type II), but with small strength
-C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
-C
-C NOCR (304). New UE model, pT-ordered showers.
-C...Key feature: no colour reconnections (NB: "Best fit" only).
-C...* NB: <pT>(Nch) problematic in this tune.
-C...* Small amount of radiation
-C...* Small amount of low-pT MI
-C...* Low degree of proton lumpiness
-C...* Large BR composite x enhancement factor
-C...* Most clever colour flow without CR ("Lambda ordering")
-C
-C ATLAS-CSC (306). New UE mode, pT-ordered showers, CTEQ6L.
-C...Key feature: 11-parameter ATLAS tune of the new framework.
-C...* Old (pre-annealing) colour reconnections a la 305.
-C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
-C
-C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
-C...with an unmodified Pythia distribution.
-C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
-C
-C ::: + Future improvements?
-C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
-C (problem: K-factor affects everything so only works as
-C intended for min-bias, not for UE ... probably need a
-C better long-term solution to handle UE as well. Anyway,
-C Mark uses MSTP(33) and PARP(31)-PARP(33).)
-
-C...Global statements
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- INTEGER PYK,PYCHGE,PYCOMP
-
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
-
-C...SCI and GAL Commonblocks
- COMMON /SCIPAR/MSWI(2),PARSCI(2)
-
-C...Internal parameters
- PARAMETER(MXTUNS=500)
- CHARACTER*8 CHVERS, CHDOC
- PARAMETER (CHVERS='1.012 ',CHDOC='Sep 2007')
- CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
- CHARACTER*42 CHMSTJ(50), CHMSTP(51:100), CHPARP(61:100),
- & CHPARJ(41:100), CH40
- CHARACTER*60 CH60
- CHARACTER*70 CH70
- DATA (CHNAMS(I),I=0,1)/'Default',' '/
- DATA (CHNAMS(I),I=100,110)/
- & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
- & 'ATLAS Tune','Tune ACR','Tune D6','Tune D6T',' '/
- DATA (CHNAMS(I),I=300,310)/
- & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
- 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',2*' '/
- DATA (CHNAMS(I),I=200,210)/
- & 'IM Tune 1','Tune APT',9*' '/
- DATA (CHNAMS(I),I=400,410)/
- & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',7*' '/
- DATA (CHMSTJ(I),I=11,20)/
- & 'HAD choice of fragmentation function(s)',4*' ',
- & 'HAD treatment of small-mass systems',4*' '/
- DATA (CHMSTJ(I),I=41,50)/
- & 'FSR type (Q2 or pT) for old framework',9*' '/
- DATA (CHMSTP(I),I=51,100)/
- 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
- 6 'ISR master switch',6*' ',
- 6 'ISR phase space choice & ME corrections',' ',
- 7 'ISR IR regularization scheme',' ',
- 7 'ISR scheme for FSR off ISR',8*' ',
- 8 'UE model',
- 8 'UE hadron transverse mass distribution',5*' ',
- 8 'BR composite scheme','BR colour scheme',
- 9 'BR primordial kT compensation',
- 9 'BR primordial kT distribution',
- 9 'BR energy partitioning scheme',2*' ',
- 9 'FSI colour (re-)connection model',5*' '/
- DATA (CHPARP(I),I=61,100)/
- 6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
- 6 2*' ','ISR Q2max factor',3*' ',
- 7 'FSR Q2max factor for non-s-channel procs',5*' ',
- 7 'FSI colour reconnection turnoff scale',
- 7 'FSI colour reconnection strength',
- 7 'BR composite x enhancement','BR breakup suppression',
- 8 2*'UE IR cutoff at reference ecm',
- 8 2*'UE mass distribution parameter',
- 8 'UE gg colour correlated fraction','UE total gg fraction',
- 8 2*' ',
- 8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
- 9 'BR primordial kT width <|kT|>',' ',
- 9 'BR primordial kT UV cutoff',7*' '/
- DATA (CHPARJ(I),I=41,90)/
- 4 ' ','HAD string parameter b',8*' ',
- 5 3*' ','HAD charm parameter','HAD bottom parameter',5*' ',
- 6 10*' ',10*' ',
- 8 'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
- SAVE /PYDAT1/,/PYPARS/
- SAVE /SCIPAR/
-
-C...1) Shorthand notation
- M13=MSTU(13)
- M11=MSTU(11)
- IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
- CHNAME=CHNAMS(ITUNE)
- IF (ITUNE.EQ.0) GOTO 9999
- ELSE
- CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
- GOTO 9999
- ENDIF
-
-C...2) Hello World
- IF (M13.GE.1) WRITE(M11,5000) CHVERS, CHDOC
-
-C...3) Tune parameters
-
-C=============================================================================
-C...Tunes S0, S1, S2, S0A, NOCR, and RAP (by P. Skands)
- IF (ITUNE.GE.300.AND.ITUNE.LE.305) THEN
- IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
- IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
- CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
- & ' with tune.')
- ENDIF
-
-C...PDFs
- MSTP(52)=1
- MSTP(51)=7
-C...ISR
- PARP(64)=1D0
-C...UE on, new model.
- MSTP(81)=21
-C...Slow IR cutoff energy scaling by default
- PARP(89)=1800D0
- PARP(90)=0.16D0
-C...Switch off trial joinings
- MSTP(96)=0
-C...Primordial kT cutoff
- PARP(93)=5D0
-
-C...S0 (300), S0A (303)
- IF (ITUNE.EQ.300.OR.ITUNE.EQ.303) THEN
- IF (M13.GE.1) THEN
- CH60='see P. Skands & D. Wicke, hep-ph/0703081'
- WRITE(M11,5030) CH60
- CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
- WRITE(M11,5030) CH60
- CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
- WRITE(M11,5030) CH60
- ENDIF
-C...Smooth ISR, low FSR
- MSTP(70)=2
- MSTP(72)=0
-C...pT0
- PARP(82)=1.85D0
-C...Transverse density profile.
- MSTP(82)=5
- PARP(83)=1.6D0
-C...Colour Reconnections
- MSTP(95)=6
- PARP(78)=0.20D0
- PARP(77)=0.0D0
-C... Reference energy for pT0 and energy scaling pace.
- IF (ITUNE.EQ.303) PARP(90)=0.25D0
-C...Lambda_FSR scale.
- PARJ(81)=0.23D0
-C...FSR activity.
- PARP(71)=4D0
-C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
- MSTP(89)=1
- MSTP(88)=0
- PARP(79)=2D0
- PARP(80)=0.01D0
-
-C...S1 (301)
- ELSEIF(ITUNE.EQ.301) THEN
- IF (M13.GE.1) THEN
- CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
- WRITE(M11,5030) CH60
- CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
- WRITE(M11,5030) CH60
- ENDIF
-C...Sharp ISR, high FSR
- MSTP(70)=0
- MSTP(72)=1
-C...pT0
- PARP(82)=2.1D0
-C...Colour Reconnections
- MSTP(95)=2
- PARP(78)=0.35D0
-C...Transverse density profile.
- MSTP(82)=5
- PARP(83)=1.4D0
-C...Lambda_FSR scale.
- PARJ(81)=0.23D0
-C...FSR activity.
- PARP(71)=4D0
-C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
- MSTP(89)=1
- MSTP(88)=0
- PARP(79)=2D0
- PARP(80)=0.01D0
-
-C...S2 (302)
- ELSEIF(ITUNE.EQ.302) THEN
- IF (M13.GE.1) THEN
- CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
- WRITE(M11,5030) CH60
- CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
- WRITE(M11,5030) CH60
- ENDIF
-C...Smooth ISR, low FSR
- MSTP(70)=2
- MSTP(72)=0
-C...pT0
- PARP(82)=1.9D0
-C...Transverse density profile.
- MSTP(82)=5
- PARP(83)=1.2D0
-C...Colour Reconnections
- MSTP(95)=4
- PARP(78)=0.15D0
-C...Lambda_FSR scale.
- PARJ(81)=0.23D0
-C...FSR activity.
- PARP(71)=4D0
-C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
- MSTP(89)=1
- MSTP(88)=0
- PARP(79)=2D0
- PARP(80)=0.01D0
-
-C...NOCR (304)
- ELSEIF(ITUNE.EQ.304) THEN
- IF (M13.GE.1) THEN
- CH60='"best try" without colour reconnections'
- WRITE(M11,5030) CH60
- CH60='see P. Skands & D. Wicke, hep-ph/0703081'
- WRITE(M11,5030) CH60
- CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
- WRITE(M11,5030) CH60
- ENDIF
-C...Smooth ISR, low FSR
- MSTP(70)=2
- MSTP(72)=0
-C...pT0
- PARP(82)=2.05D0
-C...Transverse density profile.
- MSTP(82)=5
- PARP(83)=1.8D0
-C...Colour Reconnections
- MSTP(95)=0
-C...Lambda_FSR scale.
- PARJ(81)=0.23D0
-C...FSR activity.
- PARP(71)=4D0
-C...Lambda order, Valence qq, large qq x enhc, BR-g-BR supp
- MSTP(89)=2
- MSTP(88)=0
- PARP(79)=3D0
- PARP(80)=0.01D0
-
-C..."Lo FSR" retune (305)
- ELSEIF(ITUNE.EQ.305) THEN
- IF (M13.GE.1) THEN
- CH60='"Lo FSR retune" with primitive colour reconnections'
- WRITE(M11,5030) CH60
- CH60='see T. Sjostrand & P. Skands, EPJC39(2005)129'
- WRITE(M11,5030) CH60
- ENDIF
-C...Smooth ISR, low FSR
- MSTP(70)=2
- MSTP(72)=0
-C...pT0
- PARP(82)=1.9D0
-C...Transverse density profile.
- MSTP(82)=5
- PARP(83)=2.0D0
-C...Colour Reconnections
- MSTP(95)=1
- PARP(78)=1.0D0
-C...Lambda_FSR scale.
- PARJ(81)=0.23D0
-C...FSR activity.
- PARP(71)=4D0
-C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
- MSTP(89)=1
- MSTP(88)=0
- PARP(79)=2D0
- PARP(80)=0.01D0
- ENDIF
-C...Output
- IF (M13.GE.1) THEN
- WRITE(M11,5030) ' '
- WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
- WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
- WRITE(M11,5050) 64, PARP(64), CHPARP(64)
- WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
- CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
- WRITE(M11,5030) CH60
- WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
- WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
- WRITE(M11,5050) 71, PARP(71), CHPARP(71)
- WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
- WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
- WRITE(M11,5050) 82, PARP(82), CHPARP(82)
- WRITE(M11,5050) 89, PARP(89), CHPARP(89)
- WRITE(M11,5050) 90, PARP(90), CHPARP(90)
- WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
- WRITE(M11,5050) 83, PARP(83), CHPARP(83)
- WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
- WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
- WRITE(M11,5050) 79, PARP(79), CHPARP(79)
- WRITE(M11,5050) 80, PARP(80), CHPARP(80)
- WRITE(M11,5050) 93, PARP(93), CHPARP(93)
- WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
- WRITE(M11,5050) 78, PARP(78), CHPARP(78)
- ENDIF
-
-C=============================================================================
-C...ATLAS-CSC 11-parameter tune (By A. Moraes)
- ELSEIF (ITUNE.EQ.306) THEN
- IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
- IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
- CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
- & ' with tune.')
- ENDIF
-
-C...PDFs
- MSTP(52)=2
- MSTP(54)=2
- MSTP(56)=2
- MSTP(51)=10042
- MSTP(53)=10042
- MSTP(55)=10042
-C...ISR
-C PARP(64)=1D0
-C...UE on, new model.
- MSTP(81)=21
-C...Energy scaling
- PARP(89)=1800D0
- PARP(90)=0.22D0
-C...Switch off trial joinings
- MSTP(96)=0
-C...Primordial kT cutoff
-
- IF (M13.GE.1) THEN
- CH60='see presentations by A. Moraes (ATLAS),'
- WRITE(M11,5030) CH60
- CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
- WRITE(M11,5030) CH60
- WRITE(M11,5030) ' '
- CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
- & 'externally linked and'
- WRITE(M11,5035) CH70
- CH70='MSTP(51) should be set manually according to '//
- & 'the library used'
- WRITE(M11,5035) CH70
- ENDIF
-C...Smooth ISR, low FSR
- MSTP(70)=2
- MSTP(72)=0
-C...pT0
- PARP(82)=1.9D0
-C...Transverse density profile.
- MSTP(82)=4
- PARP(83)=0.3D0
- PARP(84)=0.5D0
-C...ISR & FSR in interactions after the first (default)
- MSTP(84)=1
- MSTP(85)=1
-C...No double-counting (default)
- MSTP(86)=2
-C...Companion quark parent gluon (1-x) power
- MSTP(87)=4
-C...Primordial kT compensation along chaings (default = 0 : uniform)
- MSTP(90)=1
-C...Colour Reconnections
- MSTP(95)=1
- PARP(78)=0.2D0
-C...Lambda_FSR scale.
- PARJ(81)=0.23D0
-C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
- MSTP(89)=1
- MSTP(88)=0
-C PARP(79)=2D0
- PARP(80)=0.01D0
-C...Peterson charm frag, and c and b hadr parameters
- MSTJ(11)=3
- PARJ(54)=-0.07
- PARJ(55)=-0.006
-C... Output
- IF (M13.GE.1) THEN
- WRITE(M11,5030) ' '
- WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
- WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
- WRITE(M11,5050) 64, PARP(64), CHPARP(64)
- WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
- CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
- WRITE(M11,5030) CH60
- WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
- WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
- WRITE(M11,5050) 71, PARP(71), CHPARP(71)
- WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
- CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
- WRITE(M11,5030) CH60
- WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
- WRITE(M11,5050) 82, PARP(82), CHPARP(82)
- WRITE(M11,5050) 89, PARP(89), CHPARP(89)
- WRITE(M11,5050) 90, PARP(90), CHPARP(90)
- WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
- WRITE(M11,5050) 83, PARP(83), CHPARP(83)
- WRITE(M11,5050) 84, PARP(84), CHPARP(84)
- WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
- WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
- WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
- WRITE(M11,5050) 79, PARP(79), CHPARP(79)
- WRITE(M11,5050) 80, PARP(80), CHPARP(80)
- WRITE(M11,5050) 93, PARP(93), CHPARP(93)
- WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
- WRITE(M11,5050) 78, PARP(78), CHPARP(78)
- WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
- WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
- WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
- ENDIF
-
-C=============================================================================
-C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
-C...(100-105,108-109) and ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
- ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
- & ITUNE.EQ.109) THEN
- IF (M13.GE.1.AND.ITUNE.NE.106) THEN
- WRITE(M11,5010) ITUNE, CHNAME
- CH60='see R.D. Field (CDF), in hep-ph/0610012'
- WRITE(M11,5030) CH60
- CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
- WRITE(M11,5030) CH60
- ENDIF
-C...Multiple interactions on, old framework
- MSTP(81)=1
-C...Fast IR cutoff energy scaling by default
- PARP(89)=1800D0
- PARP(90)=0.25D0
-C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
- MSTP(51)=7
- MSTP(52)=1
- IF (ITUNE.EQ.105) THEN
- MSTP(51)=10150
- MSTP(52)=2
- ELSEIF(ITUNE.EQ.108.OR.ITUNE.EQ.109) THEN
- MSTP(52)=2
- MSTP(54)=2
- MSTP(56)=2
- MSTP(51)=10042
- MSTP(53)=10042
- MSTP(55)=10042
- ENDIF
-C...Double Gaussian matter distribution.
- MSTP(82)=4
- PARP(83)=0.5D0
- PARP(84)=0.4D0
-C...FSR activity.
- PARP(71)=4D0
-C...Lambda_FSR scale.
- PARJ(81)=0.29D0
-C...Fragmentation functions and c and b parameters
- MSTJ(11)=4
- PARJ(54)=-0.05
- PARJ(55)=-0.005
-
-C...Tune A and AW
- IF(ITUNE.EQ.100.OR.ITUNE.EQ.101) THEN
-C...pT0.
- PARP(82)=2.0D0
-c...String drawing almost completely minimizes string length.
- PARP(85)=0.9D0
- PARP(86)=0.95D0
-C...ISR cutoff, muR scale factor, and phase space size
- PARP(62)=1D0
- PARP(64)=1D0
- PARP(67)=4D0
-C...Intrinsic kT, size, and max
- MSTP(91)=1
- PARP(91)=1D0
- PARP(93)=5D0
-C...AW : higher ISR IR cutoff, but also larger alpha_s and more intrinsic kT.
- IF (ITUNE.EQ.101) THEN
- PARP(62)=1.25D0
- PARP(64)=0.2D0
- PARP(91)=2.1D0
- PARP(92)=15.0D0
- ENDIF
-
-C...Tune BW (larger alpha_s, more intrinsic kT. Smaller ISR phase space.)
- ELSEIF (ITUNE.EQ.102) THEN
-C...pT0.
- PARP(82)=1.9D0
-c...String drawing completely minimizes string length.
- PARP(85)=1.0D0
- PARP(86)=1.0D0
-C...ISR cutoff, muR scale factor, and phase space size
- PARP(62)=1.25D0
- PARP(64)=0.2D0
- PARP(67)=1D0
-C...Intrinsic kT, size, and max
- MSTP(91)=1
- PARP(91)=2.1D0
- PARP(93)=15D0
-
-C...Tune DW
- ELSEIF (ITUNE.EQ.103) THEN
-C...pT0.
- PARP(82)=1.9D0
-c...String drawing completely minimizes string length.
- PARP(85)=1.0D0
- PARP(86)=1.0D0
-C...ISR cutoff, muR scale factor, and phase space size
- PARP(62)=1.25D0
- PARP(64)=0.2D0
- PARP(67)=2.5D0
-C...Intrinsic kT, size, and max
- MSTP(91)=1
- PARP(91)=2.1D0
- PARP(93)=15D0
-
-C...Tune DWT
- ELSEIF (ITUNE.EQ.104) THEN
-C...pT0.
- PARP(82)=1.9409D0
-C...Run II ref scale and slow scaling
- PARP(89)=1960D0
- PARP(90)=0.16D0
-c...String drawing completely minimizes string length.
- PARP(85)=1.0D0
- PARP(86)=1.0D0
-C...ISR cutoff, muR scale factor, and phase space size
- PARP(62)=1.25D0
- PARP(64)=0.2D0
- PARP(67)=2.5D0
-C...Intrinsic kT, size, and max
- MSTP(91)=1
- PARP(91)=2.1D0
- PARP(93)=15D0
-
-C...Tune QW
- ELSEIF(ITUNE.EQ.105) THEN
- IF (M13.GE.1) THEN
- WRITE(M11,5030) ' '
- CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
- & 'externally linked and'
- WRITE(M11,5035) CH70
- CH70='MSTP(51) should be set manually according to '//
- & 'the library used'
- WRITE(M11,5035) CH70
- ENDIF
-C...pT0.
- PARP(82)=1.1D0
-c...String drawing completely minimizes string length.
- PARP(85)=1.0D0
- PARP(86)=1.0D0
-C...ISR cutoff, muR scale factor, and phase space size
- PARP(62)=1.25D0
- PARP(64)=0.2D0
- PARP(67)=2.5D0
-C...Intrinsic kT, size, and max
- MSTP(91)=1
- PARP(91)=2.1D0
- PARP(93)=15D0
-
-C...Tune D6 and D6T
- ELSEIF(ITUNE.EQ.108.OR.ITUNE.EQ.109) THEN
- IF (M13.GE.1) THEN
- WRITE(M11,5030) ' '
- CH70='NB! This tune requires CTEQ6L pdfs to be '//
- & 'externally linked and'
- WRITE(M11,5035) CH70
- CH70='MSTP(51) should be set manually according to '//
- & 'the library used'
- WRITE(M11,5035) CH70
- ENDIF
-C...The "Rick" proton, double gauss with 0.5/0.4
- MSTP(82)=4
- PARP(83)=0.5D0
- PARP(84)=0.4D0
-c...String drawing completely minimizes string length.
- PARP(85)=1.0D0
- PARP(86)=1.0D0
- IF (ITUNE.EQ.108) THEN
-C...D6: pT0, Run I ref scale, and fast energy scaling
- PARP(82)=1.8D0
- PARP(89)=1800D0
- PARP(90)=0.25D0
- ELSE
-C...D6T: pT0, Run II ref scale, and slow energy scaling
- PARP(82)=1.8387D0
- PARP(89)=1960D0
- PARP(90)=0.16D0
- ENDIF
-C...ISR cutoff, muR scale factor, and phase space size
- PARP(62)=1.25D0
- PARP(64)=0.2D0
- PARP(67)=2.5D0
-C...Intrinsic kT, size, and max
- MSTP(91)=1
- PARP(91)=2.1D0
- PARP(93)=15D0
-
-C...Old ATLAS-DC2 5-parameter tune
- ELSEIF(ITUNE.EQ.106) THEN
- IF (M13.GE.1) THEN
- WRITE(M11,5010) ITUNE, CHNAME
- CH60='see A. Moraes et al., SN-ATLAS-2006-057'
- WRITE(M11,5030) CH60
- CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
- WRITE(M11,5030) CH60
- ENDIF
-C... pT0.
- PARP(82)=1.8D0
-C... Different ref and rescaling pacee
- PARP(89)=1000D0
- PARP(90)=0.16D0
-C... Parameters of mass distribution
- PARP(83)=0.5D0
- PARP(84)=0.5D0
-C... Old default string drawing
- PARP(85)=0.33D0
- PARP(86)=0.66D0
-C... ISR, phase space equivalent to Tune B
- PARP(62)=1D0
- PARP(64)=1D0
- PARP(67)=1D0
-C... FSR
- PARP(71)=4D0
- PARJ(81)=0.29D0
-C... Intrinsic kT
- MSTP(91)=1
- PARP(91)=1D0
- PARP(93)=5D0
- ENDIF
-
-C... Output
- IF (M13.GE.1) THEN
- WRITE(M11,5030) ' '
- WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
- WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
- WRITE(M11,5050) 62, PARP(62), CHPARP(62)
- WRITE(M11,5050) 64, PARP(64), CHPARP(64)
- WRITE(M11,5050) 67, PARP(67), CHPARP(67)
- WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
- CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
- WRITE(M11,5030) CH60
- WRITE(M11,5050) 71, PARP(71), CHPARP(71)
- WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
- WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
- WRITE(M11,5050) 82, PARP(82), CHPARP(82)
- WRITE(M11,5050) 89, PARP(89), CHPARP(89)
- WRITE(M11,5050) 90, PARP(90), CHPARP(90)
- WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
- WRITE(M11,5050) 83, PARP(83), CHPARP(83)
- WRITE(M11,5050) 84, PARP(84), CHPARP(84)
- WRITE(M11,5050) 85, PARP(85), CHPARP(85)
- WRITE(M11,5050) 86, PARP(86), CHPARP(86)
- WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
- WRITE(M11,5050) 91, PARP(91), CHPARP(91)
- WRITE(M11,5050) 93, PARP(93), CHPARP(93)
- WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
- WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
- WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
- ENDIF
-
-C=============================================================================
-C... ACR, tune A with new CR (107)
- ELSEIF(ITUNE.EQ.107) THEN
- IF (M13.GE.1) THEN
- WRITE(M11,5010) ITUNE, CHNAME
- CH60='Tune A modified with new colour reconnections'
- WRITE(M11,5030) CH60
- CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
- WRITE(M11,5030) CH60
- CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
- WRITE(M11,5030) CH60
- CH60='R.D. Field (CDF), in hep-ph/0610012 (Tune A)'
- WRITE(M11,5030) CH60
- CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
- WRITE(M11,5030) CH60
- ENDIF
- IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
- CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
- & ' with tune. Using defaults.')
- GOTO 9998
- ENDIF
- MSTP(81)=1
- PARP(89)=1800D0
- PARP(90)=0.25D0
- MSTP(82)=4
- PARP(83)=0.5D0
- PARP(84)=0.4D0
- MSTP(51)=7
- MSTP(52)=1
- PARP(71)=4D0
- PARJ(81)=0.29D0
- PARP(82)=2.0D0
- PARP(85)=0.0D0
- PARP(86)=0.66D0
- PARP(62)=1D0
- PARP(64)=1D0
- PARP(67)=4D0
- MSTP(91)=1
- PARP(91)=1D0
- PARP(93)=5D0
- MSTP(95)=6
- PARP(78)=0.25D0
-C...Fragmentation functions and c and b parameters
- MSTJ(11)=4
- PARJ(54)=-0.05
- PARJ(55)=-0.005
-C...Output
- IF (M13.GE.1) THEN
- WRITE(M11,5030) ' '
- WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
- WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
- WRITE(M11,5050) 62, PARP(62), CHPARP(62)
- WRITE(M11,5050) 64, PARP(64), CHPARP(64)
- WRITE(M11,5050) 67, PARP(67), CHPARP(67)
- WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
- CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
- WRITE(M11,5030) CH60
- WRITE(M11,5050) 71, PARP(71), CHPARP(71)
- WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
- WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
- WRITE(M11,5050) 82, PARP(82), CHPARP(82)
- WRITE(M11,5050) 89, PARP(89), CHPARP(89)
- WRITE(M11,5050) 90, PARP(90), CHPARP(90)
- WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
- WRITE(M11,5050) 83, PARP(83), CHPARP(83)
- WRITE(M11,5050) 84, PARP(84), CHPARP(84)
- WRITE(M11,5050) 85, PARP(85), CHPARP(85)
- WRITE(M11,5050) 86, PARP(86), CHPARP(86)
- WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
- WRITE(M11,5050) 91, PARP(91), CHPARP(91)
- WRITE(M11,5050) 93, PARP(93), CHPARP(93)
- WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
- WRITE(M11,5050) 78, PARP(78), CHPARP(78)
- WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
- WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
- WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
- ENDIF
-
-C=============================================================================
-C... Intermediate model. Rap tune (retuned to post-6.406 IR factorization)
- ELSEIF(ITUNE.EQ.200) THEN
- IF (M13.GE.1) THEN
- WRITE(M11,5010) ITUNE, CHNAME
- CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
- WRITE(M11,5030) CH60
- ENDIF
- IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
- CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
- & ' with tune.')
- ENDIF
-C...PDF
- MSTP(51)=7
- MSTP(52)=1
-C...ISR
- PARP(62)=1D0
- PARP(64)=1D0
- PARP(67)=4D0
-C...FSR
- PARP(71)=4D0
- PARJ(81)=0.29D0
-C...UE
- MSTP(81)=11
- PARP(82)=2.25D0
- PARP(89)=1800D0
- PARP(90)=0.25D0
-C... ExpOfPow(1.8) overlap profile
- MSTP(82)=5
- PARP(83)=1.8D0
-C... Valence qq
- MSTP(88)=0
-C... Rap Tune
- MSTP(89)=1
-C... Default diquark, BR-g-BR supp
- PARP(79)=2D0
- PARP(80)=0.01D0
-C... Final state reconnect.
- MSTP(95)=1
- PARP(78)=0.55D0
-C...Fragmentation functions and c and b parameters
- MSTJ(11)=4
- PARJ(54)=-0.05
- PARJ(55)=-0.005
-C... Output
- IF (M13.GE.1) THEN
- WRITE(M11,5030) ' '
- WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
- WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
- WRITE(M11,5050) 62, PARP(62), CHPARP(62)
- WRITE(M11,5050) 64, PARP(64), CHPARP(64)
- WRITE(M11,5050) 67, PARP(67), CHPARP(67)
- WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
- CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
- WRITE(M11,5030) CH60
- WRITE(M11,5050) 71, PARP(71), CHPARP(71)
- WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
- WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
- WRITE(M11,5050) 82, PARP(82), CHPARP(82)
- WRITE(M11,5050) 89, PARP(89), CHPARP(89)
- WRITE(M11,5050) 90, PARP(90), CHPARP(90)
- WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
- WRITE(M11,5050) 83, PARP(83), CHPARP(83)
- WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
- WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
- WRITE(M11,5050) 79, PARP(79), CHPARP(79)
- WRITE(M11,5050) 80, PARP(80), CHPARP(80)
- WRITE(M11,5050) 93, PARP(93), CHPARP(93)
- WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
- WRITE(M11,5050) 78, PARP(78), CHPARP(78)
- WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
- WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
- WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
- ENDIF
-
-C...APT. Tune A modified to use new pT-ordered FSR.
- ELSEIF(ITUNE.EQ.201) THEN
- IF (M13.GE.1) THEN
- WRITE(M11,5010) ITUNE, CHNAME
- CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
- WRITE(M11,5030) CH60
- CH60='R.D. Field (CDF), in hep-ph/0610012 (Tune A)'
- WRITE(M11,5030) CH60
- CH60='T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
- WRITE(M11,5030) CH60
- CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
- WRITE(M11,5030) CH60
- ENDIF
- IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
- CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
- & ' with tune.')
- ENDIF
-C...First set as if Pythia tune A
-C...Multiple interactions on, old framework
- MSTP(81)=1
-C...Fast IR cutoff energy scaling by default
- PARP(89)=1800D0
- PARP(90)=0.25D0
-C...Default CTEQ5L (internal)
- MSTP(51)=7
- MSTP(52)=1
-C...Double Gaussian matter distribution.
- MSTP(82)=4
- PARP(83)=0.5D0
- PARP(84)=0.4D0
-C...FSR activity.
- PARP(71)=4D0
-c...String drawing almost completely minimizes string length.
- PARP(85)=0.9D0
- PARP(86)=0.95D0
-C...ISR cutoff, muR scale factor, and phase space size
- PARP(62)=1D0
- PARP(64)=1D0
- PARP(67)=4D0
-C...Intrinsic kT, size, and max
- MSTP(91)=1
- PARP(91)=1D0
- PARP(93)=5D0
-C...Use pT-ordered FSR
- MSTJ(41)=12
-C...Lambda_FSR scale for pT-ordering
- PARJ(81)=0.23D0
-C...Retune pT0
- PARP(82)=2.1D0
-C...Fragmentation functions and c and b parameters
- MSTJ(11)=4
- PARJ(54)=-0.05
- PARJ(55)=-0.005
-
-C... Output
- IF (M13.GE.1) THEN
- WRITE(M11,5030) ' '
- WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
- WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
- WRITE(M11,5050) 62, PARP(62), CHPARP(62)
- WRITE(M11,5050) 64, PARP(64), CHPARP(64)
- WRITE(M11,5050) 67, PARP(67), CHPARP(67)
- WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
- CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
- WRITE(M11,5030) CH60
- WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
- WRITE(M11,5050) 71, PARP(71), CHPARP(71)
- WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
- WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
- WRITE(M11,5050) 82, PARP(82), CHPARP(82)
- WRITE(M11,5050) 89, PARP(89), CHPARP(89)
- WRITE(M11,5050) 90, PARP(90), CHPARP(90)
- WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
- WRITE(M11,5050) 83, PARP(83), CHPARP(83)
- WRITE(M11,5050) 84, PARP(84), CHPARP(84)
- WRITE(M11,5050) 85, PARP(85), CHPARP(85)
- WRITE(M11,5050) 86, PARP(86), CHPARP(86)
- WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
- WRITE(M11,5050) 91, PARP(91), CHPARP(91)
- WRITE(M11,5050) 93, PARP(93), CHPARP(93)
- WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
- WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
- WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
- ENDIF
-
-C=============================================================================
-C...Uppsala models: Generalized Area Law and Soft Colour Interactions
- ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
- IF (M13.GE.1) THEN
- WRITE(M11,5010) ITUNE, CHNAME
- CH60='see J. Rathsman, PLB452(1999)364'
- WRITE(M11,5030) CH60
-C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
-C ? WRITE(M11,5030)
- CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
- WRITE(M11,5030) CH60
- WRITE(M11,5030) ' '
- CH70='NB! The GAL model must be run with modified '//
- & 'Pythia v6.215:'
- WRITE(M11,5035) CH70
- CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
- WRITE(M11,5035) CH70
- WRITE(M11,5030) ' '
- ENDIF
-C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
- MSWI(2) = 3
- PARSCI(2) = 0.10
- MSWI(1) = 2
- PARSCI(1) = 0.44
- MSTJ(16) = 0
- PARJ(42) = 0.45
- PARJ(82) = 2.0
- PARP(62) = 2.0
- MSTP(81) = 1
- MSTP(82) = 1
- PARP(81) = 1.9
- MSTP(92) = 1
- IF(CHNAME.EQ.'GAL Tune 1') THEN
-C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
- MSTP(82)=4
- PARP(83)=0.25D0
- PARP(84)=0.5D0
- PARP(82) = 1.75
- IF (M13.GE.1) THEN
- WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
- WRITE(M11,5050) 82, PARP(82), CHPARP(82)
- WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
- WRITE(M11,5050) 83, PARP(83), CHPARP(83)
- WRITE(M11,5050) 84, PARP(84), CHPARP(84)
- ENDIF
- ELSE
- IF (M13.GE.1) THEN
- WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
- WRITE(M11,5050) 81, PARP(81), CHPARP(81)
- WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
- ENDIF
- ENDIF
-C...Output
- IF (M13.GE.1) THEN
- WRITE(M11,5050) 62, PARP(62), CHPARP(62)
- WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
- WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
- CH40='FSI SCI/GAL selection'
- WRITE(M11,6040) 1, MSWI(1), CH40
- CH40='FSI SCI/GAL sea quark treatment'
- WRITE(M11,6040) 2, MSWI(2), CH40
- CH40='FSI SCI/GAL sea quark treatment parm'
- WRITE(M11,6050) 1, PARSCI(1), CH40
- CH40='FSI SCI/GAL string reco probability R_0'
- WRITE(M11,6050) 2, PARSCI(2), CH40
- WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
- WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
- ENDIF
- ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
- IF (M13.GE.1) THEN
- WRITE(M11,5010) ITUNE, CHNAME
- CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
- WRITE(M11,5030) CH60
- CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
- WRITE(M11,5030) CH60
- WRITE(M11,5030) ' '
- CH70='NB! The SCI model must be run with modified '//
- & 'Pythia v6.215:'
- WRITE(M11,5035) CH70
- CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
- WRITE(M11,5035) CH70
- WRITE(M11,5030) ' '
- ENDIF
-C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
- MSTP(81)=1
- MSTP(82)=1
- PARP(81)=2.2
- MSTP(92)=1
- MSWI(2)=2
- PARSCI(2)=0.50
- MSWI(1)=2
- PARSCI(1)=0.44
- MSTJ(16)=0
- IF (CHNAME.EQ.'SCI Tune 1') THEN
-C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
- MSTP(81) = 1
- MSTP(82) = 3
- PARP(82) = 2.4
- PARP(83) = 0.5D0
- PARP(62) = 1.5
- PARP(84)=0.25D0
- IF (M13.GE.1) THEN
- WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
- WRITE(M11,5050) 82, PARP(82), CHPARP(82)
- WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
- WRITE(M11,5050) 83, PARP(83), CHPARP(83)
- WRITE(M11,5050) 62, PARP(62), CHPARP(62)
- ENDIF
- ELSE
- IF (M13.GE.1) THEN
- WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
- WRITE(M11,5050) 81, PARP(81), CHPARP(81)
- WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
- ENDIF
- ENDIF
-C...Output
- IF (M13.GE.1) THEN
- WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
- CH40='FSI SCI/GAL selection'
- WRITE(M11,6040) 1, MSWI(1), CH40
- CH40='FSI SCI/GAL sea quark treatment'
- WRITE(M11,6040) 2, MSWI(2), CH40
- CH40='FSI SCI/GAL sea quark treatment parm'
- WRITE(M11,6050) 1, PARSCI(1), CH40
- CH40='FSI SCI/GAL string reco probability R_0'
- WRITE(M11,6050) 2, PARSCI(2), CH40
- WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
- ENDIF
-
- ELSE
- IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
-
- ENDIF
-
- 9998 IF (MSTU(13).GE.1) WRITE(M11,6000)
-
- 9999 RETURN
-
- 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',A6,' : ',
- & 'Presets for underlying-event (and min-bias)',13x,'*'/' *',
- & 20x,'Last Change : ',A8,' - P. Skands',22x,'*'/' *',76x,'*')
- 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
- 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
- 5030 FORMAT(' *',3x,10x,A60,3x,'*')
- 5035 FORMAT(' *',3x,A70,3x,'*')
- 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
- 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
- 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
- 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
- 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
- 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
- 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
- 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
- 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
-
- END
-
-C*********************************************************************
-
-C...PYEXEC
-C...Administrates the fragmentation and decay chain.
-
- SUBROUTINE PYEXEC
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
-C...Local array.
- DIMENSION PS(2,6),IJOIN(100)
-
-C...Initialize and reset.
- MSTU(24)=0
- IF(MSTU(12).NE.12345) CALL PYLIST(0)
- MSTU(29)=0
- MSTU(31)=MSTU(31)+1
- MSTU(1)=0
- MSTU(2)=0
- MSTU(3)=0
- IF(MSTU(17).LE.0) MSTU(90)=0
- MCONS=1
-
-C...Sum up momentum, energy and charge for starting entries.
- NSAV=N
- DO 110 I=1,2
- DO 100 J=1,6
- PS(I,J)=0D0
- 100 CONTINUE
- 110 CONTINUE
- DO 130 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
- DO 120 J=1,4
- PS(1,J)=PS(1,J)+P(I,J)
- 120 CONTINUE
- PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
- 130 CONTINUE
- PARU(21)=PS(1,4)
-
-C...Start by all decays of coloured resonances involved in shower.
- NORIG=N
- DO 140 I=1,NORIG
- IF(K(I,1).EQ.3) THEN
- KC=PYCOMP(K(I,2))
- IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
- ENDIF
- 140 CONTINUE
-
-C...Prepare system for subsequent fragmentation/decay.
- CALL PYPREP(0)
- IF(MINT(51).NE.0) RETURN
-
-C...Loop through jet fragmentation and particle decays.
- MBE=0
- 150 MBE=MBE+1
- IP=0
- 160 IP=IP+1
- KC=0
- IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
- IF(KC.EQ.0) THEN
-
-C...Deal with any remaining undecayed resonance
-C...(normally the task of PYEVNT, so seldom used).
- ELSEIF(MWID(KC).NE.0) THEN
- IBEG=IP
- IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
- IBEG=IP+1
- 170 IBEG=IBEG-1
- IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
- IF(K(IBEG,1).NE.2) IBEG=IBEG+1
- IEND=IP-1
- 180 IEND=IEND+1
- IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
- IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
- NJOIN=0
- DO 190 I=IBEG,IEND
- IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
- NJOIN=NJOIN+1
- IJOIN(NJOIN)=I
- ENDIF
- 190 CONTINUE
- ENDIF
- CALL PYRESD(IP)
- CALL PYPREP(IBEG)
- IF(MINT(51).NE.0) RETURN
-
-C...Particle decay if unstable and allowed. Save long-lived particle
-C...decays until second pass after Bose-Einstein effects.
- ELSEIF(KCHG(KC,2).EQ.0) THEN
- IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
- & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
- & CALL PYDECY(IP)
-
-C...Decay products may develop a shower.
- IF(MSTJ(92).GT.0) THEN
- IP1=MSTJ(92)
- QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
- & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
- MINT(33)=0
- if(parj(200).ne.1.) CALL PYSHOW(IP1,IP1+1,QMAX)
- if(parj(200).eq.1.) CALL PYSHOWQ(IP1,IP1+1,QMAX)
- CALL PYPREP(IP1)
- IF(MINT(51).NE.0) RETURN
- MSTJ(92)=0
- ELSEIF(MSTJ(92).LT.0) THEN
- IP1=-MSTJ(92)
- MINT(33)=0
- if(parj(200).ne.1.) CALL PYSHOW(IP1,-3,P(IP,5))
- if(parj(200).eq.1.) CALL PYSHOWQ(IP1,-3,P(IP,5))
- CALL PYPREP(IP1)
- IF(MINT(51).NE.0) RETURN
- MSTJ(92)=0
- ENDIF
-
-C...Jet fragmentation: string or independent fragmentation.
- ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
- MFRAG=MSTJ(1)
- IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
- IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
- IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
- & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
- IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
- ENDIF
- ENDIF
- IF(MFRAG.EQ.1) CALL PYSTRF(IP)
- IF(MFRAG.EQ.2) CALL PYINDF(IP)
- IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
- IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
- ENDIF
-
-C...Loop back if enough space left in PYJETS and no error abort.
- IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
- ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
- GOTO 160
- ELSEIF(IP.LT.N) THEN
- CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
- ENDIF
-
-C...Include simple Bose-Einstein effect parametrization if desired.
- IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
- CALL PYBOEI(NSAV)
- GOTO 150
- ENDIF
-
-C...Check that momentum, energy and charge were conserved.
- DO 210 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
- DO 200 J=1,4
- PS(2,J)=PS(2,J)+P(I,J)
- 200 CONTINUE
- PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
- 210 CONTINUE
- PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
- &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
- IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
- &'(PYEXEC:) four-momentum was not conserved')
- IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
- &'(PYEXEC:) charge was not conserved')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYPREP
-C...Rearranges partons along strings.
-C...Special considerations for systems with junctions, with
-C...possibility of junction-antijunction annihilation.
-C...Allows small systems to collapse into one or two particles.
-C...Checks flavours and colour singlet invariant masses.
-
- SUBROUTINE PYPREP(IP)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYINT1/MINT(400),VINT(400)
-C...The common block of colour tags.
- COMMON/PYCTAG/NCT,MCT(4000,2)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
- &/PYPARS/
- DATA NERRPR/0/
- SAVE NERRPR
-C...Local arrays.
- DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
- &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
- &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
- &IJCP(0:6),TJUOLD(5)
- CHARACTER CHTMP*6
-
-C...Function to give four-product.
- FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
-
-C...Rearrange parton shower product listing along strings: begin loop.
- MSTU(24)=0
- NOLD=N
- I1=N
- NJUNC=0
- NPIECE=0
- NJJSTR=0
- MSTU32=MSTU(32)+1
- DO 100 I=MAX(1,IP),N
-C...First store junction positions.
- IF(K(I,1).EQ.42) THEN
- NJUNC=NJUNC+1
- IJUNC(NJUNC,0)=I
- IJUNC(NJUNC,4)=0
- ENDIF
- 100 CONTINUE
-
- DO 250 MQGST=1,3
- DO 240 I=MAX(1,IP),N
-C...Special treatment for junctions
- IF (K(I,1).LE.0) GOTO 240
- IF(K(I,1).EQ.42) THEN
-C...MQGST=2: Look for junction-junction strings (not detected in the
-C...main search below).
- IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
- IF (NJJSTR.EQ.0) THEN
- NJJSTR = (3*NJUNC-NPIECE)/2
- ENDIF
-C...Check how many already identified strings end on this junction
- ILC=0
- DO 110 J=1,NPIECE
- IF (IPIECE(J,4).EQ.I) ILC=ILC+1
- 110 CONTINUE
-C...If less than 3, remaining must be to another junction
- IF (ILC.LT.3) THEN
- IF (ILC.NE.2) THEN
-C...Multiple j-j connections not handled yet.
- CALL PYERRM(2,
- & '(PYPREP:) Too many junction-junction strings.')
- MINT(51)=1
- RETURN
- ENDIF
-C...The colour information in the junction is unreadable for the
-C...colour space search further down in this routine, so we must
-C...start on the colour mother of this junction and then "artificially"
-C...prevent the colour mother from connecting here again.
- ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
- KCS=4
- IF (MOD(ITJUNC,2).EQ.0) KCS=5
-C...Switch colour if the junction-junction leg is presumably a
-C...junction mother leg rather than a junction daughter leg.
- IF (ITJUNC.GE.3) KCS=9-KCS
- IF (MINT(33).EQ.0) THEN
-C...Find the unconnected leg and reorder junction daughter pointers so
-C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
-C...piece.
- IA=MOD(K(I,4),MSTU(5))
- IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
- ITMP=MOD(K(I,5),MSTU(5))
- IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
- ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
- K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
- ELSE
- K(I,5)=K(I,5)+(IA-ITMP)
- ENDIF
- K(I,4)=K(I,4)+(ITMP-IA)
- IA=ITMP
- ENDIF
- IF (ITJUNC.LE.2) THEN
-C...Beam baryon junction
- K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
- K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
-C...Else 1 -> 2 decay junction
- ELSE
- K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
- K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
- ENDIF
- I1BEG = I1
- NSTP = 0
- GOTO 170
-C...Alternatively use colour tag information.
- ELSE
-C...Find a final state parton with appropriate dangling colour tag.
- JCT=0
- IA=0
- IJUMO=K(I,3)
- DO 140 J1=MAX(1,IP),N
- IF (K(J1,1).NE.3) GOTO 140
-C...Check for matching final-state colour tag
- IMATCH=0
- DO 120 J2=MAX(1,IP),N
- IF (K(J2,1).NE.3) GOTO 120
- IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
- 120 CONTINUE
- IF (IMATCH.EQ.1) GOTO 140
-C...Check whether this colour tag belongs to the present junction
-C...by seeing whether any parton with this colour tag has the same
-C...mother as the junction.
- JCT=MCT(J1,KCS-3)
- IMATCH=0
- DO 130 J2=MINT(84)+1,N
- IMO2=K(J2,3)
-C...First scattering partons have IMO1 = 3 and 4.
- IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
- & IMO2=IMO2-2
- IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
- & IMATCH=1
- 130 CONTINUE
- IF (IMATCH.EQ.0) GOTO 140
- IA=J1
- 140 CONTINUE
-C...Check for junction-junction strings without intermediate final state
-C...glue (not detected above).
- IF (IA.EQ.0) THEN
- DO 160 MJU=1,NJUNC
- IJU2=IJUNC(MJU,0)
- IF (IJU2.EQ.I) GOTO 160
- ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
-C...Only opposite types of junctions can connect to each other.
- IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
- IS=0
- DO 150 J=1,NPIECE
- IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
- 150 CONTINUE
- IF (IS.EQ.3) GOTO 160
- IB=I
- IA=IJU2
- 160 CONTINUE
- ENDIF
-C...Switch to other side of adjacent parton and step from there.
- KCS=9-KCS
- I1BEG = I1
- NSTP = 0
- GOTO 170
- ENDIF
- ELSE IF (ILC.NE.3) THEN
- ENDIF
- ENDIF
- ENDIF
-
-C...Look for coloured string endpoint, or (later) leftover gluon.
- IF(K(I,1).NE.3) GOTO 240
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0) GOTO 240
- KQ=KCHG(KC,2)
- IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
-
-C...Pick up loose string end.
- KCS=4
- IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
- IA=I
- IB=I
- I1BEG=I1
- NSTP=0
- 170 NSTP=NSTP+1
- IF(NSTP.GT.4*N) THEN
- CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
- MINT(51)=1
- RETURN
- ENDIF
-
-C...Copy undecayed parton. Finished if reached string endpoint.
- IF(K(IA,1).EQ.3) THEN
- IF(I1.GE.MSTU(4)-MSTU32-5) THEN
- CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
- MINT(51)=1
- MSTU(24)=1
- RETURN
- ENDIF
- I1=I1+1
- K(I1,1)=2
- IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
- K(I1,2)=K(IA,2)
- K(I1,3)=IA
- K(I1,4)=0
- K(I1,5)=0
- DO 180 J=1,5
- P(I1,J)=P(IA,J)
- V(I1,J)=V(IA,J)
- 180 CONTINUE
- K(IA,1)=K(IA,1)+10
- IF(K(I1,1).EQ.1) GOTO 240
- ENDIF
-
-C...Also finished (for now) if reached junction; then copy to end.
- IF(K(IA,1).EQ.42) THEN
- NCOPY=I1-I1BEG
- IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
- CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
- MINT(51)=1
- MSTU(24)=1
- RETURN
- ENDIF
- IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
- DO 200 ICOPY=1,NCOPY
- DO 190 J=1,5
- K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
- P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
- V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
- 190 CONTINUE
- 200 CONTINUE
- ENDIF
-C...For junction-junction strings, find end leg and reorder junction
-C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
-C...junction-junction string piece.
- IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
- ITMP=MOD(K(IA,4),MSTU(5))
- IF (ITMP.NE.IB) THEN
- IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
- K(IA,5)=K(IA,5)+(ITMP-IB)
- ELSE
- K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
- ENDIF
- K(IA,4)=K(IA,4)+(IB-ITMP)
- ENDIF
- ENDIF
- NPIECE=NPIECE+1
-C...IPIECE:
-C...0: endpoint in original ER
-C...1:
-C...2:
-C...3: Parton immediately next to junction
-C...4: Junction
- IPIECE(NPIECE,0)=I
- IPIECE(NPIECE,1)=MSTU32+1
- IPIECE(NPIECE,2)=MSTU32+NCOPY
- IPIECE(NPIECE,3)=IB
- IPIECE(NPIECE,4)=IA
- MSTU32=MSTU32+NCOPY
- I1=I1BEG
- GOTO 240
- ENDIF
-
-C...GOTO next parton in colour space.
- IB=IA
- IF (MINT(33).EQ.0) THEN
- IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
- & )).NE.0) THEN
- IA=MOD(K(IB,KCS),MSTU(5))
- K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
- MREV=0
- ELSE
- IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
- & MSTU(5)).EQ.0) KCS=9-KCS
- IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
- K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
- MREV=1
- ENDIF
- IF(IA.LE.0.OR.IA.GT.N) THEN
- CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
- IF(NERRPR.LT.5) THEN
- NERRPR=NERRPR+1
- WRITE(MSTU(11),*) 'started at:', I
- WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
- WRITE(MSTU(11),*) 'MQGST =',MQGST
- CALL PYLIST(4)
- ENDIF
- MINT(51)=1
- RETURN
- ENDIF
- IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
- & ,MSTU(5)).EQ.IB) THEN
- IF(MREV.EQ.1) KCS=9-KCS
- IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
- K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
- ELSE
- IF(MREV.EQ.0) KCS=9-KCS
- IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
- K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
- ENDIF
- IF(IA.NE.I) GOTO 170
-C...Use colour tag information
- ELSE
-C...First create colour tags starting on IB if none already present.
- IF (MCT(IB,KCS-3).EQ.0) THEN
- CALL PYCTTR(IB,KCS,IB)
- IF(MINT(51).NE.0) RETURN
- ENDIF
- JCT=MCT(IB,KCS-3)
- IFOUND=0
-C...Find final state tag partner
- DO 210 IT=MAX(1,IP),N
- IF (IT.EQ.IB) GOTO 210
- IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
- & .0) THEN
- IFOUND=IFOUND+1
- IA=IT
- ENDIF
- 210 CONTINUE
-C...Just copy and goto next if exactly one partner found.
- IF (IFOUND.EQ.1) THEN
- GOTO 170
-C...When no match found, match is presumably junction.
- ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
-C...Check whether this colour tag matches a junction
-C...by seeing whether any parton with this colour tag has the same
-C...mother as a junction.
-C...NB: Only type 1 and 2 junctions handled presently.
- DO 230 IJU=1,NJUNC
- IJUMO=K(IJUNC(IJU,0),3)
- ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
-C...Colours only connect to junctions, anti-colours to antijunctions:
- IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
- IMATCH=0
- DO 220 J1=MAX(1,IP),N
- IF (K(J1,1).LE.0) GOTO 220
-C...First scattering partons have IMO1 = 3 and 4.
- IMO=K(J1,3)
- IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
- & IMO=IMO-2
- IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
- & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
- & IMATCH=1
-C...Attempt at handling type > 3 junctions also. Not tested.
- IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
- & .IJUMO) IMATCH=1
- 220 CONTINUE
- IF (IMATCH.EQ.0) GOTO 230
- IA=IJUNC(IJU,0)
- IFOUND=IFOUND+1
- 230 CONTINUE
-
- IF (IFOUND.EQ.1) THEN
- GOTO 170
- ELSEIF (IFOUND.EQ.0) THEN
- WRITE(CHTMP,*) JCT
- CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
- & //CHTMP)
- IF(NERRPR.LT.5) THEN
- NERRPR=NERRPR+1
- CALL PYLIST(4)
- ENDIF
- MINT(51)=1
- RETURN
- ENDIF
- ELSEIF (IFOUND.GE.2) THEN
- WRITE(CHTMP,*) JCT
- CALL PYERRM(12
- & ,'(PYPREP:) too many occurences of colour line: '//
- & CHTMP)
- IF(NERRPR.LT.5) THEN
- NERRPR=NERRPR+1
- CALL PYLIST(4)
- ENDIF
- MINT(51)=1
- RETURN
- ENDIF
- ENDIF
- K(I1,1)=1
- 240 CONTINUE
- 250 CONTINUE
-
-C...Junction systems remain.
- IJU=0
- IJUS=0
- IJUCNT=0
- MREV=0
- IJJSTR=0
- 260 IJUCNT=IJUCNT+1
- IF (IJUCNT.LE.NJUNC) THEN
-C...If we are not processing a j-j string, treat this junction as new.
- IF (IJJSTR.EQ.0) THEN
- IJU=IJUNC(IJUCNT,0)
- MREV=0
-C...If junction has already been read, ignore it.
- IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
-C...If we are on a j-j string, goto second j-j junction.
- ELSE
- IJUCNT=IJUCNT-1
- IJU=IJUS
- ENDIF
-C...Mark selected junction read.
- DO 270 J=1,NJUNC
- IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
- 270 CONTINUE
-C...Determine junction type
- ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
-C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
-C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
-C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
- IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
- IHK=0
- 280 IHK=IHK+1
-C...Find which quarks belong to given junction.
- IHF=0
- DO 290 IPC=1,NPIECE
- IF (IPIECE(IPC,4).EQ.IJU) THEN
- IHF=IHF+1
- IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
- ENDIF
- IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
- 290 CONTINUE
-C...IHK = 3 is special. Either normal string piece, or j-j string.
- IF(IHK.EQ.3) THEN
- IF (MREV.NE.1) THEN
- DO 300 IPC=1,NPIECE
-C...If there is a j-j string starting on the present junction which has
-C...zero length, insert next junction immediately.
- IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
- & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
- IJJSTR = 1
- GOTO 340
- ENDIF
- 300 CONTINUE
- MREV = 1
-C...If MREV is 1 and IHK is 3 we are finished with this system.
- ELSE
- MREV=0
- GOTO 260
- ENDIF
- ENDIF
-
-C...If we've gotten this far, then either IHK < 3, or
-C...an interjunction string exists, or just a third normal string.
- IJUNC(IJUCNT,IHK)=0
- IJJSTR = 0
-C..Order pieces belonging to this junction. Also look for j-j.
- DO 310 IPC=1,NPIECE
- IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
- IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
- & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
- IJUNC(IJUCNT,IHK)=IPC
- IJJSTR = 1
- MREV = 0
- ENDIF
- 310 CONTINUE
-C...Copy back chains in proper order. MREV=0/1 : descending/ascending
- IPC=IJUNC(IJUCNT,IHK)
-C...Temporary solution to cover for bug.
- IF(IPC.LE.0) THEN
- CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
- MINT(51)=1
- RETURN
- ENDIF
- DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
- I1=I1+1
- DO 320 J=1,5
- K(I1,J)=K(MSTU(4)-ICP,J)
- P(I1,J)=P(MSTU(4)-ICP,J)
- V(I1,J)=V(MSTU(4)-ICP,J)
- 320 CONTINUE
- 330 CONTINUE
- K(I1,1)=2
-C...Mark last quark.
- IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
-C...Do not insert junctions at wrong places.
- IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
-C...Insert junction.
- 340 IJUS = IJU
- IF (IHK.EQ.3) THEN
-C...Shift to end junction if a j-j string has been processed.
- IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
- MREV= 1
- ENDIF
- I1=I1+1
- DO 350 J=1,5
- K(I1,J)=0
- P(I1,J)=0.
- V(I1,J)=0.
- 350 CONTINUE
- K(I1,1)=41
- K(IJUS,1)=K(IJUS,1)+10
- K(I1,2)=K(IJUS,2)
- K(I1,3)=IJUS
- 360 IF (IHK.LT.3) GOTO 280
- ELSE
- CALL PYERRM(12,'(PYPREP:) Unknown junction type')
- MINT(51)=1
- RETURN
- ENDIF
- IF (IJUCNT.NE.NJUNC) GOTO 260
- ENDIF
- N=I1
-
-C...Rearrange three strings from junction, e.g. in case one has been
-C...shortened by shower, so the last is the largest-energy one.
- IF(NJUNC.GE.1) THEN
-C...Find systems with exactly one junction.
- MJUN1=0
- NBEG=NOLD+1
- DO 470 I=NOLD+1,N
- IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
- ELSEIF(K(I,1).EQ.41) THEN
- MJUN1=MJUN1+1
- ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
- MJUN1=0
- NBEG=I+1
- ELSE
- NEND=I
-C...Sum up energy-momentum in each junction string.
- DO 370 J=1,5
- PJU(1,J)=0D0
- PJU(2,J)=0D0
- PJU(3,J)=0D0
- 370 CONTINUE
- NJU=0
- DO 390 I1=NBEG,NEND
- IF(K(I1,2).NE.21) THEN
- NJU=NJU+1
- IJUR(NJU)=I1
- ENDIF
- DO 380 J=1,5
- PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
- 380 CONTINUE
- 390 CONTINUE
-C...Find which of them has highest energy (minus mass) in rest frame.
- DO 400 J=1,5
- PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
- 400 CONTINUE
- PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
- & PJU(4,3)**2))
- DO 410 I2=1,3
- PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
- & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
- 410 CONTINUE
- IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
-C...Decide how to rearrange so that new last has highest energy.
- IF(PJU(1,6).LT.PJU(2,6)) THEN
- IRNG(1,1)=IJUR(1)
- IRNG(1,2)=IJUR(2)-1
- IRNG(2,1)=IJUR(4)
- IRNG(2,2)=IJUR(3)+1
- IRNG(4,1)=IJUR(3)-1
- IRNG(4,2)=IJUR(2)
- ELSE
- IRNG(1,1)=IJUR(4)
- IRNG(1,2)=IJUR(3)+1
- IRNG(2,1)=IJUR(2)
- IRNG(2,2)=IJUR(3)-1
- IRNG(4,1)=IJUR(2)-1
- IRNG(4,2)=IJUR(1)
- ENDIF
- IRNG(3,1)=IJUR(3)
- IRNG(3,2)=IJUR(3)
-C...Copy in correct order below bottom of current event record.
- I2=N
- DO 440 II=1,4
- DO 430 I1=IRNG(II,1),IRNG(II,2),
- & ISIGN(1,IRNG(II,2)-IRNG(II,1))
- I2=I2+1
- IF(I2.GE.MSTU(4)-MSTU32-5) THEN
- CALL PYERRM(11,
- & '(PYPREP:) no more memory left in PYJETS')
- MINT(51)=1
- MSTU(24)=1
- RETURN
- ENDIF
- DO 420 J=1,5
- K(I2,J)=K(I1,J)
- P(I2,J)=P(I1,J)
- V(I2,J)=V(I1,J)
- 420 CONTINUE
- IF(K(I2,1).EQ.1) K(I2,1)=2
- 430 CONTINUE
- 440 CONTINUE
- K(I2,1)=1
-C...Copy back up, overwriting but now in correct order.
- DO 460 I1=NBEG,NEND
- I2=I1-NBEG+N+1
- DO 450 J=1,5
- K(I1,J)=K(I2,J)
- P(I1,J)=P(I2,J)
- V(I1,J)=V(I2,J)
- 450 CONTINUE
- 460 CONTINUE
- ENDIF
- MJUN1=0
- NBEG=I+1
- ENDIF
- 470 CONTINUE
-
-C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
-C...to two q-qbar systems.
-C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
- IF (MSTJ(19).NE.1) THEN
- MJUN1 = 0
- JJGLUE = 0
- NBEG = NOLD+1
-C...Force collapse when MSTJ(19)=2.
- IF (MSTJ(19).EQ.2) THEN
- DELMJJ = 1D9
- DELMQQ = 0D0
- ENDIF
-C...Find systems with exactly two junctions.
- DO 700 I=NOLD+1,N
-C...Count junctions
- IF (K(I,1).EQ.41) THEN
- MJUN1 = MJUN1+1
-C...Check for interjunction gluons
- IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
- JJGLUE = 1
- ENDIF
- ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
-C...If end of system reached with either zero or one junction, restart
-C...with next system.
- MJUN1 = 0
- JJGLUE = 0
- NBEG = I+1
- ELSEIF(K(I,1).EQ.1) THEN
-C...If end of system reached with exactly two junctions, compute string
-C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
-C...length measure for the (q-qbar)(q-qbar) topology.
- NEND=I
-C...Loop down through chain.
- ISID=0
- DO 480 I1=NBEG,NEND
-C...Store string piece division locations in event record
- IF (K(I1,2).NE.21) THEN
- ISID = ISID+1
- IJCP(ISID) = I1
- ENDIF
- 480 CONTINUE
-C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
- ISW=0
- IF (PYR(0).LT.0.5D0) ISW=1
-C...Randomly choose which qqbar string gets the jj gluons.
- IGS=1
- IF (PYR(0).GT.0.5D0) IGS=2
-C...Only compute string lengths when no topology forced.
- IF (MSTJ(19).EQ.0) THEN
-C...Repeat following for each junction
- DO 570 IJU=1,2
-C...Initialize iterative procedure for finding JRF
- IJRFIT=0
- DO 490 IX=1,3
- TJUOLD(IX)=0D0
- 490 CONTINUE
- TJUOLD(4)=1D0
-C...Start iteration. Sum up momenta in string pieces
- 500 DO 540 IJS=1,3
-C...JD=-1 for first junction, +1 for second junction.
-C...Find out where piece starts and ends and which direction to go.
- JD=2*IJU-3
- IF (IJS.LE.2) THEN
- IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
- IB = IJCP((IJU-1)*7 - JD*IJS)
- ELSEIF (IJS.EQ.3) THEN
- JD =-JD
- IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
- IB = IJCP((IJU-1)*7 + JD*(IJS+3))
- ENDIF
-C...Initialize junction pull 4-vector.
- DO 510 J=1,5
- PUL(IJS,J)=0D0
- 510 CONTINUE
-C...Initialize weight
- PWT = 0D0
- PWTOLD = 0D0
-C...Sum up (weighted) momenta along each string piece
- DO 530 ISP=IA,IB,JD
-C...If present parton not last in chain
- IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
-C...If last parton was a junction, store present weight
- IF (K(ISP-JD,2).EQ.88) THEN
- PWTOLD = PWT
-C...If last parton was a quark, reset to stored weight.
- ELSEIF (K(ISP-JD,2).NE.21) THEN
- PWT = PWTOLD
- ENDIF
- ENDIF
-C...Skip next parton if weight already large
- IF (PWT.GT.10D0) GOTO 530
-C...Compute momentum in TJUOLD frame:
- TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
- & )*P(ISP,3)
- BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
- DO 520 J=1,3
- TMP=P(ISP,J)+TJUOLD(J)*BFC
- PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
- 520 CONTINUE
-C...Boosted energy
- TMP=TJUOLD(4)*P(ISP,4)+TDP
- PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
-C...Update weight
- PWT=PWT+TMP/PARJ(48)
-C...Put |p| rather than m in 5th slot
- PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
- & +PUL(IJS,3)**2)
- 530 CONTINUE
- 540 CONTINUE
-C...Compute boost
- IJRFIT=IJRFIT+1
- CALL PYJURF(PUL,T)
-C...Combine new boost (T) with old boost (TJUOLD)
- TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
- DO 550 IX=1,3
- TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
- & ))
- 550 CONTINUE
- TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
- & **2)
-C...If last boost small, accept JRF, else iterate.
-C...Also prevent possibility of infinite loop.
- IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
- & IJRFIT.LT.MSTJ(18))THEN
- GOTO 500
- ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
- CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
- ENDIF
-C...Store final boost, with change of sign since TJJ motion vector.
- DO 560 IX=1,3
- TJJ(IJU,IX)=-TJUOLD(IX)
- 560 CONTINUE
- TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
- & +TJJ(IJU,3)**2)
- 570 CONTINUE
-C...String length measure for (q-qbar)(q-qbar) topology.
-C...Note only momenta of nearest partons used (since rest of system
-C...identical).
- IF (JJGLUE.EQ.0) THEN
- DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
- & -1,IJCP(5-ISW)+1)
- ELSE
-C...Put jj gluons on selected string (IGS selected randomly above).
- IF (IGS.EQ.1) THEN
- DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
- & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
- ELSE
- DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
- & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
- & ,IJCP(5-ISW)+1)
- ENDIF
- ENDIF
-C...String length measure for q-q-j-j-q-q topology.
- T1G1=0D0
- T2G2=0D0
- T1T2=0D0
- T1P1=0D0
- T1P2=0D0
- T2P3=0D0
- T2P4=0D0
- ISGN=-1
-C...Note only momenta of nearest partons used (since rest of system
-C...identical).
- DO 580 IX=1,4
- IF (IX.EQ.4) ISGN=1
- T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
- T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
- T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
- T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
- IF (JJGLUE.EQ.0) THEN
-C...Junction motion vector dot product gives length when inter-junction
-C...gluons absent.
- T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
- ELSE
-C...Junction motion vector dot products with gluon momenta give length
-C...when inter-junction gluons present.
- T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
- T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
- ENDIF
- 580 CONTINUE
- DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
- IF (JJGLUE.EQ.0) THEN
- DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
- ELSE
- DELMJJ=DELMJJ*4D0*T1G1*T2G2
- ENDIF
- ENDIF
-C...If delmjj > delmqq collapse string system to q-qbar q-qbar
-C...(Always the case for MSTJ(19)=2 due to initialization above)
- IF (DELMJJ.GT.DELMQQ) THEN
-C...Put new system at end of event record
- NCOP=N
- DO 650 IST=1,2
- DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
- NCOP=NCOP+1
- DO 590 IX=1,5
- P(NCOP,IX)=P(ICOP,IX)
- K(NCOP,IX)=K(ICOP,IX)
- 590 CONTINUE
- 600 CONTINUE
- IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
-C...Insert inter-junction gluon string piece (reversed)
- NJJGL=0
- DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
- NJJGL=NJJGL+1
- NCOP=NCOP+1
- DO 610 IX=1,5
- P(NCOP,IX)=P(ICOP,IX)
- K(NCOP,IX)=K(ICOP,IX)
- 610 CONTINUE
- 620 CONTINUE
- ENDIF
- IFC=-2*IST+3
- DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
- NCOP=NCOP+1
- DO 630 IX=1,5
- P(NCOP,IX)=P(ICOP,IX)
- K(NCOP,IX)=K(ICOP,IX)
- 630 CONTINUE
- 640 CONTINUE
- K(NCOP,1)=1
- 650 CONTINUE
-C...Copy system back in right order
- DO 670 ICOP=NBEG,NEND-2
- DO 660 IX=1,5
- P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
- K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
- 660 CONTINUE
- 670 CONTINUE
-C...Shift down rest of event record
- DO 690 ICOP=NEND+1,N
- DO 680 IX=1,5
- P(ICOP-2,IX)=P(ICOP,IX)
- K(ICOP-2,IX)=K(ICOP,IX)
- 680 CONTINUE
- 690 CONTINUE
-C...Update length of event record.
- N=N-2
- ENDIF
- MJUN1=0
- NBEG=I+1
- ENDIF
- 700 CONTINUE
- ENDIF
- ENDIF
-
-C...Done if no checks on small-mass systems.
- IF(MSTJ(14).LT.0) RETURN
- IF(MSTJ(14).EQ.0) GOTO 1140
-
-C...Find lowest-mass colour singlet jet system.
- NS=N
- 710 NSIN=N-NS
- PDMIN=1D0+PARJ(32)
- IC=0
- DO 770 I=MAX(1,IP),N
- IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
- ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
- NSIN=NSIN+1
- IC=I
- DO 720 J=1,4
- DPS(J)=P(I,J)
- 720 CONTINUE
- MSTJ(93)=1
- DPS(5)=PYMASS(K(I,2))
- ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
- DO 730 J=1,4
- DPS(J)=DPS(J)+P(I,J)
- 730 CONTINUE
- MSTJ(93)=1
- DPS(5)=DPS(5)+PYMASS(K(I,2))
- ELSEIF(K(I,1).EQ.2) THEN
- DO 740 J=1,4
- DPS(J)=DPS(J)+P(I,J)
- 740 CONTINUE
- ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
- DO 750 J=1,4
- DPS(J)=DPS(J)+P(I,J)
- 750 CONTINUE
- MSTJ(93)=1
- DPS(5)=DPS(5)+PYMASS(K(I,2))
- PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
- & DPS(5)
- IF(PD.LT.PDMIN) THEN
- PDMIN=PD
- DO 760 J=1,5
- DPC(J)=DPS(J)
- 760 CONTINUE
- IC1=IC
- IC2=I
- ENDIF
- IC=0
- ELSE
- NSIN=NSIN+1
- ENDIF
- 770 CONTINUE
-
-C...Done if lowest-mass system above threshold for string frag.
- IF(PDMIN.GE.PARJ(32)) GOTO 1140
-
-C...Fill small-mass system as cluster.
- NSAV=N
- PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
- K(N+1,1)=11
- K(N+1,2)=91
- K(N+1,3)=IC1
- P(N+1,1)=DPC(1)
- P(N+1,2)=DPC(2)
- P(N+1,3)=DPC(3)
- P(N+1,4)=DPC(4)
- P(N+1,5)=PECM
-
-C...Set up history, assuming cluster -> 2 hadrons.
- NBODY=2
- K(N+1,4)=N+2
- K(N+1,5)=N+3
- K(N+2,1)=1
- K(N+3,1)=1
- IF(MSTU(16).NE.2) THEN
- K(N+2,3)=N+1
- K(N+3,3)=N+1
- ELSE
- K(N+2,3)=IC1
- K(N+3,3)=IC2
- ENDIF
- K(N+2,4)=0
- K(N+3,4)=0
- K(N+2,5)=0
- K(N+3,5)=0
- V(N+1,5)=0D0
- V(N+2,5)=0D0
- V(N+3,5)=0D0
-
-C...Find total flavour content - complicated by presence of junctions.
- NQ=0
- NDIQ=0
- DO 780 I=IC1,IC2
- IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
- NQ=NQ+1
- KFQ(NQ)=K(I,2)
- IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
- ENDIF
- 780 CONTINUE
-
-C...If several diquarks, split up one to give even number of flavours.
- IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
- I1=3
- IF(IABS(KFQ(3)).LT.1000) I1=1
- KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
- KFQ(I1)=KFQ(I1)/1000
- NQ=4
- NDIQ=NDIQ-1
- ENDIF
-
-C...If four quark ends, join two to diquark.
- IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
- I1=1
- I2=2
- IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
- IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
- KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
- IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
- KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
- & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
- KFQ(I2)=KFQ(4)
- NQ=3
- NDIQ=1
- ENDIF
-
-C...If two quark ends, plus quark or diquark, join quarks to diquark.
- IF(NQ.EQ.3) THEN
- I1=1
- I2=2
- IF(IABS(KFQ(I1)).GT.1000) I1=3
- IF(IABS(KFQ(I2)).GT.1000) I2=3
- KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
- IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
- KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
- & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
- KFQ(I2)=KFQ(3)
- NQ=2
- NDIQ=NDIQ+1
- ENDIF
-
-C...Form two particles from flavours of lowest-mass system, if feasible.
- NTRY = 0
- 790 NTRY = NTRY + 1
-
-C...Open string with two specified endpoint flavours.
- IF(NQ.EQ.2) THEN
- KC1=PYCOMP(KFQ(1))
- KC2=PYCOMP(KFQ(2))
- IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
- KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
- KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
- IF(KQ1+KQ2.NE.0) GOTO 1140
-C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
- 800 K1=KFQ(1)
- IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
- MSTU(125)=0
- CALL PYDCYK(K1,0,KFLN,K(N+2,2))
- CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
- IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
-
-C...Open string with four specified flavours.
- ELSEIF(NQ.EQ.4) THEN
- KC1=PYCOMP(KFQ(1))
- KC2=PYCOMP(KFQ(2))
- KC3=PYCOMP(KFQ(3))
- KC4=PYCOMP(KFQ(4))
- IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
- KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
- KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
- KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
- KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
- IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
-C...Combine flavours pairwise to form two hadrons.
- 810 I1=1
- I2=2
- IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
- & IABS(KFQ(2)).GT.1000)) I2=3
- IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
- & IABS(KFQ(3)).GT.1000))) I2=4
- I3=3
- IF(I2.EQ.3) I3=2
- I4=10-I1-I2-I3
- CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
- CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
- IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
-
-C...Closed string.
- ELSE
- IF(IABS(K(IC2,2)).NE.21) GOTO 1140
-C...No room for popcorn mesons in closed string -> 2 hadrons.
- MSTU(125)=0
- 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
- CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
- CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
- IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
- ENDIF
- P(N+2,5)=PYMASS(K(N+2,2))
- P(N+3,5)=PYMASS(K(N+3,2))
-
-C...If it does not work: try again (a number of times), give up (if no
-C...place to shuffle momentum or too many flavours), or form one hadron.
- IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
- IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
- GOTO 790
- ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
- GOTO 1140
- ELSE
- GOTO 890
- END IF
- END IF
-
-C...Perform two-particle decay of jet system.
-C...First step: find reference axis in decaying system rest frame.
-C...(Borrow slot N+2 for temporary direction.)
- DO 830 J=1,4
- P(N+2,J)=P(IC1,J)
- 830 CONTINUE
- DO 850 I=IC1+1,IC2-1
- IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
- & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
- FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
- DO 840 J=1,4
- P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
- 840 CONTINUE
- ENDIF
- 850 CONTINUE
- CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
- &-DPC(3)/DPC(4))
- THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
- PHI1=PYANGL(P(N+2,1),P(N+2,2))
-
-C...Second step: generate isotropic/anisotropic decay.
- PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
- &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
- 860 UE(3)=PYR(0)
- IF(PARJ(21).LE.0.01D0) UE(3)=1D0
- PT2=(1D0-UE(3)**2)*PA**2
- IF(MSTJ(16).LE.0) THEN
- PREV=0.5D0
- ELSE
- IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
- PR1=P(N+2,5)**2+PT2
- PR2=P(N+3,5)**2+PT2
- ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
- PREVCF=PARJ(42)
- IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
- PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
- ENDIF
- IF(PYR(0).LT.PREV) UE(3)=-UE(3)
- PHI=PARU(2)*PYR(0)
- UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
- UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
- DO 870 J=1,3
- P(N+2,J)=PA*UE(J)
- P(N+3,J)=-PA*UE(J)
- 870 CONTINUE
- P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
- P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
-
-C...Third step: move back to event frame and set production vertex.
- CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
- &DPC(3)/DPC(4))
- DO 880 J=1,4
- V(N+1,J)=V(IC1,J)
- V(N+2,J)=V(IC1,J)
- V(N+3,J)=V(IC2,J)
- 880 CONTINUE
- N=N+3
- GOTO 1120
-
-C...Else form one particle, if possible.
- 890 NBODY=1
- K(N+1,5)=N+2
- DO 900 J=1,4
- V(N+1,J)=V(IC1,J)
- V(N+2,J)=V(IC1,J)
- 900 CONTINUE
-
-C...Select hadron flavour from available quark flavours.
- 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
- GOTO 1140
- ELSEIF(NQ.EQ.2) THEN
- CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
- ELSE
- KFLN=1+INT((2D0+PARJ(2))*PYR(0))
- CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
- ENDIF
- IF(K(N+2,2).EQ.0) GOTO 910
- P(N+2,5)=PYMASS(K(N+2,2))
-
-C...Use old algorithm for E/p conservation? (EN)
- IF (MSTJ(16).LE.0) GOTO 1080
-
-C...Find the string piece closest to the cluster by a loop
-C...over the undecayed partons not in present cluster. (EN)
- DGLOMI=1D30
- IBEG=0
- I0=0
- NJUNC=0
- DO 940 I1=MAX(1,IP),N-1
- IF(K(I1,1).EQ.1) NJUNC=0
- IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
- IF(K(I1,1).EQ.41) GOTO 940
- IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
- I0=0
- ELSEIF(K(I1,1).EQ.2) THEN
- IF(I0.EQ.0) I0=I1
- I2=I1
- 920 I2=I2+1
- IF(K(I2,1).EQ.41) GOTO 940
- IF(K(I2,1).GT.10) GOTO 920
- IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
- IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
- & NJUNC.EQ.0) GOTO 940
- IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
- IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
- & K(I2,1).NE.1)) GOTO 940
-
-C...Define velocity vectors e1, e2, ecl and differences e3, e4.
- DO 930 J=1,3
- E1(J)=P(I1,J)/P(I1,4)
- E2(J)=P(I2,J)/P(I2,4)
- ECL(J)=P(N+1,J)/P(N+1,4)
- E3(J)=E2(J)-E1(J)
- E4(J)=ECL(J)-E1(J)
- 930 CONTINUE
-
-C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
- E3S=E3(1)**2+E3(2)**2+E3(3)**2
- E4S=E4(1)**2+E4(2)**2+E4(3)**2
- E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
- IF(E34.LE.0D0) THEN
- DDMIN=E4S
- ELSEIF(E34.LT.E3S) THEN
- DDMIN=E4S-E34**2/E3S
- ELSE
- DDMIN=E4S-2D0*E34+E3S
- ENDIF
-
-C...Is this the smallest so far?
- IF(DDMIN.LT.DGLOMI) THEN
- DGLOMI=DDMIN
- IBEG=I0
- IPCS=I1
- ENDIF
- ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
- I0=0
- ENDIF
- 940 CONTINUE
-
-C... Check if there are any strings to connect to the new gluon. (EN)
- IF (IBEG.EQ.0) GOTO 1080
-
-C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
- IF (P(N+1,5).GE.P(N+2,5)) THEN
-
-C...Construct 'gluon' that is needed to put hadron on the mass shell.
- FRAC=P(N+2,5)/P(N+1,5)
- DO 950 J=1,5
- P(N+2,J)=FRAC*P(N+1,J)
- PG(J)=(1D0-FRAC)*P(N+1,J)
- 950 CONTINUE
-
-C... Copy string with new gluon put in.
- N=N+2
- I=IBEG-1
- 960 I=I+1
- IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
- IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
- N=N+1
- DO 970 J=1,5
- K(N,J)=K(I,J)
- P(N,J)=P(I,J)
- V(N,J)=V(I,J)
- 970 CONTINUE
- K(I,1)=K(I,1)+10
- K(I,4)=N
- K(I,5)=N
- K(N,3)=I
- IF(I.EQ.IPCS) THEN
- N=N+1
- DO 980 J=1,5
- K(N,J)=K(N-1,J)
- P(N,J)=PG(J)
- V(N,J)=V(N-1,J)
- 980 CONTINUE
- K(N,2)=21
- K(N,3)=NSAV+1
- ENDIF
- IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
- GOTO 1120
-
-C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
-C...from string piece endpoints.
- ELSE
-
-C...Begin by copying string that should give energy to cluster.
- N=N+2
- I=IBEG-1
- 990 I=I+1
- IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
- IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
- N=N+1
- DO 1000 J=1,5
- K(N,J)=K(I,J)
- P(N,J)=P(I,J)
- V(N,J)=V(I,J)
- 1000 CONTINUE
- K(I,1)=K(I,1)+10
- K(I,4)=N
- K(I,5)=N
- K(N,3)=I
- IF(I.EQ.IPCS) I1=N
- IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
- I2=I1+1
-
-C...Set initial Phad.
- DO 1010 J=1,4
- P(NSAV+2,J)=P(NSAV+1,J)
- 1010 CONTINUE
-
-C...Calculate Pg, a part of which will be added to Phad later. (EN)
- 1020 IF(MSTJ(16).EQ.1) THEN
- ALPHA=1D0
- BETA=1D0
- ELSE
- ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
- BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
- ENDIF
- DO 1030 J=1,4
- PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
- 1030 CONTINUE
- PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
-
-C..Solve 2nd order equation, use the best (smallest) solution. (EN)
- PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
- & P(NSAV+2,3)**2
- PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
- & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
- DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
-
-C...If all gluon energy eaten, zero it and take a step back.
- ITER=0
- IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
- ITER=1
- DO 1040 J=1,4
- P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
- P(I1,J)=0D0
- 1040 CONTINUE
- P(I1,5)=0D0
- K(I1,1)=K(I1,1)+10
- I1=I1-1
- IF(K(I1,1).EQ.41) ITER=-1
- ENDIF
- IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
- ITER=1
- DO 1050 J=1,4
- P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
- P(I2,J)=0D0
- 1050 CONTINUE
- P(I2,5)=0D0
- K(I2,1)=K(I2,1)+10
- I2=I2+1
- IF(K(I2,1).EQ.41) ITER=-1
- ENDIF
- IF(ITER.EQ.1) GOTO 1020
-
-C...If also all endpoint energy eaten, revert to old procedure.
- IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
- & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
- DO 1060 I=NSAV+3,N
- IM=K(I,3)
- K(IM,1)=K(IM,1)-10
- K(IM,4)=0
- K(IM,5)=0
- 1060 CONTINUE
- N=NSAV
- GOTO 1080
- ENDIF
-
-C... Construct the collapsed hadron and modified string partons.
- DO 1070 J=1,4
- P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
- P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
- P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
- 1070 CONTINUE
- P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
- P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
-
-C...Finished with string collapse in new scheme.
- GOTO 1120
- ENDIF
-
-C... Use old algorithm; by choice or when in trouble.
- 1080 CONTINUE
-C...Find parton/particle which combines to largest extra mass.
- IR=0
- HA=0D0
- HSM=0D0
- DO 1100 MCOMB=1,3
- IF(IR.NE.0) GOTO 1100
- DO 1090 I=MAX(1,IP),N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
- & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
- IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
- IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
- IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
- IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
- & GOTO 1090
- HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
- HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
- IF(HSR.GT.HSM) THEN
- IR=I
- HA=HCR
- HSM=HSR
- ENDIF
- 1090 CONTINUE
- 1100 CONTINUE
-
-C...Shuffle energy and momentum to put new particle on mass shell.
- IF(IR.NE.0) THEN
- HB=PECM**2+HA
- HC=P(N+2,5)**2+HA
- HD=P(IR,5)**2+HA
- HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
- & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
- HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
- DO 1110 J=1,4
- P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
- P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
- 1110 CONTINUE
- N=N+2
- ELSE
- CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
- RETURN
- ENDIF
-
-C...Mark collapsed system and store daughter pointers. Iterate.
- 1120 DO 1130 I=IC1,IC2
- IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
- & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
- K(I,1)=K(I,1)+10
- IF(MSTU(16).NE.2) THEN
- K(I,4)=NSAV+1
- K(I,5)=NSAV+1
- ELSE
- K(I,4)=NSAV+2
- K(I,5)=NSAV+1+NBODY
- ENDIF
- ENDIF
- IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
- 1130 CONTINUE
- IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
-
-C...Check flavours and invariant masses in parton systems.
- 1140 NP=0
- KFN=0
- KQS=0
- NJU=0
- DO 1150 J=1,5
- DPS(J)=0D0
- 1150 CONTINUE
- DO 1180 I=MAX(1,IP),N
- IF(K(I,1).EQ.41) NJU=NJU+1
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0) GOTO 1180
- KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
- IF(KQ.EQ.0) GOTO 1180
- NP=NP+1
- IF(KQ.NE.2) THEN
- KFN=KFN+1
- KQS=KQS+KQ
- MSTJ(93)=1
- DPS(5)=DPS(5)+PYMASS(K(I,2))
- ENDIF
- DO 1160 J=1,4
- DPS(J)=DPS(J)+P(I,J)
- 1160 CONTINUE
- IF(K(I,1).EQ.1) THEN
- NFERR=0
- IF(NJU.EQ.0.AND.NP.NE.1) THEN
- IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
- ELSEIF(NJU.EQ.1) THEN
- IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
- ELSEIF(NJU.EQ.2) THEN
- IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
- ELSEIF(NJU.GE.3) THEN
- NFERR=1
- ENDIF
- IF(NFERR.EQ.1) THEN
- CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
- MINT(51)=1
- RETURN
- ENDIF
- IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
- & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
- & '(PYPREP:) too small mass in jet system')
- NP=0
- KFN=0
- KQS=0
- NJU=0
- DO 1170 J=1,5
- DPS(J)=0D0
- 1170 CONTINUE
- ENDIF
- 1180 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSTRF
-C...Handles the fragmentation of an arbitrary colour singlet
-C...jet system according to the Lund string fragmentation model.
-
- SUBROUTINE PYSTRF(IP)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-C...Local arrays. All MOPS variables ends with MO
- DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
- &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
- &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
- &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
- &PBST(3,5),TJUOLD(5)
-
-C...Function: four-product of two vectors.
- FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
- DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
- &DP(I,3)*DP(J,3)
-
-C...Reset counters.
- MSTJ(91)=0
- NSAV=N
- MSTU90=MSTU(90)
- NP=0
- KQSUM=0
- DO 100 J=1,5
- DPS(J)=0D0
- 100 CONTINUE
- MJU(1)=0
- MJU(2)=0
- NTRYFN=0
- IJUORI(1)=0
- IJUORI(2)=0
-
-C...Identify parton system.
- I=IP-1
- 110 I=I+1
- IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
- CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0) GOTO 110
- KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
- IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
- IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
- CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
-
-C...Take copy of partons to be considered. Check flavour sum.
- NP=NP+1
- DO 120 J=1,5
- K(N+NP,J)=K(I,J)
- P(N+NP,J)=P(I,J)
- IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
- 120 CONTINUE
- DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
- K(N+NP,3)=I
- IF(KQ.NE.2) KQSUM=KQSUM+KQ
- IF(K(I,1).EQ.41) THEN
- IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
- MJU(1)=N+NP
- IJUORI(1)=I
- ELSE
- MJU(2)=N+NP
- IJUORI(2)=I
- ENDIF
- ENDIF
- IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
- IF(MOD(KQSUM,3).NE.0) THEN
- CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
-
-C...Boost copied system to CM frame (for better numerical precision).
- IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
- MBST=0
- MSTU(33)=1
- CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
- & -DPS(3)/DPS(4))
- ELSE
- MBST=1
- HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
- DO 130 I=N+1,N+NP
- HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
- IF(P(I,3).GT.0D0) THEN
- HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
- P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
- P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
- ELSE
- HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
- P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
- P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
- ENDIF
- 130 CONTINUE
- ENDIF
-
-C...Search for very nearby partons that may be recombined.
- NTRYR=0
- NTRYWR=0
- PARU12=PARU(12)
- PARU13=PARU(13)
- MJU(3)=MJU(1)
- MJU(4)=MJU(2)
- NR=NP
- NRMIN=2
- IF(MJU(1).GT.0) NRMIN=NRMIN+2
- IF(MJU(2).GT.0) NRMIN=NRMIN+2
- 140 IF(NR.GT.NRMIN) THEN
- PDRMIN=2D0*PARU12
- DO 150 I=N+1,N+NR
- IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
- I1=I+1
- IF(I.EQ.N+NR) I1=N+1
- IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
- IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
- & GOTO 150
- IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
- & GOTO 150
- PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
- & P(I1,2)**2+P(I1,3)**2))
- PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
- PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
- IF(PDR.LT.PDRMIN) THEN
- IR=I
- PDRMIN=PDR
- ENDIF
- 150 CONTINUE
-
-C...Recombine very nearby partons to avoid machine precision problems.
- IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
- DO 160 J=1,4
- P(N+1,J)=P(N+1,J)+P(N+NR,J)
- 160 CONTINUE
- P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
- & P(N+1,3)**2))
- NR=NR-1
- GOTO 140
- ELSEIF(PDRMIN.LT.PARU12) THEN
- DO 170 J=1,4
- P(IR,J)=P(IR,J)+P(IR+1,J)
- 170 CONTINUE
- P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
- & P(IR,3)**2))
- IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
- DO 190 I=IR+1,N+NR-1
- K(I,1)=K(I+1,1)
- K(I,2)=K(I+1,2)
- DO 180 J=1,5
- P(I,J)=P(I+1,J)
- 180 CONTINUE
- 190 CONTINUE
- IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
- NR=NR-1
- IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
- IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
- GOTO 140
- ENDIF
- ENDIF
- NTRYR=NTRYR+1
-
-C...Reset particle counter. Skip ahead if no junctions are present;
-C...this is usually the case!
- NRS=MAX(5*NR+11,NP)
- NTRY=0
- 200 NTRY=NTRY+1
- IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
- PARU12=4D0*PARU12
- PARU13=2D0*PARU13
- GOTO 140
- ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
- CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- I=N+NRS
- MSTU(90)=MSTU90
- IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
- IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
- & ' junction strings not handled by MSTJ(12)>3 options')
- DO 640 JT=1,2
- NJS(JT)=0
- IF(MJU(JT).EQ.0) GOTO 640
- JS=3-2*JT
-
-C++SKANDS
-C...Find and sum up momentum on three sides of junction.
-C...Begin with previous boost = zero.
- IJRFIT=0
- DO 210 IX=1,3
- TJUOLD(IX)=0D0
- 210 CONTINUE
- TJUOLD(4)=1D0
- 220 IU=0
-C...Beginning and end of string system in event record.
- I1BEG=N+1+(JT-1)*(NR-1)
- I1END=N+NR+(JT-1)*(1-NR)
-C...Look for junction string piece end points
- DO 230 I1=I1BEG,I1END,JS
- IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
-C...Store junction string piece end points.
-C 1-junction systems 2-junction systems
-C IU : 1 2 3 4 1 2 3 4 5 6
-C IJU(IU): q-g-g-q-g-g-j-g-q q-g-g-q-g-j-g-g-j-g-q-g-g-q
- IU=IU+1
- IJU(IU)=I1
- ENDIF
-C...Sum over momenta, from junction outwards.
- 230 CONTINUE
- DO 280 IU=1,3
- PWT=0D0
-C...Initialize junction drag and string piece 4-vectors.
- DO 240 J=1,5
- PBST(IU,J)=0D0
- PJU(IU,J)=0D0
- 240 CONTINUE
-C...First two branches. Inwards out means opposite direction to JS.
-C...(JS is 1 for JT=1, -1 for JT=2)
- IF (IU.LT.3) THEN
- I1A=IJU(IU+1)-JS
- I1B=IJU(IU)
- IDIR=-JS
-C...Last branch (gq or gjgqgq). Direction now reversed.
- ELSE
- I1A=IJU(IU)+JS
- I1B=I1END
- IDIR=JS
- ENDIF
- DO 270 I1=I1A,I1B,IDIR
-C...Sum up momentum directions with exponential suppression
-C...for use in finding junction rest frame below.
- IF (K(I1,2).EQ.88) THEN
-C...gjgqgq type system encountered. Use current PWT as start
-C...for both strings.
- PWTOLD=PWT
- ELSE
- IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
-C...Sum up string piece (boosted) 4-momenta.
- DO 250 J=1,4
- PJU(IU,J)=PJU(IU,J)+P(I1,J)
- 250 CONTINUE
-C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
-C...boost is zero, see above). Skip parton if suppression factor large.
- IF (PWT.GT.10D0) GOTO 270
-C...Compute momentum in current frame:
- TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
- BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
- DO 260 J=1,3
- PTMP=P(I1,J)+TJUOLD(J)*BFC
- PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
- 260 CONTINUE
-C...Boosted energy
- PTMP=TJUOLD(4)*P(I1,4)+TDP
- PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
- PWT=PWT+PTMP/PARJ(48)
- ENDIF
- 270 CONTINUE
-C...Put |p| rather than m in 5th slot.
- PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
- PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
- 280 CONTINUE
-
-C...Calculate boost from present frame to next JRF candidate.
- IJRFIT=IJRFIT+1
- CALL PYJURF(PBST,TJU)
-
-C...After some iterations do not take full step in new direction.
- IF(IJRFIT.GT.5) THEN
- REDUCE=0.8D0**(IJRFIT-5)
- TJU(1)=REDUCE*TJU(1)
- TJU(2)=REDUCE*TJU(2)
- TJU(3)=REDUCE*TJU(3)
- TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
- ENDIF
-
-C...Combine new boost (TJU) with old boost (TJUOLD)
- TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
- DO 290 IX=1,3
- TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
- 290 CONTINUE
- TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
-
-C...If last boost small, accept JRF, else iterate.
-C...Also prevent possibility of infinite loop.
- IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
- & IJRFIT.LT.MSTJ(18)) THEN
- GOTO 220
- ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
- CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
- ENDIF
-
-C...Now store total boost in TJU and change perception.
-C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
-C...TJU = junction motion vector in string CM, so the sign changes.
- DO 300 J=1,3
- TJU(J)=-TJUOLD(J)
- 300 CONTINUE
- TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
-
-C--SKANDS
-
-C...Calculate string piece energies in junction rest frame.
- DO 310 IU=1,3
- PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
- & TJU(3)*PJU(IU,3)
- PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
- & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
- 310 CONTINUE
-
-C...Start preparing for fragmentation of two strings from junction.
- ISTA=I
- NTRYER=0
- 320 NTRYER=NTRYER+1
- I=ISTA
- DO 620 IU=1,2
- NS=IABS(IJU(IU+1)-IJU(IU))
-
-C...Junction strings: find longitudinal string directions.
- DO 350 IS=1,NS
- IS1=IJU(IU)+JS*(IS-1)
- IS2=IJU(IU)+JS*IS
- DO 330 J=1,5
- DP(1,J)=0.5D0*P(IS1,J)
- IF(IS.EQ.1) DP(1,J)=P(IS1,J)
- DP(2,J)=0.5D0*P(IS2,J)
- IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
- & (PJU(IU,5)/PBST(IU,5))
- 330 CONTINUE
- IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
- & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
- DP(3,5)=DFOUR(1,1)
- DP(4,5)=DFOUR(2,2)
- DHKC=DFOUR(1,2)
- IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
- DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
- DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
- DP(3,5)=0D0
- DP(4,5)=0D0
- DHKC=DFOUR(1,2)
- ENDIF
- DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
- DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
- DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
- IN1=N+NR+4*IS-3
- P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
- DO 340 J=1,4
- P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
- P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
- 340 CONTINUE
- 350 CONTINUE
-
-C...Junction strings: initialize flavour, momentum and starting pos.
- ISAV=I
- MSTU91=MSTU(90)
- 360 NTRY=NTRY+1
- IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
- PARU12=4D0*PARU12
- PARU13=2D0*PARU13
- GOTO 140
- ELSEIF(NTRY.GT.100) THEN
- CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- I=ISAV
- MSTU(90)=MSTU91
- IRANKJ=0
- IE(1)=K(N+1+(JT/2)*(NP-1),3)
- IF (MOD(JT+IU,2).NE.0) THEN
- IE(1)=K(IJU(IU),3)
- IF (NP-NR.NE.0) THEN
-C...If gluons have disappeared. Original IJU must be used.
- IT=IP
- NE=1
- 370 IT=IT+1
- IF (K(IT,2).NE.21) THEN
- NE=NE+1
- ENDIF
- IF (NE.EQ.IU+4*(JT-1)) THEN
- IE(1)=IT
- ELSEIF (IT.LE.IP+NP) THEN
- GOTO 370
- ELSE
- CALL PYERRM(14,'(PYSTRF:) '//
- & 'Original IJU could not be reconstructed!')
- ENDIF
- ENDIF
- ENDIF
- IN(4)=N+NR+1
- IN(5)=IN(4)+1
- IN(6)=N+NR+4*NS+1
- DO 390 JQ=1,2
- DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
- P(IN1,1)=2-JQ
- P(IN1,2)=JQ-1
- P(IN1,3)=1D0
- 380 CONTINUE
- 390 CONTINUE
- KFL(1)=K(IJU(IU),2)
- PX(1)=0D0
- PY(1)=0D0
- GAM(1)=0D0
- DO 400 J=1,5
- PJU(IU+3,J)=0D0
- 400 CONTINUE
-
-C...Junction strings: find initial transverse directions.
- DO 410 J=1,4
- DP(1,J)=P(IN(4),J)
- DP(2,J)=P(IN(4)+1,J)
- DP(3,J)=0D0
- DP(4,J)=0D0
- 410 CONTINUE
- DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
- DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
- DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
- DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
- DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
- IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
- IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
- IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
- IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
- DHC12=DFOUR(1,2)
- DHCX1=DFOUR(3,1)/DHC12
- DHCX2=DFOUR(3,2)/DHC12
- DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
- DHCY1=DFOUR(4,1)/DHC12
- DHCY2=DFOUR(4,2)/DHC12
- DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
- DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
- DO 420 J=1,4
- DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
- P(IN(6),J)=DP(3,J)
- P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
- & DHCYX*DP(3,J))
- 420 CONTINUE
-
-C...Junction strings: produce new particle, origin.
- 430 I=I+1
- IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
- CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- IRANKJ=IRANKJ+1
- K(I,1)=1
- K(I,3)=IE(1)
- K(I,4)=0
- K(I,5)=0
-
-C...Junction strings: generate flavour, hadron, pT, z and Gamma.
- 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
- IF(K(I,2).EQ.0) GOTO 360
- IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
- & IABS(KFL(3)).GT.10) THEN
- IF(PYR(0).GT.PARJ(19)) GOTO 440
- ENDIF
- P(I,5)=PYMASS(K(I,2))
- CALL PYPTDI(KFL(1),PX(3),PY(3))
- PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
- CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
- IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
- & MSTU(90).LT.8) THEN
- MSTU(90)=MSTU(90)+1
- MSTU(90+MSTU(90))=I
- PARU(90+MSTU(90))=Z
- ENDIF
- GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
- DO 450 J=1,3
- IN(J)=IN(3+J)
- 450 CONTINUE
-
-C...Junction strings: stepping within 'low' string region.
- IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
- & P(IN(1),5)**2.GE.PR(1)) THEN
- P(IN(1)+2,4)=Z*P(IN(1)+2,3)
- P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
- DO 460 J=1,4
- P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
- 460 CONTINUE
- GOTO 560
-C...Has used up energy of junction string, i.e. no more hadrons in it.
- ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
- DO 470 J=1,5
- P(I,J)=0D0
- 470 CONTINUE
- GOTO 600
-C...Stepping from 'low' string region
- ELSEIF(IN(1)+1.EQ.IN(2)) THEN
- P(IN(2)+2,4)=P(IN(2)+2,3)
- P(IN(2)+2,1)=1D0
- IN(2)=IN(2)+4
- IF(IN(2).GT.N+NR+4*NS) GOTO 360
- IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
- P(IN(1)+2,4)=P(IN(1)+2,3)
- P(IN(1)+2,1)=0D0
- IN(1)=IN(1)+4
- ENDIF
- ENDIF
-
-C...Junction strings: find new transverse directions.
- 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
- & IN(1).GT.IN(2)) GOTO 360
- IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
- DO 490 J=1,4
- DP(1,J)=P(IN(1),J)
- DP(2,J)=P(IN(2),J)
- DP(3,J)=0D0
- DP(4,J)=0D0
- 490 CONTINUE
- DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
- DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
- DHC12=DFOUR(1,2)
- IF(DHC12.LE.1D-2) THEN
- P(IN(1)+2,4)=P(IN(1)+2,3)
- P(IN(1)+2,1)=0D0
- IN(1)=IN(1)+4
- GOTO 480
- ENDIF
- IN(3)=N+NR+4*NS+5
- DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
- DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
- DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
- IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
- IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
- IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
- IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
- DHCX1=DFOUR(3,1)/DHC12
- DHCX2=DFOUR(3,2)/DHC12
- DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
- DHCY1=DFOUR(4,1)/DHC12
- DHCY2=DFOUR(4,2)/DHC12
- DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
- DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
- DO 500 J=1,4
- DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
- P(IN(3),J)=DP(3,J)
- P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
- & DHCYX*DP(3,J))
- 500 CONTINUE
-C...Express pT with respect to new axes, if sensible.
- PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
- PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
- IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
- PX(3)=PXP
- PY(3)=PYP
- ENDIF
- ENDIF
-
-C...Junction strings: sum up known four-momentum, coefficients for m2.
- DO 530 J=1,4
- DHG(J)=0D0
- P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
- & PY(3)*P(IN(3)+1,J)
- DO 510 IN1=IN(4),IN(1)-4,4
- P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
- 510 CONTINUE
- DO 520 IN2=IN(5),IN(2)-4,4
- P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
- 520 CONTINUE
- 530 CONTINUE
- DHM(1)=FOUR(I,I)
- DHM(2)=2D0*FOUR(I,IN(1))
- DHM(3)=2D0*FOUR(I,IN(2))
- DHM(4)=2D0*FOUR(IN(1),IN(2))
-
-C...Junction strings: find coefficients for Gamma expression.
- DO 550 IN2=IN(1)+1,IN(2),4
- DO 540 IN1=IN(1),IN2-1,4
- DHC=2D0*FOUR(IN1,IN2)
- DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
- IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
- IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
- IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
- 540 CONTINUE
- 550 CONTINUE
-
-C...Junction strings: solve (m2, Gamma) equation system for energies.
- DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
- IF(ABS(DHS1).LT.1D-4) GOTO 360
- DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
- & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
- DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
- P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
- & ABS(DHS1)-DHS2/DHS1)
- IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
- P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
- & (DHM(2)+DHM(4)*P(IN(2)+2,4))
-
-C...Junction strings: step to new region if necessary.
- IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
- P(IN(2)+2,4)=P(IN(2)+2,3)
- P(IN(2)+2,1)=1D0
- IN(2)=IN(2)+4
- IF(IN(2).GT.N+NR+4*NS) GOTO 360
- IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
- P(IN(1)+2,4)=P(IN(1)+2,3)
- P(IN(1)+2,1)=0D0
- IN(1)=IN(1)+4
- ENDIF
- GOTO 480
- ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
- P(IN(1)+2,4)=P(IN(1)+2,3)
- P(IN(1)+2,1)=0D0
- IN(1)=IN(1)+4
- GOTO 480
- ENDIF
-
-C...Junction strings: particle four-momentum, remainder, loop back.
- 560 DO 570 J=1,4
- P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
- & P(IN(2)+2,4)*P(IN(2),J)
- PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
- 570 CONTINUE
- IF(P(I,4).LT.P(I,5)) GOTO 360
- PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
- & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
- IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
- KFL(1)=-KFL(3)
- PX(1)=-PX(3)
- PY(1)=-PY(3)
- GAM(1)=GAM(3)
- IF(IN(3).NE.IN(6)) THEN
- DO 580 J=1,4
- P(IN(6),J)=P(IN(3),J)
- P(IN(6)+1,J)=P(IN(3)+1,J)
- 580 CONTINUE
- ENDIF
- DO 590 JQ=1,2
- IN(3+JQ)=IN(JQ)
- P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
- P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
- 590 CONTINUE
- GOTO 430
- ENDIF
-
-C...Junction strings: save quantities left after each string.
- IF(IABS(KFL(1)).GT.10) GOTO 360
- 600 I=I-1
- KFJH(IU)=KFL(1)
- DO 610 J=1,4
- PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
- 610 CONTINUE
-
-C...Junction strings: loopback if much unused energy in both strings.
- PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
- & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
- EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
- 620 CONTINUE
- IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
- & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
- & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
- & .AND.NTRYER.LT.10) GOTO 320
-
-C...Junction strings: put together to new effective string endpoint.
- NJS(JT)=I-ISTA
- KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
- IF(KFJH(1).EQ.KFJH(2)) KFLS=3
- KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
- & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
- DO 630 J=1,4
- PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
- PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
- 630 CONTINUE
- PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
- & PJS(JT,3)**2))
- PJS(JT+2,5)=0D0
- 640 CONTINUE
-
-C...Open versus closed strings. Choose breakup region for latter.
- 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
- NS=MJU(2)-MJU(1)
- NB=MJU(1)-N
- ELSEIF(MJU(1).NE.0) THEN
- NS=N+NR-MJU(1)
- NB=MJU(1)-N
- ELSEIF(MJU(2).NE.0) THEN
- NS=MJU(2)-N
- NB=1
- ELSEIF(IABS(K(N+1,2)).NE.21) THEN
- NS=NR-1
- NB=1
- ELSE
- NS=NR+1
- W2SUM=0D0
- DO 660 IS=1,NR
- P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
- W2SUM=W2SUM+P(N+NR+IS,1)
- 660 CONTINUE
- W2RAN=PYR(0)*W2SUM
- NB=0
- 670 NB=NB+1
- W2SUM=W2SUM-P(N+NR+NB,1)
- IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
- ENDIF
-
-C...Find longitudinal string directions (i.e. lightlike four-vectors).
- DO 700 IS=1,NS
- IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
- IS2=N+IS+NB-NR*((IS+NB-1)/NR)
- DO 680 J=1,5
- DP(1,J)=P(IS1,J)
- IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
- IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
- DP(2,J)=P(IS2,J)
- IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
- IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
- 680 CONTINUE
- IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
- & DP(1,2)**2-DP(1,3)**2))
- IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
- & DP(2,2)**2-DP(2,3)**2))
- DP(3,5)=DFOUR(1,1)
- DP(4,5)=DFOUR(2,2)
- DHKC=DFOUR(1,2)
- IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
- DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
- DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
- DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
- IN1=N+NR+4*IS-3
- P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
- DO 690 J=1,4
- P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
- P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
- 690 CONTINUE
- 700 CONTINUE
-
-C...Begin initialization: sum up energy, set starting position.
- ISAV=I
- MSTU91=MSTU(90)
- 710 NTRY=NTRY+1
- IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
- PARU12=4D0*PARU12
- PARU13=2D0*PARU13
- GOTO 140
- ELSEIF(NTRY.GT.100) THEN
- CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- I=ISAV
- MSTU(90)=MSTU91
- DO 730 J=1,4
- P(N+NRS,J)=0D0
- DO 720 IS=1,NR
- P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
- 720 CONTINUE
- 730 CONTINUE
- DO 750 JT=1,2
- IRANK(JT)=0
- IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
- IF(NS.GT.NR) IRANK(JT)=1
- IBARRK(JT)=0
- IE(JT)=K(N+1+(JT/2)*(NP-1),3)
- IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
- IN(3*JT+2)=IN(3*JT+1)+1
- IN(3*JT+3)=N+NR+4*NS+2*JT-1
- DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
- P(IN1,1)=2-JT
- P(IN1,2)=JT-1
- P(IN1,3)=1D0
- 740 CONTINUE
- 750 CONTINUE
-
-C.. MOPS variables and switches
- NRVMO=0
- XBMO=1D0
- MSTU(121)=0
- MSTU(122)=0
-
-C...Initialize flavour and pT variables for open string.
- IF(NS.LT.NR) THEN
- PX(1)=0D0
- PY(1)=0D0
- IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
- PX(2)=-PX(1)
- PY(2)=-PY(1)
- DO 760 JT=1,2
- KFL(JT)=K(IE(JT),2)
- IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
- IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
- MSTJ(93)=1
- PMQ(JT)=PYMASS(KFL(JT))
- GAM(JT)=0D0
- 760 CONTINUE
-
-C...Closed string: random initial breakup flavour, pT and vertex.
- ELSE
- KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
- IBMO=0
- 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
-C.. Closed string: first vertex diq attempt => enforced second
-C.. vertex diq
- IF(IABS(KFL(1)).GT.10)THEN
- IBMO=1
- MSTU(121)=0
- GOTO 770
- ENDIF
- IF(IBMO.EQ.1) MSTU(121)=-1
- KFL(2)=-KFL(1)
- CALL PYPTDI(KFL(1),PX(1),PY(1))
- PX(2)=-PX(1)
- PY(2)=-PY(1)
- PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
- 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
- ZR=PR3/(Z*P(N+NR+1,5)**2)
- IF(ZR.GE.1D0) GOTO 780
- DO 790 JT=1,2
- MSTJ(93)=1
- PMQ(JT)=PYMASS(KFL(JT))
- GAM(JT)=PR3*(1D0-Z)/Z
- IN1=N+NR+3+4*(JT/2)*(NS-1)
- P(IN1,JT)=1D0-Z
- P(IN1,3-JT)=JT-1
- P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
- P(IN1+1,JT)=ZR
- P(IN1+1,3-JT)=2-JT
- P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
- 790 CONTINUE
- ENDIF
-C.. MOPS variables
- DO 800 JT=1,2
- XTMO(JT)=1D0
- PM2QMO(JT)=PMQ(JT)**2
- IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
- 800 CONTINUE
-
-C...Find initial transverse directions (i.e. spacelike four-vectors).
- DO 840 JT=1,2
- IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
- IN1=IN(3*JT+1)
- IN3=IN(3*JT+3)
- DO 810 J=1,4
- DP(1,J)=P(IN1,J)
- DP(2,J)=P(IN1+1,J)
- DP(3,J)=0D0
- DP(4,J)=0D0
- 810 CONTINUE
- DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
- DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
- DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
- DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
- DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
- IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
- IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
- IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
- IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
- DHC12=DFOUR(1,2)
- DHCX1=DFOUR(3,1)/DHC12
- DHCX2=DFOUR(3,2)/DHC12
- DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
- DHCY1=DFOUR(4,1)/DHC12
- DHCY2=DFOUR(4,2)/DHC12
- DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
- DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
- DO 820 J=1,4
- DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
- P(IN3,J)=DP(3,J)
- P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
- & DHCYX*DP(3,J))
- 820 CONTINUE
- ELSE
- DO 830 J=1,4
- P(IN3+2,J)=P(IN3,J)
- P(IN3+3,J)=P(IN3+1,J)
- 830 CONTINUE
- ENDIF
- 840 CONTINUE
-
-C...Remove energy used up in junction string fragmentation.
- IF(MJU(1)+MJU(2).GT.0) THEN
- DO 860 JT=1,2
- IF(NJS(JT).EQ.0) GOTO 860
- DO 850 J=1,4
- P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
- 850 CONTINUE
- 860 CONTINUE
- PARJST=PARJ(33)
- IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
- WMIN=PARJST+PMQ(1)+PMQ(2)
- WREM2=FOUR(N+NRS,N+NRS)
- IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
- NTRYWR=NTRYWR+1
- IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
- GOTO 140
- ENDIF
- ENDIF
-
-C...Produce new particle: side, origin.
- 870 I=I+1
- IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
- CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
-C.. New side priority for popcorn systems
- IF(MSTU(121).LE.0)THEN
- JT=1.5D0+PYR(0)
- IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
- IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
- ENDIF
- JR=3-JT
- JS=3-2*JT
- IRANK(JT)=IRANK(JT)+1
- K(I,1)=1
- K(I,4)=0
- K(I,5)=0
-
-C...Generate flavour, hadron and pT.
- 880 K(I,3)=IE(JT)
- CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
- IF(K(I,2).EQ.0) GOTO 710
- MU90MO=MSTU(90)
- IF(MSTU(121).EQ.-1) GOTO 910
- IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
- &IABS(KFL(3)).GT.10) THEN
- IF(PYR(0).GT.PARJ(19)) GOTO 880
- ENDIF
- IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
- &K(I,3)=IJUORI(JT)
- P(I,5)=PYMASS(K(I,2))
- CALL PYPTDI(KFL(JT),PX(3),PY(3))
- PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
-
-C...Final hadrons for small invariant mass.
- MSTJ(93)=1
- PMQ(3)=PYMASS(KFL(3))
- PARJST=PARJ(33)
- IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
- WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
- IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
- &WMIN-0.5D0*PARJ(36)*PMQ(3)
- WREM2=FOUR(N+NRS,N+NRS)
- IF(WREM2.LT.0.10D0) GOTO 710
- IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
- &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
-
-C...Choose z, which gives Gamma. Shift z for heavy flavours.
- CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
- IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
- &MSTU(90).LT.8) THEN
- MSTU(90)=MSTU(90)+1
- MSTU(90+MSTU(90))=I
- PARU(90+MSTU(90))=Z
- ENDIF
- KFL1A=IABS(KFL(1))
- KFL2A=IABS(KFL(2))
- IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
- &MOD(KFL2A/1000,10)).GE.4) THEN
- PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
- PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
- Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
- PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
- IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
- ENDIF
- GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
-
-C.. MOPS baryon model modification
- XTMO3=(1D0-Z)*XTMO(JT)
- IF(IABS(KFL(3)).LE.10) NRVMO=0
- IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
- GTSTMO=1D0
- PTSTMO=1D0
- RTSTMO=PYR(0)
- IF(IABS(KFL(JT)).LE.10)THEN
- XBMO=MIN(XTMO3,1D0-(2D-10))
- GBMO=GAM(3)
- PMMO=0D0
- PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
- GTSTMO=1D0-PARF(192)**PGMO
- ELSE
- IF(IRANK(JT).EQ.1) THEN
- GBMO=GAM(JT)
- PMMO=0D0
- XBMO=1D0
- ENDIF
- IF(XBMO.LT.1D0-(1D-10))THEN
- PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
- GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
- PGMO=PGNMO
- ENDIF
- IF(MSTJ(12).GE.5)THEN
- PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
- PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
- PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
- PMMO=PMNMO
- ENDIF
- ENDIF
-
-C.. MOPS Accepting popcorn system hadron.
- IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
- IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
- NRVMO=I-N-NR
- IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
- CALL PYERRM(11,
- & '(PYSTRF:) no more memory left in PYJETS')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- IMO=I
- KFLMO=KFL(JT)
- PMQMO=PMQ(JT)
- PXMO=PX(JT)
- PYMO=PY(JT)
- GAMMO=GAM(JT)
- IRMO=IRANK(JT)
- XMO=XTMO(JT)
- DO 900 J=1,9
- IF(J.LE.5) THEN
- DO 890 LINE=1,I-N-NR
- P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
- K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
- 890 CONTINUE
- ENDIF
- INMO(J)=IN(J)
- 900 CONTINUE
- ENDIF
- ELSE
-C..Reject popcorn system, flag=-1 if enforcing new one
- MSTU(121)=-1
- IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
- ENDIF
- ENDIF
-
-
-C..Lift restoring string outside MOPS block
- 910 IF(MSTU(121).LT.0) THEN
- IF(MSTU(121).EQ.-2) MSTU(121)=0
- MSTU(90)=MU90MO
- NRVMO=0
- IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
- I=IMO
- KFL(JT)=KFLMO
- PMQ(JT)=PMQMO
- PX(JT)=PXMO
- PY(JT)=PYMO
- GAM(JT)=GAMMO
- IRANK(JT)=IRMO
- XTMO(JT)=XMO
- DO 930 J=1,9
- IF(J.LE.5) THEN
- DO 920 LINE=1,I-N-NR
- P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
- K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
- 920 CONTINUE
- ENDIF
- IN(J)=INMO(J)
- 930 CONTINUE
- GOTO 880
- ENDIF
- XTMO(JT)=XTMO3
-C.. MOPS end of modification
-
- DO 940 J=1,3
- IN(J)=IN(3*JT+J)
- 940 CONTINUE
-
-C...Stepping within or from 'low' string region easy.
- IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
- &P(IN(1),5)**2.GE.PR(JT)) THEN
- P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
- P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
- DO 950 J=1,4
- P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
- 950 CONTINUE
- GOTO 1040
- ELSEIF(IN(1)+1.EQ.IN(2)) THEN
- P(IN(JR)+2,4)=P(IN(JR)+2,3)
- P(IN(JR)+2,JT)=1D0
- IN(JR)=IN(JR)+4*JS
- IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
- IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
- P(IN(JT)+2,4)=P(IN(JT)+2,3)
- P(IN(JT)+2,JT)=0D0
- IN(JT)=IN(JT)+4*JS
- ENDIF
- ENDIF
-
-C...Find new transverse directions (i.e. spacelike string vectors).
- 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
- &IN(1).GT.IN(2)) GOTO 710
- IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
- DO 970 J=1,4
- DP(1,J)=P(IN(1),J)
- DP(2,J)=P(IN(2),J)
- DP(3,J)=0D0
- DP(4,J)=0D0
- 970 CONTINUE
- DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
- DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
- DHC12=DFOUR(1,2)
- IF(DHC12.LE.1D-2) THEN
- P(IN(JT)+2,4)=P(IN(JT)+2,3)
- P(IN(JT)+2,JT)=0D0
- IN(JT)=IN(JT)+4*JS
- GOTO 960
- ENDIF
- IN(3)=N+NR+4*NS+5
- DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
- DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
- DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
- IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
- IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
- IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
- IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
- DHCX1=DFOUR(3,1)/DHC12
- DHCX2=DFOUR(3,2)/DHC12
- DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
- DHCY1=DFOUR(4,1)/DHC12
- DHCY2=DFOUR(4,2)/DHC12
- DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
- DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
- DO 980 J=1,4
- DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
- P(IN(3),J)=DP(3,J)
- P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
- & DHCYX*DP(3,J))
- 980 CONTINUE
-C...Express pT with respect to new axes, if sensible.
- PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
- & FOUR(IN(3*JT+3)+1,IN(3)))
- PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
- & FOUR(IN(3*JT+3)+1,IN(3)+1))
- IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
- PX(3)=PXP
- PY(3)=PYP
- ENDIF
- ENDIF
-
-C...Sum up known four-momentum. Gives coefficients for m2 expression.
- DO 1010 J=1,4
- DHG(J)=0D0
- P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
- & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
- DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
- P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
- 990 CONTINUE
- DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
- P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
- 1000 CONTINUE
- 1010 CONTINUE
- DHM(1)=FOUR(I,I)
- DHM(2)=2D0*FOUR(I,IN(1))
- DHM(3)=2D0*FOUR(I,IN(2))
- DHM(4)=2D0*FOUR(IN(1),IN(2))
-
-C...Find coefficients for Gamma expression.
- DO 1030 IN2=IN(1)+1,IN(2),4
- DO 1020 IN1=IN(1),IN2-1,4
- DHC=2D0*FOUR(IN1,IN2)
- DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
- IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
- IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
- IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
- 1020 CONTINUE
- 1030 CONTINUE
-
-C...Solve (m2, Gamma) equation system for energies taken.
- DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
- IF(ABS(DHS1).LT.1D-4) GOTO 710
- DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
- &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
- DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
- P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
- &ABS(DHS1)-DHS2/DHS1)
- IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
- P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
- &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
-
-C...Step to new region if necessary.
- IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
- P(IN(JR)+2,4)=P(IN(JR)+2,3)
- P(IN(JR)+2,JT)=1D0
- IN(JR)=IN(JR)+4*JS
- IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
- IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
- P(IN(JT)+2,4)=P(IN(JT)+2,3)
- P(IN(JT)+2,JT)=0D0
- IN(JT)=IN(JT)+4*JS
- ENDIF
- GOTO 960
- ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
- P(IN(JT)+2,4)=P(IN(JT)+2,3)
- P(IN(JT)+2,JT)=0D0
- IN(JT)=IN(JT)+4*JS
- GOTO 960
- ENDIF
-
-C...Four-momentum of particle. Remaining quantities. Loop back.
- 1040 DO 1050 J=1,4
- P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
- P(N+NRS,J)=P(N+NRS,J)-P(I,J)
- 1050 CONTINUE
- IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
- &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
- &GOTO 200
- IF(P(I,4).LT.P(I,5)) GOTO 710
- KFL(JT)=-KFL(3)
- PMQ(JT)=PMQ(3)
- PX(JT)=-PX(3)
- PY(JT)=-PY(3)
- GAM(JT)=GAM(3)
- IF(IN(3).NE.IN(3*JT+3)) THEN
- DO 1060 J=1,4
- P(IN(3*JT+3),J)=P(IN(3),J)
- P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
- 1060 CONTINUE
- ENDIF
- DO 1070 JQ=1,2
- IN(3*JT+JQ)=IN(JQ)
- P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
- P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
- 1070 CONTINUE
- IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
- &IBARRK(JT)=0
- GOTO 870
-
-C...Final hadron: side, flavour, hadron, mass.
- 1080 I=I+1
- K(I,1)=1
- K(I,3)=IE(JR)
- K(I,4)=0
- K(I,5)=0
- CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
- IF(K(I,2).EQ.0) GOTO 710
- IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
- &IBARRK(JT)=0
- IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
- &K(I,3)=IJUORI(JT)
- IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
- &K(I,3)=IJUORI(JR)
- P(I,5)=PYMASS(K(I,2))
- PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
-
-C...Final two hadrons: find common setup of four-vectors.
- JQ=1
- IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
- &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
- DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
- DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
- DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
- IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
- PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
- PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
- PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
- & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
- ENDIF
-
-C...Solve kinematics for final two hadrons, if possible.
- WREM2=2D0*DHR1*DHR2*DHC12
- FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
- IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
- IF(FD.GE.1D0) GOTO 710
- FA=WREM2+PR(JT)-PR(JR)
- FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
- PREVCF=PARJ(42)
- IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
- PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
- FB=SIGN(FB,JS*(PYR(0)-PREV))
- KFL1A=IABS(KFL(1))
- KFL2A=IABS(KFL(2))
- IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
- &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
- &4D0*WREM2*PR(JT))),DBLE(JS))
- DO 1090 J=1,4
- P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
- & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
- & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
- P(I,J)=P(N+NRS,J)-P(I-1,J)
- 1090 CONTINUE
- IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
- DM2F1=P(I-1,4)**2-P(I-1,1)**2-P(I-1,2)**2-P(I-1,3)**2-P(I-1,5)**2
- DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
- IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
- NTRYFN=NTRYFN+1
- IF(NTRYFN.LT.100) GOTO 140
- CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
- ENDIF
-
-C...Mark jets as fragmented and give daughter pointers.
- N=I-NRS+1
- DO 1100 I=NSAV+1,NSAV+NP
- IM=K(I,3)
- K(IM,1)=K(IM,1)+10
- IF(MSTU(16).NE.2) THEN
- K(IM,4)=NSAV+1
- K(IM,5)=NSAV+1
- ELSE
- K(IM,4)=NSAV+2
- K(IM,5)=N
- ENDIF
- 1100 CONTINUE
-
-C...Document string system. Move up particles.
- NSAV=NSAV+1
- K(NSAV,1)=11
- K(NSAV,2)=92
- K(NSAV,3)=IP
- K(NSAV,4)=NSAV+1
- K(NSAV,5)=N
- DO 1110 J=1,4
- P(NSAV,J)=DPS(J)
- V(NSAV,J)=V(IP,J)
- 1110 CONTINUE
- P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
- V(NSAV,5)=0D0
- DO 1130 I=NSAV+1,N
- DO 1120 J=1,5
- K(I,J)=K(I+NRS-1,J)
- P(I,J)=P(I+NRS-1,J)
- V(I,J)=0D0
- 1120 CONTINUE
- 1130 CONTINUE
- MSTU91=MSTU(90)
- DO 1140 IZ=MSTU90+1,MSTU91
- MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
- PARU9T(IZ)=PARU(90+IZ)
- 1140 CONTINUE
- MSTU(90)=MSTU90
-
-C...Order particles in rank along the chain. Update mother pointer.
- DO 1160 I=NSAV+1,N
- DO 1150 J=1,5
- K(I-NSAV+N,J)=K(I,J)
- P(I-NSAV+N,J)=P(I,J)
- 1150 CONTINUE
- 1160 CONTINUE
- I1=NSAV
- DO 1190 I=N+1,2*N-NSAV
- IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
- I1=I1+1
- DO 1170 J=1,5
- K(I1,J)=K(I,J)
- P(I1,J)=P(I,J)
- 1170 CONTINUE
- IF(MSTU(16).NE.2) K(I1,3)=NSAV
- DO 1180 IZ=MSTU90+1,MSTU91
- IF(MSTU9T(IZ).EQ.I) THEN
- MSTU(90)=MSTU(90)+1
- MSTU(90+MSTU(90))=I1
- PARU(90+MSTU(90))=PARU9T(IZ)
- ENDIF
- 1180 CONTINUE
- 1190 CONTINUE
- DO 1220 I=2*N-NSAV,N+1,-1
- IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
- I1=I1+1
- DO 1200 J=1,5
- K(I1,J)=K(I,J)
- P(I1,J)=P(I,J)
- 1200 CONTINUE
- IF(MSTU(16).NE.2) K(I1,3)=NSAV
- DO 1210 IZ=MSTU90+1,MSTU91
- IF(MSTU9T(IZ).EQ.I) THEN
- MSTU(90)=MSTU(90)+1
- MSTU(90+MSTU(90))=I1
- PARU(90+MSTU(90))=PARU9T(IZ)
- ENDIF
- 1210 CONTINUE
- 1220 CONTINUE
-
-C...Boost back particle system. Set production vertices.
- IF(MBST.EQ.0) THEN
- MSTU(33)=1
- CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
- & DPS(3)/DPS(4))
- ELSE
- DO 1230 I=NSAV+1,N
- HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
- IF(P(I,3).GT.0D0) THEN
- HHPEZ=(P(I,4)+P(I,3))*HHBZ
- P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
- P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
- ELSE
- HHPEZ=(P(I,4)-P(I,3))/HHBZ
- P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
- P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
- ENDIF
- 1230 CONTINUE
- ENDIF
- DO 1250 I=NSAV+1,N
- DO 1240 J=1,4
- V(I,J)=V(IP,J)
- 1240 CONTINUE
- 1250 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYJURF
-C...From three given input vectors in PJU the boost VJU from
-C...the "lab frame" to the junction rest frame is constructed.
-
- SUBROUTINE PYJURF(PJU,VJU)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-
-C...Input, output and local arrays.
- DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
- DATA TWOPI/6.283186D0/
-
-C...Calculate masses and other invariants.
- DO 100 J=1,4
- PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
- 100 CONTINUE
- PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
- PSUM(5)=SQRT(PSUM2)
- DO 120 I=1,3
- DO 110 J=1,3
- A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
- & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
- 110 CONTINUE
- 120 CONTINUE
-
-C...Pick I to be most massive parton and J to be the one closest to I.
- ITRY=0
- I=1
- IF(A(2,2).GT.A(1,1)) I=2
- IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
- 130 ITRY=ITRY+1
- J=1+MOD(I,3)
- K=1+MOD(J,3)
- IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
- K=1+MOD(I,3)
- J=1+MOD(K,3)
- ENDIF
- PMI2=A(I,I)
- PMJ2=A(J,J)
- PMK2=A(K,K)
- AIJ=A(I,J)
- AIK=A(I,K)
- AJK=A(J,K)
-
-C...Trivial find new parton energies if all three partons are massless.
- IF(PMI2.LT.1D-4) THEN
- PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
- PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
- PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
-
-C...Else find momentum range for parton I and values at extremes.
- ELSE
- PAIMIN=0D0
- PEIMIN=SQRT(PMI2)
- PEJMIN=AIJ/PEIMIN
- PEKMIN=AIK/PEIMIN
- PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
- PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
- FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
- PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
- IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
- PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
- HI=PEIMAX**2-0.25D0*PAIMAX**2
- PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
- & 0.5D0*PAIMAX*AIJ)/HI
- PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
- & 0.5D0*PAIMAX*AIK)/HI
- PEJMAX=SQRT(PAJMAX**2+PMJ2)
- PEKMAX=SQRT(PAKMAX**2+PMK2)
- FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
-
-C...If unexpected values at upper endpoint then pick another parton.
- IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
- I1=1+MOD(I,3)
- IF(A(I1,I1).GE.1D-4) THEN
- I=I1
- GOTO 130
- ENDIF
- ITRY=ITRY+1
- I1=1+MOD(I,3)
- IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
- I=I1
- GOTO 130
- ENDIF
- ENDIF
-
-C..Start binary + linear search to find solution inside range.
- ITER=0
- ITMIN=0
- ITMAX=0
- PAI=0.5D0*(PAIMIN+PAIMAX)
- 140 ITER=ITER+1
-
-C...Derive momentum of other two partons and distance to root.
- PEI=SQRT(PAI**2+PMI2)
- HI=PEI**2-0.25D0*PAI**2
- PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
- PEJ=SQRT(PAJ**2+PMJ2)
- PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
- PEK=SQRT(PAK**2+PMK2)
- FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
-
-C...Pick next I momentum to explore, hopefully closer to root.
- IF(FNOW.GT.0D0) THEN
- PAIMIN=PAI
- FMIN=FNOW
- ITMIN=ITMIN+1
- ELSE
- PAIMAX=PAI
- FMAX=FNOW
- ITMAX=ITMAX+1
- ENDIF
- IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
- & THEN
- PAI=0.5D0*(PAIMIN+PAIMAX)
- GOTO 140
- ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
- & ABS(FNOW).GT.1D-12*PSUM2) THEN
- PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
- GOTO 140
- ENDIF
- ENDIF
-
-C...Now know energies in junction rest frame.
- PENEW(I)=PEI
- PENEW(J)=PEJ
- PENEW(K)=PEK
-
-C...Boost (copy of) partons to their rest frame.
- VXCM=-PSUM(1)/PSUM(5)
- VYCM=-PSUM(2)/PSUM(5)
- VZCM=-PSUM(3)/PSUM(5)
- GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
- DO 150 I=1,3
- FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
- FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
- PCM(I,1)=PJU(I,1)+FAC2*VXCM
- PCM(I,2)=PJU(I,2)+FAC2*VYCM
- PCM(I,3)=PJU(I,3)+FAC2*VZCM
- PCM(I,4)=PJU(I,4)*GAMCM+FAC1
- PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
- 150 CONTINUE
-
-C...Construct difference vectors and boost to junction rest frame.
- DO 160 J=1,3
- PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
- PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
- 160 CONTINUE
- PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
- PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
- PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
- PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
- PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
- C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
- C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
- VXJU=C4*PCM(4,1)+C5*PCM(5,1)
- VYJU=C4*PCM(4,2)+C5*PCM(5,2)
- VZJU=C4*PCM(4,3)+C5*PCM(5,3)
- GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
-
-C...Add two boosts, giving final result.
- FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
- VJU(1)=VXJU+FCM*VXCM
- VJU(2)=VYJU+FCM*VYCM
- VJU(3)=VZJU+FCM*VZCM
- VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
- VJU(5)=1D0
-
-C...In case of error in reconstruction: revert to CM frame of system.
- CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
- &(PCM(1,5)*PCM(2,5))
- CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
- &(PCM(1,5)*PCM(3,5))
- CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
- &(PCM(2,5)*PCM(3,5))
- ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
- ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
- DO 170 I=1,3
- FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
- FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
- PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
- PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
- PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
- PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
- PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
- 170 CONTINUE
- CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
- &(PCM(1,5)*PCM(2,5))
- CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
- &(PCM(1,5)*PCM(3,5))
- CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
- &(PCM(2,5)*PCM(3,5))
- ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
- ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
- IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
- VJU(1)=VXCM
- VJU(2)=VYCM
- VJU(3)=VZCM
- VJU(4)=GAMCM
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYINDF
-C...Handles the fragmentation of a jet system (or a single
-C...jet) according to independent fragmentation models.
-
- SUBROUTINE PYINDF(IP)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-C...Local arrays.
- DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
- &KFLO(2),PXO(2),PYO(2),WO(2)
-
-C.. MOPS error message
- IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
- &' are not treated as expected in independent fragmentation')
-
-C...Reset counters. Identify parton system and take copy. Check flavour.
- NSAV=N
- MSTU90=MSTU(90)
- NJET=0
- KQSUM=0
- DO 100 J=1,5
- DPS(J)=0D0
- 100 CONTINUE
- I=IP-1
- 110 I=I+1
- IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
- CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0) GOTO 110
- KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
- IF(KQ.EQ.0) GOTO 110
- NJET=NJET+1
- IF(KQ.NE.2) KQSUM=KQSUM+KQ
- DO 120 J=1,5
- K(NSAV+NJET,J)=K(I,J)
- P(NSAV+NJET,J)=P(I,J)
- DPS(J)=DPS(J)+P(I,J)
- 120 CONTINUE
- K(NSAV+NJET,3)=I
- IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
- &K(I+1,1).EQ.2)) GOTO 110
- IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
- CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
-
-C...Boost copied system to CM frame. Find CM energy and sum flavours.
- IF(NJET.NE.1) THEN
- MSTU(33)=1
- CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
- & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
- ENDIF
- PECM=0D0
- DO 130 J=1,3
- NFI(J)=0
- 130 CONTINUE
- DO 140 I=NSAV+1,NSAV+NJET
- PECM=PECM+P(I,4)
- KFA=IABS(K(I,2))
- IF(KFA.LE.3) THEN
- NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
- ELSEIF(KFA.GT.1000) THEN
- KFLA=MOD(KFA/1000,10)
- KFLB=MOD(KFA/100,10)
- IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
- IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
- ENDIF
- 140 CONTINUE
-
-C...Loop over attempts made. Reset counters.
- NTRY=0
- 150 NTRY=NTRY+1
- IF(NTRY.GT.200) THEN
- CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- N=NSAV+NJET
- MSTU(90)=MSTU90
- DO 160 J=1,3
- NFL(J)=NFI(J)
- IFET(J)=0
- KFLF(J)=0
- 160 CONTINUE
-
-C...Loop over jets to be fragmented.
- DO 230 IP1=NSAV+1,NSAV+NJET
- MSTJ(91)=0
- NSAV1=N
- MSTU91=MSTU(90)
-
-C...Initial flavour and momentum values. Jet along +z axis.
- KFLH=IABS(K(IP1,2))
- IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
- KFLO(2)=0
- WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
-
-C...Initial values for quark or diquark jet.
- 170 IF(IABS(K(IP1,2)).NE.21) THEN
- NSTR=1
- KFLO(1)=K(IP1,2)
- CALL PYPTDI(0,PXO(1),PYO(1))
- WO(1)=WF
-
-C...Initial values for gluon treated like random quark jet.
- ELSEIF(MSTJ(2).LE.2) THEN
- NSTR=1
- IF(MSTJ(2).EQ.2) MSTJ(91)=1
- KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
- CALL PYPTDI(0,PXO(1),PYO(1))
- WO(1)=WF
-
-C...Initial values for gluon treated like quark-antiquark jet pair,
-C...sharing energy according to Altarelli-Parisi splitting function.
- ELSE
- NSTR=2
- IF(MSTJ(2).EQ.4) MSTJ(91)=1
- KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
- KFLO(2)=-KFLO(1)
- CALL PYPTDI(0,PXO(1),PYO(1))
- PXO(2)=-PXO(1)
- PYO(2)=-PYO(1)
- WO(1)=WF*PYR(0)**(1D0/3D0)
- WO(2)=WF-WO(1)
- ENDIF
-
-C...Initial values for rank, flavour, pT and W+.
- DO 220 ISTR=1,NSTR
- 180 I=N
- MSTU(90)=MSTU91
- IRANK=0
- KFL1=KFLO(ISTR)
- PX1=PXO(ISTR)
- PY1=PYO(ISTR)
- W=WO(ISTR)
-
-C...New hadron. Generate flavour and hadron species.
- 190 I=I+1
- IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
- CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- IRANK=IRANK+1
- K(I,1)=1
- K(I,3)=IP1
- K(I,4)=0
- K(I,5)=0
- 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
- IF(K(I,2).EQ.0) GOTO 180
- IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
- IF(PYR(0).GT.PARJ(19)) GOTO 200
- ENDIF
-
-C...Find hadron mass. Generate four-momentum.
- P(I,5)=PYMASS(K(I,2))
- CALL PYPTDI(KFL1,PX2,PY2)
- P(I,1)=PX1+PX2
- P(I,2)=PY1+PY2
- PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
- CALL PYZDIS(KFL1,KFL2,PR,Z)
- MZSAV=0
- IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
- MZSAV=1
- MSTU(90)=MSTU(90)+1
- MSTU(90+MSTU(90))=I
- PARU(90+MSTU(90))=Z
- ENDIF
- P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
- P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
- IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
- & P(I,3).LE.0.001D0) THEN
- IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
- P(I,3)=0.0001D0
- P(I,4)=SQRT(PR)
- Z=P(I,4)/W
- ENDIF
-
-C...Remaining flavour and momentum.
- KFL1=-KFL2
- PX1=-PX2
- PY1=-PY2
- W=(1D0-Z)*W
- DO 210 J=1,5
- V(I,J)=0D0
- 210 CONTINUE
-
-C...Check if pL acceptable. Go back for new hadron if enough energy.
- IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
- I=I-1
- IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
- ENDIF
- IF(W.GT.PARJ(31)) GOTO 190
- N=I
- 220 CONTINUE
- IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
- IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
-
-C...Rotate jet to new direction.
- THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
- PHI=PYANGL(P(IP1,1),P(IP1,2))
- MSTU(33)=1
- CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
- K(K(IP1,3),4)=NSAV1+1
- K(K(IP1,3),5)=N
-
-C...End of jet generation loop. Skip conservation in some cases.
- 230 CONTINUE
- IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
- IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
-
-C...Subtract off produced hadron flavours, finished if zero.
- DO 240 I=NSAV+NJET+1,N
- KFA=IABS(K(I,2))
- KFLA=MOD(KFA/1000,10)
- KFLB=MOD(KFA/100,10)
- KFLC=MOD(KFA/10,10)
- IF(KFLA.EQ.0) THEN
- IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
- IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
- ELSE
- IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
- IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
- IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
- ENDIF
- 240 CONTINUE
- NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
- &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
- IF(NREQ.EQ.0) GOTO 320
-
-C...Take away flavour of low-momentum particles until enough freedom.
- NREM=0
- 250 IREM=0
- P2MIN=PECM**2
- DO 260 I=NSAV+NJET+1,N
- P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
- IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
- IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
- 260 CONTINUE
- IF(IREM.EQ.0) GOTO 150
- K(IREM,1)=7
- KFA=IABS(K(IREM,2))
- KFLA=MOD(KFA/1000,10)
- KFLB=MOD(KFA/100,10)
- KFLC=MOD(KFA/10,10)
- IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
- IF(K(IREM,1).EQ.8) GOTO 250
- IF(KFLA.EQ.0) THEN
- ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
- IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
- IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
- ELSE
- IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
- IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
- IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
- ENDIF
- NREM=NREM+1
- NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
- &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
- IF(NREQ.GT.NREM) GOTO 250
- DO 270 I=NSAV+NJET+1,N
- IF(K(I,1).EQ.8) K(I,1)=1
- 270 CONTINUE
-
-C...Find combination of existing and new flavours for hadron.
- 280 NFET=2
- IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
- IF(NREQ.LT.NREM) NFET=1
- IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
- DO 290 J=1,NFET
- IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
- KFLF(J)=ISIGN(1,NFL(1))
- IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
- IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
- 290 CONTINUE
- IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
- &GOTO 280
- IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
- &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
- &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
- IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
- IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
- IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
- IF(NFET.LE.2) KFLF(3)=0
- IF(KFLF(3).NE.0) THEN
- KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
- & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
- IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
- & KFLFC=KFLFC+ISIGN(2,KFLFC)
- ELSE
- KFLFC=KFLF(1)
- ENDIF
- CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
- IF(KF.EQ.0) GOTO 280
- DO 300 J=1,MAX(2,NFET)
- NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
- 300 CONTINUE
-
-C...Store hadron at random among free positions.
- NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
- DO 310 I=NSAV+NJET+1,N
- IF(K(I,1).EQ.7) NPOS=NPOS-1
- IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
- K(I,1)=1
- K(I,2)=KF
- P(I,5)=PYMASS(K(I,2))
- P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
- 310 CONTINUE
- NREM=NREM-1
- NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
- &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
- IF(NREM.GT.0) GOTO 280
-
-C...Compensate for missing momentum in global scheme (3 options).
- 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
- DO 340 J=1,3
- PSI(J)=0D0
- DO 330 I=NSAV+NJET+1,N
- PSI(J)=PSI(J)+P(I,J)
- 330 CONTINUE
- 340 CONTINUE
- PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
- PWS=0D0
- DO 350 I=NSAV+NJET+1,N
- IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
- IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
- & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
- IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
- 350 CONTINUE
- DO 370 I=NSAV+NJET+1,N
- IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
- IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
- & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
- IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
- DO 360 J=1,3
- P(I,J)=P(I,J)-PSI(J)*PW/PWS
- 360 CONTINUE
- P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
- 370 CONTINUE
-
-C...Compensate for missing momentum withing each jet separately.
- ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
- DO 390 I=N+1,N+NJET
- K(I,1)=0
- DO 380 J=1,5
- P(I,J)=0D0
- 380 CONTINUE
- 390 CONTINUE
- DO 410 I=NSAV+NJET+1,N
- IR1=K(I,3)
- IR2=N+IR1-NSAV
- K(IR2,1)=K(IR2,1)+1
- PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
- & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
- DO 400 J=1,3
- P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
- 400 CONTINUE
- P(IR2,4)=P(IR2,4)+P(I,4)
- P(IR2,5)=P(IR2,5)+PLS
- 410 CONTINUE
- PSS=0D0
- DO 420 I=N+1,N+NJET
- IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
- 420 CONTINUE
- DO 440 I=NSAV+NJET+1,N
- IR1=K(I,3)
- IR2=N+IR1-NSAV
- PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
- & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
- DO 430 J=1,3
- P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
- & PLS*P(IR1,J)
- 430 CONTINUE
- P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
- 440 CONTINUE
- ENDIF
-
-C...Scale momenta for energy conservation.
- IF(MOD(MSTJ(3),5).NE.0) THEN
- PMS=0D0
- PES=0D0
- PQS=0D0
- DO 450 I=NSAV+NJET+1,N
- PMS=PMS+P(I,5)
- PES=PES+P(I,4)
- PQS=PQS+P(I,5)**2/P(I,4)
- 450 CONTINUE
- IF(PMS.GE.PECM) GOTO 150
- NECO=0
- 460 NECO=NECO+1
- PFAC=(PECM-PQS)/(PES-PQS)
- PES=0D0
- PQS=0D0
- DO 480 I=NSAV+NJET+1,N
- DO 470 J=1,3
- P(I,J)=PFAC*P(I,J)
- 470 CONTINUE
- P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
- PES=PES+P(I,4)
- PQS=PQS+P(I,5)**2/P(I,4)
- 480 CONTINUE
- IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
- ENDIF
-
-C...Origin of produced particles and parton daughter pointers.
- 490 DO 500 I=NSAV+NJET+1,N
- IF(MSTU(16).NE.2) K(I,3)=NSAV+1
- IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
- 500 CONTINUE
- DO 510 I=NSAV+1,NSAV+NJET
- I1=K(I,3)
- K(I1,1)=K(I1,1)+10
- IF(MSTU(16).NE.2) THEN
- K(I1,4)=NSAV+1
- K(I1,5)=NSAV+1
- ELSE
- K(I1,4)=K(I1,4)-NJET+1
- K(I1,5)=K(I1,5)-NJET+1
- IF(K(I1,5).LT.K(I1,4)) THEN
- K(I1,4)=0
- K(I1,5)=0
- ENDIF
- ENDIF
- 510 CONTINUE
-
-C...Document independent fragmentation system. Remove copy of jets.
- NSAV=NSAV+1
- K(NSAV,1)=11
- K(NSAV,2)=93
- K(NSAV,3)=IP
- K(NSAV,4)=NSAV+1
- K(NSAV,5)=N-NJET+1
- DO 520 J=1,4
- P(NSAV,J)=DPS(J)
- V(NSAV,J)=V(IP,J)
- 520 CONTINUE
- P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
- V(NSAV,5)=0D0
- DO 540 I=NSAV+NJET,N
- DO 530 J=1,5
- K(I-NJET+1,J)=K(I,J)
- P(I-NJET+1,J)=P(I,J)
- V(I-NJET+1,J)=V(I,J)
- 530 CONTINUE
- 540 CONTINUE
- N=N-NJET+1
- DO 550 IZ=MSTU90+1,MSTU(90)
- MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
- 550 CONTINUE
-
-C...Boost back particle system. Set production vertices.
- IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
- &DPS(2)/DPS(4),DPS(3)/DPS(4))
- DO 570 I=NSAV+1,N
- DO 560 J=1,4
- V(I,J)=V(IP,J)
- 560 CONTINUE
- 570 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYDECY
-C...Handles the decay of unstable particles.
-
- SUBROUTINE PYDECY(IP)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
-C...Local arrays.
- DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
- &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
- CHARACTER CIDC*4
- DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
-
-C...Functions: momentum in two-particle decays and four-product.
- PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
- FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
-
-C...Initial values.
- NTRY=0
- NSAV=N
- KFA=IABS(K(IP,2))
- KFS=ISIGN(1,K(IP,2))
- KC=PYCOMP(KFA)
- MSTJ(92)=0
-
-C...Choose lifetime and determine decay vertex.
- IF(K(IP,1).EQ.5) THEN
- V(IP,5)=0D0
- ELSEIF(K(IP,1).NE.4) THEN
- V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
- ENDIF
- DO 100 J=1,4
- VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
- 100 CONTINUE
-
-C...Determine whether decay allowed or not.
- MOUT=0
- IF(MSTJ(22).EQ.2) THEN
- IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
- ELSEIF(MSTJ(22).EQ.3) THEN
- IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
- ELSEIF(MSTJ(22).EQ.4) THEN
- IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
- IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
- ENDIF
- IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
- K(IP,1)=4
- RETURN
- ENDIF
-
-C...Interface to external tau decay library (for tau polarization).
- IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
-
-C...Starting values for pointers and momenta.
- ITAU=IP
- DO 110 J=1,4
- PTAU(J)=P(ITAU,J)
- PCMTAU(J)=P(ITAU,J)
- 110 CONTINUE
-
-C...Iterate to find position and code of mother of tau.
- IMTAU=ITAU
- 120 IMTAU=K(IMTAU,3)
-
- IF(IMTAU.EQ.0) THEN
-C...If no known origin then impossible to do anything further.
- KFORIG=0
- IORIG=0
-
- ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
-C...If tau -> tau + gamma then add gamma energy and loop.
- IF(K(K(IMTAU,4),2).EQ.22) THEN
- DO 130 J=1,4
- PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
- 130 CONTINUE
- ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
- DO 140 J=1,4
- PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
- 140 CONTINUE
- ENDIF
- GOTO 120
-
- ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
-C...If coming from weak decay of hadron then W is not stored in record,
-C...but can be reconstructed by adding neutrino momentum.
- KFORIG=-ISIGN(24,K(ITAU,2))
- IORIG=0
- DO 160 II=K(IMTAU,4),K(IMTAU,5)
- IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
- DO 150 J=1,4
- PCMTAU(J)=PCMTAU(J)+P(II,J)
- 150 CONTINUE
- ENDIF
- 160 CONTINUE
-
- ELSE
-C...If coming from resonance decay then find latest copy of this
-C...resonance (may not completely agree).
- KFORIG=K(IMTAU,2)
- IORIG=IMTAU
- DO 170 II=IMTAU+1,IP-1
- IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
- & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
- 170 CONTINUE
- DO 180 J=1,4
- PCMTAU(J)=P(IORIG,J)
- 180 CONTINUE
- ENDIF
-
-C...Boost tau to rest frame of production process (where known)
-C...and rotate it to sit along +z axis.
- DO 190 J=1,3
- DBETAU(J)=PCMTAU(J)/PCMTAU(4)
- 190 CONTINUE
- IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
- & -DBETAU(2),-DBETAU(3))
- PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
- CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
- THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
- CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
-
-C...Call tau decay routine (if meaningful) and fill extra info.
- IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
- CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
- DO 200 II=NSAV+1,NSAV+NDECAY
- K(II,1)=1
- K(II,3)=IP
- K(II,4)=0
- K(II,5)=0
- 200 CONTINUE
- N=NSAV+NDECAY
- ENDIF
-
-C...Boost back decay tau and decay products.
- DO 210 J=1,4
- P(ITAU,J)=PTAU(J)
- 210 CONTINUE
- IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
- CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
- IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
- & DBETAU(2),DBETAU(3))
-
-C...Skip past ordinary tau decay treatment.
- MMAT=0
- MBST=0
- ND=0
- GOTO 630
- ENDIF
- ENDIF
-
-C...B-Bbar mixing: flip sign of meson appropriately.
- MMIX=0
- IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
- XBBMIX=PARJ(76)
- IF(KFA.EQ.531) XBBMIX=PARJ(77)
- IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
- IF(MMIX.EQ.1) KFS=-KFS
- ENDIF
-
-C...Check existence of decay channels. Particle/antiparticle rules.
- KCA=KC
- IF(MDCY(KC,2).GT.0) THEN
- MDMDCY=MDME(MDCY(KC,2),2)
- IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
- ENDIF
- IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
- CALL PYERRM(9,'(PYDECY:) no decay channel defined')
- RETURN
- ENDIF
- IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
- IF(KCHG(KC,3).EQ.0) THEN
- KFSP=1
- KFSN=0
- IF(PYR(0).GT.0.5D0) KFS=-KFS
- ELSEIF(KFS.GT.0) THEN
- KFSP=1
- KFSN=0
- ELSE
- KFSP=0
- KFSN=1
- ENDIF
-
-C...Sum branching ratios of allowed decay channels.
- 220 NOPE=0
- BRSU=0D0
- DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
- IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
- & KFSN*MDME(IDL,1).NE.3) GOTO 230
- IF(MDME(IDL,2).GT.100) GOTO 230
- NOPE=NOPE+1
- BRSU=BRSU+BRAT(IDL)
- 230 CONTINUE
- IF(NOPE.EQ.0) THEN
- CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
- RETURN
- ENDIF
-
-C...Select decay channel among allowed ones.
- 240 RBR=BRSU*PYR(0)
- IDL=MDCY(KCA,2)-1
- 250 IDL=IDL+1
- IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
- &KFSN*MDME(IDL,1).NE.3) THEN
- IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
- ELSEIF(MDME(IDL,2).GT.100) THEN
- IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
- ELSE
- IDC=IDL
- RBR=RBR-BRAT(IDL)
- IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
- ENDIF
-
-C...Start readout of decay channel: matrix element, reset counters.
- MMAT=MDME(IDC,2)
- 260 NTRY=NTRY+1
- IF(MOD(NTRY,200).EQ.0) THEN
- WRITE(CIDC,'(I4)') IDC
-C...Do not print warning for some well-known special cases.
- IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
- & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
- & CIDC)
- GOTO 240
- ENDIF
- IF(NTRY.GT.1000) THEN
- CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- I=N
- NP=0
- NQ=0
- MBST=0
- IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
- DO 270 J=1,4
- PV(1,J)=0D0
- IF(MBST.EQ.0) PV(1,J)=P(IP,J)
- 270 CONTINUE
- IF(MBST.EQ.1) PV(1,4)=P(IP,5)
- PV(1,5)=P(IP,5)
- PS=0D0
- PSQ=0D0
- MREM=0
- MHADDY=0
- IF(KFA.GT.80) MHADDY=1
-C.. Random flavour and popcorn system memory.
- IRNDMO=0
- JTMO=0
- MSTU(121)=0
- MSTU(125)=10
-
-C...Read out decay products. Convert to standard flavour code.
- JTMAX=5
- IF(MDME(IDC+1,2).EQ.101) JTMAX=10
- DO 280 JT=1,JTMAX
- IF(JT.LE.5) KP=KFDP(IDC,JT)
- IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
- IF(KP.EQ.0) GOTO 280
- KPA=IABS(KP)
- KCP=PYCOMP(KPA)
- IF(KPA.GT.80) MHADDY=1
- IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
- KFP=KP
- ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
- KFP=KFS*KP
- ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
- KFP=-KFS*MOD(KFA/10,10)
- ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
- KFP=KFS*(100*MOD(KFA/10,100)+3)
- ELSEIF(KPA.EQ.81) THEN
- KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
- ELSEIF(KP.EQ.82) THEN
- CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
- IF(KFP.EQ.0) GOTO 260
- KFP=-KFP
- IRNDMO=1
- MSTJ(93)=1
- IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
- ELSEIF(KP.EQ.-82) THEN
- KFP=MSTU(124)
- ENDIF
- IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
-
-C...Add decay product to event record or to quark flavour list.
- KFPA=IABS(KFP)
- KQP=KCHG(KCP,2)
- IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
- NQ=NQ+1
- KFLO(NQ)=KFP
-C...set rndmflav popcorn system pointer
- IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
- MSTJ(93)=2
- PSQ=PSQ+PYMASS(KFLO(NQ))
- ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
- & MOD(NQ,2).EQ.1) THEN
- NQ=NQ-1
- PS=PS-P(I,5)
- K(I,1)=1
- KFI=K(I,2)
- CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
- IF(K(I,2).EQ.0) GOTO 260
- MSTJ(93)=1
- P(I,5)=PYMASS(K(I,2))
- PS=PS+P(I,5)
- ELSE
- I=I+1
- NP=NP+1
- IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
- IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
- K(I,1)=1+MOD(NQ,2)
- IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
- IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
- K(I,2)=KFP
- K(I,3)=IP
- K(I,4)=0
- K(I,5)=0
- P(I,5)=PYMASS(KFP)
- PS=PS+P(I,5)
- ENDIF
- 280 CONTINUE
-
-C...Check masses for resonance decays.
- IF(MHADDY.EQ.0) THEN
- IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
- ENDIF
-
-C...Choose decay multiplicity in phase space model.
- 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
- PSP=PS
- CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
- IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
- 300 NTRY=NTRY+1
-C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
- IF(IRNDMO.EQ.0) THEN
- MSTU(121)=0
- JTMO=0
- ELSEIF(IRNDMO.EQ.1) THEN
- IRNDMO=2
- ELSE
- GOTO 260
- ENDIF
- IF(NTRY.GT.1000) THEN
- CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- IF(MMAT.LE.20) THEN
- GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
- & SIN(PARU(2)*PYR(0))
- ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
- IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
- IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
- IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
- IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
- ELSE
- ND=MMAT-20
- ENDIF
-C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
- MSTU(125)=ND-NQ/2
- IF(MSTU(121).GT.MSTU(125)) GOTO 300
-
-C...Form hadrons from flavour content.
- DO 310 JT=1,NQ
- KFL1(JT)=KFLO(JT)
- 310 CONTINUE
- IF(ND.EQ.NP+NQ/2) GOTO 330
- DO 320 I=N+NP+1,N+ND-NQ/2
-C.. Stick to started popcorn system, else pick side at random
- JT=JTMO
- IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
- CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
- IF(K(I,2).EQ.0) GOTO 300
- MSTU(125)=MSTU(125)-1
- JTMO=0
- IF(MSTU(121).GT.0) JTMO=JT
- KFL1(JT)=-KFL2
- 320 CONTINUE
- 330 JT=2
- JT2=3
- JT3=4
- IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
- IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
- & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
- IF(JT.EQ.3) JT2=2
- IF(JT.EQ.4) JT3=2
- CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
- IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
- IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
- IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
-
-C...Check that sum of decay product masses not too large.
- PS=PSP
- DO 340 I=N+NP+1,N+ND
- K(I,1)=1
- K(I,3)=IP
- K(I,4)=0
- K(I,5)=0
- P(I,5)=PYMASS(K(I,2))
- PS=PS+P(I,5)
- 340 CONTINUE
- IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
-
-C...Rescale energy to subtract off spectator quark mass.
- ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
- & .AND.NP.GE.3) THEN
- PS=PS-P(N+NP,5)
- PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
- DO 350 J=1,5
- P(N+NP,J)=PQT*PV(1,J)
- PV(1,J)=(1D0-PQT)*PV(1,J)
- 350 CONTINUE
- IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
- ND=NP-1
- MREM=1
-
-C...Fully specified final state: check mass broadening effects.
- ELSE
- IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
- ND=NP
- ENDIF
-
-C...Determine position of grandmother, number of sisters.
- NM=0
- KFAS=0
- MSGN=0
- IF(MMAT.EQ.3) THEN
- IM=K(IP,3)
- IF(IM.LT.0.OR.IM.GE.IP) IM=0
- IF(IM.NE.0) KFAM=IABS(K(IM,2))
- IF(IM.NE.0) THEN
- DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
- IF(K(IL,3).EQ.IM) NM=NM+1
- IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
- 360 CONTINUE
- IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
- & MOD(KFAM/1000,10).NE.0) NM=0
- IF(NM.EQ.2) THEN
- KFAS=IABS(K(ISIS,2))
- IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
- & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
- ENDIF
- ENDIF
- ENDIF
-
-C...Kinematics of one-particle decays.
- IF(ND.EQ.1) THEN
- DO 370 J=1,4
- P(N+1,J)=P(IP,J)
- 370 CONTINUE
- GOTO 630
- ENDIF
-
-C...Calculate maximum weight ND-particle decay.
- PV(ND,5)=P(N+ND,5)
- IF(ND.GE.3) THEN
- WTMAX=1D0/WTCOR(ND-2)
- PMAX=PV(1,5)-PS+P(N+ND,5)
- PMIN=0D0
- DO 380 IL=ND-1,1,-1
- PMAX=PMAX+P(N+IL,5)
- PMIN=PMIN+P(N+IL+1,5)
- WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
- 380 CONTINUE
- ENDIF
-
-C...Find virtual gamma mass in Dalitz decay.
- 390 IF(ND.EQ.2) THEN
- ELSEIF(MMAT.EQ.2) THEN
- PMES=4D0*PMAS(11,1)**2
- PMRHO2=PMAS(131,1)**2
- PGRHO2=PMAS(131,2)**2
- 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
- WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
- & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
- & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
- IF(WT.LT.PYR(0)) GOTO 400
- PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
-
-C...M-generator gives weight. If rejected, try again.
- ELSE
- 410 RORD(1)=1D0
- DO 440 IL1=2,ND-1
- RSAV=PYR(0)
- DO 420 IL2=IL1-1,1,-1
- IF(RSAV.LE.RORD(IL2)) GOTO 430
- RORD(IL2+1)=RORD(IL2)
- 420 CONTINUE
- 430 RORD(IL2+1)=RSAV
- 440 CONTINUE
- RORD(ND)=0D0
- WT=1D0
- DO 450 IL=ND-1,1,-1
- PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
- & (PV(1,5)-PS)
- WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
- 450 CONTINUE
- IF(WT.LT.PYR(0)*WTMAX) GOTO 410
- ENDIF
-
-C...Perform two-particle decays in respective CM frame.
- 460 DO 480 IL=1,ND-1
- PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
- UE(3)=2D0*PYR(0)-1D0
- PHI=PARU(2)*PYR(0)
- UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
- UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
- DO 470 J=1,3
- P(N+IL,J)=PA*UE(J)
- PV(IL+1,J)=-PA*UE(J)
- 470 CONTINUE
- P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
- PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
- 480 CONTINUE
-
-C...Lorentz transform decay products to lab frame.
- DO 490 J=1,4
- P(N+ND,J)=PV(ND,J)
- 490 CONTINUE
- DO 530 IL=ND-1,1,-1
- DO 500 J=1,3
- BE(J)=PV(IL,J)/PV(IL,4)
- 500 CONTINUE
- GA=PV(IL,4)/PV(IL,5)
- DO 520 I=N+IL,N+ND
- BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
- DO 510 J=1,3
- P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
- 510 CONTINUE
- P(I,4)=GA*(P(I,4)+BEP)
- 520 CONTINUE
- 530 CONTINUE
-
-C...Check that no infinite loop in matrix element weight.
- NTRY=NTRY+1
- IF(NTRY.GT.800) GOTO 560
-
-C...Matrix elements for omega and phi decays.
- IF(MMAT.EQ.1) THEN
- WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
- & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
- & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
- IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
-
-C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
- ELSEIF(MMAT.EQ.2) THEN
- FOUR12=FOUR(N+1,N+2)
- FOUR13=FOUR(N+1,N+3)
- WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
- & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
- IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
-
-C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
-C...V vector), of form cos**2(theta02) in V1 rest frame, and for
-C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
- ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
- FOUR10=FOUR(IP,IM)
- FOUR12=FOUR(IP,N+1)
- FOUR02=FOUR(IM,N+1)
- PMS1=P(IP,5)**2
- PMS0=P(IM,5)**2
- PMS2=P(N+1,5)**2
- IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
- IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
- & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
- HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
- HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
- IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
-
-C...Matrix element for "onium" -> g + g + g or gamma + g + g.
- ELSEIF(MMAT.EQ.4) THEN
- HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
- HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
- HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
- WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
- & ((1D0-HX3)/(HX1*HX2))**2
- IF(WT.LT.2D0*PYR(0)) GOTO 390
- IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
- & GOTO 390
-
-C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
- ELSEIF(MMAT.EQ.41) THEN
- IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
- IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
- HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
- IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
-
-C...Matrix elements for weak decays (only semileptonic for c and b)
- ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
- & .AND.ND.EQ.3) THEN
- IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
- IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
- IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
- ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
- DO 550 J=1,4
- P(N+NP+1,J)=0D0
- DO 540 IS=N+3,N+NP
- P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
- 540 CONTINUE
- 550 CONTINUE
- IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
- IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
- IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
- ENDIF
-
-C...Scale back energy and reattach spectator.
- 560 IF(MREM.EQ.1) THEN
- DO 570 J=1,5
- PV(1,J)=PV(1,J)/(1D0-PQT)
- 570 CONTINUE
- ND=ND+1
- MREM=0
- ENDIF
-
-C...Low invariant mass for system with spectator quark gives particle,
-C...not two jets. Readjust momenta accordingly.
- IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
- MSTJ(93)=1
- PM2=PYMASS(K(N+2,2))
- MSTJ(93)=1
- PM3=PYMASS(K(N+3,2))
- IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
- & (PARJ(32)+PM2+PM3)**2) GOTO 630
- K(N+2,1)=1
- KFTEMP=K(N+2,2)
- CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
- IF(K(N+2,2).EQ.0) GOTO 260
- P(N+2,5)=PYMASS(K(N+2,2))
- PS=P(N+1,5)+P(N+2,5)
- PV(2,5)=P(N+2,5)
- MMAT=0
- ND=2
- GOTO 460
- ELSEIF(MMAT.EQ.44) THEN
- MSTJ(93)=1
- PM3=PYMASS(K(N+3,2))
- MSTJ(93)=1
- PM4=PYMASS(K(N+4,2))
- IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
- & (PARJ(32)+PM3+PM4)**2) GOTO 600
- K(N+3,1)=1
- KFTEMP=K(N+3,2)
- CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
- IF(K(N+3,2).EQ.0) GOTO 260
- P(N+3,5)=PYMASS(K(N+3,2))
- DO 580 J=1,3
- P(N+3,J)=P(N+3,J)+P(N+4,J)
- 580 CONTINUE
- P(N+3,4)=SQRT(P(N+3,1)**2+P(N+3,2)**2+P(N+3,3)**2+P(N+3,5)**2)
- HA=P(N+1,4)**2-P(N+2,4)**2
- HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
- HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
- & (P(N+1,3)-P(N+2,3))**2
- HD=(PV(1,4)-P(N+3,4))**2
- HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
- HF=HD*HC-HB**2
- HG=HD*HC-HA*HB
- HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
- DO 590 J=1,3
- PCOR=HH*(P(N+1,J)-P(N+2,J))
- P(N+1,J)=P(N+1,J)+PCOR
- P(N+2,J)=P(N+2,J)-PCOR
- 590 CONTINUE
- P(N+1,4)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2+P(N+1,5)**2)
- P(N+2,4)=SQRT(P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2+P(N+2,5)**2)
- ND=ND-1
- ENDIF
-
-C...Check invariant mass of W jets. May give one particle or start over.
- 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
- &.AND.IABS(K(N+1,2)).LT.10) THEN
- PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
- MSTJ(93)=1
- PM1=PYMASS(K(N+1,2))
- MSTJ(93)=1
- PM2=PYMASS(K(N+2,2))
- IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
- KFLDUM=INT(1.5D0+PYR(0))
- CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
- CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
- IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
- PSM=PYMASS(KF1)+PYMASS(KF2)
- IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
- IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
- IF(MMAT.EQ.48) GOTO 390
- IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
- K(N+1,1)=1
- KFTEMP=K(N+1,2)
- CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
- IF(K(N+1,2).EQ.0) GOTO 260
- P(N+1,5)=PYMASS(K(N+1,2))
- K(N+2,2)=K(N+3,2)
- P(N+2,5)=P(N+3,5)
- PS=P(N+1,5)+P(N+2,5)
- IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
- PV(2,5)=P(N+3,5)
- MMAT=0
- ND=2
- GOTO 460
- ENDIF
-
-C...Phase space decay of partons from W decay.
- 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
- KFLO(1)=K(N+1,2)
- KFLO(2)=K(N+2,2)
- K(N+1,1)=K(N+3,1)
- K(N+1,2)=K(N+3,2)
- DO 620 J=1,5
- PV(1,J)=P(N+1,J)+P(N+2,J)
- P(N+1,J)=P(N+3,J)
- 620 CONTINUE
- PV(1,5)=PMR
- N=N+1
- NP=0
- NQ=2
- PS=0D0
- MSTJ(93)=2
- PSQ=PYMASS(KFLO(1))
- MSTJ(93)=2
- PSQ=PSQ+PYMASS(KFLO(2))
- MMAT=11
- GOTO 290
- ENDIF
-
-C...Boost back for rapidly moving particle.
- 630 N=N+ND
- IF(MBST.EQ.1) THEN
- DO 640 J=1,3
- BE(J)=P(IP,J)/P(IP,4)
- 640 CONTINUE
- GA=P(IP,4)/P(IP,5)
- DO 660 I=NSAV+1,N
- BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
- DO 650 J=1,3
- P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
- 650 CONTINUE
- P(I,4)=GA*(P(I,4)+BEP)
- 660 CONTINUE
- ENDIF
-
-C...Fill in position of decay vertex.
- DO 680 I=NSAV+1,N
- DO 670 J=1,4
- V(I,J)=VDCY(J)
- 670 CONTINUE
- V(I,5)=0D0
- 680 CONTINUE
-
-C...Set up for parton shower evolution from jets.
- IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
- K(NSAV+1,1)=3
- K(NSAV+2,1)=3
- K(NSAV+3,1)=3
- K(NSAV+1,4)=MSTU(5)*(NSAV+2)
- K(NSAV+1,5)=MSTU(5)*(NSAV+3)
- K(NSAV+2,4)=MSTU(5)*(NSAV+3)
- K(NSAV+2,5)=MSTU(5)*(NSAV+1)
- K(NSAV+3,4)=MSTU(5)*(NSAV+1)
- K(NSAV+3,5)=MSTU(5)*(NSAV+2)
- MSTJ(92)=-(NSAV+1)
- ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
- K(NSAV+2,1)=3
- K(NSAV+3,1)=3
- K(NSAV+2,4)=MSTU(5)*(NSAV+3)
- K(NSAV+2,5)=MSTU(5)*(NSAV+3)
- K(NSAV+3,4)=MSTU(5)*(NSAV+2)
- K(NSAV+3,5)=MSTU(5)*(NSAV+2)
- MSTJ(92)=NSAV+2
- ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
- & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
- K(NSAV+1,1)=3
- K(NSAV+2,1)=3
- K(NSAV+1,4)=MSTU(5)*(NSAV+2)
- K(NSAV+1,5)=MSTU(5)*(NSAV+2)
- K(NSAV+2,4)=MSTU(5)*(NSAV+1)
- K(NSAV+2,5)=MSTU(5)*(NSAV+1)
- MSTJ(92)=NSAV+1
- ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
- & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
- MSTJ(92)=NSAV+1
- ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
- & THEN
- K(NSAV+1,1)=3
- K(NSAV+2,1)=3
- K(NSAV+3,1)=3
- KCP=PYCOMP(K(NSAV+1,2))
- KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
- JCON=4
- IF(KQP.LT.0) JCON=5
- K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
- K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
- K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
- K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
- MSTJ(92)=NSAV+1
- ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
- K(NSAV+1,1)=3
- K(NSAV+3,1)=3
- K(NSAV+1,4)=MSTU(5)*(NSAV+3)
- K(NSAV+1,5)=MSTU(5)*(NSAV+3)
- K(NSAV+3,4)=MSTU(5)*(NSAV+1)
- K(NSAV+3,5)=MSTU(5)*(NSAV+1)
- MSTJ(92)=NSAV+1
- ENDIF
-
-C...Mark decayed particle; special option for B-Bbar mixing.
- IF(K(IP,1).EQ.5) K(IP,1)=15
- IF(K(IP,1).LE.10) K(IP,1)=11
- IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
- K(IP,4)=NSAV+1
- K(IP,5)=N
-
- RETURN
- END
-
-
-C*********************************************************************
-
-C...PYDCYK
-C...Handles flavour production in the decay of unstable particles
-C...and small string clusters.
-
- SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYDAT1/,/PYDAT2/
-
-
-C.. Call PYKFDI directly if no popcorn option is on
- IF(MSTJ(12).LT.2) THEN
- CALL PYKFDI(KFL1,KFL2,KFL3,KF)
- MSTU(124)=KFL3
- RETURN
- ENDIF
-
- KFL3=0
- KF=0
- IF(KFL1.EQ.0) RETURN
- KF1A=IABS(KFL1)
- KF2A=IABS(KFL2)
-
- NSTO=130
- NMAX=MIN(MSTU(125),10)
-
-C.. Identify rank 0 cluster qq
- IRANK=1
- IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
-
- IF(KF2A.GT.0)THEN
-C.. Join jets: Fails if store not empty
- IF(MSTU(121).GT.0) THEN
- MSTU(121)=0
- RETURN
- ENDIF
- CALL PYKFDI(KFL1,KFL2,KFL3,KF)
- ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
-C.. Pick popcorn meson from store, return same qq, decrease store
- KF=MSTU(NSTO+MSTU(121))
- KFL3=-KFL1
- MSTU(121)=MSTU(121)-1
- ELSE
-C.. Generate new flavour. Then done if no diquark is generated
- 100 CALL PYKFDI(KFL1,0,KFL3,KF)
- IF(MSTU(121).EQ.-1) GOTO 100
- MSTU(124)=KFL3
- IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
-
-C.. Simple case if no dynamical popcorn suppressions are considered
- IF(MSTJ(12).LT.4) THEN
- IF(MSTU(121).EQ.0) RETURN
- NMES=1
- KFPREV=-KFL3
- CALL PYKFDI(KFPREV,0,KFL3,KFM)
-C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
- IF(IABS(KFL3).LE.10)THEN
- KFL3=-KFPREV
- RETURN
- ENDIF
- GOTO 120
- ENDIF
-
-C test output qq against fake Gamma, then return if no popcorn.
- GB=2D0
- IF(IRANK.NE.0)THEN
- CALL PYZDIS(1,2103,5D0,Z)
- GB=5D0*(1D0-Z)/Z
- IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
- MSTU(121)=0
- GOTO 100
- ENDIF
- ENDIF
- IF(MSTU(121).EQ.0) RETURN
-
-C..Set store size memory. Pick fake dynamical variables of qq.
- NMES=MSTU(121)
- CALL PYPTDI(1,PX3,PY3)
- X=1D0
- POPM=0D0
- G=GB
- POPG=GB
-
-C.. Pick next popcorn meson, test with fake dynamical variables
- 110 KFPREV=-KFL3
- PX1=-PX3
- PY1=-PY3
- CALL PYKFDI(KFPREV,0,KFL3,KFM)
- IF(MSTU(121).EQ.-1) GOTO 100
- CALL PYPTDI(KFL3,PX3,PY3)
- PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
- CALL PYZDIS(KFPREV,KFL3,PM,Z)
- G=(1D0-Z)*(G+PM/Z)
- X=(1D0-Z)*X
-
- PTST=1D0
- GTST=1D0
- RTST=PYR(0)
- IF(MSTJ(12).GT.4)THEN
- POPMN=SQRT((1D0-X)*(G/X-GB))
- POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
- PTST=EXP((POPM-POPMN)*PARF(193))
- POPM=POPMN
- ENDIF
- IF(IRANK.NE.0)THEN
- POPGN=X*GB
- GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
- POPG=POPGN
- ENDIF
- IF(RTST.GT.PTST*GTST)THEN
- MSTU(121)=0
- IF(RTST.GT.PTST) MSTU(121)=-1
- GOTO 100
- ENDIF
-
-C.. Store meson
- 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
- IF(MSTU(121).GT.0) GOTO 110
-
-C.. Test accepted system size. If OK set global popcorn size variable.
- IF(NMES.GT.NMAX)THEN
- KF=0
- KFL3=0
- RETURN
- ENDIF
- MSTU(121)=NMES
- ENDIF
-
- RETURN
- END
-
-C********************************************************************
-
-C...PYKFDI
-C...Generates a new flavour pair and combines off a hadron
-
- SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYDAT1/,/PYDAT2/
-C...Local arrays.
- DIMENSION PD(7)
-
- IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
-
-C...Default flavour values. Input consistency checks.
- KF1A=IABS(KFL1)
- KF2A=IABS(KFL2)
- KFL3=0
- KF=0
- IF(KF1A.EQ.0) RETURN
- IF(KF2A.NE.0)THEN
- IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
- IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
- IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
- ENDIF
-
-C...Check if tabulated flavour probabilities are to be used.
- IF(MSTJ(15).EQ.1) THEN
- IF(MSTJ(12).GE.5) CALL PYERRM(29,
- & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
- & ' together with MSTJ(12)>=5 modification')
- KTAB1=-1
- IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
- KFL1A=MOD(KF1A/1000,10)
- KFL1B=MOD(KF1A/100,10)
- KFL1S=MOD(KF1A,10)
- IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
- & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
- IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
- IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
- KTAB2=0
- IF(KF2A.NE.0) THEN
- KTAB2=-1
- IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
- KFL2A=MOD(KF2A/1000,10)
- KFL2B=MOD(KF2A/100,10)
- KFL2S=MOD(KF2A,10)
- IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
- & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
- IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
- ENDIF
- IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
- ENDIF
-
-C.. Recognize rank 0 diquark case
- 100 IRANK=1
- KFDIQ=MAX(KF1A,KF2A)
- IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
-
-C.. Join two flavours to meson or baryon. Test for popcorn.
- IF(KF2A.GT.0)THEN
- MBARY=0
- IF(KFDIQ.GT.10) THEN
- IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
- & CALL PYNMES(KFDIQ)
- IF(MSTU(121).NE.0) THEN
- MSTU(121)=0
- RETURN
- ENDIF
- MBARY=2
- ENDIF
- KFQOLD=KF1A
- KFQVER=KF2A
- GOTO 130
- ENDIF
-
-C.. Separate incoming flavours, curtain flavour consistency check
- KFIN=KFL1
- KFQOLD=KF1A
- KFQPOP=KF1A/10000
- IF(KF1A.GT.10)THEN
- KFIN=-KFL1
- KFL1A=MOD(KF1A/1000,10)
- KFL1B=MOD(KF1A/100,10)
- IF(IRANK.EQ.0)THEN
- QAWT=1D0
- IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
- IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
- KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
- ENDIF
- IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
- MSTU(121)=0
- RETURN
- ENDIF
- KFQOLD=KFL1A+KFL1B-KFQPOP
- ENDIF
-
-C...Meson/baryon choice. Set number of mesons if starting a popcorn
-C...system.
- 110 MBARY=0
- IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
- IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
- MBARY=1
- CALL PYNMES(0)
- ENDIF
- ELSEIF(KF1A.GT.10)THEN
- MBARY=2
- IF(IRANK.EQ.0) CALL PYNMES(KF1A)
- IF(MSTU(121).GT.0) MBARY=-1
- ENDIF
-
-C..x->H+q: Choose single vertex quark. Jump to form hadron.
- IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
- KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
- KFL3=ISIGN(KFQVER,-KFIN)
- GOTO 130
- ENDIF
-
-C..x->H+qq: (IDW=proper PARF position for diquark weights)
- IDW=160
- IF(MBARY.EQ.1)THEN
- IF(MSTU(121).EQ.0) IDW=150
- SQWT=PARF(IDW+1)
- IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
- KFQPOP=1+INT((2D0+SQWT)*PYR(0))
-C.. Shift to s-curtain parameters if needed
- IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
- PARF(194)=PARF(138)*PARF(139)
- PARF(193)=PARJ(8)+PARJ(9)
- ENDIF
- ENDIF
-
-C.. x->H+qq: Get vertex quark
- IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
- IDW=MSTU(122)
- MSTU(121)=MSTU(121)-1
- IF(IDW.EQ.170) THEN
- IF(MSTU(121).EQ.0)THEN
- IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
- ELSE
- IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
- ENDIF
- ELSE
- IF(MSTU(121).EQ.0)THEN
- IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
- ELSE
- IPOS=3*5+5*4+MIN(KFQOLD-1,4)
- ENDIF
- ENDIF
- IPOS=200+30*IPOS+1
-
- IMES=-1
- RMES=PYR(0)*PARF(194)
- 120 IMES=IMES+1
- RMES=RMES-PARF(IPOS+IMES)
- IF(IMES.EQ.30) THEN
- MSTU(121)=-1
- KF=-111
- RETURN
- ENDIF
- IF(RMES.GT.0D0) GOTO 120
- KMUL=IMES/5
- KFJ=2*KMUL+1
- IF(KMUL.EQ.2) KFJ=10003
- IF(KMUL.EQ.3) KFJ=10001
- IF(KMUL.EQ.4) KFJ=20003
- IF(KMUL.EQ.5) KFJ=5
- IDIAG=0
- KFQVER=MOD(IMES,5)+1
- IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
- IF(KFQVER.GT.3)THEN
- IDIAG=KFQVER-3
- KFQVER=KFQOLD
- ENDIF
- ELSE
- IF(MBARY.EQ.-1) IDW=170
- SQWT=PARF(IDW+2)
- IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
- IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
- KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
- IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
- KFQVER=KFQPOP
- IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
- ENDIF
- ENDIF
-
-C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
- KFLDS=3
- IF(KFQPOP.NE.KFQVER)THEN
- SWT=PARF(IDW+7)
- IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
- IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
- IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
- ENDIF
- KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
- & +10000*KFQPOP
- KFL3=ISIGN(KFDIQ,KFIN)
-
-C..x->M+y: flavour for meson.
- 130 IF(MBARY.LE.0)THEN
- KFLA=MAX(KFQOLD,KFQVER)
- KFLB=MIN(KFQOLD,KFQVER)
- KFS=ISIGN(1,KFL1)
- IF(KFLA.NE.KFQOLD) KFS=-KFS
-C... Form meson, with spin and flavour mixing for diagonal states.
- IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
- IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
- IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
- RETURN
- ENDIF
- IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
- IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
- IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
- IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
- IF(PYR(0).LT.PARJ(14)) KMUL=2
- ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
- RMUL=PYR(0)
- IF(RMUL.LT.PARJ(15)) KMUL=3
- IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
- IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
- ENDIF
- KFLS=3
- IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
- IF(KMUL.EQ.5) KFLS=5
- IF(KFLA.NE.KFLB)THEN
- KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
- ELSE
- RMIX=PYR(0)
- IMIX=2*KFLA+10*KMUL
- IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
- & INT(RMIX+PARF(IMIX)))+KFLS
- IF(KFLA.GE.4) KF=110*KFLA+KFLS
- ENDIF
- IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
- IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
-
-C..Optional extra suppression of eta and eta'.
-C..Allow shift to qq->B+q in old version (set IRANK to 0)
- IF(KF.EQ.221.OR.KF.EQ.331)THEN
- IF(PYR(0).GT.PARJ(25+KF/300))THEN
- IF(KF2A.GT.0) GOTO 130
- IF(MSTJ(12).LT.4) IRANK=0
- GOTO 110
- ENDIF
- ENDIF
- MSTU(121)=0
-
-C.. x->B+y: Flavour for baryon
- ELSE
- KFLA=KFQVER
- IF(KF1A.LE.10) KFLA=KFQOLD
- KFLB=MOD(KFDIQ/1000,10)
- KFLC=MOD(KFDIQ/100,10)
- KFLDS=MOD(KFDIQ,10)
- KFLD=MAX(KFLA,KFLB,KFLC)
- KFLF=MIN(KFLA,KFLB,KFLC)
- KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
-
-C... SU(6) factors for formation of baryon.
- KBARY=3
- KDMAX=5
- KFLG=KFLB
- IF(KFLB.NE.KFLC)THEN
- KBARY=2*KFLDS-1
- KDMAX=1+KFLDS/2
- IF(KFLB.GT.2) KDMAX=KDMAX+2
- ENDIF
- IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
- KBARY=KBARY+1
- KFLG=KFLA
- ENDIF
-
- SU6MAX=PARF(140+KDMAX)
- SU6DEC=PARJ(18)
- SU6S =PARF(146)
- IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
- SU6MAX=1D0
- SU6DEC=1D0
- SU6S =1D0
- ENDIF
- SU6OCT=PARF(60+KBARY)
- IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
- SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
- IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
- ELSE
- IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
- ENDIF
- SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
-
-C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
- IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
- MSTU(121)=0
- IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
- GOTO 110
- ENDIF
-
-C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
- KSIG=1
- KFLS=2
- IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
- IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
- KSIG=KFLDS/3
- IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
- ENDIF
- KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
- IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
- ENDIF
- RETURN
-
-C...Use tabulated probabilities to select new flavour and hadron.
- 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
- KT3L=1
- KT3U=6
- ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
- KT3L=1
- KT3U=6
- ELSEIF(KTAB2.EQ.0) THEN
- KT3L=1
- KT3U=22
- ELSE
- KT3L=KTAB2
- KT3U=KTAB2
- ENDIF
- RFL=0D0
- DO 160 KTS=0,2
- DO 150 KT3=KT3L,KT3U
- RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
- 150 CONTINUE
- 160 CONTINUE
- RFL=PYR(0)*RFL
- DO 180 KTS=0,2
- KTABS=KTS
- DO 170 KT3=KT3L,KT3U
- KTAB3=KT3
- RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
- IF(RFL.LE.0D0) GOTO 190
- 170 CONTINUE
- 180 CONTINUE
- 190 CONTINUE
-
-C...Reconstruct flavour of produced quark/diquark.
- IF(KTAB3.LE.6) THEN
- KFL3A=KTAB3
- KFL3B=0
- KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
- ELSE
- KFL3A=1
- IF(KTAB3.GE.8) KFL3A=2
- IF(KTAB3.GE.11) KFL3A=3
- IF(KTAB3.GE.16) KFL3A=4
- KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
- KFL3=1000*KFL3A+100*KFL3B+1
- IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
- & KFL3+2
- KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
- ENDIF
-
-C...Reconstruct meson code.
- IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
- &KFL3B.NE.0)) THEN
- RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
- & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
- KF=110+2*KTABS+1
- IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
- IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
- & 25*KTABS)) KF=330+2*KTABS+1
- ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
- KFLA=MAX(KTAB1,KTAB3)
- KFLB=MIN(KTAB1,KTAB3)
- KFS=ISIGN(1,KFL1)
- IF(KFLA.NE.KF1A) KFS=-KFS
- KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
- ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
- KFS=ISIGN(1,KFL1)
- IF(KFL1A.EQ.KFL3A) THEN
- KFLA=MAX(KFL1B,KFL3B)
- KFLB=MIN(KFL1B,KFL3B)
- IF(KFLA.NE.KFL1B) KFS=-KFS
- ELSEIF(KFL1A.EQ.KFL3B) THEN
- KFLA=KFL3A
- KFLB=KFL1B
- KFS=-KFS
- ELSEIF(KFL1B.EQ.KFL3A) THEN
- KFLA=KFL1A
- KFLB=KFL3B
- ELSEIF(KFL1B.EQ.KFL3B) THEN
- KFLA=MAX(KFL1A,KFL3A)
- KFLB=MIN(KFL1A,KFL3A)
- IF(KFLA.NE.KFL1A) KFS=-KFS
- ELSE
- CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
- GOTO 100
- ENDIF
- KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
-
-C...Reconstruct baryon code.
- ELSE
- IF(KTAB1.GE.7) THEN
- KFLA=KFL3A
- KFLB=KFL1A
- KFLC=KFL1B
- ELSE
- KFLA=KFL1A
- KFLB=KFL3A
- KFLC=KFL3B
- ENDIF
- KFLD=MAX(KFLA,KFLB,KFLC)
- KFLF=MIN(KFLA,KFLB,KFLC)
- KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
- IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
- IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
- ENDIF
-
-C...Check that constructed flavour code is an allowed one.
- IF(KFL2.NE.0) KFL3=0
- KC=PYCOMP(KF)
- IF(KC.EQ.0) THEN
- CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
- & 'failed')
- GOTO 100
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYNMES
-C...Generates number of popcorn mesons and stores some relevant
-C...parameters.
-
- SUBROUTINE PYNMES(KFDIQ)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYDAT1/,/PYDAT2/
-
- MSTU(121)=0
- IF(MSTJ(12).LT.2) RETURN
-
-C..Old version: Get 1 or 0 popcorn mesons
- IF(MSTJ(12).LT.5)THEN
- POPWT=PARF(131)
- IF(KFDIQ.NE.0) THEN
- KFDIQA=IABS(KFDIQ)
- KFA=MOD(KFDIQA/1000,10)
- KFB=MOD(KFDIQA/100,10)
- KFS=MOD(KFDIQA,10)
- POPWT=PARF(132)
- IF(KFA.EQ.3) POPWT=PARF(133)
- IF(KFB.EQ.3) POPWT=PARF(134)
- IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
- ENDIF
- MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
- RETURN
- ENDIF
-
-C..New version: Store popcorn- or rank 0 diquark parameters
- MSTU(122)=170
- PARF(193)=PARJ(8)
- PARF(194)=PARF(139)
- IF(KFDIQ.NE.0) THEN
- MSTU(122)=180
- PARF(193)=PARJ(10)
- PARF(194)=PARF(140)
- ENDIF
- IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
- IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
- & '(PYNMES:) Neglecting too large popcorn possibility')
- RETURN
- ENDIF
-
-C..New version: Get number of popcorn mesons
- 100 RTST=PYR(0)
- MSTU(121)=-1
- 110 MSTU(121)=MSTU(121)+1
- RTST=RTST/PARF(194)
- IF(RTST.LT.1D0) GOTO 110
- IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
- & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
- RETURN
- END
-
-C***************************************************************
-
-C...PYKFIN
-C...Precalculates a set of diquark and popcorn weights.
-
- SUBROUTINE PYKFIN
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYDAT1/,/PYDAT2/
-
- DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
-
-
- MSTU(123)=1
-C..Diquark indices for dimensional variables
- IUD1=1
- IUU1=2
- IUS0=3
- ISU0=4
- IUS1=5
- ISU1=6
- ISS1=7
-
-C.. *** SU(6) factors **
-C..Modify with decuplet- (and Sigma/Lambda-) suppression.
- PARF(146)=1D0
- IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
- IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
- & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
- DO 100 I=1,6
- SU6(I)=PARF(60+I)
- SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
- 100 CONTINUE
- SU6(8)=SU6(2)*4/(3*PARF(146)+1)
- SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
- DO 110 I=1,6
- SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
- SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
- 110 CONTINUE
-
-C..SU(6)max q q' s,c,b
- SU6MUD =MAX(SU6(1) , SU6(8) )
- SU6M(IUD1)=MAX(SU6(5) , SU6(12))
- SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
- SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
- SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
- SU6M(IUS0)=SU6M(ISU0)
- SU6M(ISS1)=SU6M(IUU1)
- SU6M(IUS1)=SU6M(ISU1)
-
-C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
- PARF(141)=SU6MUD
- PARF(142)=SU6M(IUD1)
- PARF(143)=SU6M(ISU0)
- PARF(144)=SU6M(ISU1)
- PARF(145)=SU6M(ISS1)
-
-C..diquark SU(6) survival =
-C..sum over quark (quark tunnel weight)*(SU(6)).
- PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
- DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
- DMB(IUS0)=DMB(ISU0)
- DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
- DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
- DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
- DMB(IUS1)=DMB(ISU1)
- DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
-
-C.. *** Tunneling factors for Diquark production***
-C.. T: half a curtain pair = sqrt(curtain pair factor)
- IF(MSTJ(12).GE.5) THEN
- PMUD0=PYMASS(2101)
- PMUD1=PYMASS(2103)-PMUD0
- PMUS0=PYMASS(3201)-PMUD0
- PMUS1=PYMASS(3203)-PMUS0-PMUD0
- PMSS1=PYMASS(3303)-PMUS0-PMUD0
- QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
- QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
- QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
- QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
- QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
- QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
- QBB(IUD1)=QBB(IUU1)
- ELSE
- PAR2M=SQRT(PARJ(2))
- PAR3M=SQRT(PARJ(3))
- PAR4M=SQRT(PARJ(4))
- QBB(ISU0)=PAR2M*PAR3M
- QBB(IUS0)=PAR3M
- QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
- QBB(IUU1)=PAR4M
- QBB(ISU1)=PAR4M*QBB(ISU0)
- QBB(IUS1)=PAR4M*QBB(IUS0)
- QBB(IUD1)=PAR4M
- ENDIF
-
-C.. tau: spin*(vertex factor)*(T = half-curtain factor)
- QBM(ISU0)=QBB(ISU0)
- QBM(IUS0)=PARJ(2)*QBB(IUS0)
- QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
- QBM(IUU1)=6D0*QBB(IUU1)
- QBM(ISU1)=3D0*QBB(ISU1)
- QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
- QBM(IUD1)=3D0*QBB(IUD1)
-
-C.. Combine T and tau to diquark weight for q-> B+B+..
- DO 120 I=1,7
- QBB(I)=QBB(I)*QBM(I)
- 120 CONTINUE
-
- IF(MSTJ(12).GE.5)THEN
-C..New version: tau for rank 0 diquark.
- DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
- DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
- DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
- DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
- DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
- DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
- DMB(7+IUD1)=DMB(7+IUU1)/2D0
-
-C..New version: curtain flavour ratios.
-C.. s/u for q->B+M+...
-C.. s/u for rank 0 diquark: su -> ...M+B+...
-C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
- WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
- PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
- WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
- PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
- PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
- & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
- ELSE
-C..Old version: reset unused rank 0 diquark weights and
-C.. unused diquark SU(6) survival weights
- DO 130 I=1,7
- IF(MSTJ(12).LT.3) DMB(I)=1D0
- DMB(7+I)=1D0
- 130 CONTINUE
-
-C..Old version: Shuffle PARJ(7) into tau
- QBM(IUS0)=QBM(IUS0)*PARJ(7)
- QBM(ISS1)=QBM(ISS1)*PARJ(7)
- QBM(IUS1)=QBM(IUS1)*PARJ(7)
-
-C..Old version: curtain flavour ratios.
-C.. s/u for q->B+M+...
-C.. s/u for rank 0 diquark: su -> ...M+B+...
-C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
- WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
- PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
- PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
- PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
- ENDIF
-
-C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
-C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
- DO 140 I=1,7
- DMB(7+I)=DMB(7+I)*DMB(I)
- DMB(I)=DMB(I)*QBM(I)
- QBM(I)=QBM(I)*SU6M(I)/SU6MUD
- QBB(I)=QBB(I)*SU6M(I)/SU6MUD
- 140 CONTINUE
-
-C.. *** Popcorn factors ***
-
- IF(MSTJ(12).LT.5)THEN
-C.. Old version: Resulting popcorn weights.
- PARF(138)=PARJ(6)
- WS=PARF(135)*PARF(138)
- WQ=WU*PARJ(5)/3D0
- PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
- PARF(133)=WQ*
- & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
- PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
- PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
- & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
- & (1D0+QBB(IUD1)+QBB(IUU1)+
- & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
- ELSE
-C..New version: Store weights for popcorn mesons,
-C..get prel. popcorn weights.
- DO 150 IPOS=201,1400
- PARF(IPOS)=0D0
- 150 CONTINUE
- DO 160 I=138,140
- PARF(I)=0D0
- 160 CONTINUE
- IPOS=200
- PARF(193)=PARJ(8)
- DO 240 MR=0,7,7
- IF(MR.EQ.7) PARF(193)=PARJ(10)
- SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
- & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
- QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
- DO 230 NMES=0,1
- IF(NMES.EQ.1) SQWT=PARJ(2)
- DO 220 KFQPOP=1,4
- IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
- IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
- SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
- QQWT=0.5D0
- IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
- IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
- ENDIF
- DO 210 KFQOLD =1,5
- IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
- IF(NMES.EQ.1) THEN
- IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
- IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
- ENDIF
- WTTOT=0D0
- WTFAIL=0D0
- DO 190 KMUL=0,5
- PJWT=PARJ(12+KMUL)
- IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
- IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
- IF(PJWT.LE.0D0) GOTO 190
- IF(PJWT.GT.1D0) PJWT=1D0
- IMES=5*KMUL
- IMIX=2*KFQOLD+10*KMUL
- KFJ=2*KMUL+1
- IF(KMUL.EQ.2) KFJ=10003
- IF(KMUL.EQ.3) KFJ=10001
- IF(KMUL.EQ.4) KFJ=20003
- IF(KMUL.EQ.5) KFJ=5
- DO 180 KFQVER =1,3
- KFLA=MAX(KFQOLD,KFQVER)
- KFLB=MIN(KFQOLD,KFQVER)
- SWT=PARJ(11+KFLA/3+KFLA/4)
- IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
- SWT=SWT*PJWT
- QWT=SQWT/(2D0+SQWT)
- IF(KFQVER.LT.3)THEN
- IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
- IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
- ENDIF
- IF(KFQVER.NE.KFQOLD)THEN
- IMES=IMES+1
- KFM=100*KFLA+10*KFLB+KFJ
- PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
- PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
- WTTOT=WTTOT+PARF(IPOS+IMES)
- ELSE
- DO 170 ID=3,5
- IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
- IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
- IF(ID.EQ.5) DWT=PARF(IMIX)
- KFM=110*(ID-2)+KFJ
- PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
- PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
- IF(KMUL.EQ.0.AND.ID.GT.3) THEN
- WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
- PARF(IPOS+5*KMUL+ID)=
- & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
- ENDIF
- WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
- 170 CONTINUE
- ENDIF
- 180 CONTINUE
- 190 CONTINUE
- DO 200 IMES=1,30
- PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
- 200 CONTINUE
- IF(MR.EQ.7) PARF(140)=
- & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
- IF(MR.EQ.0) PARF(139-KFQPOP/3)=
- & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
- IPOS=IPOS+30
- 210 CONTINUE
- 220 CONTINUE
- 230 CONTINUE
- 240 CONTINUE
- IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
- MSTU(121)=0
-
- ENDIF
-
-C..Recombine diquark weights to flavour and spin ratios
- PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
- & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
- PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
- PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
- PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
- PARF(155)=QBB(ISU1)/QBB(ISU0)
- PARF(156)=QBB(IUS1)/QBB(IUS0)
- PARF(157)=QBB(IUD1)
-
- PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
- & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
- PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
- PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
- PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
- PARF(165)=QBM(ISU1)/QBM(ISU0)
- PARF(166)=QBM(IUS1)/QBM(IUS0)
- PARF(167)=QBM(IUD1)
-
- PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
- & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
- PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
- PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
- PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
- PARF(175)=DMB(ISU1)/DMB(ISU0)
- PARF(176)=DMB(IUS1)/DMB(IUS0)
- PARF(177)=DMB(IUD1)
-
- PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
- PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
- PARF(187)=DMB(7+IUD1)
-
- RETURN
- END
-
-
-C*********************************************************************
-
-C...PYPTDI
-C...Generates transverse momentum according to a Gaussian.
-
- SUBROUTINE PYPTDI(KFL,PX,PY)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-
-C...Generate p_T and azimuthal angle, gives p_x and p_y.
- KFLA=IABS(KFL)
- PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
- IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
- IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
- IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
- PHI=PARU(2)*PYR(0)
- PX=PT*COS(PHI)
- PY=PT*SIN(PHI)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYZDIS
-C...Generates the longitudinal splitting variable z.
-
- SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYDAT1/,/PYDAT2/
-
-C...Check if heavy flavour fragmentation.
- KFLA=IABS(KFL1)
- KFLB=IABS(KFL2)
- KFLH=KFLA
- IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
-
-C...Lund symmetric scaling function: determine parameters of shape.
- IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
- &MSTJ(11).GE.4) THEN
- FA=PARJ(41)
- IF(MSTJ(91).EQ.1) FA=PARJ(43)
- IF(KFLB.GE.10) FA=FA+PARJ(45)
- FBB=PARJ(42)
- IF(MSTJ(91).EQ.1) FBB=PARJ(44)
- FB=FBB*PR
- FC=1D0
- IF(KFLA.GE.10) FC=FC-PARJ(45)
- IF(KFLB.GE.10) FC=FC+PARJ(45)
- IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
- FRED=PARJ(46)
- IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
- FC=FC+FRED*FBB*PARF(100+KFLH)**2
- ENDIF
- MC=1
- IF(ABS(FC-1D0).GT.0.01D0) MC=2
-
-C...Determine position of maximum. Special cases for a = 0 or a = c.
- IF(FA.LT.0.02D0) THEN
- MA=1
- ZMAX=1D0
- IF(FC.GT.FB) ZMAX=FB/FC
- ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
- MA=2
- ZMAX=FB/(FB+FC)
- ELSE
- MA=3
- ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
- IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
- ENDIF
-
-C...Subdivide z range if distribution very peaked near endpoint.
- MMAX=2
- IF(ZMAX.LT.0.1D0) THEN
- MMAX=1
- ZDIV=2.75D0*ZMAX
- IF(MC.EQ.1) THEN
- FINT=1D0-LOG(ZDIV)
- ELSE
- ZDIVC=ZDIV**(1D0-FC)
- FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
- ENDIF
- ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
- MMAX=3
- FSCB=SQRT(4D0+(FC/FB)**2)
- ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
- IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
- ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
- FINT=1D0+FB*(1D0-ZDIV)
- ENDIF
-
-C...Choice of z, preweighted for peaks at low or high z.
- 100 Z=PYR(0)
- FPRE=1D0
- IF(MMAX.EQ.1) THEN
- IF(FINT*PYR(0).LE.1D0) THEN
- Z=ZDIV*Z
- ELSEIF(MC.EQ.1) THEN
- Z=ZDIV**Z
- FPRE=ZDIV/Z
- ELSE
- Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
- FPRE=(ZDIV/Z)**FC
- ENDIF
- ELSEIF(MMAX.EQ.3) THEN
- IF(FINT*PYR(0).LE.1D0) THEN
- Z=ZDIV+LOG(Z)/FB
- FPRE=EXP(FB*(Z-ZDIV))
- ELSE
- Z=ZDIV+Z*(1D0-ZDIV)
- ENDIF
- ENDIF
-
-C...Weighting according to correct formula.
- IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
- FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
- IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
- FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
- IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
-
-C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
- ELSE
- FC=PARJ(50+MAX(1,KFLH))
- IF(MSTJ(91).EQ.1) FC=PARJ(59)
- 110 Z=PYR(0)
- IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
- IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
- ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
- IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
- & GOTO 110
- ELSE
- IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
- IF(FC.LT.0D0) Z=Z**(-1D0/FC)
- ENDIF
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSHOW
-C...Generates timelike parton showers from given partons.
-
- SUBROUTINE PYSHOW(IP1,IP2,QMAX)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
- PARAMETER (MAXNUR=1000)
-C...Commonblocks.
- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
-C...Local arrays.
- DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
- &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
- &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
- &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
- &IREF(1000)
-
-C...Check that QMAX not too low.
- IF(MSTJ(41).LE.0) THEN
- RETURN
- ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
- IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
- ELSE
- IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
- & RETURN
- ENDIF
-
-C...Store positions of shower initiating partons.
- MPSPD=0
- IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
- NPA=1
- IPA(1)=IP1
- ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
- & MSTU(32))) THEN
- NPA=2
- IPA(1)=IP1
- IPA(2)=IP2
- ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
- & .AND.IP2.GE.-80) THEN
- NPA=IABS(IP2)
- DO 100 I=1,NPA
- IPA(I)=IP1+I-1
- 100 CONTINUE
- ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
- &IP2.EQ.-100) THEN
- MPSPD=1
- NPA=2
- IPA(1)=IP1+6
- IPA(2)=IP1+7
- ELSE
- CALL PYERRM(12,
- & '(PYSHOW:) failed to reconstruct showering system')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
-
-C...Send off to PYPTFS for pT-ordered evolution if requested,
-C...if at least 2 partons, and without predefined shower branchings.
- IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
- &MPSPD.EQ.0) THEN
- NPART=NPA
- DO 110 II=1,NPART
- IPART(II)=IPA(II)
- PTPART(II)=0.5D0*QMAX
- 110 CONTINUE
- CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
- RETURN
- ENDIF
-
-C...Initialization of cutoff masses etc.
- DO 120 IFL=0,40
- ISCOL(IFL)=0
- ISCHG(IFL)=0
- KSH(IFL)=0
- 120 CONTINUE
- ISCOL(21)=1
- KSH(21)=1
- PMTH(1,21)=PYMASS(21)
- PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
- PMTH(3,21)=2D0*PMTH(2,21)
- PMTH(4,21)=PMTH(3,21)
- PMTH(5,21)=PMTH(3,21)
- PMTH(1,22)=PYMASS(22)
- PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
- PMTH(3,22)=2D0*PMTH(2,22)
- PMTH(4,22)=PMTH(3,22)
- PMTH(5,22)=PMTH(3,22)
- PMQTH1=PARJ(82)
- IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
- PMQT1E=MIN(PMQTH1,PARJ(90))
- PMQTH2=PMTH(2,21)
- IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
- PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
- DO 130 IFL=1,5
- ISCOL(IFL)=1
- IF(MSTJ(41).GE.2) ISCHG(IFL)=1
- KSH(IFL)=1
- PMTH(1,IFL)=PYMASS(IFL)
- PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
- PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
- PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
- PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
- 130 CONTINUE
- DO 140 IFL=11,15,2
- IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
- IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
- PMTH(1,IFL)=PYMASS(IFL)
- PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
- PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
- PMTH(4,IFL)=PMTH(3,IFL)
- PMTH(5,IFL)=PMTH(3,IFL)
- 140 CONTINUE
- PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
- ALAMS=PARJ(81)**2
- ALFM=LOG(PT2MIN/ALAMS)
-
-C...Check on phase space available for emission.
- IREJ=0
- DO 150 J=1,5
- PS(J)=0D0
- 150 CONTINUE
- PM=0D0
- KFLA(2)=0
- DO 170 I=1,NPA
- KFLA(I)=IABS(K(IPA(I),2))
- PMA(I)=P(IPA(I),5)
-C...Special cutoff masses for initial partons (may be a heavy quark,
-C...squark, ..., and need not be on the mass shell).
- IR=30+I
- IF(NPA.LE.1) IREF(I)=IR
- IF(NPA.GE.2) IREF(I+1)=IR
- ISCOL(IR)=0
- ISCHG(IR)=0
- KSH(IR)=0
- IF(KFLA(I).LE.8) THEN
- ISCOL(IR)=1
- IF(MSTJ(41).GE.2) ISCHG(IR)=1
- ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
- & KFLA(I).EQ.17) THEN
- IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
- ELSEIF(KFLA(I).EQ.21) THEN
- ISCOL(IR)=1
- ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
- & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
- ISCOL(IR)=1
- ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
- ISCOL(IR)=1
-C...QUARKONIA+++
-C...same for QQ~[3S18]
- ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
- & KFLA(I).EQ.9900553)) THEN
- ISCOL(IR)=1
-C...QUARKONIA---
- ENDIF
- IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
- PMTH(1,IR)=PMA(I)
- IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
- PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
- PMTH(3,IR)=PMTH(2,IR)+PMQTH2
- PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
- PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
- ELSEIF(ISCOL(IR).EQ.1) THEN
- PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
- PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
- PMTH(4,IR)=PMTH(3,IR)
- PMTH(5,IR)=PMTH(3,IR)
- ELSEIF(ISCHG(IR).EQ.1) THEN
- PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
- PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
- PMTH(4,IR)=PMTH(3,IR)
- PMTH(5,IR)=PMTH(3,IR)
- ENDIF
- IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
- PM=PM+PMA(I)
- IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
- DO 160 J=1,4
- PS(J)=PS(J)+P(IPA(I),J)
- 160 CONTINUE
- 170 CONTINUE
- IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
- PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
- IF(NPA.EQ.1) PS(5)=PS(4)
- IF(PS(5).LE.PM+PMQT1E) RETURN
-
-C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
- KFSRCE=0
- IF(IP2.LE.0) THEN
- ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
- KFSRCE=IABS(K(K(IP1,3),2))
- ELSE
- IPAR1=MAX(1,K(IP1,3))
- IPAR2=MAX(1,K(IP2,3))
- IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
- & KFSRCE=IABS(K(K(IPAR1,3),2))
- ENDIF
- ITYPES=0
- IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
- IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
- IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
- IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
- IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
- IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
- IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
- IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
-
-C...Identify two primary showerers.
- ITYPE1=0
- IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
- IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
- IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
- IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
- IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
- IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
- IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
- IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
- ITYPE2=0
- IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
- IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
- IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
- IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
- IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
- IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
- IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
- IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
-
-C...Order of showerers. Presence of gluino.
- ITYPMN=MIN(ITYPE1,ITYPE2)
- ITYPMX=MAX(ITYPE1,ITYPE2)
- IORD=1
- IF(ITYPE1.GT.ITYPE2) IORD=2
- IGLUI=0
- IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
-
-C...Check if 3-jet matrix elements to be used.
- M3JC=0
- ALPHA=0.5D0
- IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
- IF(MSTJ(38).NE.0) THEN
- M3JC=MSTJ(38)
- ALPHA=PARJ(80)
- MSTJ(38)=0
- ELSEIF(MSTJ(47).GE.6) THEN
- M3JC=MSTJ(47)
- ELSE
- ICLASS=1
- ICOMBI=4
-
-C...Vector/axial vector -> q + qbar; q -> q + V.
- IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.3)) THEN
- ICLASS=2
- IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
- ICOMBI=1
- ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
- & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
-C...gamma*/Z0: assume e+e- initial state if unknown.
- EI=-1D0
- IF(KFSRCE.EQ.23) THEN
- IANNFL=K(K(IP1,3),3)
- IF(IANNFL.NE.0) THEN
- KANNFL=IABS(K(IANNFL,2))
- IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
- ENDIF
- ENDIF
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*PARU(102)
- EF=KCHG(KFLA(1),1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*PARU(102)
- XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
- SH=PS(5)**2
- SQMZ=PMAS(23,1)**2
- SQWZ=PS(5)*PMAS(23,2)
- SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
- VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
- & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
- AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
- ICOMBI=3
- ALPHA=VECT/(VECT+AXIV)
- ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
- ICOMBI=4
- ENDIF
-C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
- ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
- ICLASS=2
- ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.1)) THEN
- ICLASS=3
-
-C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
- ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
- ICLASS=4
- IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
- ICOMBI=1
- ELSEIF(KFSRCE.EQ.36) THEN
- ICOMBI=2
- ENDIF
- ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.1)) THEN
- ICLASS=5
-
-C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
- ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.3)) THEN
- ICLASS=6
- ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.2)) THEN
- ICLASS=7
- ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
- ICLASS=8
- ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.2)) THEN
- ICLASS=9
-
-C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
- ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.5)) THEN
- ICLASS=10
- ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.2)) THEN
- ICLASS=11
- ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.1)) THEN
- ICLASS=12
-
-C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
- ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
- ICLASS=13
- ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.2)) THEN
- ICLASS=14
- ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.1)) THEN
- ICLASS=15
-
-C...g -> ~g + ~g (eikonal approximation).
- ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
- ICLASS=16
- ENDIF
- M3JC=5*ICLASS+ICOMBI
- ENDIF
- ENDIF
-
-C...Find if interference with initial state partons.
- MIIS=0
- IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
- &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
- IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
- &MIIS=MSTJ(50)-3
- IF(MIIS.NE.0) THEN
- DO 190 I=1,2
- KCII(I)=0
- KCA=PYCOMP(KFLA(I))
- IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
- NIIS(I)=0
- IF(KCII(I).NE.0) THEN
- DO 180 J=1,2
- ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
- IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
- & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
- NIIS(I)=NIIS(I)+1
- IIIS(I,NIIS(I))=ICSI
- ENDIF
- 180 CONTINUE
- ENDIF
- 190 CONTINUE
- IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
- ENDIF
-
-C...Boost interfering initial partons to rest frame
-C...and reconstruct their polar and azimuthal angles.
- IF(MIIS.NE.0) THEN
- DO 210 I=1,2
- DO 200 J=1,5
- K(N+I,J)=K(IPA(I),J)
- P(N+I,J)=P(IPA(I),J)
- V(N+I,J)=0D0
- 200 CONTINUE
- 210 CONTINUE
- DO 230 I=3,2+NIIS(1)
- DO 220 J=1,5
- K(N+I,J)=K(IIIS(1,I-2),J)
- P(N+I,J)=P(IIIS(1,I-2),J)
- V(N+I,J)=0D0
- 220 CONTINUE
- 230 CONTINUE
- DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
- DO 240 J=1,5
- K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
- P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
- V(N+I,J)=0D0
- 240 CONTINUE
- 250 CONTINUE
- CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
- & -PS(2)/PS(4),-PS(3)/PS(4))
- PHI=PYANGL(P(N+1,1),P(N+1,2))
- CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
- THE=PYANGL(P(N+1,3),P(N+1,1))
- CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
- DO 260 I=3,2+NIIS(1)
- THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
- PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
- 260 CONTINUE
- DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
- THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
- & SQRT(P(N+I,1)**2+P(N+I,2)**2))
- PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
- 270 CONTINUE
- ENDIF
-
-C...Boost 3 or more partons to their rest frame.
- IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
- &-PS(2)/PS(4),-PS(3)/PS(4))
-
-C...Define imagined single initiator of shower for parton system.
- NS=N
- IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
- CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- 280 N=NS
- IF(NPA.GE.2) THEN
- K(N+1,1)=11
- K(N+1,2)=21
- K(N+1,3)=0
- K(N+1,4)=0
- K(N+1,5)=0
- P(N+1,1)=0D0
- P(N+1,2)=0D0
- P(N+1,3)=0D0
- P(N+1,4)=PS(5)
- P(N+1,5)=PS(5)
- V(N+1,5)=PS(5)**2
- N=N+1
- IREF(1)=21
- ENDIF
-
-C...Loop over partons that may branch.
- NEP=NPA
- IM=NS
- IF(NPA.EQ.1) IM=NS-1
- 290 IM=IM+1
- IF(N.GT.NS) THEN
- IF(IM.GT.N) GOTO 600
- KFLM=IABS(K(IM,2))
- IR=IREF(IM-NS)
- IF(KSH(IR).EQ.0) GOTO 290
- IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
- IGM=K(IM,3)
- ELSE
- IGM=-1
- ENDIF
- IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
- CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
-
-C...Position of aunt (sister to branching parton).
-C...Origin and flavour of daughters.
- IAU=0
- IF(IGM.GT.0) THEN
- IF(K(IM-1,3).EQ.IGM) IAU=IM-1
- IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
- ENDIF
- IF(IGM.GE.0) THEN
- K(IM,4)=N+1
- DO 300 I=1,NEP
- K(N+I,3)=IM
- 300 CONTINUE
- ELSE
- K(N+1,3)=IPA(1)
- ENDIF
- IF(IGM.LE.0) THEN
- DO 310 I=1,NEP
- K(N+I,2)=K(IPA(I),2)
- 310 CONTINUE
- ELSEIF(KFLM.NE.21) THEN
- K(N+1,2)=K(IM,2)
- K(N+2,2)=K(IM,5)
- IREF(N+1-NS)=IREF(IM-NS)
- IREF(N+2-NS)=IABS(K(N+2,2))
- ELSEIF(K(IM,5).EQ.21) THEN
- K(N+1,2)=21
- K(N+2,2)=21
- IREF(N+1-NS)=21
- IREF(N+2-NS)=21
- ELSE
- K(N+1,2)=K(IM,5)
- K(N+2,2)=-K(IM,5)
- IREF(N+1-NS)=IABS(K(N+1,2))
- IREF(N+2-NS)=IABS(K(N+2,2))
- ENDIF
-
-C...Reset flags on daughters and tries made.
- DO 320 IP=1,NEP
- K(N+IP,1)=3
- K(N+IP,4)=0
- K(N+IP,5)=0
- KFLD(IP)=IABS(K(N+IP,2))
- IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
- ITRY(IP)=0
- ISL(IP)=0
- ISI(IP)=0
- IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
- 320 CONTINUE
- ISLM=0
-
-C...Maximum virtuality of daughters.
- IF(IGM.LE.0) THEN
- DO 330 I=1,NPA
- IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
- P(N+I,5)=MIN(QMAX,PS(5))
- IR=IREF(N+I-NS)
- IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
- IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
- 330 CONTINUE
- ELSE
- IF(MSTJ(43).LE.2) PEM=V(IM,2)
- IF(MSTJ(43).GE.3) PEM=P(IM,4)
- P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
- P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
- IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
- ENDIF
- DO 340 I=1,NEP
- PMSD(I)=P(N+I,5)
- IF(ISI(I).EQ.1) THEN
- IR=IREF(N+I-NS)
- IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
- ENDIF
- V(N+I,5)=P(N+I,5)**2
- 340 CONTINUE
-
-C...Choose one of the daughters for evolution.
- 350 INUM=0
- IF(NEP.EQ.1) INUM=1
- DO 360 I=1,NEP
- IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
- 360 CONTINUE
- DO 370 I=1,NEP
- IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
- IR=IREF(N+I-NS)
- IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
- ENDIF
- 370 CONTINUE
- IF(INUM.EQ.0) THEN
- RMAX=0D0
- DO 380 I=1,NEP
- IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
- RPM=P(N+I,5)/PMSD(I)
- IR=IREF(N+I-NS)
- IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
- RMAX=RPM
- INUM=I
- ENDIF
- ENDIF
- 380 CONTINUE
- ENDIF
-
-C...Cancel choice of predetermined daughter already treated.
- INUM=MAX(1,INUM)
- INUMT=INUM
- IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
- IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
- ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
- IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
- IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
- ENDIF
-
-C...Store information on choice of evolving daughter.
- IEP(1)=N+INUM
- DO 390 I=2,NEP
- IEP(I)=IEP(I-1)+1
- IF(IEP(I).GT.N+NEP) IEP(I)=N+1
- 390 CONTINUE
- DO 400 I=1,NEP
- KFL(I)=IABS(K(IEP(I),2))
- 400 CONTINUE
- ITRY(INUM)=ITRY(INUM)+1
- IF(ITRY(INUM).GT.200) THEN
- CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- Z=0.5D0
- IR=IREF(IEP(1)-NS)
- IF(KSH(IR).EQ.0) GOTO 450
- IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
-
-C...Check if evolution already predetermined for daughter.
- IPSPD=0
- IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
- IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
- ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
- IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
- IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
- ENDIF
- IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
- ISSET(INUM)=0
- IF(IPSPD.NE.0) ISSET(INUM)=1
- ENDIF
-
-C...Select side for interference with initial state partons.
- IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
- III=IEP(1)-NS-1
- ISII(III)=0
- IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
- ISII(III)=1
- ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
- IF(PYR(0).GT.0.5D0) ISII(III)=1
- ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
- ISII(III)=1
- IF(PYR(0).GT.0.5D0) ISII(III)=2
- ENDIF
- ENDIF
-
-C...Calculate allowed z range.
- IF(NEP.EQ.1) THEN
- PMED=PS(4)
- ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
- PMED=P(IM,5)
- ELSE
- IF(INUM.EQ.1) PMED=V(IM,1)*PEM
- IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
- ENDIF
- IF(MOD(MSTJ(43),2).EQ.1) THEN
- ZC=PMTH(2,21)/PMED
- ZCE=PMTH(2,22)/PMED
- IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
- ELSE
- ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
- IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
- PMTMPE=PMTH(2,22)
- IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
- ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
- IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
- ENDIF
- ZC=MIN(ZC,0.491D0)
- ZCE=MIN(ZCE,0.49991D0)
- IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
- &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
- P(IEP(1),5)=PMTH(1,IR)
- V(IEP(1),5)=P(IEP(1),5)**2
- GOTO 450
- ENDIF
-
-C...Integral of Altarelli-Parisi z kernel for QCD.
-C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
- IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
- FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
-C...QUARKONIA+++
-C...Evolution of QQ~[3S18] state if MSTP(148)=1.
- ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
- & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
- FBR=6D0*LOG((1D0-ZC)/ZC)
-C...QUARKONIA---
- ELSEIF(MSTJ(49).EQ.0) THEN
- FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
- IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
-
-C...Integral of Altarelli-Parisi z kernel for scalar gluon.
- ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
- FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
- ELSEIF(MSTJ(49).EQ.1) THEN
- FBR=(1D0-2D0*ZC)/3D0
- IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
-
-C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
- ELSEIF(KFL(1).EQ.21) THEN
- FBR=6D0*MSTJ(45)*(0.5D0-ZC)
- ELSE
- FBR=2D0*LOG((1D0-ZC)/ZC)
- ENDIF
-
-C...Reset QCD probability for colourless.
- IF(ISCOL(IR).EQ.0) FBR=0D0
-
-C...Integral of Altarelli-Parisi kernel for photon emission.
- FBRE=0D0
- IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
- IF(KFL(1).LE.18) THEN
- FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
- ENDIF
- IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
- ENDIF
-
-C...Inner veto algorithm starts. Find maximum mass for evolution.
- 410 PMS=V(IEP(1),5)
- IF(IGM.GE.0) THEN
- PM2=0D0
- DO 420 I=2,NEP
- PM=P(IEP(I),5)
- IRI=IREF(IEP(I)-NS)
- IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
- PM2=PM2+PM
- 420 CONTINUE
- PMS=MIN(PMS,(P(IM,5)-PM2)**2)
- ENDIF
-
-C...Select mass for daughter in QCD evolution.
- B0=27D0/6D0
- DO 430 IFF=4,MSTJ(45)
- IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
- 430 CONTINUE
-C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
- PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
-C...Already predetermined choice.
- IF(IPSPD.NE.0) THEN
- PMSQCD=P(IPSPD,5)**2
- ELSEIF(FBR.LT.1D-3) THEN
- PMSQCD=0D0
- ELSEIF(MSTJ(44).LE.0) THEN
- PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
- ELSEIF(MSTJ(44).EQ.1) THEN
- PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
- ELSE
- PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
- ENDIF
-C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
- IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
- IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
- V(IEP(1),5)=PMSQCD
- MCE=1
-
-C...Select mass for daughter in QED evolution.
- IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
-C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
- PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
- IF(FBRE.LT.1D-3) THEN
- PMSQED=0D0
- ELSE
- PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
- & (PARU(101)*FBRE)))
- ENDIF
-C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
- PMSQED=PMSQED+PMTH(1,IR)**2
- IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
- & PMTH(2,IR)**2
- IF(PMSQED.GT.PMSQCD) THEN
- V(IEP(1),5)=PMSQED
- MCE=2
- ENDIF
- ENDIF
-
-C...Check whether daughter mass below cutoff.
- P(IEP(1),5)=SQRT(V(IEP(1),5))
- IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
- P(IEP(1),5)=PMTH(1,IR)
- V(IEP(1),5)=P(IEP(1),5)**2
- GOTO 450
- ENDIF
-
-C...Already predetermined choice of z, and flavour in g -> qqbar.
- IF(IPSPD.NE.0) THEN
- IPSGD1=K(IPSPD,4)
- IPSGD2=K(IPSPD,5)
- PMSGD1=P(IPSGD1,5)**2
- PMSGD2=P(IPSGD2,5)**2
- ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
- & 4D0*PMSGD1*PMSGD2))
- Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
- & PMSGD1+PMSGD2)/ALAMPS
- Z=MAX(0.00001D0,MIN(0.99999D0,Z))
- IF(KFL(1).NE.21) THEN
- K(IEP(1),5)=21
- ELSE
- K(IEP(1),5)=IABS(K(IPSGD1,2))
- ENDIF
-
-C...Select z value of branching: q -> qgamma.
- ELSEIF(MCE.EQ.2) THEN
- Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
- IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
- K(IEP(1),5)=22
-
-C...QUARKONIA+++
-C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
- ELSEIF(MSTJ(49).EQ.0.AND.
- & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
- Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
-C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
- IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
- IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
- K(IEP(1),5)=21
-C...QUARKONIA---
-
-C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
- ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
- Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
-C...Only do z weighting when no ME correction afterwards.
- IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
- K(IEP(1),5)=21
- ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
- Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
- IF(PYR(0).GT.0.5D0) Z=1D0-Z
- IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
- K(IEP(1),5)=21
- ELSEIF(MSTJ(49).NE.1) THEN
- Z=PYR(0)
- IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
- KFLB=1+INT(MSTJ(45)*PYR(0))
- PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
- IF(PMQ.GE.1D0) GOTO 410
- IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
- IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
- PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
- IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
- & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
- ELSE
- IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
- ENDIF
- K(IEP(1),5)=KFLB
-
-C...Ditto for scalar gluon model.
- ELSEIF(KFL(1).NE.21) THEN
- Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
- K(IEP(1),5)=21
- ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
- Z=ZC+(1D0-2D0*ZC)*PYR(0)
- K(IEP(1),5)=21
- ELSE
- Z=ZC+(1D0-2D0*ZC)*PYR(0)
- KFLB=1+INT(MSTJ(45)*PYR(0))
- PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
- IF(PMQ.GE.1D0) GOTO 410
- K(IEP(1),5)=KFLB
- ENDIF
-
-C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
- IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
- IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
- & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
- IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
- ELSE
- PT2APP=Z*(1D0-Z)*V(IEP(1),5)
- IF(MSTJ(44).GE.4) PT2APP=PT2APP*
- & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
- IF(PT2APP.LT.PT2MIN) GOTO 410
- IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
- ENDIF
- ENDIF
-
-C...Check if z consistent with chosen m.
- IF(KFL(1).EQ.21) THEN
- IRGD1=IABS(K(IEP(1),5))
- IRGD2=IRGD1
- ELSE
- IRGD1=IR
- IRGD2=IABS(K(IEP(1),5))
- ENDIF
- IF(NEP.EQ.1) THEN
- PED=PS(4)
- ELSEIF(NEP.GE.3) THEN
- PED=P(IEP(1),4)
- ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
- PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
- ELSE
- IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
- IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
- ENDIF
- IF(MOD(MSTJ(43),2).EQ.1) THEN
- PMQTH3=0.5D0*PARJ(82)
- IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
- IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
- PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
- PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
- ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
- & 4D0*PMQ1*PMQ2)))
- ZH=1D0+PMQ1-PMQ2
- ELSE
- ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
- ZH=1D0
- ENDIF
- IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
- &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
- ELSEIF(IPSPD.NE.0) THEN
- ELSE
- ZL=0.5D0*(ZH-ZD)
- ZU=0.5D0*(ZH+ZD)
- IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
- ENDIF
- IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
- &(1D0-ZU)))
- IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
-
-C...Width suppression for q -> q + g.
- IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
- IF(IGM.EQ.0) THEN
- EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
- ELSE
- EGLU=PMED*(1D0-Z)
- ENDIF
- CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
- IF(MSTJ(40).EQ.1) THEN
- IF(CHI.LT.PYR(0)) GOTO 410
- ELSEIF(MSTJ(40).EQ.2) THEN
- IF(1D0-CHI.LT.PYR(0)) GOTO 410
- ENDIF
- ENDIF
-
-C...Three-jet matrix element correction.
- IF(M3JC.GE.1) THEN
- WME=1D0
- WSHOW=1D0
-
-C...QED matrix elements: only for massless case so far.
- IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
- X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
- X2=1D0-V(IEP(1),5)/V(NS+1,5)
- X3=(1D0-X1)+(1D0-X2)
- KI1=K(IPA(INUM),2)
- KI2=K(IPA(3-INUM),2)
- QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
- QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
- WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
- & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
- WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
- ELSEIF(MCE.EQ.2) THEN
-
-C...QCD matrix elements, including mass effects.
- ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
- PS1ME=V(IEP(1),5)
- PM1ME=PMTH(1,IR)
- M3JCC=M3JC
- IF(IR.GE.31.AND.IGM.EQ.0) THEN
-C...QCD ME: original parton, first branching.
- PM2ME=PMTH(1,63-IR)
- ECMME=PS(5)
- ELSEIF(IR.GE.31) THEN
-C...QCD ME: original parton, subsequent branchings.
- PM2ME=PMTH(1,63-IR)
- PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
- ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
- ELSEIF(K(IM,2).EQ.21) THEN
-C...QCD ME: secondary partons, first branching.
- PM2ME=PM1ME
- ZMME=V(IM,1)
- IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
- PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
- & 4D0*PS1ME*PM2ME**2))
- PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
- & V(IM,5)
- ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
- M3JCC=66
- ELSE
-C...QCD ME: secondary partons, subsequent branchings.
- PM2ME=PM1ME
- PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
- ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
- M3JCC=66
- ENDIF
-C...Construct ME variables.
- R1ME=PM1ME/ECMME
- R2ME=PM2ME/ECMME
- X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
- X2=1D0+R2ME**2-PS1ME/ECMME**2
-C...Call ME, with right order important for two inequivalent showerers.
- IF(IR.EQ.IORD+30) THEN
- WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
- ELSE
- WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
- ENDIF
-C...Split up total ME when two radiating partons.
- ISPRAD=1
- IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
- & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
- & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
- & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
- & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
- IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
- & MAX(1D-10,2D0-X1-X2)
-C...Evaluate shower rate to be compared with.
- WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
- & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
- IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
- ELSEIF(MSTJ(49).NE.1) THEN
-
-C...Toy model scalar theory matrix elements; no mass effects.
- ELSE
- X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
- X2=1D0-V(IEP(1),5)/V(NS+1,5)
- X3=(1D0-X1)+(1D0-X2)
- WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
- WME=X3**2
- IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
- & PARJ(171)
- ENDIF
-
- IF(WME.LT.PYR(0)*WSHOW) GOTO 410
- ENDIF
-
-C...Impose angular ordering by rejection of nonordered emission.
- IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
- PEMAO=V(IM,1)*P(IM,4)
- IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
- IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
- MAOD=0
- ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
- & .OR.MSTJ(42).EQ.7)) THEN
- MAOD=0
- ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
- & .OR.MSTJ(42).EQ.6)) THEN
- MAOD=1
- PMDAO=PMTH(2,K(IEP(1),5))
- THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
- ELSE
- MAOD=1
- THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
- IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
- & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
- ENDIF
- MAOM=1
- IAOM=IM
- 440 IF(K(IAOM,5).EQ.22) THEN
- IAOM=K(IAOM,3)
- IF(K(IAOM,3).LE.NS) MAOM=0
- IF(MAOM.EQ.1) GOTO 440
- ENDIF
- IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
- THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
- IF(THE2ID.LT.THE2IM) GOTO 410
- ENDIF
- ENDIF
-
-C...Impose user-defined maximum angle at first branching.
- IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
- IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
- THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
- IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
- ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
- THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
- IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
- ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
- THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
- IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
- ENDIF
- ENDIF
-
-C...Impose angular constraint in first branching from interference
-C...with initial state partons.
- IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
- THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
- IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
- IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
- ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
- IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
- ENDIF
- ENDIF
-
-C...End of inner veto algorithm. Check if only one leg evolved so far.
- 450 V(IEP(1),1)=Z
- ISL(1)=0
- ISL(2)=0
- IF(NEP.EQ.1) GOTO 490
- IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
- DO 460 I=1,NEP
- IR=IREF(N+I-NS)
- IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
- IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
- ENDIF
- 460 CONTINUE
-
-C...Check if chosen multiplet m1,m2,z1,z2 is physical.
- IF(NEP.GE.3) THEN
- PMSUM=0D0
- DO 470 I=1,NEP
- PMSUM=PMSUM+P(N+I,5)
- 470 CONTINUE
- IF(PMSUM.GE.PS(5)) GOTO 350
- ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
- DO 480 I1=N+1,N+2
- IRDA=IREF(I1-NS)
- IF(KSH(IRDA).EQ.0) GOTO 480
- IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
- IF(IRDA.EQ.21) THEN
- IRGD1=IABS(K(I1,5))
- IRGD2=IRGD1
- ELSE
- IRGD1=IRDA
- IRGD2=IABS(K(I1,5))
- ENDIF
- I2=2*N+3-I1
- IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
- PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
- ELSE
- IF(I1.EQ.N+1) ZM=V(IM,1)
- IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
- PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
- & 4D0*V(N+1,5)*V(N+2,5))
- PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
- & V(IM,5)
- ENDIF
- IF(MOD(MSTJ(43),2).EQ.1) THEN
- PMQTH3=0.5D0*PARJ(82)
- IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
- IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
- PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
- PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
- ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
- & 4D0*PMQ1*PMQ2)))
- ZH=1D0+PMQ1-PMQ2
- ELSE
- ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
- ZH=1D0
- ENDIF
- IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
- & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
- ELSE
- ZL=0.5D0*(ZH-ZD)
- ZU=0.5D0*(ZH+ZD)
- IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
- & ISSET(1).EQ.0) THEN
- ISL(1)=1
- ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
- & ISSET(2).EQ.0) THEN
- ISL(2)=1
- ENDIF
- ENDIF
- IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
- & ZL*(1D0-ZU)))
- IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
- 480 CONTINUE
- IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
- ISL(3-ISLM)=0
- ISLM=3-ISLM
- ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
- ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
- ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
- IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
- IF(ISL(1).EQ.1) ISL(2)=0
- IF(ISL(1).EQ.0) ISLM=1
- IF(ISL(2).EQ.0) ISLM=2
- ENDIF
- IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
- ENDIF
- IRD1=IREF(N+1-NS)
- IRD2=IREF(N+2-NS)
- IF(IGM.GT.0) THEN
- IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
- & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
- PMQ1=V(N+1,5)/V(IM,5)
- PMQ2=V(N+2,5)/V(IM,5)
- ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
- & 4D0*PMQ1*PMQ2)))
- ZH=1D0+PMQ1-PMQ2
- ZL=0.5D0*(ZH-ZD)
- ZU=0.5D0*(ZH+ZD)
- IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
- ENDIF
- ENDIF
-
-C...Accepted branch. Construct four-momentum for initial partons.
- 490 MAZIP=0
- MAZIC=0
- IF(NEP.EQ.1) THEN
- P(N+1,1)=0D0
- P(N+1,2)=0D0
- P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
- & P(N+1,5))))
- P(N+1,4)=P(IPA(1),4)
- V(N+1,2)=P(N+1,4)
- ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
- PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
- P(N+1,1)=0D0
- P(N+1,2)=0D0
- P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
- P(N+1,4)=PED1
- P(N+2,1)=0D0
- P(N+2,2)=0D0
- P(N+2,3)=-P(N+1,3)
- P(N+2,4)=P(IM,5)-PED1
- V(N+1,2)=P(N+1,4)
- V(N+2,2)=P(N+2,4)
- ELSEIF(NEP.GE.3) THEN
-C...Rescale all momenta for energy conservation.
- LOOP=0
- PES=0D0
- PQS=0D0
- DO 510 I=1,NEP
- DO 500 J=1,4
- P(N+I,J)=P(IPA(I),J)
- 500 CONTINUE
- PES=PES+P(N+I,4)
- PQS=PQS+P(N+I,5)**2/P(N+I,4)
- 510 CONTINUE
- 520 LOOP=LOOP+1
- FAC=(PS(5)-PQS)/(PES-PQS)
- PES=0D0
- PQS=0D0
- DO 540 I=1,NEP
- DO 530 J=1,3
- P(N+I,J)=FAC*P(N+I,J)
- 530 CONTINUE
- P(N+I,4)=SQRT(P(N+I,5)**2+P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
- V(N+I,2)=P(N+I,4)
- PES=PES+P(N+I,4)
- PQS=PQS+P(N+I,5)**2/P(N+I,4)
- 540 CONTINUE
- IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
-
-C...Construct transverse momentum for ordinary branching in shower.
- ELSE
- ZM=V(IM,1)
- LOOPPT=0
- 550 LOOPPT=LOOPPT+1
- PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
- PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
- IF(PZM.LE.0D0) THEN
- PTS=0D0
- ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
- & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
- PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
- ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
- PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
- & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
- ELSE
- PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
- ENDIF
- IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
- ZM=0.05D0+0.9D0*ZM
- GOTO 550
- ELSEIF(PTS.LT.0D0) THEN
- GOTO 280
- ENDIF
- PT=SQRT(MAX(0D0,PTS))
-
-C...Global statistics.
- MINT(353)=MINT(353)+1
- VINT(353)=VINT(353)+PT
- IF (MINT(353).EQ.1) VINT(358)=PT
-
-C...Find coefficient of azimuthal asymmetry due to gluon polarization.
- HAZIP=0D0
- IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
- & .AND.IAU.NE.0) THEN
- IF(K(IGM,3).NE.0) MAZIP=1
- ZAU=V(IGM,1)
- IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
- IF(MAZIP.EQ.0) ZAU=0D0
- IF(K(IGM,2).NE.21) THEN
- HAZIP=2D0*ZAU/(1D0+ZAU**2)
- ELSE
- HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
- ENDIF
- IF(K(N+1,2).NE.21) THEN
- HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
- ELSE
- HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
- ENDIF
- ENDIF
-
-C...Find coefficient of azimuthal asymmetry due to soft gluon
-C...interference.
- HAZIC=0D0
- IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
- & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
- IF(K(IGM,3).NE.0) MAZIC=N+1
- IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
- IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
- & ZM.GT.0.5D0) MAZIC=N+2
- IF(K(IAU,2).EQ.22) MAZIC=0
- ZS=ZM
- IF(MAZIC.EQ.N+2) ZS=1D0-ZM
- ZGM=V(IGM,1)
- IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
- IF(MAZIC.EQ.0) ZGM=1D0
- IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
- & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
- HAZIC=MIN(0.95D0,HAZIC)
- ENDIF
- ENDIF
-
-C...Construct energies for ordinary branching in shower.
- 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
- IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
- & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
- P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
- & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
- ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
- P(N+1,4)=PEM*V(IM,1)
- ELSE
- P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
- & SQRT(PMLS)*ZM)/V(IM,5)
- ENDIF
-
-C...Already predetermined choice of phi angle or not
- PHI=PARU(2)*PYR(0)
- IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
- IPSPD=IP1+IM-NS-2
- IF(K(IPSPD,4).GT.0) THEN
- IPSGD1=K(IPSPD,4)
- IF(IM.EQ.NS+2) THEN
- PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
- ELSE
- PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
- ENDIF
- ENDIF
- ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
- IPSPD=IP1+IM-NS-2
- IF(K(IPSPD,4).GT.0) THEN
- IPSGD1=K(IPSPD,4)
- PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
- THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
- CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
- CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
- PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
- CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
- ENDIF
- ENDIF
-
-C...Construct momenta for ordinary branching in shower.
- P(N+1,1)=PT*COS(PHI)
- P(N+1,2)=PT*SIN(PHI)
- IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
- & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
- P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
- & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
- ELSEIF(PZM.GT.0D0) THEN
- P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
- & 2D0*PEM*P(N+1,4))/PZM
- ELSE
- P(N+1,3)=0D0
- ENDIF
- P(N+2,1)=-P(N+1,1)
- P(N+2,2)=-P(N+1,2)
- P(N+2,3)=PZM-P(N+1,3)
- P(N+2,4)=PEM-P(N+1,4)
- IF(MSTJ(43).LE.2) THEN
- V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
- V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
- ENDIF
- ENDIF
-
-C...Rotate and boost daughters.
- IF(IGM.GT.0) THEN
- IF(MSTJ(43).LE.2) THEN
- BEX=P(IGM,1)/P(IGM,4)
- BEY=P(IGM,2)/P(IGM,4)
- BEZ=P(IGM,3)/P(IGM,4)
- GA=P(IGM,4)/P(IGM,5)
- GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
- & P(IM,4))
- ELSE
- BEX=0D0
- BEY=0D0
- BEZ=0D0
- GA=1D0
- GABEP=0D0
- ENDIF
- PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
- THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
- IF(PTIMB.GT.1D-4) THEN
- PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
- ELSE
- PHI=0D0
- ENDIF
- DO 570 I=N+1,N+2
- DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
- & SIN(THE)*COS(PHI)*P(I,3)
- DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
- & SIN(THE)*SIN(PHI)*P(I,3)
- DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
- DP(4)=P(I,4)
- DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
- DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
- P(I,1)=DP(1)+DGABP*BEX
- P(I,2)=DP(2)+DGABP*BEY
- P(I,3)=DP(3)+DGABP*BEZ
- P(I,4)=GA*(DP(4)+DBP)
- 570 CONTINUE
- ENDIF
-
-C...Weight with azimuthal distribution, if required.
- IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
- DO 580 J=1,3
- DPT(1,J)=P(IM,J)
- DPT(2,J)=P(IAU,J)
- DPT(3,J)=P(N+1,J)
- 580 CONTINUE
- DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
- DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
- DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
- DO 590 J=1,3
- DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
- DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
- 590 CONTINUE
- DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
- DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
- IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
- CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
- & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
- IF(MAZIP.NE.0) THEN
- IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
- & GOTO 560
- ENDIF
- IF(MAZIC.NE.0) THEN
- IF(MAZIC.EQ.N+2) CAD=-CAD
- IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
- & .LT.PYR(0)) GOTO 560
- ENDIF
- ENDIF
- ENDIF
-
-C...Azimuthal anisotropy due to interference with initial state partons.
- IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
- &K(N+2,2).EQ.21)) THEN
- III=IM-NS-1
- IF(ISII(III).GE.1) THEN
- IAZIID=N+1
- IF(K(N+1,2).NE.21) IAZIID=N+2
- IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
- & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
- THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
- IF(III.EQ.2) THEIID=PARU(1)-THEIID
- PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
- HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
- CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
- PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
- IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
- IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
- & .LT.PYR(0)) GOTO 560
- ENDIF
- ENDIF
-
-C...Continue loop over partons that may branch, until none left.
- IF(IGM.GE.0) K(IM,1)=14
- N=N+NEP
- NEP=2
- IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
- CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
- IF(MSTU(21).GE.1) N=NS
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- GOTO 290
-
-C...Set information on imagined shower initiator.
- 600 IF(NPA.GE.2) THEN
- K(NS+1,1)=11
- K(NS+1,2)=94
- K(NS+1,3)=IP1
- IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
- K(NS+1,4)=NS+2
- K(NS+1,5)=NS+1+NPA
- IIM=1
- ELSE
- IIM=0
- ENDIF
-
-C...Reconstruct string drawing information.
- DO 610 I=NS+1+IIM,N
- KQ=KCHG(PYCOMP(K(I,2)),2)
- IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
- K(I,1)=1
- ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
- & IABS(K(I,2)).LE.18) THEN
- K(I,1)=1
- ELSEIF(K(I,1).LE.10) THEN
- K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
- K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
- ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
- ID1=MOD(K(I,4),MSTU(5))
- IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
- IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
- & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
- ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
- K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
- K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
- K(ID1,4)=K(ID1,4)+MSTU(5)*I
- K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
- K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
- K(ID2,5)=K(ID2,5)+MSTU(5)*I
- ELSE
- ID1=MOD(K(I,4),MSTU(5))
- ID2=ID1+1
- K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
- K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
- IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
- K(ID1,4)=K(ID1,4)+MSTU(5)*I
- K(ID1,5)=K(ID1,5)+MSTU(5)*I
- ELSE
- K(ID1,4)=0
- K(ID1,5)=0
- ENDIF
- K(ID2,4)=0
- K(ID2,5)=0
- ENDIF
- 610 CONTINUE
-
-C...Transformation from CM frame.
- IF(NPA.EQ.1) THEN
- THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
- PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
- MSTU(33)=1
- CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
- ELSEIF(NPA.EQ.2) THEN
- BEX=PS(1)/PS(4)
- BEY=PS(2)/PS(4)
- BEZ=PS(3)/PS(4)
- GA=PS(4)/PS(5)
- GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
- & /(1D0+GA)-P(IPA(1),4))
- THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
- & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
- PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
- MSTU(33)=1
- CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
- ELSE
- CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
- & PS(3)/PS(4))
- MSTU(33)=1
- CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
- ENDIF
-
-C...Decay vertex of shower.
- DO 630 I=NS+1,N
- DO 620 J=1,5
- V(I,J)=V(IP1,J)
- 620 CONTINUE
- 630 CONTINUE
-
-C...Delete trivial shower, else connect initiators.
- IF(N.LE.NS+NPA+IIM) THEN
- N=NS
- ELSE
- DO 640 IP=1,NPA
- K(IPA(IP),1)=14
- K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
- K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
- K(NS+IIM+IP,3)=IPA(IP)
- IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
- IF(K(NS+IIM+IP,1).NE.1) THEN
- K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
- K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
- ENDIF
- 640 CONTINUE
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYPTFS
-C...Generates pT-ordered timelike final-state parton showers.
-
-C...MODE defines how to find radiators and recoilers.
-C... = 0 : based on colour flow between undecayed partons.
-C... = 1 : for IPART <= NPARTD only consider primary partons,
-C... whether decayed or not; else as above.
-C... = 2 : based on common history, whether decayed or not.
-
- SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Parameter statement for maximum size of showers.
- PARAMETER (MAXNUR=1000)
-C...Commonblocks.
- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYCTAG/NCT,MCT(4000,2)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
- &/PYINT1/
-C...Local arrays.
- DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
- &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
- &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
- &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
-C...Statement functions.
- SHAT(I,J)=(P(I,4)+P(J,4))**2-(P(I,1)+P(J,1))**2-
- &(P(I,2)+P(J,2))**2-(P(I,3)+P(J,3))**2
-
-C...Initial values. Check that valid system.
- PTGEN=0D0
- IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
- &MSTJ(41).NE.12) RETURN
- IF(NPART.LE.0) THEN
- CALL PYERRM(2,'(PYPTFS:) showering system too small')
- RETURN
- ENDIF
- PT2CMX=PTMAX**2
-
-C...Mass thresholds and Lambda for QCD evolution.
- PMB=PMAS(5,1)
- PMC=PMAS(4,1)
- ALAM5=PARJ(81)
- ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
- ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
- PMBS=PMB**2
- PMCS=PMC**2
- ALAM5S=ALAM5**2
- ALAM4S=ALAM4**2
- ALAM3S=ALAM3**2
-
-C...Cutoff scale for QCD evolution. Starting pT2.
- NFLAV=MAX(0,MIN(5,MSTJ(45)))
- PT0C=0.5D0*PARJ(82)
- PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
-
-C...Parameters for QED evolution.
- AEM2PI=PARU(101)/PARU(2)
- PT0EQ=0.5D0*PARJ(83)
- PT0EL=0.5D0*PARJ(90)
-
-C...Reset. Remove irrelevant colour tags.
- NEVOL=0
- DO 100 J=1,4
- PSUM(J)=0D0
- 100 CONTINUE
- DO 110 I=MINT(84)+1,N
- IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
- K(I,5)=0
- MCT(I,2)=0
- ENDIF
- IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
- K(I,4)=0
- MCT(I,1)=0
- ENDIF
- 110 CONTINUE
- NPARTS=NPART
-
-C...Begin loop to set up showering partons. Sum four-momenta.
- DO 210 IP=1,NPART
- I=IPART(IP)
- IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
- IF(K(I,1).GT.10) GOTO 210
- ELSEIF(K(I,3).GT.MINT(84)) THEN
- IF(K(I,3).GT.MINT(84)+2) GOTO 210
- ELSE
- IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 210
- ENDIF
- DO 120 J=1,4
- PSUM(J)=PSUM(J)+P(I,J)
- 120 CONTINUE
-
-C...Find colour and charge, but skip diquarks.
- IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 210
- KCOL=ISIGN(KCHG(PYCOMP(K(I,2)),2),K(I,2))
- KCHA=ISIGN(KCHG(PYCOMP(K(I,2)),1),K(I,2))
-
-C...Either colour or anticolour charge radiates; for gluon both.
- DO 160 JSGCOL=1,-1,-2
- IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
- JCOL=4+(1-JSGCOL)/2
- JCOLR=9-JCOL
-
-C...Basic info about radiating parton.
- NEVOL=NEVOL+1
- IPOS(NEVOL)=I
- IFLG(NEVOL)=0
- ISCOL(NEVOL)=JSGCOL
- ISCHG(NEVOL)=0
- PTSCA(NEVOL)=PTPART(IP)
-
-C...Begin search for colour recoiler when MODE = 0 or 1.
- IF(MODE.LE.1) THEN
-C...Find sister with matching anticolour to the radiating parton.
- IROLD=I
- IRNEW=K(IROLD,JCOL)/MSTU(5)
- MOVE=1
-
-C...The following will add MCT colour tracing for unprepped events
-C...If not done, trace Les Houches colour tags for this dipole
-C IF (MCT(I,JCOL-3).EQ.0) THEN
-C CALL PYCTTR(I,JCOL,INEW)
-C...Clean up mother/daughter 'read' tags set by PYCTTR
-C DO 125 IR=1,N
-C K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
-C K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
-C 125 CONTINUE
-C ENDIF
-
-C...Skip radiation off loose colour ends.
- 130 IF(IRNEW.EQ.0) THEN
- NEVOL=NEVOL-1
- GOTO 160
-
-C...Optionally skip radiation on dipole to beam remnant.
- ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
- NEVOL=NEVOL-1
- GOTO 160
-
-C...For now always skip radiation on dipole to junction.
- ELSEIF(K(IRNEW,2).EQ.88) THEN
- NEVOL=NEVOL-1
- GOTO 160
-
-C...For MODE=1: if reached primary then done.
- ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
- & IRNEW.LE.NPARTD) THEN
-
-C...If sister stable and points back then done.
- ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
- & THEN
- IF(K(IRNEW,1).LT.10) THEN
-
-C...If sister unstable then go to her daughter.
- ELSE
- IROLD=IRNEW
- IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
- MOVE=2
- GOTO 130
- ENDIF
-
-C...If found mother then look for aunt.
- ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
- & IROLD) THEN
- IROLD=IRNEW
- IRNEW=K(IROLD,JCOL)/MSTU(5)
- GOTO 130
-
-C...If daughter stable then done.
- ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
- & THEN
- IF(K(IRNEW,1).LT.10) THEN
-
-C...If daughter unstable then go to granddaughter.
- ELSE
- IROLD=IRNEW
- IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
- MOVE=2
- GOTO 130
- ENDIF
-
-C...If daughter points to another daughter then done or move up.
- ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
- & IROLD) THEN
- IF(K(IRNEW,1).LT.10) THEN
- ELSE
- IROLD=IRNEW
- IRNEW=K(IRNEW,JCOL)/MSTU(5)
- MOVE=1
- GOTO 130
- ENDIF
- ENDIF
-
-C...Begin search for colour recoiler when MODE = 2.
- ELSE
- IROLD=I
- IRNEW=K(IROLD,JCOL)/MSTU(5)
- 140 IF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
-C...Step up to mother if radiating parton already branched.
- IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
- IROLD=IRNEW
- IRNEW=K(IROLD,JCOL)/MSTU(5)
- GOTO 140
-C...Pick sister by history if no anticolour available.
- ELSE
- IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
- IRNEW=IROLD-1
- ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
- & THEN
- IRNEW=IROLD+1
-C...Last resort: pick at random among other primaries.
- ELSE
- ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
- IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
- ENDIF
- ENDIF
- ENDIF
-C...Trace down if sister branched.
- 150 IF(K(IRNEW,1).GT.10) THEN
- IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
- GOTO 150
- ENDIF
- ENDIF
-
-C...Now found other end of colour dipole.
- IREC(NEVOL)=IRNEW
- ENDIF
- 160 CONTINUE
-
-C...Also electrical charge may radiate; so far only quarks and leptons.
- IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
- & IABS(K(I,2)).LE.18) THEN
-
-C...Basic info about radiating parton.
- NEVOL=NEVOL+1
- IPOS(NEVOL)=I
- IFLG(NEVOL)=0
- ISCOL(NEVOL)=0
- ISCHG(NEVOL)=KCHA
- PTSCA(NEVOL)=PTPART(IP)
-
-C...Pick nearest (= smallest invariant mass) charged particle
-C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
- IF(MODE.LE.1) THEN
- IRNEW=0
- PM2MIN=VINT(2)
- DO 170 IP2=1,NPART+N-MINT(53)
- IF(IP2.EQ.IP) GOTO 170
- IF(IP2.LE.NPART) THEN
- I2=IPART(IP2)
- IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
- IF(K(I2,1).GT.10) GOTO 170
- ELSEIF(K(I2,3).GT.MINT(84)) THEN
- IF(K(I2,3).GT.MINT(84)+2) GOTO 170
- ELSE
- IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 170
- ENDIF
- ELSE
- I2=MINT(53)+IP2-NPART
- ENDIF
- IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 170
- PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
- & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
- IF(PM2INV.LT.PM2MIN) THEN
- IRNEW=I2
- PM2MIN=PM2INV
- ENDIF
- 170 CONTINUE
- IF(IRNEW.EQ.0) THEN
- NEVOL=NEVOL-1
- GOTO 210
- ENDIF
-
-C...Begin search for charge recoiler when MODE = 2.
- ELSE
- IROLD=I
-C...Pick sister by history; step up if parton already branched.
- 180 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
- IROLD=K(IROLD,3)
- GOTO 180
- ENDIF
- IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
- IRNEW=IROLD-1
- ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
- IRNEW=IROLD+1
-C...Last resort: pick at random among other primaries.
- ELSE
- ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
- IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
- ENDIF
-C...Trace down if sister branched.
- 190 IF(K(IRNEW,1).GT.10) THEN
- DO 200 IR=IRNEW+1,N
- IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
- IRNEW=IR
- GOTO 190
- ENDIF
- 200 CONTINUE
- ENDIF
- ENDIF
- IREC(NEVOL)=IRNEW
- ENDIF
-
-C...End loop to set up showering partons. System invariant mass.
- 210 CONTINUE
- IF(NEVOL.LE.0) RETURN
- PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
-
-C...Check if 3-jet matrix elements to be used.
- M3JC=0
- ALPHA=0.5D0
- NMESYS=0
- IF(MSTJ(47).GE.1) THEN
-
-C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
- KFSRCE=0
- IPART1=K(IPART(1),3)
- IPART2=K(IPART(2),3)
- 220 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
- KFSRCE=IABS(K(IPART1,2))
- ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
- IPART1=K(IPART1,3)
- GOTO 220
- ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
- IPART2=K(IPART2,3)
- GOTO 220
- ENDIF
- ITYPES=0
- IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
- IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
- IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
- IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
- IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
- IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
- IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
- IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
-
-C...Identify two primary showerers.
- KFLA1=IABS(K(IPART(1),2))
- ITYPE1=0
- IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
- IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
- IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
- IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
- IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
- IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
- IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
- IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
- KFLA2=IABS(K(IPART(2),2))
- ITYPE2=0
- IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
- IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
- IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
- IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
- IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
- IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
- IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
- IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
-
-C...Order of showerers. Presence of gluino.
- ITYPMN=MIN(ITYPE1,ITYPE2)
- ITYPMX=MAX(ITYPE1,ITYPE2)
- IORD=1
- IF(ITYPE1.GT.ITYPE2) IORD=2
- IGLUI=0
- IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
-
-C...Require exactly two primary showerers for ME corrections.
- NPRIM=0
- IF(IPART1.GT.0) THEN
- DO 230 I=1,N
- IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
- 230 CONTINUE
- ENDIF
- IF(NPRIM.NE.2) THEN
-
-C...Predetermined and default matrix element kinds.
- ELSEIF(MSTJ(38).NE.0) THEN
- M3JC=MSTJ(38)
- ALPHA=PARJ(80)
- MSTJ(38)=0
- ELSEIF(MSTJ(47).GE.6) THEN
- M3JC=MSTJ(47)
- ELSE
- ICLASS=1
- ICOMBI=4
-
-C...Vector/axial vector -> q + qbar; q -> q + V.
- IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.3)) THEN
- ICLASS=2
- IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
- ICOMBI=1
- ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
- & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
-C...gamma*/Z0: assume e+e- initial state if unknown.
- EI=-1D0
- IF(KFSRCE.EQ.23) THEN
- IANNFL=IPART1
- IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
- IF(IANNFL.GT.0) THEN
- IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
- ENDIF
- IF(IANNFL.NE.0) THEN
- KANNFL=IABS(K(IANNFL,2))
- IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
- ENDIF
- ENDIF
- AI=SIGN(1D0,EI+0.1D0)
- VI=AI-4D0*EI*PARU(102)
- EF=KCHG(KFLA1,1)/3D0
- AF=SIGN(1D0,EF+0.1D0)
- VF=AF-4D0*EF*PARU(102)
- XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
- SH=PSUM(5)**2
- SQMZ=PMAS(23,1)**2
- SQWZ=PSUM(5)*PMAS(23,2)
- SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
- VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
- & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
- AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
- ICOMBI=3
- ALPHA=VECT/(VECT+AXIV)
- ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
- ICOMBI=4
- ENDIF
-C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
- ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
- ICLASS=2
- ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.1)) THEN
- ICLASS=3
-
-C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
- ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
- ICLASS=4
- IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
- ICOMBI=1
- ELSEIF(KFSRCE.EQ.36) THEN
- ICOMBI=2
- ENDIF
- ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.1)) THEN
- ICLASS=5
-
-C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
- ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.3)) THEN
- ICLASS=6
- ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.2)) THEN
- ICLASS=7
- ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
- ICLASS=8
- ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.2)) THEN
- ICLASS=9
-
-C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
- ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.5)) THEN
- ICLASS=10
- ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.2)) THEN
- ICLASS=11
- ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.1)) THEN
- ICLASS=12
-
-C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
- ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
- ICLASS=13
- ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.2)) THEN
- ICLASS=14
- ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
- & ITYPES.EQ.1)) THEN
- ICLASS=15
-
-C...g -> ~g + ~g (eikonal approximation).
- ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
- ICLASS=16
- ENDIF
- M3JC=5*ICLASS+ICOMBI
- ENDIF
-
-C...Store pair that together define matrix element treatment.
- IF(M3JC.NE.0) THEN
- NMESYS=1
- MESYS(NMESYS,0)=M3JC
- MESYS(NMESYS,1)=IPART(1)
- MESYS(NMESYS,2)=IPART(2)
- ENDIF
-
-C...Store qqbar or l+l- pairs for QED radiation.
- IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
- NMESYS=NMESYS+1
- MESYS(NMESYS,0)=101
- IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
- MESYS(NMESYS,1)=IPART(1)
- MESYS(NMESYS,2)=IPART(2)
- ENDIF
-
-C...Store other qqbar/l+l- pairs from g/gamma branchings.
- DO 270 I1=1,N
- IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 270
- I1M=K(I1,3)
- 240 IF(I1M.GT.0.AND.K(I1M,2).EQ.K(I1,2)) THEN
- I1M=K(I1M,3)
- GOTO 240
- ENDIF
-C...Move up this check to avoid out-of-bounds.
- IF(I1M.EQ.0) GOTO 270
- IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 270
- DO 260 I2=I1+1,N
- IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 260
- I2M=K(I2,3)
- 250 IF(I2M.GT.0.AND.K(I2M,2).EQ.K(I2,2)) THEN
- I2M=K(I2M,3)
- GOTO 250
- ENDIF
- IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
- NMESYS=NMESYS+1
- MESYS(NMESYS,0)=66
- MESYS(NMESYS,1)=I1
- MESYS(NMESYS,2)=I2
- NMESYS=NMESYS+1
- MESYS(NMESYS,0)=102
- MESYS(NMESYS,1)=I1
- MESYS(NMESYS,2)=I2
- ENDIF
- 260 CONTINUE
- 270 CONTINUE
- ENDIF
-
-C..Loopback point for counting number of emissions.
- NGEN=0
- 280 NGEN=NGEN+1
-
-C...Begin loop to evolve all existing partons, if required.
- 290 IMX=0
- PT2MX=0D0
- DO 360 IEVOL=1,NEVOL
- IF(IFLG(IEVOL).EQ.0) THEN
-
-C...Basic info on radiator and recoil.
- I=IPOS(IEVOL)
- IR=IREC(IEVOL)
- SHT=SHAT(I,IR)
- PM2I=P(I,5)**2
- PM2R=P(IR,5)**2
-
-C...Invariant mass of "dipole".Starting value for pT evolution.
- SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
- PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
-
-C...Case of evolution by QCD branching.
- IF(ISCOL(IEVOL).NE.0) THEN
-
-C...Parton-by-parton maximum scale from initial conditions.
- IF(MSTP(72).EQ.0) THEN
- DO 300 IPRT=1,NPARTS
- IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
- 300 CONTINUE
- ENDIF
-
-C...If kinematically impossible then do not evolve.
- IF(PT2.LT.PT2CMN) THEN
- IFLG(IEVOL)=-1
- GOTO 360
- ENDIF
-
-C...Check if part of system for which ME corrections should be applied.
- IMESYS=0
- DO 310 IME=1,NMESYS
- IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
- & MESYS(IME,0).LT.100) IMESYS=IME
- 310 CONTINUE
-
-C...Special flag for colour octet states.
- MOCT=0
- IF(K(I,2).EQ.21) MOCT=1
- IF(K(I,2).EQ.KSUSY1+21) MOCT=2
-
-C...Upper estimate for matrix element weighting and colour factor.
-C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
- WTPSGL=2D0
- COLFAC=4D0/3D0
- IF(MOCT.GE.1) COLFAC=3D0/2D0
- IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
- WTPSQQ=0.5D0*0.5D0*NFLAV
-
-C...Determine overestimated z range: switch at c and b masses.
- 320 IZRG=1
- PT2MNE=PT2CMN
- B0=27D0/6D0
- ALAMS=ALAM3S
- IF(PT2.GT.1.01D0*PMCS) THEN
- IZRG=2
- PT2MNE=PMCS
- B0=25D0/6D0
- ALAMS=ALAM4S
- ENDIF
- IF(PT2.GT.1.01D0*PMBS) THEN
- IZRG=3
- PT2MNE=PMBS
- B0=23D0/6D0
- ALAMS=ALAM5S
- ENDIF
- ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
- IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
-
-C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
- EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
- EVCOEF=EVEMGL
- IF(MOCT.EQ.1) THEN
- EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
- EVCOEF=EVCOEF+EVEMQQ
- ENDIF
-
-C...Pick pT2 (in overestimated z range).
- 330 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
-
-C...Loopback if crossed c/b mass thresholds.
- IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
- PT2=PMBS
- GOTO 320
- ENDIF
- IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
- PT2=PMCS
- GOTO 320
- ENDIF
-
-C...Finish if below lower cutoff.
- IF(PT2.LT.PT2CMN) THEN
- IFLG(IEVOL)=-1
- GOTO 360
- ENDIF
-
-C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
- IFLAG=1
- IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
-
-C...Pick z: dz/(1-z) or dz.
- IF(IFLAG.EQ.1) THEN
- Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
- ELSE
- Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
- ENDIF
-
-C...Loopback if outside allowed range for given pT2.
- ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
- IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
- IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 330
- PM2=PM2I+PT2/(Z*(1D0-Z))
- IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 330
-
-C...No weighting for primary partons; to be done later on.
- IF(IMESYS.GT.0) THEN
-
-C...Weighting of q->qg/X->Xg branching.
- ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
- IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 330
-
-C...Weighting of g->gg branching.
- ELSEIF(IFLAG.EQ.1) THEN
- IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 330
-
-C...Flavour choice and weighting of g->qqbar branching.
- ELSE
- KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
- PMQ=PMAS(KFQ,1)
- ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
- WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
- IF(WTME.LT.PYR(0)) GOTO 330
- IFLAG=10+KFQ
- ENDIF
-
-C...Case of evolution by QED branching.
- ELSEIF(ISCHG(IEVOL).NE.0) THEN
-
-C...If kinematically impossible then do not evolve.
- PT2EMN=PT0EQ**2
- IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
- IF(PT2.LT.PT2EMN) THEN
- IFLG(IEVOL)=-1
- GOTO 360
- ENDIF
-
-C...Check if part of system for which ME corrections should be applied.
- IMESYS=0
- DO 340 IME=1,NMESYS
- IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
- & MESYS(IME,0).GT.100) IMESYS=IME
- 340 CONTINUE
-
-C...Charge. Matrix element weighting factor.
- CHG=ISCHG(IEVOL)/3D0
- WTPSGA=2D0
-
-C...Determine overestimated z range. Find evolution coefficient.
- ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
- IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
- EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
-
-C...Pick pT2 (in overestimated z range).
- 350 PT2=PT2*PYR(0)**(1D0/EVCOEF)
-
-C...Finish if below lower cutoff.
- IF(PT2.LT.PT2EMN) THEN
- IFLG(IEVOL)=-1
- GOTO 360
- ENDIF
-
-C...Pick z: dz/(1-z).
- Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
-
-C...Loopback if outside allowed range for given pT2.
- ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
- IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
- IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
- PM2=PM2I+PT2/(Z*(1D0-Z))
- IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
-
-C...Weighting by branching kernel, except if ME weighting later.
- IF(IMESYS.EQ.0) THEN
- IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 350
- ENDIF
- IFLAG=3
- ENDIF
-
-C...Save acceptable branching.
- IFLG(IEVOL)=IFLAG
- IMESAV(IEVOL)=IMESYS
- PT2SAV(IEVOL)=PT2
- ZSAV(IEVOL)=Z
- SHTSAV(IEVOL)=SHT
- ENDIF
-
-C...Check if branching has highest pT.
- IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
- IMX=IEVOL
- PT2MX=PT2SAV(IEVOL)
- ENDIF
- 360 CONTINUE
-
-C...Finished if no more branchings to be done.
- IF(IMX.EQ.0) GOTO 480
-
-C...Restore info on hardest branching to be processed.
- I=IPOS(IMX)
- IR=IREC(IMX)
- KCOL=ISCOL(IMX)
- KCHA=ISCHG(IMX)
- IMESYS=IMESAV(IMX)
- PT2=PT2SAV(IMX)
- Z=ZSAV(IMX)
- SHT=SHTSAV(IMX)
- PM2I=P(I,5)**2
- PM2R=P(IR,5)**2
- PM2=PM2I+PT2/(Z*(1D0-Z))
-
-C...Special flag for colour octet states.
- MOCT=0
- IF(K(I,2).EQ.21) MOCT=1
- IF(K(I,2).EQ.KSUSY1+21) MOCT=2
-
-C...Restore further info for g->qqbar branching.
- KFQ=0
- IF(IFLG(IMX).GT.10) THEN
- KFQ=IFLG(IMX)-10
- PMQ=PMAS(KFQ,1)
- ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
- ENDIF
-
-C...For branching g include azimuthal asymmetries from polarization.
- ASYPOL=0D0
- IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
-C...Trace grandmother via intermediate recoil copies.
- KFGM=0
- IM=I
- 370 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
- & K(IM,3).GT.0) THEN
- IM=K(IM,3)
- IF(IM.GT.MINT(84)) GOTO 370
- ENDIF
- IGM=K(IM,3)
- IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
- & KFGM=IABS(K(IGM,2))
-C...Define approximate energy sharing by identifying aunt.
- IAU=IM+1
- IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
- IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
- ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
-C...Coefficient from gluon production.
- IF(KFGM.LE.6) THEN
- ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
- ELSE
- ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
- ENDIF
-C...Coefficient from gluon decay.
- IF(KFQ.EQ.0) THEN
- ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
- ELSE
- ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
- ENDIF
- ENDIF
- ENDIF
-
-C...Create new slots for branching products and recoil.
- INEW=N+1
- IGNEW=N+2
- IRNEW=N+3
- N=N+3
-
-C...Set status, flavour and mother of new ones.
- K(INEW,1)=K(I,1)
- K(IGNEW,1)=3
- IF(KCHA.NE.0) K(IGNEW,1)=1
- K(IRNEW,1)=K(IR,1)
- IF(KFQ.EQ.0) THEN
- K(INEW,2)=K(I,2)
- K(IGNEW,2)=21
- IF(KCHA.NE.0) K(IGNEW,2)=22
- ELSE
- K(INEW,2)=-ISIGN(KFQ,KCOL)
- K(IGNEW,2)=-K(INEW,2)
- ENDIF
- K(IRNEW,2)=K(IR,2)
- K(INEW,3)=I
- K(IGNEW,3)=I
- K(IRNEW,3)=IR
-
-C...Find rest frame and angles of branching+recoil.
- DO 380 J=1,5
- P(INEW,J)=P(I,J)
- P(IGNEW,J)=0D0
- P(IRNEW,J)=P(IR,J)
- 380 CONTINUE
- BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
- BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
- BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
- CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
- PHI=PYANGL(P(INEW,1),P(INEW,2))
- THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
-
-C...Derive kinematics of branching: generics (like g->gg).
- DO 390 J=1,4
- P(INEW,J)=0D0
- P(IRNEW,J)=0D0
- 390 CONTINUE
- PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
- PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
- PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
- PTCOR=SQRT(MAX(0D0,PT2COR))
- PZN=(PEM**2*Z-0.5D0*PM2)/PZM
- PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
-C...Specific kinematics reduction for q->qg with m_q > 0.
- IF(MOCT.NE.1) THEN
- PTCOR=(1D0-PM2I/PM2)*PTCOR
- PZN=PZN+PM2I*PZG/PM2
- PZG=(1D0-PM2I/PM2)*PZG
-C...Specific kinematics reduction for g->qqbar with m_q > 0.
- ELSEIF(KFQ.NE.0) THEN
- P(INEW,5)=PMQ
- P(IGNEW,5)=PMQ
- PTCOR=ROOTQQ*PTCOR
- PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
- PZG=PZM-PZN
- ENDIF
-
-C...Pick phi and construct kinematics of branching.
- 400 PHIROT=PARU(2)*PYR(0)
- P(INEW,1)=PTCOR*COS(PHIROT)
- P(INEW,2)=PTCOR*SIN(PHIROT)
- P(INEW,3)=PZN
- P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
- P(IGNEW,1)=-P(INEW,1)
- P(IGNEW,2)=-P(INEW,2)
- P(IGNEW,3)=PZG
- P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
- P(IRNEW,1)=0D0
- P(IRNEW,2)=0D0
- P(IRNEW,3)=-PZM
- P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
-
-C...Boost branching system to lab frame.
- CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
-
-C...Renew choice of phi angle according to polarization asymmetry.
- IF(ABS(ASYPOL).GT.1D-3) THEN
- DO 410 J=1,3
- DPT(1,J)=P(I,J)
- DPT(2,J)=P(IAU,J)
- DPT(3,J)=P(INEW,J)
- 410 CONTINUE
- DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
- DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
- DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
- DO 420 J=1,3
- DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
- DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
- 420 CONTINUE
- DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
- DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
- IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
- CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
- & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
- IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
- & GOTO 400
- ENDIF
- ENDIF
-
-C...Matrix element corrections for primary partons when requested.
- IF(IMESYS.GT.0) THEN
- M3JC=MESYS(IMESYS,0)
-
-C...Identify recoiling partner and set up three-body kinematics.
- IRP=MESYS(IMESYS,1)
- IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
- IF(IRP.EQ.IR) IRP=IRNEW
- DO 430 J=1,4
- PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
- 430 CONTINUE
- PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
- & PSUM(3)**2))
- X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
- & PSUM(3)*P(INEW,3))/PSUM(5)**2
- X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
- & PSUM(3)*P(IRP,3))/PSUM(5)**2
- X3=2D0-X1-X2
- R1ME=P(INEW,5)/PSUM(5)
- R2ME=P(IRP,5)/PSUM(5)
-
-C...Matrix elements for gluon emission.
- IF(M3JC.LT.100) THEN
-
-C...Call ME, with right order important for two inequivalent showerers.
- IF(MESYS(IMESYS,IORD).EQ.I) THEN
- WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
- ELSE
- WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
- ENDIF
-
-C...Split up total ME when two radiating partons.
- ISPRAD=1
- IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
- & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
- & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
- IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
- & MAX(1D-10,2D0-X1-X2)
-
-C...Evaluate shower rate.
- WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
- & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
- IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
-
-C...Matrix elements for photon emission: still rather primitive.
- ELSE
-
-C...For generic charge combination currently only massless expression.
- IF(M3JC.EQ.101) THEN
- CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
- CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
- WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
- WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
-
-C...For flavour neutral system assume vector source and include masses.
- ELSE
- WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
- & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
- WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
- & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
- ENDIF
- ENDIF
-
-C...Perform weighting with W_ME/W_PS.
- IF(WME.LT.PYR(0)*WPS) THEN
- N=N-3
- IFLG(IMX)=0
- PT2CMX=PT2
- GOTO 290
- ENDIF
- ENDIF
-
-C...Now for sure accepted branching. Save highest pT.
- IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
-
-C...Update status for obsolete ones. Bookkkep the moved original parton
-C...and new daughter (arbitrary choice for g->gg or g->qqbar).
-C...Do not bookkeep radiated photon, since it cannot radiate further.
- K(I,1)=K(I,1)+10
- K(IR,1)=K(IR,1)+10
- DO 440 IP=1,NPART
- IF(IPART(IP).EQ.I) IPART(IP)=INEW
- IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
- 440 CONTINUE
- IF(KCHA.EQ.0) THEN
- NPART=NPART+1
- IPART(NPART)=IGNEW
- ENDIF
-
-C...Initialize colour flow of branching.
-C...Use both old and new style colour tags for flexibility.
- K(INEW,4)=0
- K(IGNEW,4)=0
- K(INEW,5)=0
- K(IGNEW,5)=0
- JCOLP=4+(1-KCOL)/2
- JCOLN=9-JCOLP
- MCT(INEW,1)=0
- MCT(INEW,2)=0
- MCT(IGNEW,1)=0
- MCT(IGNEW,2)=0
- MCT(IRNEW,1)=0
- MCT(IRNEW,2)=0
-
-C...Trivial colour flow for l->lgamma and q->qgamma.
- IF(IABS(KCHA).EQ.3) THEN
- K(I,4)=INEW
- K(I,5)=IGNEW
- ELSEIF(KCHA.NE.0) THEN
- IF(K(I,4).NE.0) THEN
- K(I,4)=K(I,4)+INEW
- K(INEW,4)=MSTU(5)*I
- MCT(INEW,1)=MCT(I,1)
- ENDIF
- IF(K(I,5).NE.0) THEN
- K(I,5)=K(I,5)+INEW
- K(INEW,5)=MSTU(5)*I
- MCT(INEW,2)=MCT(I,2)
- ENDIF
-
-C...Set colour flow for q->qg and g->gg.
- ELSEIF(KFQ.EQ.0) THEN
- K(I,JCOLP)=K(I,JCOLP)+IGNEW
- K(IGNEW,JCOLP)=MSTU(5)*I
- K(INEW,JCOLP)=MSTU(5)*IGNEW
- K(IGNEW,JCOLN)=MSTU(5)*INEW
- MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
- NCT=NCT+1
- MCT(INEW,JCOLP-3)=NCT
- MCT(IGNEW,JCOLN-3)=NCT
- IF(MOCT.GE.1) THEN
- K(I,JCOLN)=K(I,JCOLN)+INEW
- K(INEW,JCOLN)=MSTU(5)*I
- MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
- ENDIF
-
-C...Set colour flow for g->qqbar.
- ELSE
- K(I,JCOLN)=K(I,JCOLN)+INEW
- K(INEW,JCOLN)=MSTU(5)*I
- K(I,JCOLP)=K(I,JCOLP)+IGNEW
- K(IGNEW,JCOLP)=MSTU(5)*I
- MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
- MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
- ENDIF
-
-C...Daughter info for colourless recoiling parton.
- IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
- K(IR,4)=IRNEW
- K(IR,5)=IRNEW
- K(IRNEW,4)=0
- K(IRNEW,5)=0
-
-C...Colour of recoiling parton sails through unchanged.
- ELSE
- IF(K(IR,4).NE.0) THEN
- K(IR,4)=K(IR,4)+IRNEW
- K(IRNEW,4)=MSTU(5)*IR
- MCT(IRNEW,1)=MCT(IR,1)
- ENDIF
- IF(K(IR,5).NE.0) THEN
- K(IR,5)=K(IR,5)+IRNEW
- K(IRNEW,5)=MSTU(5)*IR
- MCT(IRNEW,2)=MCT(IR,2)
- ENDIF
- ENDIF
-
-C...Vertex information trivial.
- DO 450 J=1,5
- V(INEW,J)=V(I,J)
- V(IGNEW,J)=V(I,J)
- V(IRNEW,J)=V(IR,J)
- 450 CONTINUE
-
-C...Update list of old radiators.
- DO 460 IEVOL=1,NEVOL
- IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
- IPOS(IEVOL)=INEW
- IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
- IREC(IEVOL)=IRNEW
- IFLG(IEVOL)=0
- ELSEIF(IPOS(IEVOL).EQ.I) THEN
- IPOS(IEVOL)=INEW
- IFLG(IEVOL)=0
- ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
- IPOS(IEVOL)=IRNEW
- IREC(IEVOL)=INEW
- IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL) IREC(IEVOL)=IGNEW
- IFLG(IEVOL)=0
- ELSEIF(IPOS(IEVOL).EQ.IR) THEN
- IPOS(IEVOL)=IRNEW
- IFLG(IEVOL)=0
- ENDIF
-C...Update links of old connected partons.
- IF(IREC(IEVOL).EQ.I) THEN
- IREC(IEVOL)=INEW
- IFLG(IEVOL)=0
- ELSEIF(IREC(IEVOL).EQ.IR) THEN
- IREC(IEVOL)=IRNEW
- IFLG(IEVOL)=0
- ENDIF
- 460 CONTINUE
-
-C...q->qg or g->gg: create new gluon radiators.
- IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
- NEVOL=NEVOL+1
- IPOS(NEVOL)=INEW
- IREC(NEVOL)=IGNEW
- IFLG(NEVOL)=0
- ISCOL(NEVOL)=KCOL
- ISCHG(NEVOL)=0
- PTSCA(NEVOL)=SQRT(PT2)
- NEVOL=NEVOL+1
- IPOS(NEVOL)=IGNEW
- IREC(NEVOL)=INEW
- IFLG(NEVOL)=0
- ISCOL(NEVOL)=-KCOL
- ISCHG(NEVOL)=0
- PTSCA(NEVOL)=PTSCA(NEVOL-1)
- ENDIF
-
-C...Update matrix elements parton list and add new for g/gamma->qqbar.
- DO 470 IME=1,NMESYS
- IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
- IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
- IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
- IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
- 470 CONTINUE
- IF(KFQ.NE.0) THEN
- NMESYS=NMESYS+1
- MESYS(NMESYS,0)=66
- MESYS(NMESYS,1)=INEW
- MESYS(NMESYS,2)=IGNEW
- NMESYS=NMESYS+1
- MESYS(NMESYS,0)=102
- MESYS(NMESYS,1)=INEW
- MESYS(NMESYS,2)=IGNEW
- ENDIF
-
-C...Global statistics.
- MINT(353)=MINT(353)+1
- VINT(353)=VINT(353)+PTCOR
- IF (MINT(353).EQ.1) VINT(358)=PTCOR
-
-C...Loopback for more emissions if enough space.
- PT2CMX=PT2
- IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
- &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
- GOTO 280
- ELSE
- CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
- ENDIF
-
-C...Done.
- 480 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYMAEL
-C...Auxiliary to PYSHOW and PYPTFS.
-C...Matrix elements for gluon (or photon) emission from
-C...a two-body state; to be used by the parton shower routine.
-C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
-C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
-C... = (alpha-strong/2 pi) * CF * PYMAEL,
-C...i.e. normalization is such that one recovers the familiar
-C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
-C...Coupling structure:
-C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
-C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
-C... = 16-19 : q -> q V
-C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
-C... = 26-29 : q -> q S
-C... = 31-34 : V -> ~q ~qbar (~q = squark)
-C... = 36-39 : ~q -> ~q V
-C... = 41-44 : S -> ~q ~qbar
-C... = 46-49 : ~q -> ~q S
-C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
-C... = 56-59 : ~q -> q chi
-C... = 61-64 : q -> ~q chi
-C... = 66-69 : ~g -> q ~qbar
-C... = 71-74 : ~q -> q ~g
-C... = 76-79 : q -> ~q ~g
-C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
-C...Note that the order of the decay products is important.
-C...In each set of four, the variants are ordered as:
-C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
-C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
-C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
-C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
-
- FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-
-C...Check input values. Return zero outside allowed phase space.
- PYMAEL=0D0
- IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
- IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
- IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
- IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
- &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
- ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
-
-C...Initial values and flags.
- ICLASS=NI/5
- ICOMBI=NI-5*ICLASS
- ISSET1=0
- ISSET2=0
- ISSET4=0
-
-C... Phase space.
- PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
-
-C...Eikonal expression; also acts as default.
- IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
- RLO=PS
- IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
- ANUM=0D0
- ELSEIF(ICOMBI.EQ.2) THEN
- ANUM=(2D0-X1-X2)**2
- ELSEIF(ICOMBI.EQ.3) THEN
- ANUM=ALPCOR*(2D0-X1-X2)**2
- ELSE
- ANUM=0.5D0*(2D0-X1-X2)**2
- ENDIF
- RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
- & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
- & R1**2/(1D0+R2**2-R1**2-X2)**2-
- & R2**2/(1D0+R1**2-R2**2-X1)**2)
- ICOMBI=0
-
-C...V -> q qbar (V = gamma*/Z0/W+-/...).
- ELSEIF(ICLASS.EQ.2) THEN
- IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
- RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
- RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
- & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
- & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
- & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
- & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
- & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
- & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
- & (-1+R1**2-R2**2+X2)**2
- RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
- & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
- & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
- & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
- & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
- & -X1-X2)**2+X1*(2-X1-X2)**2)/
- & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
- RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
- & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
- & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
- & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
- & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
- RFO1=RFO1/2.D0
- ISSET1=1
- ENDIF
- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
- RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
- RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
- & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
- & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
- & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
- & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
- & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
- & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
- RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
- & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
- & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
- & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
- & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
- & -X1-X2)**2+X1*(2-X1-X2)**2)/
- & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
- RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
- & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
- & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
- & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
- & +X2)/(-1-R1**2+R2**2+X1)**2
- RFO2=RFO2/2.D0
- ISSET2=1
- ENDIF
- IF(ICOMBI.EQ.4) THEN
- RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
- RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
- & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
- & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
- & (-1-R1**2+R2**2+X1)**2
- RFO4=RFO4
- & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
- & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
- & -R1**2*X2**2+X1*X2**2)/
- & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
- RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
- & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
- & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
- & (-1+R1**2-R2**2+X2)**2
- RFO4=RFO4/2.D0
- ISSET4=1
- ENDIF
-
-C...q -> q V.
- ELSEIF(ICLASS.EQ.3) THEN
- IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
- RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
- & +R1**2*R2**2-2D0*R2**4)
- RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
- & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
- & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
- & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
- & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
- & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
- & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
- RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
- & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
- & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
- & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
- & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
- RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
- & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
- & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
- & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
- & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
- & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
- & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
- ISSET1=1
- ENDIF
- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
- RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
- & +R1**2*R2**2-2D0*R2**4)
- RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
- & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
- & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
- & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
- & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
- & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
- & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
- RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
- & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
- & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
- & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
- & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
- RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
- & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
- & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
- & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
- & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
- & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
- & +X1*X2**2)/(-2+X1+X2)**2
- ISSET2=1
- ENDIF
- IF(ICOMBI.EQ.4) THEN
- RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
- RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
- & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
- & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
- & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
- & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
- RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
- & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
- & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
- & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
- RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
- & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
- & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
- & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
- & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
- & +X1*X2**2)/(2-X1-X2)**2
- ISSET4=1
- ENDIF
-
-C...S -> q qbar (S = h0/H0/A0/H+-/...).
- ELSEIF(ICLASS.EQ.4) THEN
- IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
- RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
- RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
- & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
- & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
- & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
- & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
- & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
- & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
- & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
- & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
- ISSET1=1
- ENDIF
- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
- RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
- RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
- & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
- & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
- & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
- & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
- & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
- & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
- & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
- & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
- & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
- ISSET2=1
- ENDIF
- IF(ICOMBI.EQ.4) THEN
- RLO4=PS*(1D0-R1**2-R2**2)
- RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
- & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
- & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
- & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
- & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
- & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
- & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
- ISSET4=1
- ENDIF
-
-C...q -> q S.
- ELSEIF(ICLASS.EQ.5) THEN
- IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
- RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
- RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
- & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
- & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
- & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
- & (1-R1**2+R2**2-X2)/(-2+X1+X2)
- & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
- & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
- & (-1+R1**2-R2**2+X2)**2
- ISSET1=1
- ENDIF
- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
- RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
- RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
- & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
- & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
- & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
- & (1-R1**2+R2**2-X2)/(-2+X1+X2)
- & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
- & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
- & (-1+R1**2-R2**2+X2)**2
- ISSET2=1
- ENDIF
- IF(ICOMBI.EQ.4) THEN
- RLO4=PS*(1D0+R1**2-R2**2)
- RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
- & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
- & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
- & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
- & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
- & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
- ISSET4=1
- ENDIF
-
-C...V -> ~q ~qbar (~q = squark).
- ELSEIF(ICLASS.EQ.6) THEN
- RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
- RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
- & (-1-R1**2+R2**2+X1)**2
- & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
- & (-1-R1**2+R2**2+X1)
- & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
- & /(-1+R1**2-R2**2+X2)**2
- & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
- & (-1+R1**2-R2**2+X2)
- & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
- & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
- & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
- & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
- ISSET1=1
-
-C...~q -> ~q V.
- ELSEIF(ICLASS.EQ.7) THEN
- RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
- RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
- & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
- & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
- & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
- & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
- & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
- & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
- & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
- & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
- & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
- & (3*(-2+X1+X2))
- RFO1=3D0*RFO1/8D0
- ISSET1=1
-
-C...S -> ~q ~qbar.
- ELSEIF(ICLASS.EQ.8) THEN
- RLO1=PS
- RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
- & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
- & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
- & -R1**2*X2**2+X1*X2**2)/
- & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
- RFO1=2D0*RFO1
- ISSET1=1
-
-C...~q -> ~q S.
- ELSEIF(ICLASS.EQ.9) THEN
- RLO1=PS
- RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
- & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
- & -(X1+X2)/(-2+X1+X2)**2
- ISSET1=1
-
-C...chi -> q ~qbar (chi = neutralino/chargino).
- ELSEIF(ICLASS.EQ.10) THEN
- IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
- RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
- RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
- & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
- & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
- & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
- & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
- & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
- & (-1+R1**2-R2**2+X2)**2
- ISSET1=1
- ENDIF
- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
- RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
- RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
- & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
- & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
- & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
- & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
- & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
- & (-1+R1**2-R2**2+X2)**2
- ISSET2=1
- ENDIF
- IF(ICOMBI.EQ.4) THEN
- RLO4=PS*(1+R1**2-R2**2)
- RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
- & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
- & +X2+R1**2*X2-X1*X2/2)/
- & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
- & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
- & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
- ISSET4=1
- ENDIF
-
-C...~q -> q chi.
- ELSEIF(ICLASS.EQ.11) THEN
- IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
- RLO1=PS*(1D0-(R1+R2)**2)
- RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
- & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
- & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
- & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
- & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
- & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
- & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
- ISSET1=1
- ENDIF
- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
- RLO2=PS*(1D0-(R1-R2)**2)
- RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
- & (-2+X1+X2)**2
- & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
- & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
- & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
- & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
- & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
- & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
- ISSET2=1
- ENDIF
- IF(ICOMBI.EQ.4) THEN
- RLO4=PS*(1D0-R1**2-R2**2)
- RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
- & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
- & +3*R1**2*X2-R2**2*X2-X1*X2)/
- & (-1+R1**2-R2**2+X2)**2
- & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
- & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
- & (2-X1-X2)/(-1+R1**2-R2**2+X2)
- ISSET4=1
- ENDIF
-
-C...q -> ~q chi.
- ELSEIF(ICLASS.EQ.12) THEN
- IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
- RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
- RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
- & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
- & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
- & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
- & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
- & (2-X1-X2)/(-1+R1**2-R2**2+X2)
- ISSET1=1
- END IF
- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
- RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
- RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
- & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
- & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
- & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
- & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
- & (2-X1-X2)/(-1+R1**2-R2**2+X2)
- ISSET2=1
- END IF
- IF(ICOMBI.EQ.4) THEN
- RLO4=PS*(1D0-R1**2+R2**2)
- RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
- & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
- & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
- & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
- & +R1**2*X2-X1*X2/2-X2**2/2)/
- & (2-X1-X2)/(-1+R1**2-R2**2+X2)
- ISSET4=1
- END IF
-
-C...~g -> q ~qbar.
- ELSEIF(ICLASS.EQ.13) THEN
- IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
- RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
- RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
- & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
- & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
- & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
- & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
- & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
- & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
- & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
- & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
- & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
- & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
- & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
- & (3*(-1+R1**2-R2**2+X2)**2)
- RFO1=3D0*RFO1/4D0
- ISSET1=1
- ENDIF
- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
- RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
- RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
- & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
- & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
- & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
- & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
- & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
- & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
- & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
- & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
- & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
- & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
- & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
- & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
- & (3*(-1+R1**2-R2**2+X2)**2)
- RFO2=3D0*RFO2/4D0
- ISSET2=1
- ENDIF
- IF(ICOMBI.EQ.4) THEN
- RLO4=PS*(1D0+R1**2-R2**2)
- RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
- & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
- & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
- & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
- & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
- & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
- & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
- & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
- & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
- & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
- & (3*(-1+R1**2-R2**2+X2)**2)
- RFO4=3D0*RFO4/8D0
- ISSET4=1
- ENDIF
-
-C...~q -> q ~g.
- ELSEIF(ICLASS.EQ.14) THEN
- IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
- RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
- RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
- & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
- & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
- & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
- & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
- & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
- & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
- & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
- & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
- & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
- & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
- & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
- & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
- RFO1=RFO1
- & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
- & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
- & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
- RFO1=9D0*RFO1/64D0
- ISSET1=1
- ENDIF
- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
- RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
- RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
- & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
- & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
- & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
- & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
- & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
- & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
- & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
- & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
- & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
- RFO2=RFO2
- & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
- & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
- & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
- & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
- & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
- & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
- RFO2=9D0*RFO2/64D0
- ISSET2=1
- ENDIF
- IF(ICOMBI.EQ.4) THEN
- RLO4=PS*(1-R1**2-R2**2)
- RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
- & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
- & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
- & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
- & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
- & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
- & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
- & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
- & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
- & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
- & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
- RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
- & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
- & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
- RFO4=9D0*RFO4/128D0
- ISSET4=1
- ENDIF
-
-C...q -> ~q ~g.
- ELSEIF(ICLASS.EQ.15) THEN
- IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
- RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
- RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
- & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
- & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
- & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
- & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
- & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
- & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
- & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
- & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
- RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
- & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
- & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
- & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
- & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
- RFO1=9D0*RFO1/32D0
- ISSET1=1
- END IF
- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
- RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
- RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
- & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
- & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
- & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
- & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
- & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
- & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
- & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
- & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
- RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
- & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
- & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
- & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
- & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
- RFO2=9D0*RFO2/32D0
- ISSET2=1
- END IF
- IF(ICOMBI.EQ.4) THEN
- RLO4=PS*(1D0-R1**2+R2**2)
- RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
- & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
- & -R2**2*X2/2-X1*X2/2)/
- & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
- & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
- & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
- & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
- & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
- RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
- & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
- & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
- & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
- RFO4=9D0*RFO4/64D0
- ISSET4=1
- END IF
-
-C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
- ELSEIF(ICLASS.EQ.16) THEN
- RLO=PS
- IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
- ANUM=0D0
- ELSEIF(ICOMBI.EQ.2) THEN
- ANUM=(2D0-X1-X2)**2
- ELSEIF(ICOMBI.EQ.3) THEN
- ANUM=ALPCOR*(2D0-X1-X2)**2
- ELSE
- ANUM=0.5D0*(2D0-X1-X2)**2
- ENDIF
- RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
- & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
- & R1**2/(1D0+R2**2-R1**2-X2)**2-
- & R2**2/(1D0+R1**2-R2**2-X1)**2)
- RFO=9D0*RFO/4D0
- ICOMBI=0
- ENDIF
-
-C...Find relevant LO and FO expression.
- IF(ICOMBI.EQ.0) THEN
- ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
- RLO=RLO1
- RFO=RFO1
- ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
- RLO=RLO2
- RFO=RFO2
- ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
- RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
- RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
- ELSEIF(ISSET4.EQ.1) THEN
- RLO=RLO4
- RFO=RFO4
- ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
- RLO=0.5D0*(RLO1+RLO2)
- RFO=0.5D0*(RFO1+RFO2)
- ELSEIF(ISSET1.EQ.1) THEN
- RLO=RLO1
- RFO=RFO1
- ELSE
- CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
- RLO=1D0
- RFO=0D0
- ENDIF
-
-C...Output.
- PYMAEL=RFO/RLO
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYBOEI
-C...Modifies an event so as to approximately take into account
-C...Bose-Einstein effects according to a simple phenomenological
-C...parametrization.
-
- SUBROUTINE PYBOEI(NSAV)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYINT1/MINT(400),VINT(400)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
-C...Local arrays and data.
- DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
- &BEIW(100),BEI3W(100)
- DATA KFBE/211,-211,111,321,-321,130,310,221,331/
-C...Statement function: squared invariant mass.
- SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
- &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
-
-C...Boost event to overall CM frame. Calculate CM energy.
- IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
- DO 100 J=1,4
- DPS(J)=0D0
- 100 CONTINUE
- DO 120 I=1,N
- KFA=IABS(K(I,2))
- IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
- & .AND.K(I,3).GT.0) THEN
- KFMA=IABS(K(K(I,3),2))
- IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
- ENDIF
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
- DO 110 J=1,4
- DPS(J)=DPS(J)+P(I,J)
- 110 CONTINUE
- 120 CONTINUE
- CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
- &-DPS(3)/DPS(4))
- PECM=0D0
- DO 130 I=1,N
- IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
- 130 CONTINUE
-
-C...Check if we have separated strings
-
-C...Reserve copy of particles by species at end of record.
- IWP=0
- IWN=0
- NBE(0)=N+MSTU(3)
- NMAX=NBE(0)
- SMMIN=PECM
- DO 190 IBE=1,MIN(10,MSTJ(52)+1)
- NBE(IBE)=NBE(IBE-1)
- DO 180 I=NSAV+1,N
- IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
- DO 140 IIBE=1,IBE-1
- IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
- 140 CONTINUE
- ELSE
- IF(K(I,2).NE.KFBE(IBE)) GOTO 180
- ENDIF
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
- IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
- CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
- RETURN
- ENDIF
- NBE(IBE)=NBE(IBE)+1
- NMAX=NBE(IBE)
- K(NBE(IBE),1)=I
- K(NBE(IBE),2)=0
- K(NBE(IBE),3)=0
- K(NBE(IBE),4)=0
- K(NBE(IBE),5)=0
- P(NBE(IBE),1)=0.0D0
- P(NBE(IBE),2)=0.0D0
- P(NBE(IBE),3)=0.0D0
- P(NBE(IBE),4)=0.0D0
- P(NBE(IBE),5)=0.0D0
- SMMIN=MIN(SMMIN,P(I,5))
-C...Check if particles comes from different W's or Z's
- IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
- IM=I
- 150 IF(K(IM,3).GT.0) THEN
- IM=K(IM,3)
- IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
- K(NBE(IBE),5)=IM
- IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
- IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
- IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
- IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
- ENDIF
- ENDIF
-C...Check if particles comes from different strings.
- IF(PARJ(94).GT.0.0D0) THEN
- IM=I
- 160 IF(K(IM,3).GT.0) THEN
- IM=K(IM,3)
- IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
- K(NBE(IBE),5)=IM
- ENDIF
- ENDIF
- DO 170 J=1,3
- P(NBE(IBE),J)=0D0
- V(NBE(IBE),J)=0D0
- 170 CONTINUE
- P(NBE(IBE),5)=-1.0D0
- 180 CONTINUE
- 190 CONTINUE
- IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
-
-C...Calculate separation between W+ and W- or between two Z0's.
-C...No separation if there has been re-connections.
- SIGW=PARJ(93)
- IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
- IF(K(IWP,2).EQ.23) THEN
- DMW=PMAS(23,1)
- DGW=PMAS(23,2)
- ELSE
- DMW=PMAS(24,1)
- DGW=PMAS(24,2)
- ENDIF
- DMP=P(IWP,5)
- DMN=P(IWN,5)
- TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
- TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
- TAUP=-TAUPD*LOG(PYR(IDUM))
- TAUN=-TAUND*LOG(PYR(IDUM))
- DXP=TAUP*PYP(IWP,8)/DMP
- DXN=TAUN*PYP(IWN,8)/DMN
- DX=DXP+DXN
- SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
- IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
- ENDIF
-
-C...Add separation between strings.
- IF(PARJ(94).GT.0.0D0) THEN
- SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
- IWP=-1
- IWN=-1
- ENDIF
-
- IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
- DO 220 IBE=1,MIN(9,MSTJ(52))
- DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
- Q2MIN=PECM**2
- I1=K(I1M,1)
- DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
- IF(I2M.EQ.I1M) GOTO 200
- I2=K(I2M,1)
- Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
- & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
- & (P(I1,5)+P(I2,5))**2
- IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
- Q2MIN=Q2
- ENDIF
- 200 CONTINUE
- P(I1M,5)=Q2MIN
- 210 CONTINUE
- 220 CONTINUE
- ENDIF
-
-C...Tabulate integral for subsequent momentum shift.
- DO 400 IBE=1,MIN(9,MSTJ(52))
- IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
- IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
- & .LE.1) GOTO 270
- IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
- & NBE(7)-NBE(6)).LE.1) GOTO 270
- IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
- IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
- IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
- IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
- IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
- QDEL=0.1D0*MIN(PMHQ,PARJ(93))
- QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
- QDELW=0.1D0*MIN(PMHQ,SIGW)
- QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
- IF(MSTJ(51).EQ.1) THEN
- NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
- NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
- NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
- NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
- BEEX=EXP(0.5D0*QDEL/PARJ(93))
- BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
- BEEXW=EXP(0.5D0*QDELW/SIGW)
- BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
- BERT=EXP(-QDEL/PARJ(93))
- BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
- BERTW=EXP(-QDELW/SIGW)
- BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
- ELSE
- NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
- NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
- NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
- NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
- ENDIF
- DO 230 IBIN=1,NBIN
- QBIN=QDEL*(IBIN-0.5D0)
- BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
- IF(MSTJ(51).EQ.1) THEN
- BEEX=BEEX*BERT
- BEI(IBIN)=BEI(IBIN)*BEEX
- ELSE
- BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
- ENDIF
- IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
- 230 CONTINUE
- DO 240 IBIN=1,NBIN3
- QBIN=QDEL3*(IBIN-0.5D0)
- BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
- IF(MSTJ(51).EQ.1) THEN
- BEEX3=BEEX3*BERT3
- BEI3(IBIN)=BEI3(IBIN)*BEEX3
- ELSE
- BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
- ENDIF
- IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
- 240 CONTINUE
- DO 250 IBIN=1,NBINW
- QBIN=QDELW*(IBIN-0.5D0)
- BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
- IF(MSTJ(51).EQ.1) THEN
- BEEXW=BEEXW*BERTW
- BEIW(IBIN)=BEIW(IBIN)*BEEXW
- ELSE
- BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
- ENDIF
- IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
- 250 CONTINUE
- DO 260 IBIN=1,NBIN3W
- QBIN=QDEL3W*(IBIN-0.5D0)
- BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
- & SQRT(QBIN**2+PMHQ**2)
- IF(MSTJ(51).EQ.1) THEN
- BEEX3W=BEEX3W*BERT3W
- BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
- ELSE
- BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
- ENDIF
- IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
- 260 CONTINUE
-
-C...Loop through particle pairs and find old relative momentum.
- 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
- I1=K(I1M,1)
- DO 380 I2M=I1M+1,NBE(IBE)
- IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
- IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
- I2=K(I2M,1)
- Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
- & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
- IF(Q2OLD.LE.0.0D0) GOTO 380
- QOLD=SQRT(Q2OLD)
-
-C...Calculate new relative momentum.
- QMOV=0.0D0
- QMOV3=0.0D0
- QMOVW=0.0D0
- QMOV3W=0.0D0
- IF(QOLD.LT.1D-3*QDEL) THEN
- GOTO 280
- ELSEIF(QOLD.LE.QDEL) THEN
- QMOV=QOLD/3D0
- ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
- RBIN=QOLD/QDEL
- IBIN=RBIN
- RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
- QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
- & SQRT(Q2OLD+PMHQ**2)/Q2OLD
- ELSE
- QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
- ENDIF
- 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
- IF(QOLD.LT.1D-3*QDEL3) THEN
- GOTO 290
- ELSEIF(QOLD.LE.QDEL3) THEN
- QMOV3=QOLD/3D0
- ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
- RBIN3=QOLD/QDEL3
- IBIN3=RBIN3
- RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
- QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
- & SQRT(Q2OLD+PMHQ**2)/Q2OLD
- ELSE
- QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
- ENDIF
- 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
- RSCALE=1.0D0
- IF(MSTJ(54).EQ.2)
- & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
- IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
- & K(I1M,5).EQ.K(I2M,5)) GOTO 320
-
- IF(QOLD.LT.1D-3*QDELW) THEN
- GOTO 300
- ELSEIF(QOLD.LE.QDELW) THEN
- QMOVW=QOLD/3D0
- ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
- RBINW=QOLD/QDELW
- IBINW=RBINW
- RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
- QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
- & SQRT(Q2OLD+PMHQ**2)/Q2OLD
- ELSE
- QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
- ENDIF
- 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
- IF(QOLD.LT.1D-3*QDEL3W) THEN
- GOTO 310
- ELSEIF(QOLD.LE.QDEL3W) THEN
- QMOV3W=QOLD/3D0
- ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
- RBIN3W=QOLD/QDEL3W
- IBIN3W=RBIN3W
- RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
- QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
- & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
- ELSE
- QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
- ENDIF
- 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
- IF(MSTJ(54).EQ.2)
- & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
-
- 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
- DO 330 J=1,3
- P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
- P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
- 330 CONTINUE
- IF(MSTJ(54).GE.1) THEN
- CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
- DO 340 J=1,3
- V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
- V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
- 340 CONTINUE
- ELSEIF(MSTJ(54).LE.-1) THEN
- EDEL=P(I1,4)+P(I2,4)-
- & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
- A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
- & (P(I1,3)-P(I2,3))**2
- WMAX=-1.0D20
- MI3=0
- MI4=0
- S12=SDIP(I1,I2)
- SM1=(P(I1,5)+SMMIN)**2
- DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
- IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
- IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
- IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
- & K(I3M,5).NE.K(I1M,5)) GOTO 360
- I3=K(I3M,1)
- IF(K(I3,2).EQ.K(I1,2)) GOTO 360
- S13=SDIP(I1,I3)
- S23=SDIP(I2,I3)
- SM3=(P(I3,5)+SMMIN)**2
- IF(MSTJ(54).EQ.-2) THEN
- WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
- & S23*MIN(SM1,SM3))*SM1)
- ELSE
- WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
- & (P(I1,3)+P(I2,3)+P(I3,3))**2-
- & (P(I1,2)+P(I2,2)+P(I3,2))**2-
- & (P(I1,1)+P(I2,1)+P(I3,1))**2)
- ENDIF
- IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
- IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
- & GOTO 360
- ELSE
- IF(WMAX*WI.GE.1.0) GOTO 360
- ENDIF
- DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
- IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
- IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
- IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
- & K(I4M,5).NE.K(I1M,5)) GOTO 350
- I4=K(I4M,1)
- IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
- & GOTO 350
- IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
- & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
- & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
- & GOTO 350
- IF(MSTJ(54).EQ.-2) THEN
- S14=SDIP(I1,I4)
- S24=SDIP(I2,I4)
- S34=SDIP(I3,I4)
- W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
- W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
- W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
- W=MIN(W,MIN(S23,S24)*S13*S14)
- W=1.0D0/W
- ELSE
-C...weight=1-cos(theta)/mtot2
- S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
- & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
- & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
- & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
- W=1.0D0/S1234
- IF(W.LE.WMAX) GOTO 350
- ENDIF
- IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
- & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
- IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
- & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
- IF(W.LE.WMAX) GOTO 350
- MI3=I3M
- MI4=I4M
- WMAX=W
- 350 CONTINUE
- 360 CONTINUE
- IF(MI4.EQ.0) GOTO 380
- I3=K(MI3,1)
- I4=K(MI4,1)
- EOLD=P(I3,4)+P(I4,4)
- ENEW=EOLD+EDEL
- P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
- & (P(I3,3)+P(I4,3))**2
- Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
- Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
- CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
- DO 370 J=1,3
- V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
- V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
- 370 CONTINUE
- ENDIF
- 380 CONTINUE
- 390 CONTINUE
- 400 CONTINUE
-
-C...Shift momenta and recalculate energies.
- ESUMP=0.0D0
- ESUM=0.0D0
- PROD=0.0D0
- DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
- I=K(IM,1)
- ESUMP=ESUMP+P(I,4)
- DO 410 J=1,3
- P(I,J)=P(I,J)+P(IM,J)
- 410 CONTINUE
- P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
- ESUM=ESUM+P(I,4)
- DO 420 J=1,3
- PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
- 420 CONTINUE
- 430 CONTINUE
-
- PARJ(96)=0.0D0
- IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
- 440 ALPHA=(ESUMP-ESUM)/PROD
- PARJ(96)=PARJ(96)+ALPHA
- PROD=0.0D0
- ESUM=0.0D0
- DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
- I=K(IM,1)
- DO 450 J=1,3
- P(I,J)=P(I,J)+ALPHA*V(IM,J)
- 450 CONTINUE
- P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
- ESUM=ESUM+P(I,4)
- DO 460 J=1,3
- PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
- 460 CONTINUE
- 470 CONTINUE
- IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
- & GOTO 440
- ENDIF
-
-C...Rescale all momenta for energy conservation.
- PES=0D0
- PQS=0D0
- DO 480 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
- PES=PES+P(I,4)
- PQS=PQS+P(I,5)**2/P(I,4)
- 480 CONTINUE
- PARJ(95)=PES-PECM
- FAC=(PECM-PQS)/(PES-PQS)
- DO 500 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
- DO 490 J=1,3
- P(I,J)=FAC*P(I,J)
- 490 CONTINUE
- P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
- 500 CONTINUE
-
-C...Boost back to correct reference frame.
- 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
- DO 520 I=1,N
- IF(K(I,1).LT.0) K(I,1)=-K(I,1)
- 520 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYBESQ
-C...Calculates the momentum shift in a system of two particles assuming
-C...the relative momentum squared should be shifted to Q2NEW. NI is the
-C...last position occupied in /PYJETS/.
-
- SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYJETS/,/PYDAT1/
-C...Local arrays and data.
- DIMENSION DP(5)
- SAVE HC1
-
- IF(MSTJ(55).EQ.0) THEN
- DQ2=Q2NEW-Q2OLD
- DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
- & (P(I1,3)-P(I2,3))**2
- DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
- & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
- SE=P(I1,4)+P(I2,4)
- DE=P(I1,4)-P(I2,4)
- DQ2SE=DQ2+SE**2
- DA=SE*DE*DP12-DP2*DQ2SE
- DB=DP2*DQ2SE-DP12**2
- HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
- DO 100 J=1,3
- PD=HA*(P(I1,J)-P(I2,J))
- P(NI+1,J)=PD
- P(NI+2,J)=-PD
- 100 CONTINUE
- RETURN
- ENDIF
-
- K(NI+1,1)=1
- K(NI+2,1)=1
- DO 110 J=1,5
- P(NI+1,J)=P(I1,J)
- P(NI+2,J)=P(I2,J)
- DP(J)=P(I1,J)+P(I2,J)
- 110 CONTINUE
-
-C...Boost to cms and rotate first particle to z-axis
- CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
- &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
- PHI=PYANGL(P(NI+1,1),P(NI+1,2))
- THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
- S=Q2NEW+(P(I1,5)+P(I2,5))**2
- PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
- P(NI+1,1)=0.0D0
- P(NI+1,2)=0.0D0
- P(NI+1,3)=PZ
- P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
- P(NI+2,1)=0.0D0
- P(NI+2,2)=0.0D0
- P(NI+2,3)=-PZ
- P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
- DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
- CALL PYROBO(NI+1,NI+2,THE,PHI,
- &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
-
- DO 120 J=1,3
- P(NI+1,J)=P(NI+1,J)-P(I1,J)
- P(NI+2,J)=P(NI+2,J)-P(I2,J)
- 120 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYMASS
-C...Gives the mass of a particle/parton.
-
- FUNCTION PYMASS(KF)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYDAT1/,/PYDAT2/
-
-C...Reset variables. Compressed code. Special case for popcorn diquarks.
- PYMASS=0D0
- KFA=IABS(KF)
- KC=PYCOMP(KF)
- IF(KC.EQ.0) THEN
- MSTJ(93)=0
- RETURN
- ENDIF
-
-C...Guarantee use of constituent masses for internal checks.
- IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
- &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
- IF(KFA.LE.5) THEN
- PYMASS=PARF(100+KFA)
- IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
- ELSEIF(KFA.LE.10) THEN
- PYMASS=PMAS(KFA,1)
- ELSEIF(MSTJ(93).EQ.1) THEN
- PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
- ELSE
- PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
- ENDIF
-
-C...Other masses can be read directly off table.
- ELSE
- PYMASS=PMAS(KC,1)
- ENDIF
-
-C...Optional mass broadening according to truncated Breit-Wigner
-C...(either in m or in m^2).
- IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
- IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
- PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
- & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
- ELSE
- PM0=PYMASS
- PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
- & (PM0*PMAS(KC,2)))
- PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
- PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
- & (PMUPP-PMLOW)*PYR(0))))
- ENDIF
- ENDIF
- MSTJ(93)=0
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYMRUN
-C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
-C...for Higgs couplings. Everything else sent on to PYMASS.
-
- FUNCTION PYMRUN(KF,Q2)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
-
-C...Most masses not handled here.
- KFA=IABS(KF)
- IF(KFA.EQ.0.OR.KFA.GT.6) THEN
- PYMRUN=PYMASS(KF)
-
-C...Current-algebra masses, but no Q2 dependence.
- ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
- PYMRUN=PARF(90+KFA)
-
-C...Running current-algebra masses.
- ELSE
- AS=PYALPS(Q2)
- PYMRUN=PARF(90+KFA)*
- & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
- & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYNAME
-C...Gives the particle/parton name as a character string.
-
- SUBROUTINE PYNAME(KF,CHAU)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT4/CHAF(500,2)
- CHARACTER CHAF*16
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
-C...Local character variable.
- CHARACTER CHAU*16
-
-C...Read out code with distinction particle/antiparticle.
- CHAU=' '
- KC=PYCOMP(KF)
- IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
-
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYCHGE
-C...Gives three times the charge for a particle/parton.
-
- FUNCTION PYCHGE(KF)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYDAT2/
-
-C...Read out charge and change sign for antiparticle.
- PYCHGE=0
- KC=PYCOMP(KF)
- IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYCOMP
-C...Compress the standard KF codes for use in mass and decay arrays;
-C...also checks whether a given code actually is defined.
-
- FUNCTION PYCOMP(KF)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYDAT1/,/PYDAT2/
-C...Local arrays and saved data.
- DIMENSION KFORD(100:500),KCORD(101:500)
- SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
-
-C...Whenever necessary reorder codes for faster search.
- IF(MSTU(20).EQ.0) THEN
- NFORD=100
- KFORD(100)=0
- DO 120 I=101,500
- KFA=KCHG(I,4)
- IF(KFA.LE.100) GOTO 120
- NFORD=NFORD+1
- DO 100 I1=NFORD-1,0,-1
- IF(KFA.GE.KFORD(I1)) GOTO 110
- KFORD(I1+1)=KFORD(I1)
- KCORD(I1+1)=KCORD(I1)
- 100 CONTINUE
- 110 KFORD(I1+1)=KFA
- KCORD(I1+1)=I
- 120 CONTINUE
- MSTU(20)=1
- KFLAST=0
- KCLAST=0
- ENDIF
-
-C...Fast action if same code as in latest call.
- IF(KF.EQ.KFLAST) THEN
- PYCOMP=KCLAST
- RETURN
- ENDIF
-
-C...Starting values. Remove internal diquark flags.
- PYCOMP=0
- KFA=IABS(KF)
- IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
- & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
-
-C...Simple cases: direct translation.
- IF(KFA.GT.KFORD(NFORD)) THEN
- ELSEIF(KFA.LE.100) THEN
- PYCOMP=KFA
-
-C...Else binary search.
- ELSE
- IMIN=100
- IMAX=NFORD+1
- 130 IAVG=(IMIN+IMAX)/2
- IF(KFORD(IAVG).GT.KFA) THEN
- IMAX=IAVG
- IF(IMAX.GT.IMIN+1) GOTO 130
- ELSEIF(KFORD(IAVG).LT.KFA) THEN
- IMIN=IAVG
- IF(IMAX.GT.IMIN+1) GOTO 130
- ELSE
- PYCOMP=KCORD(IAVG)
- ENDIF
- ENDIF
-
-C...Check if antiparticle allowed.
- IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
- IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
- ENDIF
-
-C...Save codes for possible future fast action.
- KFLAST=KF
- KCLAST=PYCOMP
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYERRM
-C...Informs user of errors in program execution.
-
- SUBROUTINE PYERRM(MERR,CHMESS)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYJETS/,/PYDAT1/
-C...Local character variable.
- CHARACTER CHMESS*(*)
-
-C...Write first few warnings, then be silent.
- IF(MERR.LE.10) THEN
- MSTU(27)=MSTU(27)+1
- MSTU(28)=MERR
- IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
- & MERR,MSTU(31),CHMESS
-
-C...Write first few errors, then be silent or stop program.
- ELSEIF(MERR.LE.20) THEN
- IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
- MSTU(30)=MSTU(30)+1
- MSTU(24)=MERR-10
- IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
- & MERR-10,MSTU(31),CHMESS
- IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
- WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
- WRITE(MSTU(11),5200)
- IF(MERR.NE.17) CALL PYLIST(2)
- CALL PYSTOP(3)
- ENDIF
-
-C...Stop program in case of irreparable error.
- ELSE
- WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
- CALL PYSTOP(3)
- ENDIF
-
-C...Formats for output.
- 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
- &' PYEXEC calls:'/5X,A)
- 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
- &' PYEXEC calls:'/5X,A)
- 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
- &'event!')
- 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
- &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYALEM
-C...Calculates the running alpha_electromagnetic.
-
- FUNCTION PYALEM(Q2)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-
-C...Calculate real part of photon vacuum polarization.
-C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
-C...For hadrons use parametrization of H. Burkhardt et al.
-C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
- AEMPI=PARU(101)/(3D0*PARU(1))
- IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
- RPIGG=0D0
- ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
- RPIGG=0D0
- ELSEIF(MSTU(101).EQ.2) THEN
- RPIGG=1D0-PARU(101)/PARU(103)
- ELSEIF(Q2.LT.0.09D0) THEN
- RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
- ELSEIF(Q2.LT.9D0) THEN
- RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
- & 0.00238D0*LOG(1D0+3.927D0*Q2)
- ELSEIF(Q2.LT.1D4) THEN
- RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
- & 0.00299D0*LOG(1D0+Q2)
- ELSE
- RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
- & 0.00293D0*LOG(1D0+Q2)
- ENDIF
-
-C...Calculate running alpha_em.
- PYALEM=PARU(101)/(1D0-RPIGG)
- PARU(108)=PYALEM
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYALPS
-C...Gives the value of alpha_strong.
-
- FUNCTION PYALPS(Q2)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYDAT1/,/PYDAT2/
-C...Coefficients for second-order threshold matching.
-C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
- DIMENSION STEPDN(6),STEPUP(6)
-c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
-c &(2D0*321D0/3703D0),0D0/
-c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
-c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
- DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
- DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
-
-C...Constant alpha_strong trivial. Pick artificial Lambda.
- IF(MSTU(111).LE.0) THEN
- PYALPS=PARU(111)
- MSTU(118)=MSTU(112)
- PARU(117)=0.2D0
- IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
- & ((33D0-2D0*MSTU(112))*PARU(111)))
- PARU(118)=PARU(111)
- RETURN
- ENDIF
-
-C...Find effective Q2, number of flavours and Lambda.
- Q2EFF=Q2
- IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
- NF=MSTU(112)
- ALAM2=PARU(112)**2
- 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
- Q2THR=PARU(113)*PMAS(NF,1)**2
- IF(Q2EFF.LT.Q2THR) THEN
- NF=NF-1
- Q2RAT=Q2THR/ALAM2
- ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
- IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
- GOTO 100
- ENDIF
- ENDIF
- 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
- Q2THR=PARU(113)*PMAS(NF+1,1)**2
- IF(Q2EFF.GT.Q2THR) THEN
- NF=NF+1
- Q2RAT=Q2THR/ALAM2
- ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
- IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
- GOTO 110
- ENDIF
- ENDIF
- IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
- PARU(117)=SQRT(ALAM2)
-
-C...Evaluate first or second order alpha_strong.
- B0=(33D0-2D0*NF)/6D0
- ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
- IF(MSTU(111).EQ.1) THEN
- PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
- ELSE
- B1=(153D0-19D0*NF)/6D0
- PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
- & (B0**2*ALGQ)))
- ENDIF
- MSTU(118)=NF
- PARU(118)=PYALPS
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYANGL
-C...Reconstructs an angle from given x and y coordinates.
-
- FUNCTION PYANGL(X,Y)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-
- PYANGL=0D0
- R=SQRT(X**2+Y**2)
- IF(R.LT.1D-20) RETURN
- IF(ABS(X)/R.LT.0.8D0) THEN
- PYANGL=SIGN(ACOS(X/R),Y)
- ELSE
- PYANGL=ASIN(Y/R)
- IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
- PYANGL=PARU(1)-PYANGL
- ELSEIF(X.LT.0D0) THEN
- PYANGL=-PARU(1)-PYANGL
- ENDIF
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYROBO
-C...Performs rotations and boosts.
-
- SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYJETS/,/PYDAT1/
-C...Local arrays.
- DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
-
-C...Find and check range of rotation/boost.
- IMIN=IMI
- IF(IMIN.LE.0) IMIN=1
- IF(MSTU(1).GT.0) IMIN=MSTU(1)
- IMAX=IMA
- IF(IMAX.LE.0) IMAX=N
- IF(MSTU(2).GT.0) IMAX=MSTU(2)
- IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
- CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
- RETURN
- ENDIF
-
-C...Optional resetting of V (when not set before.)
- IF(MSTU(33).NE.0) THEN
- DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
- DO 100 J=1,5
- V(I,J)=0D0
- 100 CONTINUE
- 110 CONTINUE
- MSTU(33)=0
- ENDIF
-
-C...Rotate, typically from z axis to direction (theta,phi).
- IF(THE**2+PHI**2.GT.1D-20) THEN
- ROT(1,1)=COS(THE)*COS(PHI)
- ROT(1,2)=-SIN(PHI)
- ROT(1,3)=SIN(THE)*COS(PHI)
- ROT(2,1)=COS(THE)*SIN(PHI)
- ROT(2,2)=COS(PHI)
- ROT(2,3)=SIN(THE)*SIN(PHI)
- ROT(3,1)=-SIN(THE)
- ROT(3,2)=0D0
- ROT(3,3)=COS(THE)
- DO 140 I=IMIN,IMAX
- IF(K(I,1).LE.0) GOTO 140
- DO 120 J=1,3
- PR(J)=P(I,J)
- VR(J)=V(I,J)
- 120 CONTINUE
- DO 130 J=1,3
- P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
- V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
- 130 CONTINUE
- 140 CONTINUE
- ENDIF
-
-C...Boost, typically from rest to momentum/energy=beta.
- IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
- DBX=BEX
- DBY=BEY
- DBZ=BEZ
- DB=SQRT(DBX**2+DBY**2+DBZ**2)
- EPS1=1D0-1D-12
- IF(DB.GT.EPS1) THEN
-C...Rescale boost vector if too close to unity.
- CALL PYERRM(3,'(PYROBO:) boost vector too large')
- DBX=DBX*(EPS1/DB)
- DBY=DBY*(EPS1/DB)
- DBZ=DBZ*(EPS1/DB)
- DB=EPS1
- ENDIF
- DGA=1D0/SQRT(1D0-DB**2)
- DO 160 I=IMIN,IMAX
- IF(K(I,1).LE.0) GOTO 160
- DO 150 J=1,4
- DP(J)=P(I,J)
- DV(J)=V(I,J)
- 150 CONTINUE
- DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
- DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
- P(I,1)=DP(1)+DGABP*DBX
- P(I,2)=DP(2)+DGABP*DBY
- P(I,3)=DP(3)+DGABP*DBZ
- P(I,4)=DGA*(DP(4)+DBP)
- DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
- DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
- V(I,1)=DV(1)+DGABV*DBX
- V(I,2)=DV(2)+DGABV*DBY
- V(I,3)=DV(3)+DGABV*DBZ
- V(I,4)=DGA*(DV(4)+DBV)
- 160 CONTINUE
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYEDIT
-C...Performs global manipulations on the event record, in particular
-C...to exclude unstable or undetectable partons/particles.
-
- SUBROUTINE PYEDIT(MEDIT)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYCTAG/NCT,MCT(4000,2)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
-C...Local arrays.
- DIMENSION NS(2),PTS(2),PLS(2)
-
-C...Remove unwanted partons/particles.
- IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
- IMAX=N
- IF(MSTU(2).GT.0) IMAX=MSTU(2)
- I1=MAX(1,MSTU(1))-1
- DO 110 I=MAX(1,MSTU(1)),IMAX
- IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
- IF(MEDIT.EQ.1) THEN
- IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
- ELSEIF(MEDIT.EQ.2) THEN
- IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
- & K(I,2).EQ.KSUSY1+39) GOTO 110
- ELSEIF(MEDIT.EQ.3) THEN
- IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0) GOTO 110
- IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
- ELSEIF(MEDIT.EQ.5) THEN
- IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0) GOTO 110
- IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
- & KCHG(KC,2).EQ.0) GOTO 110
- ENDIF
-
-C...Pack remaining partons/particles. Origin no longer known.
- I1=I1+1
- DO 100 J=1,5
- K(I1,J)=K(I,J)
- P(I1,J)=P(I,J)
- V(I1,J)=V(I,J)
- 100 CONTINUE
- K(I1,3)=0
- 110 CONTINUE
- IF(I1.LT.N) MSTU(3)=0
- IF(I1.LT.N) MSTU(70)=0
- N=I1
-
-C...Selective removal of class of entries. New position of retained.
- ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
- I1=0
- DO 120 I=1,N
- K(I,3)=MOD(K(I,3),MSTU(5))
- IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
- IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
- IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
- & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
- IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
- & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
- IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
- I1=I1+1
- K(I,3)=K(I,3)+MSTU(5)*I1
- 120 CONTINUE
-
-C...Find new event history information and replace old.
- DO 140 I=1,N
- IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
- & K(I,3)/MSTU(5).EQ.0) GOTO 140
- ID=I
- 130 IM=MOD(K(ID,3),MSTU(5))
- IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
- IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
- & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
- ID=IM
- GOTO 130
- ENDIF
- ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
- IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
- & K(IM,2).EQ.94) THEN
- ID=IM
- GOTO 130
- ENDIF
- ENDIF
- K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
- IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
- IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
- & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
- IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
- & K(K(I,4),3)/MSTU(5)
- IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
- & K(K(I,5),3)/MSTU(5)
- ELSE
- KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
- IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
- & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
- KCD=MOD(K(I,4),MSTU(5))
- IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
- K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
- KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
- IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
- KCD=MOD(K(I,5),MSTU(5))
- IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
- K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
- ENDIF
- 140 CONTINUE
-
-C...Pack remaining entries.
- I1=0
- MSTU90=MSTU(90)
- MSTU(90)=0
- DO 170 I=1,N
- IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
- I1=I1+1
- DO 150 J=1,5
- K(I1,J)=K(I,J)
- P(I1,J)=P(I,J)
- V(I1,J)=V(I,J)
- 150 CONTINUE
-C...Also update LHA1 colour tags
- MCT(I1,1)=MCT(I,1)
- MCT(I1,2)=MCT(I,2)
- K(I1,3)=MOD(K(I1,3),MSTU(5))
- DO 160 IZ=1,MSTU90
- IF(I.EQ.MSTU(90+IZ)) THEN
- MSTU(90)=MSTU(90)+1
- MSTU(90+MSTU(90))=I1
- PARU(90+MSTU(90))=PARU(90+IZ)
- ENDIF
- 160 CONTINUE
- 170 CONTINUE
- IF(I1.LT.N) MSTU(3)=0
- IF(I1.LT.N) MSTU(70)=0
- N=I1
-
-C...Fill in some missing daughter pointers (lost in colour flow).
- ELSEIF(MEDIT.EQ.16) THEN
- DO 220 I=1,N
- IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
- IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
-C...Find daughters who point to mother.
- DO 180 I1=I+1,N
- IF(K(I1,3).NE.I) THEN
- ELSEIF(K(I,4).EQ.0) THEN
- K(I,4)=I1
- ELSE
- K(I,5)=I1
- ENDIF
- 180 CONTINUE
- IF(K(I,5).EQ.0) K(I,5)=K(I,4)
- IF(K(I,4).NE.0) GOTO 220
-C...Find daughters who point to documentation version of mother.
- IM=K(I,3)
- IF(IM.LE.0.OR.IM.GE.I) GOTO 220
- IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
- IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
- DO 190 I1=I+1,N
- IF(K(I1,3).NE.IM) THEN
- ELSEIF(K(I,4).EQ.0) THEN
- K(I,4)=I1
- ELSE
- K(I,5)=I1
- ENDIF
- 190 CONTINUE
- IF(K(I,5).EQ.0) K(I,5)=K(I,4)
- IF(K(I,4).NE.0) GOTO 220
-C...Find daughters who point to documentation daughters who,
-C...in their turn, point to documentation mother.
- ID1=IM
- ID2=IM
- DO 200 I1=IM+1,I-1
- IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
- ID2=I1
- IF(ID1.EQ.IM) ID1=I1
- ENDIF
- 200 CONTINUE
- DO 210 I1=I+1,N
- IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
- ELSEIF(K(I,4).EQ.0) THEN
- K(I,4)=I1
- ELSE
- K(I,5)=I1
- ENDIF
- 210 CONTINUE
- IF(K(I,5).EQ.0) K(I,5)=K(I,4)
- 220 CONTINUE
-
-C...Save top entries at bottom of PYJETS commonblock.
- ELSEIF(MEDIT.EQ.21) THEN
- IF(2*N.GE.MSTU(4)) THEN
- CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
- RETURN
- ENDIF
- DO 240 I=1,N
- DO 230 J=1,5
- K(MSTU(4)-I,J)=K(I,J)
- P(MSTU(4)-I,J)=P(I,J)
- V(MSTU(4)-I,J)=V(I,J)
- 230 CONTINUE
- 240 CONTINUE
- MSTU(32)=N
-
-C...Restore bottom entries of commonblock PYJETS to top.
- ELSEIF(MEDIT.EQ.22) THEN
- DO 260 I=1,MSTU(32)
- DO 250 J=1,5
- K(I,J)=K(MSTU(4)-I,J)
- P(I,J)=P(MSTU(4)-I,J)
- V(I,J)=V(MSTU(4)-I,J)
- 250 CONTINUE
- 260 CONTINUE
- N=MSTU(32)
-
-C...Mark primary entries at top of commonblock PYJETS as untreated.
- ELSEIF(MEDIT.EQ.23) THEN
- I1=0
- DO 270 I=1,N
- KH=K(I,3)
- IF(KH.GE.1) THEN
- IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
- ENDIF
- IF(KH.NE.0) GOTO 280
- I1=I1+1
- IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
- IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
- 270 CONTINUE
- 280 N=I1
-
-C...Place largest axis along z axis and second largest in xy plane.
- ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
- CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
- & P(MSTU(61),2)),0D0,0D0,0D0)
- CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
- & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
- CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
- & P(MSTU(61)+1,2)),0D0,0D0,0D0)
- IF(MEDIT.EQ.31) RETURN
-
-C...Rotate to put slim jet along +z axis.
- DO 290 IS=1,2
- NS(IS)=0
- PTS(IS)=0D0
- PLS(IS)=0D0
- 290 CONTINUE
- DO 300 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
- IF(MSTU(41).GE.2) THEN
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
- & K(I,2).EQ.KSUSY1+39) GOTO 300
- IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
- & .EQ.0) GOTO 300
- ENDIF
- IS=2D0-SIGN(0.5D0,P(I,3))
- NS(IS)=NS(IS)+1
- PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
- 300 CONTINUE
- IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
- & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
-
-C...Rotate to put second largest jet into -z,+x quadrant.
- DO 310 I=1,N
- IF(P(I,3).GE.0D0) GOTO 310
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
- IF(MSTU(41).GE.2) THEN
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
- & K(I,2).EQ.KSUSY1+39) GOTO 310
- IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
- & .EQ.0) GOTO 310
- ENDIF
- IS=2D0-SIGN(0.5D0,P(I,1))
- PLS(IS)=PLS(IS)-P(I,3)
- 310 CONTINUE
- IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
- & 0D0,0D0,0D0)
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYLIST
-C...Gives program heading, or lists an event, or particle
-C...data, or current parameter values.
-
- SUBROUTINE PYLIST(MLIST)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-
-C...HEPEVT commonblock.
- PARAMETER (NMXHEP=4000)
- COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
- DOUBLE PRECISION PHEP,VHEP
- SAVE /HEPEVT/
-
-C...User process event common block.
- INTEGER MAXNUP
- PARAMETER (MAXNUP=500)
- INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
- DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
- COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
- &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
- &VTIMUP(MAXNUP),SPINUP(MAXNUP)
- SAVE /HEPEUP/
-
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYCTAG/NCT,MCT(4000,2)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
-C...Local arrays, character variables and data.
- CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
- DIMENSION PS(6)
- DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
-
-C...Initialization printout: version number and date of last change.
- IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
- CALL PYLOGO
- MSTU(12)=12345
- IF(MLIST.EQ.0) RETURN
- ENDIF
-
-C...List event data, including additional lines after N.
- IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
- IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
- IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
- IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
- IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
- LMX=12
- IF(MLIST.GE.2) LMX=16
- ISTR=0
- IMAX=N
- IF(MSTU(2).GT.0) IMAX=MSTU(2)
- DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
- IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
- IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
- IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
-
-C...Get particle name, pad it and check it is not too long.
- CALL PYNAME(K(I,2),CHAP)
- LEN=0
- DO 100 LEM=1,16
- IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
- 100 CONTINUE
- MDL=(K(I,1)+19)/10
- LDL=0
- IF(MDL.EQ.2.OR.MDL.GE.8) THEN
- CHAC=CHAP
- IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
- ELSE
- LDL=1
- IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
- IF(LEN.EQ.0) THEN
- CHAC=CHDL(MDL)(1:2*LDL)//' '
- ELSE
- CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
- & CHDL(MDL)(LDL+1:2*LDL)//' '
- IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
- ENDIF
- ENDIF
-
-C...Add information on string connection.
- IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
- & THEN
- KC=PYCOMP(K(I,2))
- KCC=0
- IF(KC.NE.0) KCC=KCHG(KC,2)
- IF(IABS(K(I,2)).EQ.39) THEN
- IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
- ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
- ISTR=1
- IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
- ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
- IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
- ELSEIF(KCC.NE.0) THEN
- ISTR=0
- IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
- ENDIF
- ENDIF
- IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
- & CHAC(LMX-1:LMX-1)='I'
-
-C...Write data for particle/jet.
- IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
- WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
- & (P(I,J2),J2=1,5)
- ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
- WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
- & (P(I,J2),J2=1,5)
- ELSEIF(MLIST.EQ.1) THEN
- WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
- & (P(I,J2),J2=1,5)
- ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
- & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
- IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
- & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
- & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
- & (P(I,J2),J2=1,5)
- IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
- & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
- & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
- & ,10000),MCT(I,1),MCT(I,2)
- ELSE
- IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
- & (P(I,J2),J2=1,5)
- IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
- & ,MCT(I,1),MCT(I,2)
- ENDIF
- IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
-
-C...Insert extra separator lines specified by user.
- IF(MSTU(70).GE.1) THEN
- ISEP=0
- DO 110 J=1,MIN(10,MSTU(70))
- IF(I.EQ.MSTU(70+J)) ISEP=1
- 110 CONTINUE
- IF(ISEP.EQ.1) THEN
- IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
- IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
- IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
- ENDIF
- ENDIF
- 120 CONTINUE
-
-C...Sum of charges and momenta.
- DO 130 J=1,6
- PS(J)=PYP(0,J)
- 130 CONTINUE
- IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
- WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
- ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
- WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
- ELSEIF(MLIST.EQ.1) THEN
- WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
- ELSEIF(MLIST.LE.3) THEN
- WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
- ELSE
- WRITE(MSTU(11),7000) PS(6)
- ENDIF
-
-C...Simple listing of HEPEVT entries (mainly for test purposes).
- ELSEIF(MLIST.EQ.5) THEN
- WRITE(MSTU(11),7100)
- DO 140 I=1,NHEP
- IF(ISTHEP(I).EQ.0) GOTO 140
- WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
- & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
- 140 CONTINUE
-
-
-C...Simple listing of user-process entries (mainly for test purposes).
- ELSEIF(MLIST.EQ.7) THEN
- WRITE(MSTU(11),7300)
- DO 150 I=1,NUP
- WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
- & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
- 150 CONTINUE
-
-C...Give simple list of KF codes defined in program.
- ELSEIF(MLIST.EQ.11) THEN
- WRITE(MSTU(11),7500)
- DO 160 KF=1,80
- CALL PYNAME(KF,CHAP)
- CALL PYNAME(-KF,CHAN)
- IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
- IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
- 160 CONTINUE
- DO 190 KFLS=1,3,2
- DO 180 KFLA=1,5
- DO 170 KFLB=1,KFLA-(3-KFLS)/2
- KF=1000*KFLA+100*KFLB+KFLS
- CALL PYNAME(KF,CHAP)
- CALL PYNAME(-KF,CHAN)
- WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
- 170 CONTINUE
- 180 CONTINUE
- 190 CONTINUE
- DO 220 KMUL=0,5
- KFLS=3
- IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
- IF(KMUL.EQ.5) KFLS=5
- KFLR=0
- IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
- IF(KMUL.EQ.4) KFLR=2
- DO 210 KFLB=1,5
- DO 200 KFLC=1,KFLB-1
- KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
- CALL PYNAME(KF,CHAP)
- CALL PYNAME(-KF,CHAN)
- WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
- IF(KF.EQ.311) THEN
- KFK=130
- CALL PYNAME(KFK,CHAP)
- WRITE(MSTU(11),7600) KFK,CHAP
- KFK=310
- CALL PYNAME(KFK,CHAP)
- WRITE(MSTU(11),7600) KFK,CHAP
- ENDIF
- 200 CONTINUE
- KF=10000*KFLR+110*KFLB+KFLS
- CALL PYNAME(KF,CHAP)
- WRITE(MSTU(11),7600) KF,CHAP
- 210 CONTINUE
- 220 CONTINUE
- KF=100443
- CALL PYNAME(KF,CHAP)
- WRITE(MSTU(11),7600) KF,CHAP
- KF=100553
- CALL PYNAME(KF,CHAP)
- WRITE(MSTU(11),7600) KF,CHAP
- DO 260 KFLSP=1,3
- KFLS=2+2*(KFLSP/3)
- DO 250 KFLA=1,5
- DO 240 KFLB=1,KFLA
- DO 230 KFLC=1,KFLB
- IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
- & GOTO 230
- IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
- IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
- IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
- CALL PYNAME(KF,CHAP)
- CALL PYNAME(-KF,CHAN)
- WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
- 230 CONTINUE
- 240 CONTINUE
- 250 CONTINUE
- 260 CONTINUE
- DO 270 KC=1,500
- KF=KCHG(KC,4)
- IF(KF.LT.1000000) GOTO 270
- CALL PYNAME(KF,CHAP)
- CALL PYNAME(-KF,CHAN)
- IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
- IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
- 270 CONTINUE
-
-C...List parton/particle data table. Check whether to be listed.
- ELSEIF(MLIST.EQ.12) THEN
- WRITE(MSTU(11),7700)
- DO 300 KC=1,MSTU(6)
- KF=KCHG(KC,4)
- IF(KF.EQ.0) GOTO 300
- IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
- & GOTO 300
-
-C...Find particle name and mass. Print information.
- CALL PYNAME(KF,CHAP)
- IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
- CALL PYNAME(-KF,CHAN)
- WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
- & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
-
-C...Particle decay: channel number, branching ratios, matrix element,
-C...decay products.
- DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
- DO 280 J=1,5
- CALL PYNAME(KFDP(IDC,J),CHAD(J))
- 280 CONTINUE
- WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
- & (CHAD(J),J=1,5)
- 290 CONTINUE
- 300 CONTINUE
-
-C...List parameter value table.
- ELSEIF(MLIST.EQ.13) THEN
- WRITE(MSTU(11),8000)
- DO 310 I=1,200
- WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
- 310 CONTINUE
- ENDIF
-
-C...Format statements for output on unit MSTU(11) (by default 6).
- 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
- &5X,'KF orig p_x p_y p_z E m'/)
- 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
- &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
- &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
- 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
- &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
- &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
- &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
- 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
- & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
- & ,' C tag AC tag'/)
- 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
- 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
- 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
- 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
- 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
- 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
- 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
- 6200 FORMAT(66X,5(1X,F12.3))
- 6300 FORMAT(1X,78('='))
- 6400 FORMAT(1X,130('='))
- 6500 FORMAT(1X,65('='))
- 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
- 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
- 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
- 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
- &5F13.5)
- 7000 FORMAT(19X,'sum charge:',F6.2)
- 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
- &//' I IST ID Mothers Daughters p_x p_y p_z',
- &' E m')
- 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
- 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
- &//' I IST ID Mothers Colours p_x p_y p_z',
- &' E m')
- 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
- 7500 FORMAT(///20X,'List of KF codes in program'/)
- 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
- 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
- &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
- &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
- &1X,'ME',3X,'Br.rat.',4X,'decay products')
- 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
- &1X,1P,E13.5,3X,I2)
- 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
- 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
- &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
- 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYLOGO
-C...Writes a logo for the program.
-
- SUBROUTINE PYLOGO
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter for length of information block.
- PARAMETER (IREFER=21)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- SAVE /PYDAT1/,/PYPARS/
-C...Local arrays and character variables.
- INTEGER IDATI(6)
- CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
- &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
-
-C...Data on months, logo, titles, and references.
- DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
- &'Oct','Nov','Dec'/
- DATA (LOGO(J),J=1,19)/
- &' *......* ',
- &' *:::!!:::::::::::* ',
- &' *::::::!!::::::::::::::* ',
- &' *::::::::!!::::::::::::::::* ',
- &' *:::::::::!!:::::::::::::::::* ',
- &' *:::::::::!!:::::::::::::::::* ',
- &' *::::::::!!::::::::::::::::*! ',
- &' *::::::!!::::::::::::::* !! ',
- &' !! *:::!!:::::::::::* !! ',
- &' !! !* -><- * !! ',
- &' !! !! !! ',
- &' !! !! !! ',
- &' !! !! ',
- &' !! lh !! ',
- &' !! !! ',
- &' !! hh !! ',
- &' !! ll !! ',
- &' !! !! ',
- &' !! '/
- DATA (LOGO(J),J=20,38)/
- &'Welcome to the Lund Monte Carlo!',
- &' ',
- &'PPP Y Y TTTTT H H III A ',
- &'P P Y Y T H H I A A ',
- &'PPP Y T HHHHH I AAAAA',
- &'P Y T H H I A A',
- &'P Y T H H III A A',
- &' ',
- &'This is PYTHIA version x.xxx ',
- &'Last date of change: xx xxx 200x',
- &' ',
- &'Now is xx xxx 200x at xx:xx:xx ',
- &' ',
- &'Disclaimer: this program comes ',
- &'without any guarantees. Beware ',
- &'of errors and use common sense ',
- &'when interpreting results. ',
- &' ',
- &'Copyright T. Sjostrand (2007) '/
- DATA (REFER(J),J=1,14)/
- &'An archive of program versions and d',
- &'ocumentation is found on the web: ',
- &'http://www.thep.lu.se/~torbjorn/Pyth',
- &'ia.html ',
- &' ',
- &' ',
- &'When you cite this program, the offi',
- &'cial reference is to the 6.4 manual:',
- &'T. Sjostrand, S. Mrenna and P. Skand',
- &'s, JHEP05 (2006) 026 ',
- &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
- &'-T) [hep-ph/0603175]. ',
- &' ',
- &' '/
- DATA (REFER(J),J=15,32)/
- &'Also remember that the program, to a',
- &' large extent, represents original ',
- &'physics research. Other publications',
- &' of special relevance to your ',
- &'studies may therefore deserve separa',
- &'te mention. ',
- &' ',
- &' ',
- &'Main author: Torbjorn Sjostrand; CER',
- &'N/PH, CH-1211 Geneva, Switzerland, ',
- &' and Department of Theoretical Phys',
- &'ics, Lund University, Lund, Sweden; ',
- &' phone: + 41 - 22 - 767 82 27; e-ma',
- &'il: torbjorn@thep.lu.se ',
- &'Author: Stephen Mrenna; Computing Di',
- &'vision, GDS Group, ',
- &' Fermi National Accelerator Laborat',
- &'ory, MS 234, Batavia, IL 60510, USA;'/
- DATA (REFER(J),J=33,2*IREFER)/
- &' phone: + 1 - 630 - 840 - 2556; e-m',
- &'ail: mrenna@fnal.gov ',
- &'Author: Peter Skands; Theoretical Ph',
- &'ysics Department, ',
- &' Fermi National Accelerator Laborat',
- &'ory, MS 106, Batavia, IL 60510, USA;',
- &' and CERN/PH, CH-1211 Geneva, Switz',
- &'erland; ',
- &' phone: + 41 - 22 - 767 24 59; e-ma',
- &'il: skands@fnal.gov '/
-
-C...Check that PYDATA linked.
- IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
- WRITE(*,'(1X,A)')
- & 'Error: PYDATA has not been linked.'
- WRITE(*,'(1X,A)') 'Execution stopped!'
- CALL PYSTOP(8)
-
-C...Write current version number and current date+time.
- ELSE
- WRITE(VERS,'(I1)') MSTP(181)
- LOGO(28)(24:24)=VERS
- WRITE(SUBV,'(I3)') MSTP(182)
- LOGO(28)(26:28)=SUBV
- IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
- WRITE(DATE,'(I2)') MSTP(185)
- LOGO(29)(22:23)=DATE
- LOGO(29)(25:27)=MONTH(MSTP(184))
- WRITE(YEAR,'(I4)') MSTP(183)
- LOGO(29)(29:32)=YEAR
- CALL PYTIME(IDATI)
- IF(IDATI(1).LE.0) THEN
- LOGO(31)=' '
- ELSE
- WRITE(DATE,'(I2)') IDATI(3)
- LOGO(31)(8:9)=DATE
- LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
- WRITE(YEAR,'(I4)') IDATI(1)
- LOGO(31)(15:18)=YEAR
- WRITE(HOUR,'(I2)') IDATI(4)
- LOGO(31)(23:24)=HOUR
- WRITE(MINU,'(I2)') IDATI(5)
- LOGO(31)(26:27)=MINU
- IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
- WRITE(SECO,'(I2)') IDATI(6)
- LOGO(31)(29:30)=SECO
- IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
- ENDIF
- ENDIF
-
-C...Loop over lines in header. Define page feed and side borders.
- DO 100 ILIN=1,29+IREFER
- LINE=' '
- IF(ILIN.EQ.1) THEN
- LINE(1:1)='1'
- ELSE
- LINE(2:3)='**'
- LINE(78:79)='**'
- ENDIF
-
-C...Separator lines and logos.
- IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
- LINE(4:77)='***********************************************'//
- & '***************************'
- ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
- LINE(6:37)=LOGO(ILIN-5)
- LINE(44:75)=LOGO(ILIN+14)
- ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
- LINE(5:40)=REFER(2*ILIN-51)
- LINE(41:76)=REFER(2*ILIN-50)
- ENDIF
-
-C...Write lines to appropriate unit.
- WRITE(MSTU(11),'(A79)') LINE
- 100 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYUPDA
-C...Facilitates the updating of particle and decay data
-C...by allowing it to be done in an external file.
-
- SUBROUTINE PYUPDA(MUPDA,LFN)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- COMMON/PYDAT4/CHAF(500,2)
- CHARACTER CHAF*16
- COMMON/PYINT4/MWID(500),WIDS(500,5)
- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
-C...Local arrays, character variables and data.
- CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
- &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
- DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
- &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
- &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
- &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
- &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
-
-C...Write header if not yet done.
- IF(MSTU(12).NE.12345) CALL PYLIST(0)
-
-C...Write information on file for editing.
- IF(MUPDA.EQ.1) THEN
- DO 110 KC=1,500
- WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
- & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
- & MWID(KC),MDCY(KC,1)
- DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
- WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
- & (KFDP(IDC,J),J=1,5)
- 100 CONTINUE
- 110 CONTINUE
-
-C...Read complete set of information from edited file or
-C...read partial set of new or updated information from edited file.
- ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
-
-C...Reset counters.
- KCC=100
- NDC=0
- CHKF=' '
- IF(MUPDA.EQ.2) THEN
- DO 120 I=1,MSTU(6)
- KCHG(I,4)=0
- 120 CONTINUE
- ELSE
- DO 130 KC=1,MSTU(6)
- IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
- NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
- 130 CONTINUE
- ENDIF
-
-C...Begin of loop: read new line; unknown whether particle or
-C...decay data.
- 140 READ(LFN,5200,END=190) CHINL
-
-C...Identify particle code and whether already defined (for MUPDA=3).
- IF(CHINL(2:10).NE.' ') THEN
- CHKF=CHINL(2:10)
- READ(CHKF,5300) KF
- IF(MUPDA.EQ.2) THEN
- IF(KF.LE.100) THEN
- KC=KF
- ELSE
- KCC=KCC+1
- KC=KCC
- ENDIF
- ELSE
- KCREP=0
- IF(KF.LE.100) THEN
- KCREP=KF
- ELSE
- DO 150 KCR=101,KCC
- IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
- 150 CONTINUE
- ENDIF
-C...Remove duplicate old decay data.
- IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
- IDCREP=MDCY(KCREP,2)
- NDCREP=MDCY(KCREP,3)
- DO 160 I=1,KCC
- IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
- 160 CONTINUE
- DO 180 I=IDCREP,NDC-NDCREP
- MDME(I,1)=MDME(I+NDCREP,1)
- MDME(I,2)=MDME(I+NDCREP,2)
- BRAT(I)=BRAT(I+NDCREP)
- DO 170 J=1,5
- KFDP(I,J)=KFDP(I+NDCREP,J)
- 170 CONTINUE
- 180 CONTINUE
- NDC=NDC-NDCREP
- KC=KCREP
- ELSEIF(KCREP.NE.0) THEN
- KC=KCREP
- ELSE
- KCC=KCC+1
- KC=KCC
- ENDIF
- ENDIF
-
-C...Study line with particle data.
- IF(KC.GT.MSTU(6)) CALL PYERRM(27,
- & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
- READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
- & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
- & MWID(KC),MDCY(KC,1)
- MDCY(KC,2)=0
- MDCY(KC,3)=0
-
-C...Study line with decay data.
- ELSE
- NDC=NDC+1
- IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
- & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
- IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
- MDCY(KC,3)=MDCY(KC,3)+1
- READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
- & (KFDP(NDC,J),J=1,5)
- ENDIF
-
-C...End of loop; ensure that PYCOMP tables are updated.
- GOTO 140
- 190 CONTINUE
- MSTU(20)=0
-
-C...Perform possible tests that new information is consistent.
- DO 220 KC=1,MSTU(6)
- KF=KCHG(KC,4)
- IF(KF.EQ.0) GOTO 220
- WRITE(CHKF,5300) KF
- IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
- & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
- & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
- BRSUM=0D0
- DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
- IF(MDME(IDC,2).GT.80) GOTO 210
- KQ=KCHG(KC,1)
- PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
- MERR=0
- DO 200 J=1,5
- KP=KFDP(IDC,J)
- IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
- IF(KP.EQ.81) KQ=0
- ELSEIF(PYCOMP(KP).EQ.0) THEN
- MERR=3
- ELSE
- KQ=KQ-PYCHGE(KP)
- KPC=PYCOMP(KP)
- PMS=PMS-PMAS(KPC,1)
- IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
- & PMAS(KPC,3))
- ENDIF
- 200 CONTINUE
- IF(KQ.NE.0) MERR=MAX(2,MERR)
- IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
- & MERR=MAX(1,MERR)
- IF(MERR.EQ.3) CALL PYERRM(17,
- & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
- IF(MERR.EQ.2) CALL PYERRM(17,
- & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
- IF(MERR.EQ.1) CALL PYERRM(7,
- & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
- BRSUM=BRSUM+BRAT(IDC)
- 210 CONTINUE
- WRITE(CHTMP,5500) BRSUM
- IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
- & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
- & CHTMP(9:16)//' for KF ='//CHKF)
- 220 CONTINUE
-
-C...Write DATA statements for inclusion in program.
- ELSEIF(MUPDA.EQ.4) THEN
-
-C...Find out how many codes and decay channels are actually used.
- KCC=0
- NDC=0
- DO 230 I=1,MSTU(6)
- IF(KCHG(I,4).NE.0) THEN
- KCC=I
- NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
- ENDIF
- 230 CONTINUE
-
-C...Initialize writing of DATA statements for inclusion in program.
- DO 300 IVAR=1,22
- NDIM=MSTU(6)
- IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
- NLIN=1
- CHLIN=' '
- CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
- LLIN=35
- CHOLD='START'
-
-C...Loop through variables for conversion to characters.
- DO 280 IDIM=1,NDIM
- IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
- IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
- IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
- IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
- IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
- IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
- IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
- IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
- IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
- IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
- IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
- IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
- IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
- IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
- IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
- IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
- IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
- IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
- IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
- IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
- IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
- IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
-
-C...Replace variables beyond what is properly defined.
- IF(IVAR.LE.4) THEN
- IF(IDIM.GT.KCC) CHTMP=' 0'
- ELSEIF(IVAR.LE.8) THEN
- IF(IDIM.GT.KCC) CHTMP=' 0.0'
- ELSEIF(IVAR.LE.11) THEN
- IF(IDIM.GT.KCC) CHTMP=' 0'
- ELSEIF(IVAR.LE.13) THEN
- IF(IDIM.GT.NDC) CHTMP=' 0'
- ELSEIF(IVAR.LE.14) THEN
- IF(IDIM.GT.NDC) CHTMP=' 0.0'
- ELSEIF(IVAR.LE.19) THEN
- IF(IDIM.GT.NDC) CHTMP=' 0'
- ELSEIF(IVAR.LE.21) THEN
- IF(IDIM.GT.KCC) CHTMP=' '
- ELSE
- IF(IDIM.GT.KCC) CHTMP=' 0'
- ENDIF
-
-C...Length of variable, trailing decimal zeros, quotation marks.
- LLOW=1
- LHIG=1
- DO 240 LL=1,16
- IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
- IF(CHTMP(LL:LL).NE.' ') LHIG=LL
- 240 CONTINUE
- CHNEW=CHTMP(LLOW:LHIG)//' '
- LNEW=1+LHIG-LLOW
- IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
- LNEW=LNEW+1
- 250 LNEW=LNEW-1
- IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
- IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
- IF(LNEW.EQ.0) THEN
- CHNEW(1:3)='0D0'
- LNEW=3
- ELSE
- CHNEW(LNEW+1:LNEW+2)='D0'
- LNEW=LNEW+2
- ENDIF
- ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
- DO 260 LL=LNEW,1,-1
- IF(CHNEW(LL:LL).EQ.'''') THEN
- CHTMP=CHNEW
- CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
- LNEW=LNEW+1
- ENDIF
- 260 CONTINUE
- LNEW=MIN(14,LNEW)
- CHTMP=CHNEW
- CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
- LNEW=LNEW+2
- ENDIF
-
-C...Form composite character string, often including repetition counter.
- IF(CHNEW.NE.CHOLD) THEN
- NRPT=1
- CHOLD=CHNEW
- CHCOM=CHNEW
- LCOM=LNEW
- ELSE
- LRPT=LNEW+1
- IF(NRPT.GE.2) LRPT=LNEW+3
- IF(NRPT.GE.10) LRPT=LNEW+4
- IF(NRPT.GE.100) LRPT=LNEW+5
- IF(NRPT.GE.1000) LRPT=LNEW+6
- LLIN=LLIN-LRPT
- NRPT=NRPT+1
- WRITE(CHTMP,5400) NRPT
- LRPT=1
- IF(NRPT.GE.10) LRPT=2
- IF(NRPT.GE.100) LRPT=3
- IF(NRPT.GE.1000) LRPT=4
- CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
- LCOM=LRPT+1+LNEW
- ENDIF
-
-C...Add characters to end of line, to new line (after storing old line),
-C...or to new block of lines (after writing old block).
- IF(LLIN+LCOM.LE.70) THEN
- CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
- LLIN=LLIN+LCOM+1
- ELSEIF(NLIN.LE.19) THEN
- CHLIN(LLIN+1:72)=' '
- CHBLK(NLIN)=CHLIN
- NLIN=NLIN+1
- CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
- LLIN=6+LCOM+1
- ELSE
- CHLIN(LLIN:72)='/'//' '
- CHBLK(NLIN)=CHLIN
- WRITE(CHTMP,5400) IDIM-NRPT
- CHBLK(1)(30:33)=CHTMP(13:16)
- DO 270 ILIN=1,NLIN
- WRITE(LFN,5700) CHBLK(ILIN)
- 270 CONTINUE
- NLIN=1
- CHLIN=' '
- CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
- & ',I= , )/'//CHCOM(1:LCOM)//','
- WRITE(CHTMP,5400) IDIM-NRPT+1
- CHLIN(25:28)=CHTMP(13:16)
- LLIN=35+LCOM+1
- ENDIF
- 280 CONTINUE
-
-C...Write final block of lines.
- CHLIN(LLIN:72)='/'//' '
- CHBLK(NLIN)=CHLIN
- WRITE(CHTMP,5400) NDIM
- CHBLK(1)(30:33)=CHTMP(13:16)
- DO 290 ILIN=1,NLIN
- WRITE(LFN,5700) CHBLK(ILIN)
- 290 CONTINUE
- 300 CONTINUE
- ENDIF
-
-C...Formats for reading and writing particle data.
- 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
- 5100 FORMAT(10X,2I5,F12.6,5I10)
- 5200 FORMAT(A120)
- 5300 FORMAT(I9)
- 5400 FORMAT(I16)
- 5500 FORMAT(F16.5)
- 5600 FORMAT(F16.6)
- 5700 FORMAT(A72)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYK
-C...Provides various integer-valued event related data.
-
- FUNCTION PYK(I,J)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-
-C...Default value. For I=0 number of entries, number of stable entries
-C...or 3 times total charge.
- PYK=0
- IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
- ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
- PYK=N
- ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
- DO 100 I1=1,N
- IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
- IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
- & PYCHGE(K(I1,2))
- 100 CONTINUE
- ELSEIF(I.EQ.0) THEN
-
-C...For I > 0 direct readout of K matrix or charge.
- ELSEIF(J.LE.5) THEN
- PYK=K(I,J)
- ELSEIF(J.EQ.6) THEN
- PYK=PYCHGE(K(I,2))
-
-C...Status (existing/fragmented/decayed), parton/hadron separation.
- ELSEIF(J.LE.8) THEN
- IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
- IF(J.EQ.8) PYK=PYK*K(I,2)
- ELSEIF(J.LE.12) THEN
- KFA=IABS(K(I,2))
- KC=PYCOMP(KFA)
- KQ=0
- IF(KC.NE.0) KQ=KCHG(KC,2)
- IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
- IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
- IF(J.EQ.11) PYK=KC
- IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
-
-C...Heaviest flavour in hadron/diquark.
- ELSEIF(J.EQ.13) THEN
- KFA=IABS(K(I,2))
- PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
- IF(KFA.LT.10) PYK=KFA
- IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
- PYK=PYK*ISIGN(1,K(I,2))
-
-C...Particle history: generation, ancestor, rank.
- ELSEIF(J.LE.15) THEN
- I2=I
- I1=I
- 110 PYK=PYK+1
- I2=I1
- I1=K(I1,3)
- IF(I1.GT.0) THEN
- IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
- ENDIF
- IF(J.EQ.15) PYK=I2
- ELSEIF(J.EQ.16) THEN
- KFA=IABS(K(I,2))
- IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
- & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
- I1=I
- 120 I2=I1
- I1=K(I1,3)
- IF(I1.GT.0) THEN
- KFAM=IABS(K(I1,2))
- ILP=1
- IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
- IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
- & ILP=0
- IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
- IF(ILP.EQ.1) GOTO 120
- ENDIF
- IF(K(I1,1).EQ.12) THEN
- DO 130 I3=I1+1,I2
- IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
- & .AND.K(I3,2).NE.93) PYK=PYK+1
- 130 CONTINUE
- ELSE
- I3=I2
- 140 PYK=PYK+1
- I3=I3+1
- IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
- ENDIF
- ENDIF
-
-C...Particle coming from collapsing jet system or not.
- ELSEIF(J.EQ.17) THEN
- I1=I
- 150 PYK=PYK+1
- I3=I1
- I1=K(I1,3)
- I0=MAX(1,I1)
- KC=PYCOMP(K(I0,2))
- IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
- IF(PYK.EQ.1) PYK=-1
- IF(PYK.GT.1) PYK=0
- RETURN
- ENDIF
- IF(KCHG(KC,2).EQ.0) GOTO 150
- IF(K(I1,1).NE.12) PYK=0
- IF(K(I1,1).NE.12) RETURN
- I2=I1
- 160 I2=I2+1
- IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
- K3M=K(I3-1,3)
- IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
- K3P=K(I3+1,3)
- IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
-
-C...Number of decay products. Colour flow.
- ELSEIF(J.EQ.18) THEN
- IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
- IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
- ELSEIF(J.LE.22) THEN
- IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
- IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
- IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
- IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
- IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
- ELSE
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYP
-C...Provides various real-valued event related data.
-
- FUNCTION PYP(I,J)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-C...Local array.
- DIMENSION PSUM(4)
-
-C...Set default value. For I = 0 sum of momenta or charges,
-C...or invariant mass of system.
- PYP=0D0
- IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
- ELSEIF(I.EQ.0.AND.J.LE.4) THEN
- DO 100 I1=1,N
- IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
- 100 CONTINUE
- ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
- DO 120 J1=1,4
- PSUM(J1)=0D0
- DO 110 I1=1,N
- IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
- & P(I1,J1)
- 110 CONTINUE
- 120 CONTINUE
- PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
- ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
- DO 130 I1=1,N
- IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
- 130 CONTINUE
- ELSEIF(I.EQ.0) THEN
-
-C...Direct readout of P matrix.
- ELSEIF(J.LE.5) THEN
- PYP=P(I,J)
-
-C...Charge, total momentum, transverse momentum, transverse mass.
- ELSEIF(J.LE.12) THEN
- IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
- IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
- IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
- IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
- IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
-
-C...Theta and phi angle in radians or degrees.
- ELSEIF(J.LE.16) THEN
- IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
- IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
- IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
-
-C...True rapidity, rapidity with pion mass, pseudorapidity.
- ELSEIF(J.LE.19) THEN
- PMR=0D0
- IF(J.EQ.17) PMR=P(I,5)
- IF(J.EQ.18) PMR=PYMASS(211)
- PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
- PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
- & 1D20)),P(I,3))
-
-C...Energy and momentum fractions (only to be used in CM frame).
- ELSEIF(J.LE.25) THEN
- IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
- IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
- IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
- IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
- IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
- IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSPHE
-C...Performs sphericity tensor analysis to give sphericity,
-C...aplanarity and the related event axes.
-
- SUBROUTINE PYSPHE(SPH,APL)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-C...Local arrays.
- DIMENSION SM(3,3),SV(3,3)
-
-C...Calculate matrix to be diagonalized.
- NP=0
- DO 110 J1=1,3
- DO 100 J2=J1,3
- SM(J1,J2)=0D0
- 100 CONTINUE
- 110 CONTINUE
- PS=0D0
- DO 140 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
- IF(MSTU(41).GE.2) THEN
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
- & K(I,2).EQ.KSUSY1+39) GOTO 140
- IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
- & GOTO 140
- ENDIF
- NP=NP+1
- PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
- PWT=1D0
- IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
- & MAX(1D-10,PA)**(PARU(41)-2D0)
- DO 130 J1=1,3
- DO 120 J2=J1,3
- SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
- 120 CONTINUE
- 130 CONTINUE
- PS=PS+PWT*PA**2
- 140 CONTINUE
-
-C...Very low multiplicities (0 or 1) not considered.
- IF(NP.LE.1) THEN
- CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
- SPH=-1D0
- APL=-1D0
- RETURN
- ENDIF
- DO 160 J1=1,3
- DO 150 J2=J1,3
- SM(J1,J2)=SM(J1,J2)/PS
- 150 CONTINUE
- 160 CONTINUE
-
-C...Find eigenvalues to matrix (third degree equation).
- SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
- &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
- SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
- &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
- &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
- SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
- P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
- P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
- P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
- IF(P(N+2,4).LT.1D-5) THEN
- CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
- SPH=-1D0
- APL=-1D0
- RETURN
- ENDIF
-
-C...Find first and last eigenvector by solving equation system.
- DO 240 I=1,3,2
- DO 180 J1=1,3
- SV(J1,J1)=SM(J1,J1)-P(N+I,4)
- DO 170 J2=J1+1,3
- SV(J1,J2)=SM(J1,J2)
- SV(J2,J1)=SM(J1,J2)
- 170 CONTINUE
- 180 CONTINUE
- SMAX=0D0
- DO 200 J1=1,3
- DO 190 J2=1,3
- IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
- JA=J1
- JB=J2
- SMAX=ABS(SV(J1,J2))
- 190 CONTINUE
- 200 CONTINUE
- SMAX=0D0
- DO 220 J3=JA+1,JA+2
- J1=J3-3*((J3-1)/3)
- RL=SV(J1,JB)/SV(JA,JB)
- DO 210 J2=1,3
- SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
- IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
- JC=J1
- SMAX=ABS(SV(J1,J2))
- 210 CONTINUE
- 220 CONTINUE
- JB1=JB+1-3*(JB/3)
- JB2=JB+2-3*((JB+1)/3)
- P(N+I,JB1)=-SV(JC,JB2)
- P(N+I,JB2)=SV(JC,JB1)
- P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
- & SV(JA,JB)
- PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
- SGN=(-1D0)**INT(PYR(0)+0.5D0)
- DO 230 J=1,3
- P(N+I,J)=SGN*P(N+I,J)/PA
- 230 CONTINUE
- 240 CONTINUE
-
-C...Middle axis orthogonal to other two. Fill other codes.
- SGN=(-1D0)**INT(PYR(0)+0.5D0)
- P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
- P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
- P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
- DO 260 I=1,3
- K(N+I,1)=31
- K(N+I,2)=95
- K(N+I,3)=I
- K(N+I,4)=0
- K(N+I,5)=0
- P(N+I,5)=0D0
- DO 250 J=1,5
- V(I,J)=0D0
- 250 CONTINUE
- 260 CONTINUE
-
-C...Calculate sphericity and aplanarity. Select storing option.
- SPH=1.5D0*(P(N+2,4)+P(N+3,4))
- APL=1.5D0*P(N+3,4)
- MSTU(61)=N+1
- MSTU(62)=NP
- IF(MSTU(43).LE.1) MSTU(3)=3
- IF(MSTU(43).GE.2) N=N+3
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYTHRU
-C...Performs thrust analysis to give thrust, oblateness
-C...and the related event axes.
-
- SUBROUTINE PYTHRU(THR,OBL)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-C...Local arrays.
- DIMENSION TDI(3),TPR(3)
-
-C...Take copy of particles that are to be considered in thrust analysis.
- NP=0
- PS=0D0
- DO 100 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
- IF(MSTU(41).GE.2) THEN
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
- & K(I,2).EQ.KSUSY1+39) GOTO 100
- IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
- & GOTO 100
- ENDIF
- IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
- CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
- THR=-2D0
- OBL=-2D0
- RETURN
- ENDIF
- NP=NP+1
- K(N+NP,1)=23
- P(N+NP,1)=P(I,1)
- P(N+NP,2)=P(I,2)
- P(N+NP,3)=P(I,3)
- P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
- P(N+NP,5)=1D0
- IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
- & P(N+NP,4)**(PARU(42)-1D0)
- PS=PS+P(N+NP,4)*P(N+NP,5)
- 100 CONTINUE
-
-C...Very low multiplicities (0 or 1) not considered.
- IF(NP.LE.1) THEN
- CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
- THR=-1D0
- OBL=-1D0
- RETURN
- ENDIF
-
-C...Loop over thrust and major. T axis along z direction in latter case.
- DO 320 ILD=1,2
- IF(ILD.EQ.2) THEN
- K(N+NP+1,1)=31
- PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
- MSTU(33)=1
- CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
- THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
- CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
- ENDIF
-
-C...Find and order particles with highest p (pT for major).
- DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
- P(ILF,4)=0D0
- 110 CONTINUE
- DO 160 I=N+1,N+NP
- IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
- DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
- IF(P(I,4).LE.P(ILF,4)) GOTO 140
- DO 120 J=1,5
- P(ILF+1,J)=P(ILF,J)
- 120 CONTINUE
- 130 CONTINUE
- ILF=N+NP+3
- 140 DO 150 J=1,5
- P(ILF+1,J)=P(I,J)
- 150 CONTINUE
- 160 CONTINUE
-
-C...Find and order initial axes with highest thrust (major).
- DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
- P(ILG,4)=0D0
- 170 CONTINUE
- NC=2**(MIN(MSTU(44),NP)-1)
- DO 250 ILC=1,NC
- DO 180 J=1,3
- TDI(J)=0D0
- 180 CONTINUE
- DO 200 ILF=1,MIN(MSTU(44),NP)
- SGN=P(N+NP+ILF+3,5)
- IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
- DO 190 J=1,4-ILD
- TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
- 190 CONTINUE
- 200 CONTINUE
- TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
- DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
- IF(TDS.LE.P(ILG,4)) GOTO 230
- DO 210 J=1,4
- P(ILG+1,J)=P(ILG,J)
- 210 CONTINUE
- 220 CONTINUE
- ILG=N+NP+MSTU(44)+4
- 230 DO 240 J=1,3
- P(ILG+1,J)=TDI(J)
- 240 CONTINUE
- P(ILG+1,4)=TDS
- 250 CONTINUE
-
-C...Iterate direction of axis until stable maximum.
- P(N+NP+ILD,4)=0D0
- ILG=0
- 260 ILG=ILG+1
- THP=0D0
- 270 THPS=THP
- DO 280 J=1,3
- IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
- IF(THP.GT.1D-10) TDI(J)=TPR(J)
- TPR(J)=0D0
- 280 CONTINUE
- DO 300 I=N+1,N+NP
- SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
- DO 290 J=1,4-ILD
- TPR(J)=TPR(J)+SGN*P(I,J)
- 290 CONTINUE
- 300 CONTINUE
- THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
- IF(THP.GE.THPS+PARU(48)) GOTO 270
-
-C...Save good axis. Try new initial axis until a number of tries agree.
- IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
- IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
- IAGR=0
- SGN=(-1D0)**INT(PYR(0)+0.5D0)
- DO 310 J=1,3
- P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
- 310 CONTINUE
- P(N+NP+ILD,4)=THP
- P(N+NP+ILD,5)=0D0
- ENDIF
- IAGR=IAGR+1
- IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
- 320 CONTINUE
-
-C...Find minor axis and value by orthogonality.
- SGN=(-1D0)**INT(PYR(0)+0.5D0)
- P(N+NP+3,1)=-SGN*P(N+NP+2,2)
- P(N+NP+3,2)=SGN*P(N+NP+2,1)
- P(N+NP+3,3)=0D0
- THP=0D0
- DO 330 I=N+1,N+NP
- THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
- 330 CONTINUE
- P(N+NP+3,4)=THP/PS
- P(N+NP+3,5)=0D0
-
-C...Fill axis information. Rotate back to original coordinate system.
- DO 350 ILD=1,3
- K(N+ILD,1)=31
- K(N+ILD,2)=96
- K(N+ILD,3)=ILD
- K(N+ILD,4)=0
- K(N+ILD,5)=0
- DO 340 J=1,5
- P(N+ILD,J)=P(N+NP+ILD,J)
- V(N+ILD,J)=0D0
- 340 CONTINUE
- 350 CONTINUE
- CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
-
-C...Calculate thrust and oblateness. Select storing option.
- THR=P(N+1,4)
- OBL=P(N+2,4)-P(N+3,4)
- MSTU(61)=N+1
- MSTU(62)=NP
- IF(MSTU(43).LE.1) MSTU(3)=3
- IF(MSTU(43).GE.2) N=N+3
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYCLUS
-C...Subdivides the particle content of an event into jets/clusters.
-
- SUBROUTINE PYCLUS(NJET)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-C...Local arrays and saved variables.
- DIMENSION PS(5)
- SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
-
-C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
- R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
- &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
- R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
- &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
- R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
- &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
-
-C...If first time, reset. If reentering, skip preliminaries.
- IF(MSTU(48).LE.0) THEN
- NP=0
- DO 100 J=1,5
- PS(J)=0D0
- 100 CONTINUE
- PSS=0D0
- PIMASS=PMAS(PYCOMP(211),1)
- ELSE
- NJET=NSAV
- IF(MSTU(43).GE.2) N=N-NJET
- DO 110 I=N+1,N+NJET
- P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
- 110 CONTINUE
- IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
- R2ACC=PARU(44)**2
- ELSE
- R2ACC=PARU(45)*PS(5)**2
- ENDIF
- NLOOP=0
- GOTO 300
- ENDIF
-
-C...Find which particles are to be considered in cluster search.
- DO 140 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
- IF(MSTU(41).GE.2) THEN
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
- & K(I,2).EQ.KSUSY1+39) GOTO 140
- IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
- & GOTO 140
- ENDIF
- IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
- CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
- NJET=-1
- RETURN
- ENDIF
-
-C...Take copy of these particles, with space left for jets later on.
- NP=NP+1
- K(N+NP,3)=I
- DO 120 J=1,5
- P(N+NP,J)=P(I,J)
- 120 CONTINUE
- IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
- IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
- P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
- P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
- DO 130 J=1,4
- PS(J)=PS(J)+P(N+NP,J)
- 130 CONTINUE
- PSS=PSS+P(N+NP,5)
- 140 CONTINUE
- DO 160 I=N+1,N+NP
- K(I+NP,3)=K(I,3)
- DO 150 J=1,5
- P(I+NP,J)=P(I,J)
- 150 CONTINUE
- 160 CONTINUE
- PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
-
-C...Very low multiplicities not considered.
- IF(NP.LT.MSTU(47)) THEN
- CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
- NJET=-1
- RETURN
- ENDIF
-
-C...Find precluster configuration. If too few jets, make harder cuts.
- NLOOP=0
- IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
- R2ACC=PARU(44)**2
- ELSE
- R2ACC=PARU(45)*PS(5)**2
- ENDIF
- RINIT=1.25D0*PARU(43)
- IF(NP.LE.MSTU(47)+2) RINIT=0D0
- 170 RINIT=0.8D0*RINIT
- NPRE=0
- NREM=NP
- DO 180 I=N+NP+1,N+2*NP
- K(I,4)=0
- 180 CONTINUE
-
-C...Sum up small momentum region. Jet if enough absolute momentum.
- IF(MSTU(46).LE.2) THEN
- DO 190 J=1,4
- P(N+1,J)=0D0
- 190 CONTINUE
- DO 210 I=N+NP+1,N+2*NP
- IF(P(I,5).GT.2D0*RINIT) GOTO 210
- NREM=NREM-1
- K(I,4)=1
- DO 200 J=1,4
- P(N+1,J)=P(N+1,J)+P(I,J)
- 200 CONTINUE
- 210 CONTINUE
- P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
- IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
- IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
- IF(NREM.EQ.0) GOTO 170
- ENDIF
-
-C...Find fastest remaining particle.
- 220 NPRE=NPRE+1
- PMAX=0D0
- DO 230 I=N+NP+1,N+2*NP
- IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
- IMAX=I
- PMAX=P(I,5)
- 230 CONTINUE
- DO 240 J=1,5
- P(N+NPRE,J)=P(IMAX,J)
- 240 CONTINUE
- NREM=NREM-1
- K(IMAX,4)=NPRE
-
-C...Sum up precluster around it according to pT separation.
- IF(MSTU(46).LE.2) THEN
- DO 260 I=N+NP+1,N+2*NP
- IF(K(I,4).NE.0) GOTO 260
- R2=R2T(I,IMAX)
- IF(R2.GT.RINIT**2) GOTO 260
- NREM=NREM-1
- K(I,4)=NPRE
- DO 250 J=1,4
- P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
- 250 CONTINUE
- 260 CONTINUE
- P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
-
-C...Sum up precluster around it according to mass or
-C...Durham pT separation.
- ELSE
- 270 IMIN=0
- R2MIN=RINIT**2
- DO 280 I=N+NP+1,N+2*NP
- IF(K(I,4).NE.0) GOTO 280
- IF(MSTU(46).LE.4) THEN
- R2=R2M(I,N+NPRE)
- ELSE
- R2=R2D(I,N+NPRE)
- ENDIF
- IF(R2.GE.R2MIN) GOTO 280
- IMIN=I
- R2MIN=R2
- 280 CONTINUE
- IF(IMIN.NE.0) THEN
- DO 290 J=1,4
- P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
- 290 CONTINUE
- P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
- NREM=NREM-1
- K(IMIN,4)=NPRE
- GOTO 270
- ENDIF
- ENDIF
-
-C...Check if more preclusters to be found. Start over if too few.
- IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
- IF(NREM.GT.0) GOTO 220
- NJET=NPRE
-
-C...Reassign all particles to nearest jet. Sum up new jet momenta.
- 300 TSAV=0D0
- PSJT=0D0
- 310 IF(MSTU(46).LE.1) THEN
- DO 330 I=N+1,N+NJET
- DO 320 J=1,4
- V(I,J)=0D0
- 320 CONTINUE
- 330 CONTINUE
- DO 360 I=N+NP+1,N+2*NP
- R2MIN=PSS**2
- DO 340 IJET=N+1,N+NJET
- IF(P(IJET,5).LT.RINIT) GOTO 340
- R2=R2T(I,IJET)
- IF(R2.GE.R2MIN) GOTO 340
- IMIN=IJET
- R2MIN=R2
- 340 CONTINUE
- K(I,4)=IMIN-N
- DO 350 J=1,4
- V(IMIN,J)=V(IMIN,J)+P(I,J)
- 350 CONTINUE
- 360 CONTINUE
- PSJT=0D0
- DO 380 I=N+1,N+NJET
- DO 370 J=1,4
- P(I,J)=V(I,J)
- 370 CONTINUE
- P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
- PSJT=PSJT+P(I,5)
- 380 CONTINUE
- ENDIF
-
-C...Find two closest jets.
- R2MIN=2D0*MAX(R2ACC,PS(5)**2)
- DO 400 ITRY1=N+1,N+NJET-1
- DO 390 ITRY2=ITRY1+1,N+NJET
- IF(MSTU(46).LE.2) THEN
- R2=R2T(ITRY1,ITRY2)
- ELSEIF(MSTU(46).LE.4) THEN
- R2=R2M(ITRY1,ITRY2)
- ELSE
- R2=R2D(ITRY1,ITRY2)
- ENDIF
- IF(R2.GE.R2MIN) GOTO 390
- IMIN1=ITRY1
- IMIN2=ITRY2
- R2MIN=R2
- 390 CONTINUE
- 400 CONTINUE
-
-C...If allowed, join two closest jets and start over.
- IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
- IREC=MIN(IMIN1,IMIN2)
- IDEL=MAX(IMIN1,IMIN2)
- DO 410 J=1,4
- P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
- 410 CONTINUE
- P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
- DO 430 I=IDEL+1,N+NJET
- DO 420 J=1,5
- P(I-1,J)=P(I,J)
- 420 CONTINUE
- 430 CONTINUE
- IF(MSTU(46).GE.2) THEN
- DO 440 I=N+NP+1,N+2*NP
- IORI=N+K(I,4)
- IF(IORI.EQ.IDEL) K(I,4)=IREC-N
- IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
- 440 CONTINUE
- ENDIF
- NJET=NJET-1
- GOTO 300
-
-C...Divide up broad jet if empty cluster in list of final ones.
- ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
- DO 450 I=N+1,N+NJET
- K(I,5)=0
- 450 CONTINUE
- DO 460 I=N+NP+1,N+2*NP
- K(N+K(I,4),5)=K(N+K(I,4),5)+1
- 460 CONTINUE
- IEMP=0
- DO 470 I=N+1,N+NJET
- IF(K(I,5).EQ.0) IEMP=I
- 470 CONTINUE
- IF(IEMP.NE.0) THEN
- NLOOP=NLOOP+1
- ISPL=0
- R2MAX=0D0
- DO 480 I=N+NP+1,N+2*NP
- IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
- IJET=N+K(I,4)
- R2=R2T(I,IJET)
- IF(R2.LE.R2MAX) GOTO 480
- ISPL=I
- R2MAX=R2
- 480 CONTINUE
- IF(ISPL.NE.0) THEN
- IJET=N+K(ISPL,4)
- DO 490 J=1,4
- P(IEMP,J)=P(ISPL,J)
- P(IJET,J)=P(IJET,J)-P(ISPL,J)
- 490 CONTINUE
- P(IEMP,5)=P(ISPL,5)
- P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
- IF(NLOOP.LE.2) GOTO 300
- ENDIF
- ENDIF
- ENDIF
-
-C...If generalized thrust has not yet converged, continue iteration.
- IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
- &THEN
- TSAV=PSJT/PSS
- GOTO 310
- ENDIF
-
-C...Reorder jets according to energy.
- DO 510 I=N+1,N+NJET
- DO 500 J=1,5
- V(I,J)=P(I,J)
- 500 CONTINUE
- 510 CONTINUE
- DO 540 INEW=N+1,N+NJET
- PEMAX=0D0
- DO 520 ITRY=N+1,N+NJET
- IF(V(ITRY,4).LE.PEMAX) GOTO 520
- IMAX=ITRY
- PEMAX=V(ITRY,4)
- 520 CONTINUE
- K(INEW,1)=31
- K(INEW,2)=97
- K(INEW,3)=INEW-N
- K(INEW,4)=0
- DO 530 J=1,5
- P(INEW,J)=V(IMAX,J)
- 530 CONTINUE
- V(IMAX,4)=-1D0
- K(IMAX,5)=INEW
- 540 CONTINUE
-
-C...Clean up particle-jet assignments and jet information.
- DO 550 I=N+NP+1,N+2*NP
- IORI=K(N+K(I,4),5)
- K(I,4)=IORI-N
- IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
- K(IORI,4)=K(IORI,4)+1
- 550 CONTINUE
- IEMP=0
- PSJT=0D0
- DO 570 I=N+1,N+NJET
- K(I,5)=0
- PSJT=PSJT+P(I,5)
- P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
- DO 560 J=1,5
- V(I,J)=0D0
- 560 CONTINUE
- IF(K(I,4).EQ.0) IEMP=I
- 570 CONTINUE
-
-C...Select storing option. Output variables. Check for failure.
- MSTU(61)=N+1
- MSTU(62)=NP
- MSTU(63)=NPRE
- PARU(61)=PS(5)
- PARU(62)=PSJT/PSS
- PARU(63)=SQRT(R2MIN)
- IF(NJET.LE.1) PARU(63)=0D0
- IF(IEMP.NE.0) THEN
- CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
- NJET=-1
- RETURN
- ENDIF
- IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
- IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
- NSAV=NJET
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYCELL
-C...Provides a simple way of jet finding in eta-phi-ET coordinates,
-C...as used for calorimeters at hadron colliders.
-
- SUBROUTINE PYCELL(NJET)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-
-C...Loop over all particles. Find cell that was hit by given particle.
- PTLRAT=1D0/SINH(PARU(51))**2
- NP=0
- NC=N
- DO 110 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
- IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
- IF(MSTU(41).GE.2) THEN
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
- & K(I,2).EQ.KSUSY1+39) GOTO 110
- IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
- & GOTO 110
- ENDIF
- NP=NP+1
- PT=SQRT(P(I,1)**2+P(I,2)**2)
- ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
- IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
- & (ETA/PARU(51)+1D0))))
- PHI=PYANGL(P(I,1),P(I,2))
- IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
- & (PHI/PARU(1)+1D0))))
- IETPH=MSTU(52)*IETA+IPHI
-
-C...Add to cell already hit, or book new cell.
- DO 100 IC=N+1,NC
- IF(IETPH.EQ.K(IC,3)) THEN
- K(IC,4)=K(IC,4)+1
- P(IC,5)=P(IC,5)+PT
- GOTO 110
- ENDIF
- 100 CONTINUE
- IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
- CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
- NJET=-2
- RETURN
- ENDIF
- NC=NC+1
- K(NC,3)=IETPH
- K(NC,4)=1
- K(NC,5)=2
- P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
- P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
- P(NC,5)=PT
- 110 CONTINUE
-
-C...Smear true bin content by calorimeter resolution.
- IF(MSTU(53).GE.1) THEN
- DO 130 IC=N+1,NC
- PEI=P(IC,5)
- IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
- 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
- & COS(PARU(2)*PYR(0))
- IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
- P(IC,5)=PEF
- IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
- 130 CONTINUE
- ENDIF
-
-C...Remove cells below threshold.
- IF(PARU(58).GT.0D0) THEN
- NCC=NC
- NC=N
- DO 140 IC=N+1,NCC
- IF(P(IC,5).GT.PARU(58)) THEN
- NC=NC+1
- K(NC,3)=K(IC,3)
- K(NC,4)=K(IC,4)
- K(NC,5)=K(IC,5)
- P(NC,1)=P(IC,1)
- P(NC,2)=P(IC,2)
- P(NC,5)=P(IC,5)
- ENDIF
- 140 CONTINUE
- ENDIF
-
-C...Find initiator cell: the one with highest pT of not yet used ones.
- NJ=NC
- 150 ETMAX=0D0
- DO 160 IC=N+1,NC
- IF(K(IC,5).NE.2) GOTO 160
- IF(P(IC,5).LE.ETMAX) GOTO 160
- ICMAX=IC
- ETA=P(IC,1)
- PHI=P(IC,2)
- ETMAX=P(IC,5)
- 160 CONTINUE
- IF(ETMAX.LT.PARU(52)) GOTO 220
- IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
- CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
- NJET=-2
- RETURN
- ENDIF
- K(ICMAX,5)=1
- NJ=NJ+1
- K(NJ,4)=0
- K(NJ,5)=1
- P(NJ,1)=ETA
- P(NJ,2)=PHI
- P(NJ,3)=0D0
- P(NJ,4)=0D0
- P(NJ,5)=0D0
-
-C...Sum up unused cells within required distance of initiator.
- DO 170 IC=N+1,NC
- IF(K(IC,5).EQ.0) GOTO 170
- IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
- DPHIA=ABS(P(IC,2)-PHI)
- IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
- PHIC=P(IC,2)
- IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
- IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
- K(IC,5)=-K(IC,5)
- K(NJ,4)=K(NJ,4)+K(IC,4)
- P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
- P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
- P(NJ,5)=P(NJ,5)+P(IC,5)
- 170 CONTINUE
-
-C...Reject cluster below minimum ET, else accept.
- IF(P(NJ,5).LT.PARU(53)) THEN
- NJ=NJ-1
- DO 180 IC=N+1,NC
- IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
- 180 CONTINUE
- ELSEIF(MSTU(54).LE.2) THEN
- P(NJ,3)=P(NJ,3)/P(NJ,5)
- P(NJ,4)=P(NJ,4)/P(NJ,5)
- IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
- & P(NJ,4))
- DO 190 IC=N+1,NC
- IF(K(IC,5).LT.0) K(IC,5)=0
- 190 CONTINUE
- ELSE
- DO 200 J=1,4
- P(NJ,J)=0D0
- 200 CONTINUE
- DO 210 IC=N+1,NC
- IF(K(IC,5).GE.0) GOTO 210
- P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
- P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
- P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
- P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
- K(IC,5)=0
- 210 CONTINUE
- ENDIF
- GOTO 150
-
-C...Arrange clusters in falling ET sequence.
- 220 DO 250 I=1,NJ-NC
- ETMAX=0D0
- DO 230 IJ=NC+1,NJ
- IF(K(IJ,5).EQ.0) GOTO 230
- IF(P(IJ,5).LT.ETMAX) GOTO 230
- IJMAX=IJ
- ETMAX=P(IJ,5)
- 230 CONTINUE
- K(IJMAX,5)=0
- K(N+I,1)=31
- K(N+I,2)=98
- K(N+I,3)=I
- K(N+I,4)=K(IJMAX,4)
- K(N+I,5)=0
- DO 240 J=1,5
- P(N+I,J)=P(IJMAX,J)
- V(N+I,J)=0D0
- 240 CONTINUE
- 250 CONTINUE
- NJET=NJ-NC
-
-C...Convert to massless or massive four-vectors.
- IF(MSTU(54).EQ.2) THEN
- DO 260 I=N+1,N+NJET
- ETA=P(I,3)
- P(I,1)=P(I,5)*COS(P(I,4))
- P(I,2)=P(I,5)*SIN(P(I,4))
- P(I,3)=P(I,5)*SINH(ETA)
- P(I,4)=P(I,5)*COSH(ETA)
- P(I,5)=0D0
- 260 CONTINUE
- ELSEIF(MSTU(54).GE.3) THEN
- DO 270 I=N+1,N+NJET
- P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
- 270 CONTINUE
- ENDIF
-
-C...Information about storage.
- MSTU(61)=N+1
- MSTU(62)=NP
- MSTU(63)=NC-N
- IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
- IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYJMAS
-C...Determines, approximately, the two jet masses that minimize
-C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
-
- SUBROUTINE PYJMAS(PMH,PML)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-C...Local arrays.
- DIMENSION SM(3,3),SAX(3),PS(3,5)
-
-C...Reset.
- NP=0
- DO 120 J1=1,3
- DO 100 J2=J1,3
- SM(J1,J2)=0D0
- 100 CONTINUE
- DO 110 J2=1,4
- PS(J1,J2)=0D0
- 110 CONTINUE
- 120 CONTINUE
- PSS=0D0
- PIMASS=PMAS(PYCOMP(211),1)
-
-C...Take copy of particles that are to be considered in mass analysis.
- DO 170 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
- IF(MSTU(41).GE.2) THEN
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
- & K(I,2).EQ.KSUSY1+39) GOTO 170
- IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
- & GOTO 170
- ENDIF
- IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
- CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
- PMH=-2D0
- PML=-2D0
- RETURN
- ENDIF
- NP=NP+1
- DO 130 J=1,5
- P(N+NP,J)=P(I,J)
- 130 CONTINUE
- IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
- IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
- P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
-
-C...Fill information in sphericity tensor and total momentum vector.
- DO 150 J1=1,3
- DO 140 J2=J1,3
- SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
- 140 CONTINUE
- 150 CONTINUE
- PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
- DO 160 J=1,4
- PS(3,J)=PS(3,J)+P(N+NP,J)
- 160 CONTINUE
- 170 CONTINUE
-
-C...Very low multiplicities (0 or 1) not considered.
- IF(NP.LE.1) THEN
- CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
- PMH=-1D0
- PML=-1D0
- RETURN
- ENDIF
- PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
- &PS(3,3)**2))
-
-C...Find largest eigenvalue to matrix (third degree equation).
- DO 190 J1=1,3
- DO 180 J2=J1,3
- SM(J1,J2)=SM(J1,J2)/PSS
- 180 CONTINUE
- 190 CONTINUE
- SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
- &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
- SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
- &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
- &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
- SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
- SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
-
-C...Find largest eigenvector by solving equation system.
- DO 210 J1=1,3
- SM(J1,J1)=SM(J1,J1)-SMA
- DO 200 J2=J1+1,3
- SM(J2,J1)=SM(J1,J2)
- 200 CONTINUE
- 210 CONTINUE
- SMAX=0D0
- DO 230 J1=1,3
- DO 220 J2=1,3
- IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
- JA=J1
- JB=J2
- SMAX=ABS(SM(J1,J2))
- 220 CONTINUE
- 230 CONTINUE
- SMAX=0D0
- DO 250 J3=JA+1,JA+2
- J1=J3-3*((J3-1)/3)
- RL=SM(J1,JB)/SM(JA,JB)
- DO 240 J2=1,3
- SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
- IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
- JC=J1
- SMAX=ABS(SM(J1,J2))
- 240 CONTINUE
- 250 CONTINUE
- JB1=JB+1-3*(JB/3)
- JB2=JB+2-3*((JB+1)/3)
- SAX(JB1)=-SM(JC,JB2)
- SAX(JB2)=SM(JC,JB1)
- SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
-
-C...Divide particles into two initial clusters by hemisphere.
- DO 270 I=N+1,N+NP
- PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
- IS=1
- IF(PSAX.LT.0D0) IS=2
- K(I,3)=IS
- DO 260 J=1,4
- PS(IS,J)=PS(IS,J)+P(I,J)
- 260 CONTINUE
- 270 CONTINUE
- PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
- &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
-
-C...Reassign one particle at a time; find maximum decrease of m^2 sum.
- 280 PMD=0D0
- IM=0
- DO 290 J=1,4
- PS(3,J)=PS(1,J)-PS(2,J)
- 290 CONTINUE
- DO 300 I=N+1,N+NP
- PPS=P(I,4)*PS(3,4)-P(I,1)*PS(3,1)-P(I,2)*PS(3,2)-P(I,3)*PS(3,3)
- IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
- IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
- IF(PMDI.LT.PMD) THEN
- PMD=PMDI
- IM=I
- ENDIF
- 300 CONTINUE
-
-C...Loop back if significant reduction in sum of m^2.
- IF(PMD.LT.-PARU(48)*PMS) THEN
- PMS=PMS+PMD
- IS=K(IM,3)
- DO 310 J=1,4
- PS(IS,J)=PS(IS,J)-P(IM,J)
- PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
- 310 CONTINUE
- K(IM,3)=3-IS
- GOTO 280
- ENDIF
-
-C...Final masses and output.
- MSTU(61)=N+1
- MSTU(62)=NP
- PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
- PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
- PMH=MAX(PS(1,5),PS(2,5))
- PML=MIN(PS(1,5),PS(2,5))
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYFOWO
-C...Calculates the first few Fox-Wolfram moments.
-
- SUBROUTINE PYFOWO(H10,H20,H30,H40)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-
-C...Copy momenta for particles and calculate H0.
- NP=0
- H0=0D0
- HD=0D0
- DO 110 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
- IF(MSTU(41).GE.2) THEN
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
- & K(I,2).EQ.KSUSY1+39) GOTO 110
- IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
- & GOTO 110
- ENDIF
- IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
- CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
- H10=-1D0
- H20=-1D0
- H30=-1D0
- H40=-1D0
- RETURN
- ENDIF
- NP=NP+1
- DO 100 J=1,3
- P(N+NP,J)=P(I,J)
- 100 CONTINUE
- P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
- H0=H0+P(N+NP,4)
- HD=HD+P(N+NP,4)**2
- 110 CONTINUE
- H0=H0**2
-
-C...Very low multiplicities (0 or 1) not considered.
- IF(NP.LE.1) THEN
- CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
- H10=-1D0
- H20=-1D0
- H30=-1D0
- H40=-1D0
- RETURN
- ENDIF
-
-C...Calculate H1 - H4.
- H10=0D0
- H20=0D0
- H30=0D0
- H40=0D0
- DO 130 I1=N+1,N+NP
- DO 120 I2=I1+1,N+NP
- CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
- & (P(I1,4)*P(I2,4))
- H10=H10+P(I1,4)*P(I2,4)*CTHE
- H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
- H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
- H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
- & 0.375D0)
- 120 CONTINUE
- 130 CONTINUE
-
-C...Calculate H1/H0 - H4/H0. Output.
- MSTU(61)=N+1
- MSTU(62)=NP
- H10=(HD+2D0*H10)/H0
- H20=(HD+2D0*H20)/H0
- H30=(HD+2D0*H30)/H0
- H40=(HD+2D0*H40)/H0
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYTABU
-C...Evaluates various properties of an event, with statistics
-C...accumulated during the course of the run and
-C...printed at the end.
-
- SUBROUTINE PYTABU(MTABU)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Parameter statement to help give large particle numbers.
- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
- &KEXCIT=4000000,KDIMEN=5000000)
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
-C...Local arrays, character variables, saved variables and data.
- DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
- &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
- &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
- &KFDM(8),KFDC(200,0:8),NPDC(200)
- SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
- &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
- &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
- CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
- DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
- &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
- &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
- &NEVDC/0/,NKFDC/0/,NREDC/0/
-
-C...Reset statistics on initial parton state.
- IF(MTABU.EQ.10) THEN
- NEVIS=0
- NKFIS=0
-
-C...Identify and order flavour content of initial state.
- ELSEIF(MTABU.EQ.11) THEN
- NEVIS=NEVIS+1
- KFM1=2*IABS(MSTU(161))
- IF(MSTU(161).GT.0) KFM1=KFM1-1
- KFM2=2*IABS(MSTU(162))
- IF(MSTU(162).GT.0) KFM2=KFM2-1
- KFMN=MIN(KFM1,KFM2)
- KFMX=MAX(KFM1,KFM2)
- DO 100 I=1,NKFIS
- IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
- IKFIS=-I
- GOTO 110
- ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
- & KFMX.LT.KFIS(I,2))) THEN
- IKFIS=I
- GOTO 110
- ENDIF
- 100 CONTINUE
- IKFIS=NKFIS+1
- 110 IF(IKFIS.LT.0) THEN
- IKFIS=-IKFIS
- ELSE
- IF(NKFIS.GE.100) RETURN
- DO 130 I=NKFIS,IKFIS,-1
- KFIS(I+1,1)=KFIS(I,1)
- KFIS(I+1,2)=KFIS(I,2)
- DO 120 J=0,10
- NPIS(I+1,J)=NPIS(I,J)
- 120 CONTINUE
- 130 CONTINUE
- NKFIS=NKFIS+1
- KFIS(IKFIS,1)=KFMN
- KFIS(IKFIS,2)=KFMX
- DO 140 J=0,10
- NPIS(IKFIS,J)=0
- 140 CONTINUE
- ENDIF
- NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
-
-C...Count number of partons in initial state.
- NP=0
- DO 160 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
- ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
- ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
- & THEN
- ELSE
- IM=I
- 150 IM=K(IM,3)
- IF(IM.LE.0.OR.IM.GT.N) THEN
- NP=NP+1
- ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
- NP=NP+1
- ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
- ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
- & .NE.0) THEN
- ELSE
- GOTO 150
- ENDIF
- ENDIF
- 160 CONTINUE
- NPCO=MAX(NP,1)
- IF(NP.GE.6) NPCO=6
- IF(NP.GE.8) NPCO=7
- IF(NP.GE.11) NPCO=8
- IF(NP.GE.16) NPCO=9
- IF(NP.GE.26) NPCO=10
- NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
- MSTU(62)=NP
-
-C...Write statistics on initial parton state.
- ELSEIF(MTABU.EQ.12) THEN
- FAC=1D0/MAX(1,NEVIS)
- WRITE(MSTU(11),5000) NEVIS
- DO 170 I=1,NKFIS
- KFMN=KFIS(I,1)
- IF(KFMN.EQ.0) KFMN=KFIS(I,2)
- KFM1=(KFMN+1)/2
- IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
- CALL PYNAME(KFM1,CHAU)
- CHIS(1)=CHAU(1:12)
- IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
- KFMX=KFIS(I,2)
- IF(KFIS(I,1).EQ.0) KFMX=0
- KFM2=(KFMX+1)/2
- IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
- CALL PYNAME(KFM2,CHAU)
- CHIS(2)=CHAU(1:12)
- IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
- WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
- & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
- 170 CONTINUE
-
-C...Copy statistics on initial parton state into /PYJETS/.
- ELSEIF(MTABU.EQ.13) THEN
- FAC=1D0/MAX(1,NEVIS)
- DO 190 I=1,NKFIS
- KFMN=KFIS(I,1)
- IF(KFMN.EQ.0) KFMN=KFIS(I,2)
- KFM1=(KFMN+1)/2
- IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
- KFMX=KFIS(I,2)
- IF(KFIS(I,1).EQ.0) KFMX=0
- KFM2=(KFMX+1)/2
- IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
- K(I,1)=32
- K(I,2)=99
- K(I,3)=KFM1
- K(I,4)=KFM2
- K(I,5)=NPIS(I,0)
- DO 180 J=1,5
- P(I,J)=FAC*NPIS(I,J)
- V(I,J)=FAC*NPIS(I,J+5)
- 180 CONTINUE
- 190 CONTINUE
- N=NKFIS
- DO 200 J=1,5
- K(N+1,J)=0
- P(N+1,J)=0D0
- V(N+1,J)=0D0
- 200 CONTINUE
- K(N+1,1)=32
- K(N+1,2)=99
- K(N+1,5)=NEVIS
- MSTU(3)=1
-
-C...Reset statistics on number of particles/partons.
- ELSEIF(MTABU.EQ.20) THEN
- NEVFS=0
- NPRFS=0
- NFIFS=0
- NCHFS=0
- NKFFS=0
-
-C...Identify whether particle/parton is primary or not.
- ELSEIF(MTABU.EQ.21) THEN
- NEVFS=NEVFS+1
- MSTU(62)=0
- DO 260 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
- MSTU(62)=MSTU(62)+1
- KC=PYCOMP(K(I,2))
- MPRI=0
- IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
- MPRI=1
- ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
- MPRI=1
- ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
- MPRI=1
- ELSEIF(KC.EQ.0) THEN
- ELSEIF(K(K(I,3),1).EQ.13) THEN
- IM=K(K(I,3),3)
- IF(IM.LE.0.OR.IM.GT.N) THEN
- MPRI=1
- ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
- MPRI=1
- ENDIF
- ELSEIF(KCHG(KC,2).EQ.0) THEN
- KCM=PYCOMP(K(K(I,3),2))
- IF(KCM.NE.0) THEN
- IF(KCHG(KCM,2).NE.0) MPRI=1
- ENDIF
- ENDIF
- IF(KC.NE.0.AND.MPRI.EQ.1) THEN
- IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
- ENDIF
- IF(K(I,1).LE.10) THEN
- NFIFS=NFIFS+1
- IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
- ENDIF
-
-C...Fill statistics on number of particles/partons in event.
- KFA=IABS(K(I,2))
- KFS=3-ISIGN(1,K(I,2))-MPRI
- DO 210 IP=1,NKFFS
- IF(KFA.EQ.KFFS(IP)) THEN
- IKFFS=-IP
- GOTO 220
- ELSEIF(KFA.LT.KFFS(IP)) THEN
- IKFFS=IP
- GOTO 220
- ENDIF
- 210 CONTINUE
- IKFFS=NKFFS+1
- 220 IF(IKFFS.LT.0) THEN
- IKFFS=-IKFFS
- ELSE
- IF(NKFFS.GE.400) RETURN
- DO 240 IP=NKFFS,IKFFS,-1
- KFFS(IP+1)=KFFS(IP)
- DO 230 J=1,4
- NPFS(IP+1,J)=NPFS(IP,J)
- 230 CONTINUE
- 240 CONTINUE
- NKFFS=NKFFS+1
- KFFS(IKFFS)=KFA
- DO 250 J=1,4
- NPFS(IKFFS,J)=0
- 250 CONTINUE
- ENDIF
- NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
- 260 CONTINUE
-
-C...Write statistics on particle/parton composition of events.
- ELSEIF(MTABU.EQ.22) THEN
- FAC=1D0/MAX(1,NEVFS)
- WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
- DO 270 I=1,NKFFS
- CALL PYNAME(KFFS(I),CHAU)
- KC=PYCOMP(KFFS(I))
- MDCYF=0
- IF(KC.NE.0) MDCYF=MDCY(KC,1)
- WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
- & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
- 270 CONTINUE
-
-C...Copy particle/parton composition information into /PYJETS/.
- ELSEIF(MTABU.EQ.23) THEN
- FAC=1D0/MAX(1,NEVFS)
- DO 290 I=1,NKFFS
- K(I,1)=32
- K(I,2)=99
- K(I,3)=KFFS(I)
- K(I,4)=0
- K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
- DO 280 J=1,4
- P(I,J)=FAC*NPFS(I,J)
- V(I,J)=0D0
- 280 CONTINUE
- P(I,5)=FAC*K(I,5)
- V(I,5)=0D0
- 290 CONTINUE
- N=NKFFS
- DO 300 J=1,5
- K(N+1,J)=0
- P(N+1,J)=0D0
- V(N+1,J)=0D0
- 300 CONTINUE
- K(N+1,1)=32
- K(N+1,2)=99
- K(N+1,5)=NEVFS
- P(N+1,1)=FAC*NPRFS
- P(N+1,2)=FAC*NFIFS
- P(N+1,3)=FAC*NCHFS
- MSTU(3)=1
-
-C...Reset factorial moments statistics.
- ELSEIF(MTABU.EQ.30) THEN
- NEVFM=0
- NMUFM=0
- DO 330 IM=1,3
- DO 320 IB=1,10
- DO 310 IP=1,4
- FM1FM(IM,IB,IP)=0D0
- FM2FM(IM,IB,IP)=0D0
- 310 CONTINUE
- 320 CONTINUE
- 330 CONTINUE
-
-C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
- ELSEIF(MTABU.EQ.31) THEN
- NEVFM=NEVFM+1
- NLOW=N+MSTU(3)
- NUPP=NLOW
- DO 410 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
- IF(MSTU(41).GE.2) THEN
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
- & K(I,2).EQ.KSUSY1+39) GOTO 410
- IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
- & PYCHGE(K(I,2)).EQ.0) GOTO 410
- ENDIF
- PMR=0D0
- IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
- IF(MSTU(42).GE.2) PMR=P(I,5)
- PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
- YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
- & 1D20)),P(I,3))
- IF(ABS(YETA).GT.PARU(57)) GOTO 410
- PHI=PYANGL(P(I,1),P(I,2))
- IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
- IYETA=MAX(0,MIN(511,IYETA))
- IPHI=512D0*(PHI+PARU(1))/PARU(2)
- IPHI=MAX(0,MIN(511,IPHI))
- IYEP=0
- DO 340 IB=0,9
- IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
- 340 CONTINUE
-
-C...Order particles in (pseudo)rapidity and/or azimuth.
- IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
- CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
- RETURN
- ENDIF
- NUPP=NUPP+1
- IF(NUPP.EQ.NLOW+1) THEN
- K(NUPP,1)=IYETA
- K(NUPP,2)=IPHI
- K(NUPP,3)=IYEP
- ELSE
- DO 350 I1=NUPP-1,NLOW+1,-1
- IF(IYETA.GE.K(I1,1)) GOTO 360
- K(I1+1,1)=K(I1,1)
- 350 CONTINUE
- 360 K(I1+1,1)=IYETA
- DO 370 I1=NUPP-1,NLOW+1,-1
- IF(IPHI.GE.K(I1,2)) GOTO 380
- K(I1+1,2)=K(I1,2)
- 370 CONTINUE
- 380 K(I1+1,2)=IPHI
- DO 390 I1=NUPP-1,NLOW+1,-1
- IF(IYEP.GE.K(I1,3)) GOTO 400
- K(I1+1,3)=K(I1,3)
- 390 CONTINUE
- 400 K(I1+1,3)=IYEP
- ENDIF
- 410 CONTINUE
- K(NUPP+1,1)=2**10
- K(NUPP+1,2)=2**10
- K(NUPP+1,3)=4**10
-
-C...Calculate sum of factorial moments in event.
- DO 480 IM=1,3
- DO 430 IB=1,10
- DO 420 IP=1,4
- FEVFM(IB,IP)=0D0
- 420 CONTINUE
- 430 CONTINUE
- DO 450 IB=1,10
- IF(IM.LE.2) IBIN=2**(10-IB)
- IF(IM.EQ.3) IBIN=4**(10-IB)
- IAGR=K(NLOW+1,IM)/IBIN
- NAGR=1
- DO 440 I=NLOW+2,NUPP+1
- ICUT=K(I,IM)/IBIN
- IF(ICUT.EQ.IAGR) THEN
- NAGR=NAGR+1
- ELSE
- IF(NAGR.EQ.1) THEN
- ELSEIF(NAGR.EQ.2) THEN
- FEVFM(IB,1)=FEVFM(IB,1)+2D0
- ELSEIF(NAGR.EQ.3) THEN
- FEVFM(IB,1)=FEVFM(IB,1)+6D0
- FEVFM(IB,2)=FEVFM(IB,2)+6D0
- ELSEIF(NAGR.EQ.4) THEN
- FEVFM(IB,1)=FEVFM(IB,1)+12D0
- FEVFM(IB,2)=FEVFM(IB,2)+24D0
- FEVFM(IB,3)=FEVFM(IB,3)+24D0
- ELSE
- FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
- FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
- FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
- & (NAGR-3D0)
- FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
- & (NAGR-3D0)*(NAGR-4D0)
- ENDIF
- IAGR=ICUT
- NAGR=1
- ENDIF
- 440 CONTINUE
- 450 CONTINUE
-
-C...Add results to total statistics.
- DO 470 IB=10,1,-1
- DO 460 IP=1,4
- IF(FEVFM(1,IP).LT.0.5D0) THEN
- FEVFM(IB,IP)=0D0
- ELSEIF(IM.LE.2) THEN
- FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
- ELSE
- FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
- ENDIF
- FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
- FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
- 460 CONTINUE
- 470 CONTINUE
- 480 CONTINUE
- NMUFM=NMUFM+(NUPP-NLOW)
- MSTU(62)=NUPP-NLOW
-
-C...Write accumulated statistics on factorial moments.
- ELSEIF(MTABU.EQ.32) THEN
- FAC=1D0/MAX(1,NEVFM)
- IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
- IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
- IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
- DO 510 IM=1,3
- WRITE(MSTU(11),5500)
- DO 500 IB=1,10
- BYETA=2D0*PARU(57)
- IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
- BPHI=PARU(2)
- IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
- IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
- IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
- DO 490 IP=1,4
- FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
- FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
- & FMOMA(IP)**2)))
- 490 CONTINUE
- WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
- & IP=1,4)
- 500 CONTINUE
- 510 CONTINUE
-
-C...Copy statistics on factorial moments into /PYJETS/.
- ELSEIF(MTABU.EQ.33) THEN
- FAC=1D0/MAX(1,NEVFM)
- DO 540 IM=1,3
- DO 530 IB=1,10
- I=10*(IM-1)+IB
- K(I,1)=32
- K(I,2)=99
- K(I,3)=1
- IF(IM.NE.2) K(I,3)=2**(IB-1)
- K(I,4)=1
- IF(IM.NE.1) K(I,4)=2**(IB-1)
- K(I,5)=0
- P(I,1)=2D0*PARU(57)/K(I,3)
- V(I,1)=PARU(2)/K(I,4)
- DO 520 IP=1,4
- P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
- V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
- & P(I,IP+1)**2)))
- 520 CONTINUE
- 530 CONTINUE
- 540 CONTINUE
- N=30
- DO 550 J=1,5
- K(N+1,J)=0
- P(N+1,J)=0D0
- V(N+1,J)=0D0
- 550 CONTINUE
- K(N+1,1)=32
- K(N+1,2)=99
- K(N+1,5)=NEVFM
- MSTU(3)=1
-
-C...Reset statistics on Energy-Energy Correlation.
- ELSEIF(MTABU.EQ.40) THEN
- NEVEE=0
- DO 560 J=1,25
- FE1EC(J)=0D0
- FE2EC(J)=0D0
- FE1EC(51-J)=0D0
- FE2EC(51-J)=0D0
- FE1EA(J)=0D0
- FE2EA(J)=0D0
- 560 CONTINUE
-
-C...Find particles to include, with proper assumed mass.
- ELSEIF(MTABU.EQ.41) THEN
- NEVEE=NEVEE+1
- NLOW=N+MSTU(3)
- NUPP=NLOW
- ECM=0D0
- DO 570 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
- IF(MSTU(41).GE.2) THEN
- KC=PYCOMP(K(I,2))
- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
- & K(I,2).EQ.KSUSY1+39) GOTO 570
- IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
- & PYCHGE(K(I,2)).EQ.0) GOTO 570
- ENDIF
- PMR=0D0
- IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
- IF(MSTU(42).GE.2) PMR=P(I,5)
- IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
- CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
- RETURN
- ENDIF
- NUPP=NUPP+1
- P(NUPP,1)=P(I,1)
- P(NUPP,2)=P(I,2)
- P(NUPP,3)=P(I,3)
- P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
- P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
- ECM=ECM+P(NUPP,4)
- 570 CONTINUE
- IF(NUPP.EQ.NLOW) RETURN
-
-C...Analyze Energy-Energy Correlation in event.
- FAC=(2D0/ECM**2)*50D0/PARU(1)
- DO 580 J=1,50
- FEVEE(J)=0D0
- 580 CONTINUE
- DO 600 I1=NLOW+2,NUPP
- DO 590 I2=NLOW+1,I1-1
- CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
- & (P(I1,5)*P(I2,5))
- THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
- ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
- FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
- 590 CONTINUE
- 600 CONTINUE
- DO 610 J=1,25
- FE1EC(J)=FE1EC(J)+FEVEE(J)
- FE2EC(J)=FE2EC(J)+FEVEE(J)**2
- FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
- FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
- FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
- FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
- 610 CONTINUE
- MSTU(62)=NUPP-NLOW
-
-C...Write statistics on Energy-Energy Correlation.
- ELSEIF(MTABU.EQ.42) THEN
- FAC=1D0/MAX(1,NEVEE)
- WRITE(MSTU(11),5700) NEVEE
- DO 620 J=1,25
- FEEC1=FAC*FE1EC(J)
- FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
- FEEC2=FAC*FE1EC(51-J)
- FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
- FEECA=FAC*FE1EA(J)
- FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
- WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
- & FEEC2,FEES2,FEECA,FEESA
- 620 CONTINUE
-
-C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
- ELSEIF(MTABU.EQ.43) THEN
- FAC=1D0/MAX(1,NEVEE)
- DO 630 I=1,25
- K(I,1)=32
- K(I,2)=99
- K(I,3)=0
- K(I,4)=0
- K(I,5)=0
- P(I,1)=FAC*FE1EC(I)
- V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
- P(I,2)=FAC*FE1EC(51-I)
- V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
- P(I,3)=FAC*FE1EA(I)
- V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
- P(I,4)=PARU(1)*(I-1)/50D0
- P(I,5)=PARU(1)*I/50D0
- V(I,4)=3.6D0*(I-1)
- V(I,5)=3.6D0*I
- 630 CONTINUE
- N=25
- DO 640 J=1,5
- K(N+1,J)=0
- P(N+1,J)=0D0
- V(N+1,J)=0D0
- 640 CONTINUE
- K(N+1,1)=32
- K(N+1,2)=99
- K(N+1,5)=NEVEE
- MSTU(3)=1
-
-C...Reset statistics on decay channels.
- ELSEIF(MTABU.EQ.50) THEN
- NEVDC=0
- NKFDC=0
- NREDC=0
-
-C...Identify and order flavour content of final state.
- ELSEIF(MTABU.EQ.51) THEN
- NEVDC=NEVDC+1
- NDS=0
- DO 670 I=1,N
- IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
- NDS=NDS+1
- IF(NDS.GT.8) THEN
- NREDC=NREDC+1
- RETURN
- ENDIF
- KFM=2*IABS(K(I,2))
- IF(K(I,2).LT.0) KFM=KFM-1
- DO 650 IDS=NDS-1,1,-1
- IIN=IDS+1
- IF(KFM.LT.KFDM(IDS)) GOTO 660
- KFDM(IDS+1)=KFDM(IDS)
- 650 CONTINUE
- IIN=1
- 660 KFDM(IIN)=KFM
- 670 CONTINUE
-
-C...Find whether old or new final state.
- DO 690 IDC=1,NKFDC
- IF(NDS.LT.KFDC(IDC,0)) THEN
- IKFDC=IDC
- GOTO 700
- ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
- DO 680 I=1,NDS
- IF(KFDM(I).LT.KFDC(IDC,I)) THEN
- IKFDC=IDC
- GOTO 700
- ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
- GOTO 690
- ENDIF
- 680 CONTINUE
- IKFDC=-IDC
- GOTO 700
- ENDIF
- 690 CONTINUE
- IKFDC=NKFDC+1
- 700 IF(IKFDC.LT.0) THEN
- IKFDC=-IKFDC
- ELSEIF(NKFDC.GE.200) THEN
- NREDC=NREDC+1
- RETURN
- ELSE
- DO 720 IDC=NKFDC,IKFDC,-1
- NPDC(IDC+1)=NPDC(IDC)
- DO 710 I=0,8
- KFDC(IDC+1,I)=KFDC(IDC,I)
- 710 CONTINUE
- 720 CONTINUE
- NKFDC=NKFDC+1
- KFDC(IKFDC,0)=NDS
- DO 730 I=1,NDS
- KFDC(IKFDC,I)=KFDM(I)
- 730 CONTINUE
- NPDC(IKFDC)=0
- ENDIF
- NPDC(IKFDC)=NPDC(IKFDC)+1
-
-C...Write statistics on decay channels.
- ELSEIF(MTABU.EQ.52) THEN
- FAC=1D0/MAX(1,NEVDC)
- WRITE(MSTU(11),5900) NEVDC
- DO 750 IDC=1,NKFDC
- DO 740 I=1,KFDC(IDC,0)
- KFM=KFDC(IDC,I)
- KF=(KFM+1)/2
- IF(2*KF.NE.KFM) KF=-KF
- CALL PYNAME(KF,CHAU)
- CHDC(I)=CHAU(1:12)
- IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
- 740 CONTINUE
- WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
- 750 CONTINUE
- IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
-
-C...Copy statistics on decay channels into /PYJETS/.
- ELSEIF(MTABU.EQ.53) THEN
- FAC=1D0/MAX(1,NEVDC)
- DO 780 IDC=1,NKFDC
- K(IDC,1)=32
- K(IDC,2)=99
- K(IDC,3)=0
- K(IDC,4)=0
- K(IDC,5)=KFDC(IDC,0)
- DO 760 J=1,5
- P(IDC,J)=0D0
- V(IDC,J)=0D0
- 760 CONTINUE
- DO 770 I=1,KFDC(IDC,0)
- KFM=KFDC(IDC,I)
- KF=(KFM+1)/2
- IF(2*KF.NE.KFM) KF=-KF
- IF(I.LE.5) P(IDC,I)=KF
- IF(I.GE.6) V(IDC,I-5)=KF
- 770 CONTINUE
- V(IDC,5)=FAC*NPDC(IDC)
- 780 CONTINUE
- N=NKFDC
- DO 790 J=1,5
- K(N+1,J)=0
- P(N+1,J)=0D0
- V(N+1,J)=0D0
- 790 CONTINUE
- K(N+1,1)=32
- K(N+1,2)=99
- K(N+1,5)=NEVDC
- V(N+1,5)=FAC*NREDC
- MSTU(3)=1
- ENDIF
-
-C...Format statements for output on unit MSTU(11) (default 6).
- 5000 FORMAT(///20X,'Event statistics - initial state'/
- &20X,'based on an analysis of ',I6,' events'//
- &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
- &'according to fragmenting system multiplicity'/
- &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
- &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
- 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
- 5200 FORMAT(///20X,'Event statistics - final state'/
- &20X,'based on an analysis of ',I7,' events'//
- &5X,'Mean primary multiplicity =',F10.4/
- &5X,'Mean final multiplicity =',F10.4/
- &5X,'Mean charged multiplicity =',F10.4//
- &5X,'Number of particles produced per event (directly and via ',
- &'decays/branchings)'/
- &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
- &8X,'Total'/35X,'prim seco prim seco'/)
- 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
- 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
- &20X,'based on an analysis of ',I6,' events'//
- &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
- &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
- 5500 FORMAT(10X)
- 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
- 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
- &20X,'based on an analysis of ',I6,' events'//
- &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
- &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
- 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
- 5900 FORMAT(///20X,'Decay channel analysis - final state'/
- &20X,'based on an analysis of ',I6,' events'//
- &2X,'Probability',10X,'Complete final state'/)
- 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
- 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
- &'or table overflow)')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYEEVT
-C...Handles the generation of an e+e- annihilation jet event.
-
- SUBROUTINE PYEEVT(KFL,ECM)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-
-C...Check input parameters.
- IF(MSTU(12).NE.12345) CALL PYLIST(0)
- IF(KFL.LT.0.OR.KFL.GT.8) THEN
- CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
- IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
- IF(ECM.LT.ECMMIN) THEN
- CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
-
-C...Check consistency of MSTJ options set.
- IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
- CALL PYERRM(6,
- & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
- MSTJ(110)=1
- ENDIF
- IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
- CALL PYERRM(6,
- & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
- MSTJ(111)=0
- ENDIF
-
-C...Initialize alpha_strong and total cross-section.
- MSTU(111)=MSTJ(108)
- IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
- &MSTU(111)=1
- PARU(112)=PARJ(121)
- IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
- IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
- &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
- &XTOT)
- IF(MSTJ(116).GE.3) MSTJ(116)=1
- PARJ(171)=0D0
-
-C...Add initial e+e- to event record (documentation only).
- NTRY=0
- 100 NTRY=NTRY+1
- IF(NTRY.GT.100) THEN
- CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
- RETURN
- ENDIF
- MSTU(24)=0
- NC=0
- IF(MSTJ(115).GE.2) THEN
- NC=NC+2
- CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
- K(NC-1,1)=21
- CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
- K(NC,1)=21
- ENDIF
-
-C...Radiative photon (in initial state).
- MK=0
- ECMC=ECM
- IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
- &THEK,PHIK,ALPK)
- IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
- IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
- NC=NC+1
- CALL PY1ENT(NC,22,PAK,THEK,PHIK)
- K(NC,3)=MIN(MSTJ(115)/2,1)
- ENDIF
-
-C...Virtual exchange boson (gamma or Z0).
- IF(MSTJ(115).GE.3) THEN
- NC=NC+1
- KF=22
- IF(MSTJ(102).EQ.2) KF=23
- MSTU10=MSTU(10)
- MSTU(10)=1
- P(NC,5)=ECMC
- CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
- K(NC,1)=21
- K(NC,3)=1
- MSTU(10)=MSTU10
- ENDIF
-
-C...Choice of flavour and jet configuration.
- CALL PYXKFL(KFL,ECM,ECMC,KFLC)
- IF(KFLC.EQ.0) GOTO 100
- CALL PYXJET(ECMC,NJET,CUT)
- KFLN=21
- IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
- &X12,X14)
- IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
- IF(NJET.EQ.2) MSTJ(120)=1
-
-C...Fill jet configuration and origin.
- IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
- IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
- &ECMC)
- IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
- IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
- &-KFLC,ECMC,X1,X2,X4,X12,X14)
- IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
- &-KFLC,ECMC,X1,X2,X4,X12,X14)
- IF(MSTU(24).NE.0) GOTO 100
- DO 110 IP=NC+1,N
- K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
- 110 CONTINUE
-
-C...Angular orientation according to matrix element.
- IF(MSTJ(106).EQ.1) THEN
- CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
- CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
- CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
- ENDIF
-
-C...Rotation and boost from radiative photon.
- IF(MK.EQ.1) THEN
- DBEK=-PAK/(ECM-PAK)
- NMIN=NC+1-MSTJ(115)/3
- CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
- CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
- CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
- ENDIF
-
-C...Generate parton shower. Rearrange along strings and check.
- IF(MSTJ(101).EQ.5) THEN
- if(parj(200).ne.1.) CALL PYSHOW(N-1,N,ECMC)
- if(parj(200).eq.1.) CALL PYSHOWQ(N-1,N,ECMC)
- MSTJ14=MSTJ(14)
- IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
- IF(MSTJ(105).GE.0) MSTU(28)=0
- CALL PYPREP(0)
- MSTJ(14)=MSTJ14
- IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
- ENDIF
-
-C...Fragmentation/decay generation. Information for PYTABU.
- IF(MSTJ(105).EQ.1) CALL PYEXEC
- MSTU(161)=KFLC
- MSTU(162)=-KFLC
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYXTEE
-C...Calculates total cross-section, including initial state
-C...radiation effects.
-
- SUBROUTINE PYXTEE(KFL,ECM,XTOT)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYDAT1/,/PYDAT2/
-
-C...Status, (optimized) Q^2 scale, alpha_strong.
- PARJ(151)=ECM
- MSTJ(119)=10*MSTJ(102)+KFL
- IF(MSTJ(111).EQ.0) THEN
- Q2R=ECM**2
- ELSEIF(MSTU(111).EQ.0) THEN
- PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
- & ((33D0-2D0*MSTU(112))*PARU(111)))))
- Q2R=PARJ(168)*ECM**2
- ELSE
- PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
- & (2D0*PARU(112)/ECM)**2))
- Q2R=PARJ(168)*ECM**2
- ENDIF
- ALSPI=PYALPS(Q2R)/PARU(1)
-
-C...QCD corrections factor in R.
- IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
- RQCD=1D0
- ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
- RQCD=1D0+ALSPI
- ELSEIF(MSTJ(109).EQ.0) THEN
- RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
- IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
- & LOG(PARJ(168))*ALSPI**2)
- ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
- RQCD=1D0+(3D0/4D0)*ALSPI
- ELSE
- RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
- ENDIF
-
-C...Calculate Z0 width if default value not acceptable.
- IF(MSTJ(102).GE.3) THEN
- RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
- & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
- DO 100 KFLC=5,6
- VQ=1D0
- IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
- & (2D0*PYMASS(KFLC)/ ECM)**2))
- IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
- IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
- RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
- 100 CONTINUE
- PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
- & (1D0-PARU(102)))
- ENDIF
-
-C...Calculate propagator and related constants for QFD case.
- POLL=1D0-PARJ(131)*PARJ(132)
- IF(MSTJ(102).GE.2) THEN
- SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
- SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
- SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
- VE=4D0*PARU(102)-1D0
- SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
- SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
- HF1I=SFI*SF1I
- HF1W=SFW*SF1W
- ENDIF
-
-C...Loop over different flavours: charge, velocity.
- RTOT=0D0
- RQQ=0D0
- RQV=0D0
- RVA=0D0
- DO 110 KFLC=1,MAX(MSTJ(104),KFL)
- IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
- MSTJ(93)=1
- PMQ=PYMASS(KFLC)
- IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
- QF=KCHG(KFLC,1)/3D0
- VQ=1D0
- IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
-
-C...Calculate R and sum of charges for QED or QFD case.
- RQQ=RQQ+3D0*QF**2*POLL
- IF(MSTJ(102).LE.1) THEN
- RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
- ELSE
- VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
- RQV=RQV-6D0*QF*VF*SF1I
- RVA=RVA+3D0*(VF**2+1D0)*SF1W
- RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
- & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
- ENDIF
- 110 CONTINUE
- RSUM=RQQ
- IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
-
-C...Calculate cross-section, including QCD corrections.
- PARJ(141)=RQQ
- PARJ(142)=RTOT
- PARJ(143)=RTOT*RQCD
- PARJ(144)=PARJ(143)
- PARJ(145)=PARJ(141)*86.8D0/ECM**2
- PARJ(146)=PARJ(142)*86.8D0/ECM**2
- PARJ(147)=PARJ(143)*86.8D0/ECM**2
- PARJ(148)=PARJ(147)
- PARJ(157)=RSUM*RQCD
- PARJ(158)=0D0
- PARJ(159)=0D0
- XTOT=PARJ(147)
- IF(MSTJ(107).LE.0) RETURN
-
-C...Virtual cross-section.
- XKL=PARJ(135)
- XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
- ALE=2D0*LOG(ECM/PYMASS(11))-1D0
- SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
- &1.526D0*LOG(ECM**2/0.932D0)
-
-C...Soft and hard radiative cross-section in QED case.
- IF(MSTJ(102).LE.1) THEN
- SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
- SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
- SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
-
-C...Soft and hard radiative cross-section in QFD case.
- ELSE
- SZM=1D0-(PARJ(123)/ECM)**2
- SZW=PARJ(123)*PARJ(124)/ECM**2
- PARJ(161)=-RQQ/RSUM
- PARJ(162)=-(RQQ+RQV+RVA)/RSUM
- PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
- PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
- & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
- SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
- & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
- SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
- & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
- & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
- SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
- & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
- & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
- & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
- ENDIF
-
-C...Total cross-section and fraction of hard photon events.
- PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
- PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
- PARJ(144)=PARJ(157)
- PARJ(148)=PARJ(144)*86.8D0/ECM**2
- XTOT=PARJ(148)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYRADK
-C...Generates initial state photon radiation.
-
- SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-
-C...Function: cumulative hard photon spectrum in QFD case.
- FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
- &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
-
-C...Determine whether radiative photon or not.
- MK=0
- PAK=0D0
- IF(PARJ(160).LT.PYR(0)) RETURN
- MK=1
-
-C...Photon energy range. Find photon momentum in QED case.
- XKL=PARJ(135)
- XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
- IF(MSTJ(102).LE.1) THEN
- 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
- IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
-
-C...Ditto in QFD case, by numerical inversion of integrated spectrum.
- ELSE
- SZM=1D0-(PARJ(123)/ECM)**2
- SZW=PARJ(123)*PARJ(124)/ECM**2
- FXKL=FXK(XKL)
- FXKU=FXK(XKU)
- FXKD=1D-4*(FXKU-FXKL)
- FXKR=FXKL+PYR(0)*(FXKU-FXKL)
- NXK=0
- 110 NXK=NXK+1
- XK=0.5D0*(XKL+XKU)
- FXKV=FXK(XK)
- IF(FXKV.GT.FXKR) THEN
- XKU=XK
- FXKU=FXKV
- ELSE
- XKL=XK
- FXKL=FXKV
- ENDIF
- IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
- XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
- ENDIF
- PAK=0.5D0*ECM*XK
-
-C...Photon polar and azimuthal angle.
- PME=2D0*(PYMASS(11)/ECM)**2
- 120 CTHM=PME*(2D0/PME)**PYR(0)
- IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
- &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
- CTHE=1D0-CTHM
- IF(PYR(0).GT.0.5D0) CTHE=-CTHE
- STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
- THEK=PYANGL(CTHE,STHE)
- PHIK=PARU(2)*PYR(0)
-
-C...Rotation angle for hadronic system.
- SGN=1D0
- IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
- &PYR(0)) SGN=-1D0
- ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
- &(2D0-XK*(1D0-SGN*CTHE)))
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYXKFL
-C...Selects flavour for produced qqbar pair.
-
- SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYDAT1/,/PYDAT2/
-
-C...Calculate maximum weight in QED or QFD case.
- IF(MSTJ(102).LE.1) THEN
- RFMAX=4D0/9D0
- ELSE
- POLL=1D0-PARJ(131)*PARJ(132)
- SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
- SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
- SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
- VE=4D0*PARU(102)-1D0
- HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
- HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
- RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
- & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
- & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
- & 1D0)*HF1W)
- ENDIF
-
-C...Choose flavour. Gives charge and velocity.
- NTRY=0
- 100 NTRY=NTRY+1
- IF(NTRY.GT.100) THEN
- CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
- KFLC=0
- RETURN
- ENDIF
- KFLC=KFL
- IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
- MSTJ(93)=1
- PMQ=PYMASS(KFLC)
- IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
- QF=KCHG(KFLC,1)/3D0
- VQ=1D0
- IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
-
-C...Calculate weight in QED or QFD case.
- IF(MSTJ(102).LE.1) THEN
- RF=QF**2
- RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
- ELSE
- VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
- RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
- RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
- & VQ**3*HF1W
- IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
- ENDIF
-
-C...Weighting or new event (radiative photon). Cross-section update.
- IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
- PARJ(158)=PARJ(158)+1D0
- IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
- IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
- IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
- PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
- PARJ(148)=PARJ(144)*86.8D0/ECM**2
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYXJET
-C...Selects number of jets in matrix element approach.
-
- SUBROUTINE PYXJET(ECM,NJET,CUT)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-C...Local array and data.
- DIMENSION ZHUT(5)
- DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
-
-C...Trivial result for two-jets only, including parton shower.
- IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
- CUT=0D0
-
-C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
- ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
- CF=4D0/3D0
- IF(MSTJ(109).EQ.2) CF=1D0
- IF(MSTJ(111).EQ.0) THEN
- Q2=ECM**2
- Q2R=ECM**2
- ELSEIF(MSTU(111).EQ.0) THEN
- PARJ(169)=MIN(1D0,PARJ(129))
- Q2=PARJ(169)*ECM**2
- PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
- & ((33D0-2D0*MSTU(112))*PARU(111)))))
- Q2R=PARJ(168)*ECM**2
- ELSE
- PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
- Q2=PARJ(169)*ECM**2
- PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
- & (2D0*PARU(112)/ECM)**2))
- Q2R=PARJ(168)*ECM**2
- ENDIF
-
-C...alpha_strong for R and R itself.
- ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
- IF(IABS(MSTJ(101)).EQ.1) THEN
- RQCD=1D0+ALSPI
- ELSEIF(MSTJ(109).EQ.0) THEN
- RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
- IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
- & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
- ELSE
- RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
- ENDIF
-
-C...alpha_strong for jet rate. Initial value for y cut.
- ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
- CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
- IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
- & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
- IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
-
-C...Parametrization of first order three-jet cross-section.
- 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
- PARJ(152)=0D0
- ELSE
- PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
- & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
- & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
- & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
- IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
- & PARJ(152)=0D0
- ENDIF
-
-C...Parametrization of second order three-jet cross-section.
- IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
- & CUT.GE.0.25D0) THEN
- PARJ(153)=0D0
- ELSEIF(MSTJ(110).LE.1) THEN
- CT=LOG(1D0/CUT-2D0)
- PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
- & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
-
-C...Interpolation in second/first order ratio for Zhu parametrization.
- ELSEIF(MSTJ(110).EQ.2) THEN
- IZA=0
- DO 110 IY=1,5
- IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
- 110 CONTINUE
- IF(IZA.NE.0) THEN
- ZHURAT=ZHUT(IZA)
- ELSE
- IZ=100D0*CUT
- ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
- ENDIF
- PARJ(153)=ALSPI*PARJ(152)*ZHURAT
- ENDIF
-
-C...Shift in second order three-jet cross-section with optimized Q^2.
- IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
- & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
- & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
-
-C...Parametrization of second order four-jet cross-section.
- IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
- PARJ(154)=0D0
- ELSE
- CT=LOG(1D0/CUT-5D0)
- IF(CUT.LE.0.018D0) THEN
- XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
- IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
- & 0.4059D0*CT**2)
- XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
- IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
- ELSE
- XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
- IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
- & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
- XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
- & 0.002093D0*CT**3)
- IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
- ENDIF
- PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
- PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
- ENDIF
-
-C...If negative three-jet rate, change y' optimization parameter.
- IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
- & PARJ(169).LT.0.99D0) THEN
- PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
- Q2=PARJ(169)*ECM**2
- ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
- GOTO 100
- ENDIF
-
-C...If too high cross-section, use harder cuts, or fail.
- IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
- IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
- & PARJ(169).LT.0.99D0) THEN
- PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
- Q2=PARJ(169)*ECM**2
- ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
- GOTO 100
- ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
- CALL PYERRM(26,
- & '(PYXJET:) no allowed y cut value for Zhu parametrization')
- ENDIF
- CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
- & PARJ(154))**(-1D0/3D0)
- IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
- GOTO 100
- ENDIF
-
-C...Scalar gluon (first order only).
- ELSE
- ALSPI=PYALPS(ECM**2)/PARU(1)
- CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
- PARJ(152)=0D0
- IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
- & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
- PARJ(153)=0D0
- PARJ(154)=0D0
- ENDIF
-
-C...Select number of jets.
- PARJ(150)=CUT
- IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
- NJET=2
- ELSEIF(MSTJ(101).LE.0) THEN
- NJET=MIN(4,2-MSTJ(101))
- ELSE
- RNJ=PYR(0)
- NJET=2
- IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
- IF(PARJ(154).GT.RNJ) NJET=4
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYX3JT
-C...Selects the kinematical variables of three-jet events.
-
- SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-C...Local array.
- DIMENSION ZHUP(5,12)
-
-C...Coefficients of Zhu second order parametrization.
- DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
- &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
- &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
- &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
- &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
- &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
- &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
- &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
- &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
- &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
- &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
-
-C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
- DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
- &X**7/49D0
-
-C...Event type. Mass effect factors and other common constants.
- MSTJ(120)=2
- MSTJ(121)=0
- PMQ=PYMASS(KFL)
- QME=(2D0*PMQ/ECM)**2
- IF(MSTJ(109).NE.1) THEN
- CUTL=LOG(CUT)
- CUTD=LOG(1D0/CUT-2D0)
- IF(MSTJ(109).EQ.0) THEN
- CF=4D0/3D0
- CN=3D0
- TR=2D0
- WTMX=MIN(20D0,37D0-6D0*CUTD)
- IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
- ELSE
- CF=1D0
- CN=0D0
- TR=12D0
- WTMX=0D0
- ENDIF
-
-C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
- ALS2PI=PARU(118)/PARU(2)
- WTOPT=0D0
- IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
- & LOG(PARJ(169))*ALS2PI
- WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
-
-C...Choose three-jet events in allowed region.
- 100 NJET=3
- 110 Y13L=CUTL+CUTD*PYR(0)
- Y23L=CUTL+CUTD*PYR(0)
- Y13=EXP(Y13L)
- Y23=EXP(Y23L)
- Y12=1D0-Y13-Y23
- IF(Y12.LE.CUT) GOTO 110
- IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
-
-C...Second order corrections.
- IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
- Y12L=LOG(Y12)
- Y13M=LOG(1D0-Y13)
- Y23M=LOG(1D0-Y23)
- Y12M=LOG(1D0-Y12)
- IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
- IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
- IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
- IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
- IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
- IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
- WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
- WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
- & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
- & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
- & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
- & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
- & TR*(2D0*CUTL/3D0-10D0/9D0)+
- & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
- & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
- & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
- & Y13*Y23)/(Y12+Y13)**2)/WT1+
- & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
- & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
- & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
- & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
- & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
- & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
- & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
- IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
- IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
- PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
-
- ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
-C...Second order corrections; Zhu parametrization of ERT.
- ZX=(Y23-Y13)**2
- ZY=1D0-Y12
- IZA=0
- DO 120 IY=1,5
- IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
- 120 CONTINUE
- IF(IZA.NE.0) THEN
- IZ=IZA
- WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
- & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
- & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
- & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
- ELSE
- IZ=100D0*CUT
- WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
- & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
- & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
- & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
- IZ=IZ+1
- WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
- & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
- & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
- & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
- WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
- ENDIF
- IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
- IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
- PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
- ENDIF
-
-C...Impose mass cuts (gives two jets). For fixed jet number new try.
- X1=1D0-Y23
- X2=1D0-Y13
- X3=1D0-Y12
- IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
- IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
- & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
- & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
- IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
-
-C...Scalar gluon model (first order only, no mass effects).
- ELSE
- 130 NJET=3
- 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
- IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
- YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
- X1=1D0-0.5D0*(X3+YD)
- X2=1D0-0.5D0*(X3-YD)
- IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
- IF(MSTJ(102).GE.2) THEN
- IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
- & X3**2*PYR(0)) NJET=2
- ENDIF
- IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYX4JT
-C...Selects the kinematical variables of four-jet events.
-
- SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-C...Local arrays.
- DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
-
-C...Common constants. Colour factors for QCD and Abelian gluon theory.
- PMQ=PYMASS(KFL)
- QME=(2D0*PMQ/ECM)**2
- CT=LOG(1D0/CUT-5D0)
- IF(MSTJ(109).EQ.0) THEN
- CF=4D0/3D0
- CN=3D0
- TR=2.5D0
- ELSE
- CF=1D0
- CN=0D0
- TR=15D0
- ENDIF
-
-C...Choice of process (qqbargg or qqbarqqbar).
- 100 NJET=4
- IT=1
- IF(PARJ(155).GT.PYR(0)) IT=2
- IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
- IF(IT.EQ.1) WTMX=0.7D0/CUT**2
- IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
- IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
- ID=1
-
-C...Sample the five kinematical variables (for qqgg preweighted in y34).
- 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
- Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
- IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
- IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
- IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
- VT=PYR(0)
- CP=COS(PARU(1)*PYR(0))
- Y14=(Y134-Y34)*VT
- Y13=Y134-Y14-Y34
- VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
- Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
- &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
- Y23=Y234-Y34-Y24
- Y12=1D0-Y134-Y23-Y24
- IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
- Y123=Y12+Y13+Y23
- Y124=Y12+Y14+Y24
-
-C...Calculate matrix elements for qqgg or qqqq process.
- IC=0
- WTTOT=0D0
- 120 IC=IC+1
- IF(IT.EQ.1) THEN
- WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
- & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
- & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
- & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
- & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
- & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
- & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
- & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
- WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
- & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
- & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
- & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
- WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
- & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
- & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
- & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
- & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
- & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
- & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
- & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
- & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
- & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
- & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
- & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
- WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
- & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
- & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
- & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
- & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
- & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
- & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
- & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
- & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
- & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
- & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
- & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
- & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
- & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
- & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
- & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
- WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
- & CN*WTC(IC))/8D0
- ELSE
- WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
- & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
- & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
- & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
- & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
- & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
- & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
- & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
- & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
- WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
- & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
- & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
- & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
- & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
- & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
- & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
- & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
- WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
- ENDIF
-
-C...Permutations of momenta in matrix element. Weighting.
- 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
- YSAV=Y13
- Y13=Y14
- Y14=YSAV
- YSAV=Y23
- Y23=Y24
- Y24=YSAV
- YSAV=Y123
- Y123=Y124
- Y124=YSAV
- ENDIF
- IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
- YSAV=Y13
- Y13=Y23
- Y23=YSAV
- YSAV=Y14
- Y14=Y24
- Y24=YSAV
- YSAV=Y134
- Y134=Y234
- Y234=YSAV
- ENDIF
- IF(IC.LE.3) GOTO 120
- IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
- IC=5
-
-C...qqgg events: string configuration and event type.
- IF(IT.EQ.1) THEN
- IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
- PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
- & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
- IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
- & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
- IF(ID.EQ.2) GOTO 130
- ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
- PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
- IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
- IF(ID.EQ.2) GOTO 130
- ENDIF
- MSTJ(120)=3
- IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
- & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
- KFLN=21
-
-C...Mass cuts. Kinematical variables out.
- IF(Y12.LE.CUT+QME) NJET=2
- IF(NJET.EQ.2) GOTO 150
- Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
- X1=1D0-(1D0-Q12)*Y234-Q12*Y134
- X4=1D0-(1D0-Q12)*Y134-Q12*Y234
- X2=1D0-Y124
- X12=(1D0-Q12)*Y13+Q12*Y23
- X14=Y12-0.5D0*QME
- IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
-
-C...qqbarqqbar events: string configuration, choose new flavour.
- ELSE
- IF(ID.EQ.1) THEN
- WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
- IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
- IF(WTR.LT.WTD(3)+WTD(4)) ID=3
- IF(WTR.LT.WTD(4)) ID=4
- IF(ID.GE.2) GOTO 130
- ENDIF
- MSTJ(120)=5
- PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
- 140 KFLN=1+INT(5D0*PYR(0))
- IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
- IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
- IF(KFLN.GT.MSTJ(104)) NJET=2
- PMQN=PYMASS(KFLN)
- QMEN=(2D0*PMQN/ECM)**2
-
-C...Mass cuts. Kinematical variables out.
- IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
- IF(NJET.EQ.2) GOTO 150
- Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
- Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
- X1=1D0-(1D0-Q24)*Y123-Q24*Y134
- X4=1D0-(1D0-Q24)*Y134-Q24*Y123
- X2=1D0-(1D0-Q13)*Y234-Q13*Y124
- X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
- & Q13*Y23)
- X14=Y24-0.5D0*QME
- X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
- & Q13*Y14)
- IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
- & (PARJ(127)+PMQ+PMQN)**2) NJET=2
- IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
- ENDIF
- 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYXDIF
-C...Gives the angular orientation of events.
-
- SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-
-C...Charge. Factors depending on polarization for QED case.
- QF=KCHG(KFL,1)/3D0
- POLL=1D0-PARJ(131)*PARJ(132)
- POLD=PARJ(132)-PARJ(131)
- IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
- HF1=POLL
- HF2=0D0
- HF3=PARJ(133)**2
- HF4=0D0
-
-C...Factors depending on flavour, energy and polarization for QFD case.
- ELSE
- SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
- SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
- SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
- AE=-1D0
- VE=4D0*PARU(102)-1D0
- AF=SIGN(1D0,QF)
- VF=AF-4D0*QF*PARU(102)
- HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
- & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
- HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
- & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
- HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
- & SFW*SFF**2*(VE**2-AE**2))
- HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
- & SFF*AE
- ENDIF
-
-C...Mass factor. Differential cross-sections for two-jet events.
- SQ2=SQRT(2D0)
- QME=0D0
- IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
- &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
- IF(NJET.EQ.2) THEN
- SIGU=4D0*SQRT(1D0-QME)
- SIGL=2D0*QME*SQRT(1D0-QME)
- SIGT=0D0
- SIGI=0D0
- SIGA=0D0
- SIGP=4D0
-
-C...Kinematical variables. Reduce four-jet event to three-jet one.
- ELSE
- IF(NJET.EQ.3) THEN
- X1=2D0*P(NC+1,4)/ECM
- X2=2D0*P(NC+3,4)/ECM
- ELSE
- ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
- & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
- X1=2D0*P(NC+1,4)/ECMR
- X2=2D0*P(NC+4,4)/ECMR
- ENDIF
-
-C...Differential cross-sections for three-jet (or reduced four-jet).
- XQ=(1D0-X1)/(1D0-X2)
- CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
- ST12=SQRT(1D0-CT12**2)
- IF(MSTJ(109).NE.1) THEN
- SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
- & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
- SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
- & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
- & X2)*XQ
- SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
- SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
- & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
- SIGA=X2**2*ST12/SQ2
- SIGP=2D0*(X1**2-X2**2*CT12)
-
-C...Differential cross-sect for scalar gluons (no mass effects).
- ELSE
- X3=2D0-X1-X2
- XT=X2*ST12
- CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
- SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
- & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
- SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
- & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
- SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
- & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
- SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
- & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
- SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
- SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
- ENDIF
- ENDIF
-
-C...Upper bounds for differential cross-section.
- HF1A=ABS(HF1)
- HF2A=ABS(HF2)
- HF3A=ABS(HF3)
- HF4A=ABS(HF4)
- SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
- &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
- &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
- &2D0*HF2A*ABS(SIGP)
-
-C...Generate angular orientation according to differential cross-sect.
- 100 CHI=PARU(2)*PYR(0)
- CTHE=2D0*PYR(0)-1D0
- PHI=PARU(2)*PYR(0)
- CCHI=COS(CHI)
- SCHI=SIN(CHI)
- C2CHI=COS(2D0*CHI)
- S2CHI=SIN(2D0*CHI)
- THE=ACOS(CTHE)
- STHE=SIN(THE)
- C2PHI=COS(2D0*(PHI-PARJ(134)))
- S2PHI=SIN(2D0*(PHI-PARJ(134)))
- SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
- &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
- &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
- &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
- &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
- &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
- &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
- IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYONIA
-C...Generates Upsilon and toponium decays into three gluons
-C...or two gluons and a photon.
-
- SUBROUTINE PYONIA(KFL,ECM)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
-
-C...Printout. Check input parameters.
- IF(MSTU(12).NE.12345) CALL PYLIST(0)
- IF(KFL.LT.0.OR.KFL.GT.8) THEN
- CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
- IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
- CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
- IF(MSTU(21).GE.1) RETURN
- ENDIF
-
-C...Initial e+e- and onium state (optional).
- NC=0
- IF(MSTJ(115).GE.2) THEN
- NC=NC+2
- CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
- K(NC-1,1)=21
- CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
- K(NC,1)=21
- ENDIF
- KFLC=IABS(KFL)
- IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
- NC=NC+1
- KF=110*KFLC+3
- MSTU10=MSTU(10)
- MSTU(10)=1
- P(NC,5)=ECM
- CALL PY1ENT(NC,KF,ECM,0D0,0D0)
- K(NC,1)=21
- K(NC,3)=1
- MSTU(10)=MSTU10
- ENDIF
-
-C...Choose x1 and x2 according to matrix element.
- NTRY=0
- 100 X1=PYR(0)
- X2=PYR(0)
- X3=2D0-X1-X2
- IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
- &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
- NTRY=NTRY+1
- NJET=3
- IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
- IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
-
-C...Photon-gluon-gluon events. Small system modifications. Jet origin.
- MSTU(111)=MSTJ(108)
- IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
- &MSTU(111)=1
- PARU(112)=PARJ(121)
- IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
- QF=0D0
- IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
- RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
- MK=0
- ECMC=ECM
- IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
- IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
- & NJET=2
- IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
- IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
- ELSE
- MK=1
- ECMC=SQRT(1D0-X1)*ECM
- IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
- K(NC+1,1)=1
- K(NC+1,2)=22
- K(NC+1,4)=0
- K(NC+1,5)=0
- IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
- IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
- IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
- IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
- NJET=2
- IF(ECMC.LT.4D0*PARJ(127)) THEN
- MSTU10=MSTU(10)
- MSTU(10)=1
- P(NC+2,5)=ECMC
- CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
- MSTU(10)=MSTU10
- NJET=0
- ENDIF
- ENDIF
- DO 110 IP=NC+1,N
- K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
- 110 CONTINUE
-
-C...Differential cross-sections. Upper limit for cross-section.
- IF(MSTJ(106).EQ.1) THEN
- SQ2=SQRT(2D0)
- HF1=1D0-PARJ(131)*PARJ(132)
- HF3=PARJ(133)**2
- CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
- ST13=SQRT(1D0-CT13**2)
- SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
- SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
- SIGT=0.5D0*SIGL
- SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
- SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
- & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
-
-C...Angular orientation of event.
- 120 CHI=PARU(2)*PYR(0)
- CTHE=2D0*PYR(0)-1D0
- PHI=PARU(2)*PYR(0)
- CCHI=COS(CHI)
- SCHI=SIN(CHI)
- C2CHI=COS(2D0*CHI)
- S2CHI=SIN(2D0*CHI)
- THE=ACOS(CTHE)
- STHE=SIN(THE)
- C2PHI=COS(2D0*(PHI-PARJ(134)))
- S2PHI=SIN(2D0*(PHI-PARJ(134)))
- SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
- & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
- & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
- & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
- & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
- IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
- CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
- CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
- ENDIF
-
-C...Generate parton shower. Rearrange along strings and check.
- IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
- if(parj(200).ne.1.) CALL PYSHOW(NC+MK+1,-NJET,ECMC)
- if(parj(200).eq.1.) CALL PYSHOWQ(NC+MK+1,-NJET,ECMC)
- MSTJ14=MSTJ(14)
- IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
- IF(MSTJ(105).GE.0) MSTU(28)=0
- CALL PYPREP(0)
- MSTJ(14)=MSTJ14
- IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
- ENDIF
-
-C...Generate fragmentation. Information for PYTABU:
- IF(MSTJ(105).EQ.1) CALL PYEXEC
- MSTU(161)=110*KFLC+3
- MSTU(162)=0
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYBOOK
-C...Books a histogram.
-
- SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
-
-C...Double precision declaration.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-C...Commonblock.
- COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
- SAVE /PYBINS/
-C...Local character variables.
- CHARACTER TITLE*(*), TITFX*60
-
-C...Check that input is sensible. Find initial address in memory.
- IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
- &'(PYBOOK:) not allowed histogram number')
- IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
- &'(PYBOOK:) not allowed number of bins')
- IF(XL.GE.XU) CALL PYERRM(28,
- &'(PYBOOK:) x limits in wrong order')
- INDX(ID)=IHIST(4)
- IHIST(4)=IHIST(4)+28+NX
- IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
- &'(PYBOOK:) out of histogram space')
- IS=INDX(ID)
-
-C...Store histogram size and reset contents.
- BIN(IS+1)=NX
- BIN(IS+2)=XL
- BIN(IS+3)=XU
- BIN(IS+4)=(XU-XL)/NX
- CALL PYNULL(ID)
-
-C...Store title by conversion to integer to double precision.
- TITFX=TITLE//' '
- DO 100 IT=1,20
- BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
- & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
- 100 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYFILL
-C...Fills entry in histogram.
-
- SUBROUTINE PYFILL(ID,X,W)
-
-C...Double precision declaration.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-C...Commonblock.
- COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
- SAVE /PYBINS/
-
-C...Find initial address in memory. Increase number of entries.
- IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
- &'(PYFILL:) not allowed histogram number')
- IS=INDX(ID)
- IF(IS.EQ.0) CALL PYERRM(28,
- &'(PYFILL:) filling unbooked histogram')
- BIN(IS+5)=BIN(IS+5)+1D0
-
-C...Find bin in x, including under/overflow, and fill.
- IF(X.LT.BIN(IS+2)) THEN
- BIN(IS+6)=BIN(IS+6)+W
- ELSEIF(X.GE.BIN(IS+3)) THEN
- BIN(IS+8)=BIN(IS+8)+W
- ELSE
- BIN(IS+7)=BIN(IS+7)+W
- IX=(X-BIN(IS+2))/BIN(IS+4)
- IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
- BIN(IS+9+IX)=BIN(IS+9+IX)+W
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYFACT
-C...Multiplies histogram contents by factor.
-
- SUBROUTINE PYFACT(ID,F)
-
-C...Double precision declaration.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-C...Commonblock.
- COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
- SAVE /PYBINS/
-
-C...Find initial address in memory. Multiply all contents bins.
- IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
- &'(PYFACT:) not allowed histogram number')
- IS=INDX(ID)
- IF(IS.EQ.0) CALL PYERRM(28,
- &'(PYFACT:) scaling unbooked histogram')
- DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
- BIN(IX)=F*BIN(IX)
- 100 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYOPER
-C...Performs operations between histograms.
-
- SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
-
-C...Double precision declaration.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-C...Commonblock.
- COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
- SAVE /PYBINS/
-C...Character variable.
- CHARACTER OPER*(*)
-
-C...Find initial addresses in memory, and histogram size.
- IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
- &'(PYFACT:) not allowed histogram number')
- IS1=INDX(ID1)
- IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
- IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
- NX=NINT(BIN(IS3+1))
- IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
-
-C...Update info on number of histogram entries.
- IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
- BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
- ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
- BIN(IS3+5)=BIN(IS1+5)
- ENDIF
-
-C...Operations on pair of histograms: addition, subtraction,
-C...multiplication, division.
- IF(OPER.EQ.'+') THEN
- DO 100 IX=6,8+NX
- BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
- 100 CONTINUE
- ELSEIF(OPER.EQ.'-') THEN
- DO 110 IX=6,8+NX
- BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
- 110 CONTINUE
- ELSEIF(OPER.EQ.'*') THEN
- DO 120 IX=6,8+NX
- BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
- 120 CONTINUE
- ELSEIF(OPER.EQ.'/') THEN
- DO 130 IX=6,8+NX
- FA2=F2*BIN(IS2+IX)
- IF(ABS(FA2).LE.1D-20) THEN
- BIN(IS3+IX)=0D0
- ELSE
- BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
- ENDIF
- 130 CONTINUE
-
-C...Operations on single histogram: multiplication+addition,
-C...square root+addition, logarithm+addition.
- ELSEIF(OPER.EQ.'A') THEN
- DO 140 IX=6,8+NX
- BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
- 140 CONTINUE
- ELSEIF(OPER.EQ.'S') THEN
- DO 150 IX=6,8+NX
- BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
- 150 CONTINUE
- ELSEIF(OPER.EQ.'L') THEN
- ZMIN=1D20
- DO 160 IX=9,8+NX
- IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
- & ZMIN=0.8D0*BIN(IS1+IX)
- 160 CONTINUE
- DO 170 IX=6,8+NX
- BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
- 170 CONTINUE
-
-C...Operation on two or three histograms: average and
-C...standard deviation.
- ELSEIF(OPER.EQ.'M') THEN
- DO 180 IX=6,8+NX
- IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
- BIN(IS2+IX)=0D0
- ELSE
- BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
- ENDIF
- IF(ID3.NE.0) THEN
- IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
- BIN(IS3+IX)=0D0
- ELSE
- BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
- & BIN(IS2+IX)**2))
- ENDIF
- ENDIF
- BIN(IS1+IX)=F1*BIN(IS1+IX)
- 180 CONTINUE
- ENDIF
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYHIST
-C...Prints and resets all histograms.
-
- SUBROUTINE PYHIST
-
-C...Double precision declaration.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-C...Commonblock.
- COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
- SAVE /PYBINS/
-
-C...Loop over histograms, print and reset used ones.
- DO 100 ID=1,IHIST(1)
- IS=INDX(ID)
- IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
- CALL PYPLOT(ID)
- CALL PYNULL(ID)
- ENDIF
- 100 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYPLOT
-C...Prints a histogram (but does not reset it).
-
- SUBROUTINE PYPLOT(ID)
-
-C...Double precision declaration.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
- SAVE /PYDAT1/,/PYBINS/
-C...Local arrays and character variables.
- DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
- CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
-
-C...Steps in histogram scale. Character sequence.
- DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
- DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
-
-C...Find initial address in memory; skip if empty histogram.
- IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
- IS=INDX(ID)
- IF(IS.EQ.0) RETURN
- IF(NINT(BIN(IS+5)).LE.0) THEN
- WRITE(MSTU(11),5000) ID
- RETURN
- ENDIF
-
-C...Number of histogram lines and x bins.
- LIN=IHIST(3)-18
- NX=NINT(BIN(IS+1))
-
-C...Extract title by conversion from double precision via integer.
- DO 100 IT=1,20
- IEQ=NINT(BIN(IS+8+NX+IT))
- TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
- & //CHAR(MOD(IEQ,256))
- 100 CONTINUE
-
-C...Find time; print title.
- CALL PYTIME(IDATI)
- IF(IDATI(1).GT.0) THEN
- WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
- ELSE
- WRITE(MSTU(11),5200) ID, TITLE
- ENDIF
-
-C...Find minimum and maximum bin content.
- YMIN=BIN(IS+9)
- YMAX=BIN(IS+9)
- DO 110 IX=IS+10,IS+8+NX
- IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
- IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
- 110 CONTINUE
-
-C...Determine scale and step size for y axis.
- IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
- IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
- IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
- IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
- IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
- IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
- DELY=DYAC(1)
- DO 120 IDEL=1,9
- IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
- 120 CONTINUE
- DY=DELY*10D0**IPOT
-
-C...Convert bin contents to integer form; fractional fill in top row.
- DO 130 IX=1,NX
- CTA=ABS(BIN(IS+8+IX))/DY
- IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
- IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
- 130 CONTINUE
- IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
- IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
-
-C...Print histogram row by row.
- DO 150 IR=IRMA,IRMI,-1
- IF(IR.EQ.0) GOTO 150
- OUT=' '
- DO 140 IX=1,NX
- IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
- IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
- 140 CONTINUE
- WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
- 150 CONTINUE
-
-C...Print sign and value of bin contents.
- IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
- OUT=' '
- DO 160 IX=1,NX
- IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
- IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
- 160 CONTINUE
- WRITE(MSTU(11),5400) OUT
- DO 180 IR=4,1,-1
- DO 170 IX=1,NX
- OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
- 170 CONTINUE
- WRITE(MSTU(11),5500) IPOT+IR-4, OUT
- 180 CONTINUE
-
-C...Print sign and value of lower bin edge.
- IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
- & 10.0001D0)-10
- OUT=' '
- DO 190 IX=1,NX
- IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
- & OUT(IX:IX)=CHA(11)
- IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
- 190 CONTINUE
- WRITE(MSTU(11),5600) OUT
- DO 210 IR=3,1,-1
- DO 200 IX=1,NX
- OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
- 200 CONTINUE
- WRITE(MSTU(11),5500) IPOT+IR-3, OUT
- 210 CONTINUE
- ENDIF
-
-C...Calculate and print statistics.
- CSUM=0D0
- CXSUM=0D0
- CXXSUM=0D0
- DO 220 IX=1,NX
- CTA=ABS(BIN(IS+8+IX))
- X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
- CSUM=CSUM+CTA
- CXSUM=CXSUM+CTA*X
- CXXSUM=CXXSUM+CTA*X**2
- 220 CONTINUE
- XMEAN=CXSUM/MAX(CSUM,1D-20)
- XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
- WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
- &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
-
-C...Formats for output.
- 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
- 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
- &I2,':',I2/)
- 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
- 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
- 5400 FORMAT(/8X,'Contents',3X,A100)
- 5500 FORMAT(9X,'*10**',I2,3X,A100)
- 5600 FORMAT(/8X,'Low edge',3X,A100)
- 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
- &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
- &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYNULL
-C...Resets bin contents of a histogram.
-
- SUBROUTINE PYNULL(ID)
-
-C...Double precision declaration.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-C...Commonblock.
- COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
- SAVE /PYBINS/
-
- IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
- IS=INDX(ID)
- IF(IS.EQ.0) RETURN
- DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
- BIN(IX)=0D0
- 100 CONTINUE
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYDUMP
-C...Dumps histogram contents on file for reading by other program.
-C...Can also read back own dump.
-
- SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
-
-C...Double precision declaration.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-C...Commonblock.
- COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
- SAVE /PYBINS/
-C...Local arrays and character variables.
- DIMENSION IHI(*),ISS(100),VAL(5)
- CHARACTER TITLE*60,FORMAT*13
-
-C...Dump all histograms that have been booked,
-C...including titles and ranges, one after the other.
- IF(MDUMP.EQ.1) THEN
-
-C...Loop over histograms and find which are wanted and booked.
- IF(NHI.LE.0) THEN
- NW=IHIST(1)
- ELSE
- NW=NHI
- ENDIF
- DO 130 IW=1,NW
- IF(NHI.EQ.0) THEN
- ID=IW
- ELSE
- ID=IHI(IW)
- ENDIF
- IS=INDX(ID)
- IF(IS.NE.0) THEN
-
-C...Write title, histogram size, filling statistics.
- NX=NINT(BIN(IS+1))
- DO 100 IT=1,20
- IEQ=NINT(BIN(IS+8+NX+IT))
- TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
- & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
- 100 CONTINUE
- WRITE(LFN,5100) ID,TITLE
- WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
- WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
- & BIN(IS+8)
-
-
-C...Write histogram contents, in groups of five.
- DO 120 IXG=1,(NX+4)/5
- DO 110 IXV=1,5
- IX=5*IXG+IXV-5
- IF(IX.LE.NX) THEN
- VAL(IXV)=BIN(IS+8+IX)
- ELSE
- VAL(IXV)=0D0
- ENDIF
- 110 CONTINUE
- WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
- 120 CONTINUE
-
-C...Go to next histogram; finish.
- ELSEIF(NHI.GT.0) THEN
- CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
- ENDIF
- 130 CONTINUE
-
-C...Read back in histograms dumped MDUMP=1.
- ELSEIF(MDUMP.EQ.2) THEN
-
-C...Read histogram number, title and range, and book.
- 140 READ(LFN,5100,END=170) ID,TITLE
- READ(LFN,5200) NX,XL,XU
- CALL PYBOOK(ID,TITLE,NX,XL,XU)
- IS=INDX(ID)
-
-C...Read filling statistics.
- READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
- BIN(IS+5)=DBLE(NENTRY)
-
-C...Read histogram contents, in groups of five.
- DO 160 IXG=1,(NX+4)/5
- READ(LFN,5400) (VAL(IXV),IXV=1,5)
- DO 150 IXV=1,5
- IX=5*IXG+IXV-5
- IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
- 150 CONTINUE
- 160 CONTINUE
-
-C...Go to next histogram; finish.
- GOTO 140
- 170 CONTINUE
-
-C...Write histogram contents in column format,
-C...convenient e.g. for GNUPLOT input.
- ELSEIF(MDUMP.EQ.3) THEN
-
-C...Find addresses to wanted histograms.
- NSS=0
- IF(NHI.LE.0) THEN
- NW=IHIST(1)
- ELSE
- NW=NHI
- ENDIF
- DO 180 IW=1,NW
- IF(NHI.EQ.0) THEN
- ID=IW
- ELSE
- ID=IHI(IW)
- ENDIF
- IS=INDX(ID)
- IF(IS.NE.0.AND.NSS.LT.100) THEN
- NSS=NSS+1
- ISS(NSS)=IS
- ELSEIF(NSS.GE.100) THEN
- CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
- ELSEIF(NHI.GT.0) THEN
- CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
- ENDIF
- 180 CONTINUE
-
-C...Check that they have common number of x bins. Fix format.
- NX=NINT(BIN(ISS(1)+1))
- DO 190 IW=2,NSS
- IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
- CALL PYERRM(8,'(PYDUMP:) different number of bins')
- RETURN
- ENDIF
- 190 CONTINUE
- FORMAT='(1P,000E12.4)'
- WRITE(FORMAT(5:7),'(I3)') NSS+1
-
-C...Write histogram contents; first column x values.
- DO 200 IX=1,NX
- X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
- WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
- 200 CONTINUE
-
- ENDIF
-
-C...Formats for output.
- 5100 FORMAT(I5,5X,A60)
- 5200 FORMAT(I5,1P,2D12.4)
- 5300 FORMAT(I12,1P,3D12.4)
- 5400 FORMAT(1P,5D12.4)
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYSTOP
-C...Allows users to handle STOP statemens
-
- SUBROUTINE PYSTOP(MCOD)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-
-
-C...Write message, then stop
- WRITE(MSTU(11),5000) MCOD
- STOP
-
-
-C...Formats for output.
- 5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
- RETURN
- END
-
-C*********************************************************************
-
-C...PYKCUT
-C...Dummy routine, which the user can replace in order to make cuts on
-C...the kinematics on the parton level before the matrix elements are
-C...evaluated and the event is generated. The cross-section estimates
-C...will automatically take these cuts into account, so the given
-C...values are for the allowed phase space region only. MCUT=0 means
-C...that the event has passed the cuts, MCUT=1 that it has failed.
-
- SUBROUTINE PYKCUT(MCUT)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- SAVE /PYDAT1/,/PYINT1/,/PYINT2/
-
-C...Set default value (accepting event) for MCUT.
- MCUT=0
-
-C...Read out subprocess number.
- ISUB=MINT(1)
- ISTSB=ISET(ISUB)
-
-C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
- TAU=VINT(21)
- YST=VINT(22)
- CTH=0D0
- IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
- TAUP=0D0
- IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
-
-C...Calculate x_1, x_2, x_F.
- IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
- X1=SQRT(TAU)*EXP(YST)
- X2=SQRT(TAU)*EXP(-YST)
- ELSE
- X1=SQRT(TAUP)*EXP(YST)
- X2=SQRT(TAUP)*EXP(-YST)
- ENDIF
- XF=X1-X2
-
-C...Calculate shat, that, uhat, p_T^2.
- SHAT=TAU*VINT(2)
- SQM3=VINT(63)
- SQM4=VINT(64)
- RM3=SQM3/SHAT
- RM4=SQM4/SHAT
- BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
- RPTS=4D0*VINT(71)**2/SHAT
- BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
- RM34=2D0*RM3*RM4
- RSQM=1D0+RM34
- RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
- THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
- UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
- PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
-
-C...Decisions by user to be put here.
-
-C...Stop program if this routine is ever called.
-C...You should not copy these lines to your own routine.
- WRITE(MSTU(11),5000)
- CALL PYSTOP(6)
-
-C...Format for error printout.
- 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
- &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
- &1X,'Execution stopped!')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYEVWT
-C...Dummy routine, which the user can replace in order to multiply the
-C...standard PYTHIA differential cross-section by a process- and
-C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
-C...to generation of weighted events, with weight 1/WTXS, while for
-C...MSTP(142)=2 it corresponds to a modification of the underlying
-C...physics.
-
- SUBROUTINE PYEVWT(WTXS)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- COMMON/PYINT1/MINT(400),VINT(400)
- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
- SAVE /PYDAT1/,/PYINT1/,/PYINT2/
-
-C...Set default weight for WTXS.
- WTXS=1D0
-
-C...Read out subprocess number.
- ISUB=MINT(1)
- ISTSB=ISET(ISUB)
-
-C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
- TAU=VINT(21)
- YST=VINT(22)
- CTH=0D0
- IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
- TAUP=0D0
- IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
-
-C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
- X1=VINT(41)
- X2=VINT(42)
- XF=X1-X2
- SHAT=VINT(44)
- THAT=VINT(45)
- UHAT=VINT(46)
- PT2=VINT(48)
-
-C...Modifications by user to be put here.
-
-C...Stop program if this routine is ever called.
-C...You should not copy these lines to your own routine.
- WRITE(MSTU(11),5000)
- CALL PYSTOP(4)
-
-C...Format for error printout.
- 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
- &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
- &1X,'Execution stopped!')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...UPINIT
-C...Dummy routine, to be replaced by a user implementing external
-C...processes. Is supposed to fill the HEPRUP commonblock with info
-C...on incoming beams and allowed processes.
-
-C...New example: handles a standard Les Houches Events File.
-
- SUBROUTINE UPINIT
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-
-C...PYTHIA commonblock: only used to provide read unit MSTP(161).
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- SAVE /PYPARS/
-
-C...User process initialization commonblock.
- INTEGER MAXPUP
- PARAMETER (MAXPUP=100)
- INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
- DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
- COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
- &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
- &LPRUP(MAXPUP)
- SAVE /HEPRUP/
-
-C...Lines to read in assumed never longer than 200 characters.
- PARAMETER (MAXLEN=200)
- CHARACTER*(MAXLEN) STRING
-
-C...Format for reading lines.
- CHARACTER*6 STRFMT
- STRFMT='(A000)'
- WRITE(STRFMT(3:5),'(I3)') MAXLEN
-
-C...Loop until finds line beginning with "<init>" or "<init ".
- 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
- IBEG=0
- 110 IBEG=IBEG+1
-C...Allow indentation.
- IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
- IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
- &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
-
-C...Read first line of initialization info.
- READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
- &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
-
-C...Read NPRUP subsequent lines with information on each process.
- DO 120 IPR=1,NPRUP
- READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
- & XMAXUP(IPR),LPRUP(IPR)
- 120 CONTINUE
- RETURN
-
-C...Error exit: give up if initalization does not work.
- 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
- WRITE(*,*) ' Event generation will be stopped.'
- CALL PYSTOP(12)
-
- RETURN
- END
-
-C...Old example: handles a simple Pythia 6.4 initialization file.
-
-c SUBROUTINE UPINIT
-
-C...Double precision and integer declarations.
-c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
-c IMPLICIT INTEGER(I-N)
-
-C...Commonblocks.
-c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
-c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
-c SAVE /PYDAT1/,/PYPARS/
-
-C...User process initialization commonblock.
-c INTEGER MAXPUP
-c PARAMETER (MAXPUP=100)
-c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
-c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
-c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
-c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
-c &LPRUP(MAXPUP)
-c SAVE /HEPRUP/
-
-C...Read info from file.
-c IF(MSTP(161).GT.0) THEN
-c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
-c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
-c DO 100 IPR=1,NPRUP
-c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
-c & XMAXUP(IPR),LPRUP(IPR)
-c 100 CONTINUE
-c RETURN
-C...Error or prematurely reached end of file.
-c 110 WRITE(MSTU(11),5000)
-c STOP
-
-C...Else not implemented.
-c ELSE
-c WRITE(MSTU(11),5100)
-c STOP
-c ENDIF
-
-C...Format for error printout.
-c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
-c &1X,'Execution stopped!')
-c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
-c &1X,'Dummy routine in PYTHIA file called instead.'/
-c &1X,'Execution stopped!')
-
-c RETURN
-c END
-
-C*********************************************************************
-
-C...UPEVNT
-C...Dummy routine, to be replaced by a user implementing external
-C...processes. Depending on cross section model chosen, it either has
-C...to generate a process of the type IDPRUP requested, or pick a type
-C...itself and generate this event. The event is to be stored in the
-C...HEPEUP commonblock, including (often) an event weight.
-
-C...New example: handles a standard Les Houches Events File.
-
- SUBROUTINE UPEVNT
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-
-C...PYTHIA commonblock: only used to provide read unit MSTP(162).
- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
- SAVE /PYPARS/
-
-C...User process event common block.
- INTEGER MAXNUP
- PARAMETER (MAXNUP=500)
- INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
- DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
- COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
- &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
- &VTIMUP(MAXNUP),SPINUP(MAXNUP)
- SAVE /HEPEUP/
-
-C...Lines to read in assumed never longer than 200 characters.
- PARAMETER (MAXLEN=200)
- CHARACTER*(MAXLEN) STRING
-
-C...Format for reading lines.
- CHARACTER*6 STRFMT
- STRFMT='(A000)'
- WRITE(STRFMT(3:5),'(I3)') MAXLEN
-
-C...Loop until finds line beginning with "<event>" or "<event ".
- 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
- IBEG=0
- 110 IBEG=IBEG+1
-C...Allow indentation.
- IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
- IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
- &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
-
-C...Read first line of event info.
- READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
- &AQEDUP,AQCDUP
-
-C...Read NUP subsequent lines with information on each particle.
- DO 120 I=1,NUP
- READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
- & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
- & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
- 120 CONTINUE
- RETURN
-
-C...Error exit, typically when no more events.
- 130 WRITE(*,*) ' Failed to read LHEF event information.'
- WRITE(*,*) ' Will assume end of file has been reached.'
- NUP=0
- MSTI(51)=1
-
- RETURN
- END
-
-C...Old example: handles a simple Pythia 6.4 event file.
-
-c SUBROUTINE UPEVNT
-
-C...Double precision and integer declarations.
-c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
-c IMPLICIT INTEGER(I-N)
-
-C...Commonblocks.
-c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
-c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
-c SAVE /PYDAT1/,/PYPARS/
-
-C...User process event common block.
-c INTEGER MAXNUP
-c PARAMETER (MAXNUP=500)
-c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
-c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
-c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
-c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
-c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
-c SAVE /HEPEUP/
-
-C...Read info from file.
-c IF(MSTP(162).GT.0) THEN
-c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
-c & AQEDUP,AQCDUP
-c DO 100 I=1,NUP
-c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
-c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
-c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
-c 100 CONTINUE
-c RETURN
-C...Special when reached end of file or other error.
-c 110 NUP=0
-
-C...Else not implemented.
-c ELSE
-c WRITE(MSTU(11),5000)
-c STOP
-c ENDIF
-
-C...Format for error printout.
-c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
-c &1X,'Dummy routine in PYTHIA file called instead.'/
-c &1X,'Execution stopped!')
-
-c RETURN
-c END
-
-C*********************************************************************
-
-C...UPVETO
-C...Dummy routine, to be replaced by user, to veto event generation
-C...on the parton level, after parton showers but before multiple
-C...interactions, beam remnants and hadronization is added.
-C...If resonances like W, Z, top, Higgs and SUSY particles are handed
-C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
-C...be undecayed at this stage; if decayed their decay products will
-C...have been allowed to shower.
-
-C...All partons at the end of the shower phase are stored in the
-C...HEPEVT commonblock. The interesting information is
-C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
-C...IDHEP(I) = the particle ID code according to PDG conventions,
-C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
-C...All ISTHEP entries are 1, while the rest is zeroed.
-
-C...The user decision is to be conveyed by the IVETO value.
-C...IVETO = 0 : retain current event and generate in full;
-C... = 1 : abort generation of current event and move to next.
-
- SUBROUTINE UPVETO(IVETO)
-
-C...HEPEVT commonblock.
- PARAMETER (NMXHEP=4000)
- COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
- &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
- DOUBLE PRECISION PHEP,VHEP
- SAVE /HEPEVT/
-
-C...Next few lines allow you to see what info PYVETO extracted from
-C...the full event record for the first two events.
-C...Delete if you don't want it.
- DATA NLIST/0/
- SAVE NLIST
- IF(NLIST.LE.2) THEN
- WRITE(*,*) ' Full event record at time of UPVETO call:'
- CALL PYLIST(1)
- WRITE(*,*) ' Part of event record made available to UPVETO:'
- CALL PYLIST(5)
- NLIST=NLIST+1
- ENDIF
-
-C...Make decision here.
- IVETO = 0
-
- RETURN
- END
-
-C*********************************************************************
-
-C*********************************************************************
-
-C...SUGRA
-C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
-
- SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
- INTEGER IMODL
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-
-C...Stop program if this routine is ever called.
- WRITE(MSTU(11),5000)
- CALL PYSTOP(110)
-
-C...Format for error printout.
- 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
- &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
- &1X,'Execution stopped!')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...VISAJE
-C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
-
- FUNCTION VISAJE()
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- CHARACTER*40 VISAJE
-
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-
-C...Assign default value.
- VISAJE='Undefined'
-
-C...Stop program if this routine is ever called.
- WRITE(MSTU(11),5000)
- CALL PYSTOP(110)
-
-C...Format for error printout.
- 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
- &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
- &1X,'Execution stopped!')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...SSMSSM
-C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
-
- SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
- &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
- &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
- &IDUM1,IDUM2)
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
- &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
- &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-
-C...Stop program if this routine is ever called.
- WRITE(MSTU(11),5000)
- CALL PYSTOP(110)
-
-C...Format for error printout.
- 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
- &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
- &1X,'Execution stopped!')
- RETURN
- END
-
-C*********************************************************************
-
-C...FHSETFLAGS
-C...Dummy function, to be removed when FEYNHIGGS is to be linked.
-
- SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-Cmssmpart = 4 # full MSSM [recommended]
-Cfieldren = 0 # MSbar field ren. [strongly recommended]
-Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
-Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
-Cp2approx = 0 # no approximation [recommended]
-Clooplevel= 2 # include 2-loop corrections
-Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
-Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
-
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-
-C...Stop program if this routine is ever called.
- WRITE(MSTU(11),5000)
- CALL PYSTOP(103)
-
-C...Format for error printout.
- 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
- &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
- &1X,'Execution stopped!')
- RETURN
- END
-
-C*********************************************************************
-
-C...FHSETPARA
-C...Dummy function, to be removed when FEYNHIGGS is to be linked.
-
- SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
- & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
- & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
- & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-
- DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
- DOUBLE COMPLEX DMU,
- & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
- & DM1, DM2, DM3
-
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-
-C...Stop program if this routine is ever called.
- WRITE(MSTU(11),5000)
- CALL PYSTOP(103)
-
-C...Format for error printout.
- 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
- &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
- &1X,'Execution stopped!')
- RETURN
- END
-
-C*********************************************************************
-
-C...FHHIGGSCORR
-C...Dummy function, to be removed when FEYNHIGGS is to be linked.
-
- SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
-
-C...FeynHiggs variables
- DOUBLE PRECISION RMHIGG(4)
- DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
- DOUBLE COMPLEX DMU,
- & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
- & DM1, DM2, DM3
-
-C...Commonblocks.
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYDAT1/
-
-C...Stop program if this routine is ever called.
- WRITE(MSTU(11),5000)
- CALL PYSTOP(103)
-
-C...Format for error printout.
- 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
- &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
- &1X,'Execution stopped!')
- RETURN
- END
-
-C*********************************************************************
-
-C...PYTAUD
-C...Dummy routine, to be replaced by user, to handle the decay of a
-C...polarized tau lepton.
-C...Input:
-C...ITAU is the position where the decaying tau is stored in /PYJETS/.
-C...IORIG is the position where the mother of the tau is stored;
-C... is 0 when the mother is not stored.
-C...KFORIG is the flavour of the mother of the tau;
-C... is 0 when the mother is not known.
-C...Note that IORIG=0 does not necessarily imply KFORIG=0;
-C... e.g. in B hadron semileptonic decays the W propagator
-C... is not explicitly stored but the W code is still unambiguous.
-C...Output:
-C...NDECAY is the number of decay products in the current tau decay.
-C...These decay products should be added to the /PYJETS/ common block,
-C...in positions N+1 through N+NDECAY. For each product I you must
-C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
-C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
-
- SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
-C...Commonblocks.
- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
- SAVE /PYJETS/,/PYDAT1/
-
-C...Stop program if this routine is ever called.
-C...You should not copy these lines to your own routine.
- NDECAY=ITAU+IORIG+KFORIG
- WRITE(MSTU(11),5000)
- CALL PYSTOP(10)
-
-C...Format for error printout.
- 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
- &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
- &1X,'Execution stopped!')
-
- RETURN
- END
-
-C*********************************************************************
-
-C...PYTIME
-C...Finds current date and time.
-C...Since this task is not standardized in Fortran 77, the routine
-C...is dummy, to be replaced by the user. Examples are given for
-C...the Fortran 90 routine and DEC Fortran 77, and what to do if
-C...you do not have access to suitable routines.
-
- SUBROUTINE PYTIME(IDATI)
-
-C...Double precision and integer declarations.
- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
- IMPLICIT INTEGER(I-N)
- INTEGER PYK,PYCHGE,PYCOMP
- CHARACTER*8 ATIME
-C...Local array.
- INTEGER IDATI(6),IDTEMP(3),IVAL(8)
-
-C...Example 0: if you do not have suitable routines.
- DO 100 J=1,6
- IDATI(J)=0
- 100 CONTINUE
-
-C...Example 1: Fortran 90 routine.
-C CALL DATE_AND_TIME(VALUES=IVAL)
-C IDATI(1)=IVAL(1)
-C IDATI(2)=IVAL(2)
-C IDATI(3)=IVAL(3)
-C IDATI(4)=IVAL(5)
-C IDATI(5)=IVAL(6)
-C IDATI(6)=IVAL(7)
-
-C...Example 2: DEC Fortran 77. AIX.
-C CALL IDATE(IMON,IDAY,IYEAR)
-C IDATI(1)=IYEAR
-C IDATI(2)=IMON
-C IDATI(3)=IDAY
-C CALL ITIME(IHOUR,IMIN,ISEC)
-C IDATI(4)=IHOUR
-C IDATI(5)=IMIN
-C IDATI(6)=ISEC
-
-C...Example 3: DEC Fortran, IRIX, IRIX64.
-C CALL IDATE(IMON,IDAY,IYEAR)
-C IDATI(1)=IYEAR
-C IDATI(2)=IMON
-C IDATI(3)=IDAY
-C CALL TIME(ATIME)
-C IHOUR=0
-C IMIN=0
-C ISEC=0
-C READ(ATIME(1:2),'(I2)') IHOUR
-C READ(ATIME(4:5),'(I2)') IMIN
-C READ(ATIME(7:8),'(I2)') ISEC
-C IDATI(4)=IHOUR
-C IDATI(5)=IMIN
-C IDATI(6)=ISEC
-
-C...Example 4: GNU LINUX libU77, SunOS.
-C CALL IDATE(IDTEMP)
-C IDATI(1)=IDTEMP(3)
-C IDATI(2)=IDTEMP(2)
-C IDATI(3)=IDTEMP(1)
-C CALL ITIME(IDTEMP)
-C IDATI(4)=IDTEMP(1)
-C IDATI(5)=IDTEMP(2)
-C IDATI(6)=IDTEMP(3)
-
-C...Common code to ensure right century.
- IDATI(1)=2000+MOD(IDATI(1),100)
-
- RETURN
- END
-
-
-
-
git://git.uio.no / u / mrichter / AliRoot.git / blobdiff