C*********************************************************************
C*********************************************************************
C* **
C* March 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* phone + 1 - 630 - 840 - 2270 **
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 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,
&139*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,139*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,
&133*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,133*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.02911D0,0.01741D0,0.04536D0,0.09511D0,0.8686D0,0.62395D0,
&0.19192D0,123.27638D0,0.02296D0,0.18886D0,23.26819D0,2.86306D0,
&0D0,3.45903D0,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,133*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.29108D0,0.17412D0,0.45362D0,0.95114D0,8.68604D0,6.23946D0,
&1.91923D0,450D0,0.22959D0,1.88863D0,232.68185D0,28.63059D0,0D0,
&34.59032D0,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,133*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,118*0D0,133*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,6*1,133*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,4023,4047,4073,4097,4103,4110,
&4117,4124,4130,4136,4145,4149,4153,4156,4158,4178,4200,4222,4244/
DATA (MDCY(I,2),I= 352, 500)/4259,4271,4278,7*0,4285,4286,4287,
&4288,4289,4290,133*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,24,26,24,6,3*7,2*6,9,2*4,3,2,20,
&3*22,15,12,2*7,7*0,6*1,133*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,85*1,
&2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,4*-1,200*1,2*-1,2*1,-1,
&1249*1,2*-1,377*1,2*-1,1868*1,2*-1,6*1,2*-1,9*1,-1,3*1,-1,3*1,
&5*-1,3*1,-1,14*1,2*-1,6*1,2*-1,67*1,2*-1,6*1,2*-1,117*1,3710*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,4*32,8*0,8*32,14*0,16*32,12*0,8*32,8*0,
&46*32,3*53,12*0,8*32,12*0,66*51,6*32,9*0,9*32,17*0,6*51,3710*0/
DATA (BRAT(I) ,I= 1, 346)/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.000349D0,0.048707D0,0.768308D0,
&4*0D0,0.000227D0,0.064048D0,0D0,0.040621D0,0.002043D0,0.000615D0,
&0.006981D0,0.068099D0,62*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.000049D0,0.000774D0,5*0D0,0.000074D0,0D0,0.000417D0/
DATA (BRAT(I) ,I= 347, 651)/0.000015D0,0.000061D0,0.30671D0,
&0.689011D0,0D0,0.002889D0,69*0D0,0.000001D0,0.000121D0,
&0.001924D0,4*0D0,0.000001D0,0.000184D0,0D0,0.003106D0,0.000015D0,
&0.000003D0,2*0D0,0.994646D0,66*0D0,0.000021D0,0.090135D0,2*0D0,
&0.000013D0,0.003714D0,0D0,0.906117D0,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/
DATA (BRAT(I) ,I= 652, 823)/0.302D0,0.0302D0,0.0212D0,0.0016D0,
&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/
DATA (BRAT(I) ,I= 824, 991)/2*0.02D0,0.03D0,2*0.005D0,0.015D0,
&0.037D0,0.028D0,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/
DATA (BRAT(I) ,I= 992,1183)/1D0,2*0.3D0,2*0.2D0,0.047D0,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/
DATA (BRAT(I) ,I=1184,1377)/2*0.08D0,0.76D0,0.08D0,1D0,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/
DATA (BRAT(I) ,I=1378,1580)/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,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/
DATA (BRAT(I) ,I=1581,4149)/0.008D0,0.024D0,0.008D0,0.024D0,
&0.425D0,0.02D0,0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,
&0.017431D0,0.054048D0,0.857694D0,2*0D0,0.00025D0,0.070578D0,0D0,
&0.022748D0,0.026576D0,0.359486D0,0.561581D0,2*0D0,0.000104D0,
&0.029504D0,0.011185D0,0.034681D0,0.550354D0,2*0D0,0.00016D0,
&0.045287D0,0.358333D0,0.445781D0,0D0,0.554219D0,0.144051D0,
&2*0.351902D0,0D0,0.082107D0,0.029566D0,0.001511D0,0.000726D0,
&0.004518D0,0.006522D0,0.004518D0,0.006522D0,0.004513D0,3*0D0,
&0.002908D0,0.000973D0,0.002908D0,0.000973D0,0.002908D0,
&0.000973D0,2*0D0,0.143982D0,0.489888D0,0.1951D0,0D0,0.114302D0,
&0.008426D0,0.014868D0,0.000763D0,2*0D0,0.000763D0,0.01484D0,
&0.000003D0,2*0D0,0.000027D0,0.001945D0,5*0D0,3*0.00503D0,0D0,
&0.133776D0,0.003284D0,0.37169D0,0.006838D0,2*0.030954D0,
&0.00163D0,0D0,0.047224D0,0.073737D0,0.047224D0,0.073732D0,
&0.047179D0,3*0D0,0.034761D0,0.009166D0,0.034761D0,0.009166D0,
&0.034759D0,0.009166D0,2*0D0,4*0.009069D0,0.510147D0,0.453576D0,
&6*0D0,1D0,6*0D0,1D0,4*0.001128D0,0.571047D0,0.382288D0,
&0.042153D0,4*0.016597D0,0.93361D0,0D0,4*0.016597D0,0.93361D0,0D0,
&4*0.05515D0,0.34469D0,0D0,0.228998D0,0.164208D0,0.041503D0,
&0.850973D0,0.005411D0,0.045025D0,0.098591D0,0.849898D0/
DATA (BRAT(I) ,I=4150,4280)/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,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/
DATA (BRAT(I) ,I=4281,8000)/0.090428D0,0.001808D0,0.81372D0,0D0,
&6*1D0,3710*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,4127)/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,
&2*24,2*3000211,2*22,2*23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
&2*24,3*3000211,24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,22,
&23,24,3000211,24,3000211,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
&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/
DATA (KFDP(I,1),I=4128,8000)/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,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,
&3710*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,4136)/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,-24,-3000211,-24,-3000211,
&3000111,3000221,3000111,3000221,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,
&-13,-14,-15,-16,-17,-18,23,3000111,23,3000111,22,3000221,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,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
&-17,-18,-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/
DATA (KFDP(I,2),I=4137,8000)/-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,
&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,3710*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,169*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,3757*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]',133*' '/
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-',139*' '/
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, 411, 2007, 03, 30, 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, -1, -1, -1,
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, 0,
7 0, 0, 0, 0, 0,
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,133*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' ', ' ',
7' '/
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, 4*0D0,
4 49*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!'
STOP
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)
STOP
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)
STOP
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/W50512/QCDL4,QCDL5
SAVE /W50511/,/W50512/
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...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(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))
STOP
ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
WRITE(MSTU(11),5300) ISUB
STOP
ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
WRITE(MSTU(11),5400) ISUB
STOP
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)
STOP
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)
STOP
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/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/,/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)
STOP
ENDIF
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/.
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)
CALL PYSHOW(IPU3,IPU4,QMAX)
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)
STOP
ENDIF
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 /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
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)
ENDIF
PARJ(81)=ALAMSV
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
C...External processes: handle successive showers.
ELSEIF(ISET(ISUB).EQ.11) THEN
CALL PYADSH(NFIN)
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)') ''
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 ... block.
WRITE(MSTP(163),'(A)') ''
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)') ''
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 block. Copy event lines, omitting trailing blanks.
WRITE(MSTP(163),'(A)') ''
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 block. Loop back to look for next event.
WRITE(MSTP(163),'(A)') ''
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)') ''
320 WRITE(MSTP(163),'(A)') ''
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)
STOP
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) STOP
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))
STOP
ENDIF
IF(S.LT.PARP(2)**2) THEN
WRITE(MSTU(11),5900) SQRT(S)
STOP
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)
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
&/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/
C...Local arrays, character variables and data.
CHARACTER CVAR(4)*4
DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
&NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7),
&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
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
ELSEIF(ISUB.EQ.194) THEN
KFR1=KTECHN+113
ELSEIF(ISUB.EQ.195) THEN
KFR1=KTECHN+213
ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
KFR1=KTECHN+113
ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
KFR1=KTECHN+213
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)
IF(KFR1.EQ.KTECHN+113) THEN
CALL PYTECM(S1,S2)
TAUR1=S1/VINT(2)
ENDIF
GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
MINT(72)=1
MINT(73)=KFR1
VINT(73)=TAUR1
VINT(74)=GAMR1
ENDIF
KFR2=0
IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
$ THEN
KFR2=23
IF(ISUB.EQ.194) THEN
KFR2=KTECHN+223
ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
KFR2=KTECHN+223
ENDIF
KCR2=PYCOMP(KFR2)
TAUR2=PMAS(KCR2,1)**2/VINT(2)
IF(KFR2.EQ.KTECHN+223) THEN
CALL PYTECM(S1,S2)
TAUR2=S2/VINT(2)
ENDIF
GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
& CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
MINT(72)=2
MINT(74)=KFR2
VINT(75)=TAUR2
VINT(76)=GAMR2
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
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).
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) NPTS(1)=NPTS(1)+1
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
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(MTAU.GT.2+2*MINT(72)) MTAU=7
RTAU=0.5D0
C...Special case when both resonances have same mass,
C...as is often the case in process 194.
IF(MINT(72).EQ.2) THEN
IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
& 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
RTAU=0.4D0
ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
RTAU=0.6D0
ENDIF
ENDIF
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).GT.2+2*MINT(72)) 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.AND.IBIN.EQ.7) IBIN=3+2*MINT(72)
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(NBIN.GT.2+2*MINT(72)) THEN
WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)*
& TAU/MAX(2D-10,1D0-TAU)
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.AND.IBIN.GT.2+2*MINT(72)) ICOF=7
IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
COEF(ISUB,ICOF)=COEFO(IBIN)
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)
STOP
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,8D11.3)
5600 FORMAT(1X,'Result for ',A4,':',7F9.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)
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
&/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/
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
ELSEIF(ISUB.EQ.194) THEN
KFR1=KTECHN+113
ELSEIF(ISUB.EQ.195) THEN
KFR1=KTECHN+213
ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN
KFR1=KTECHN+113
ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
KFR1=KTECHN+213
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)
IF(KFR1.EQ.KTECHN+113) THEN
CALL PYTECM(S1,S2)
TAUR1=S1/VINT(2)
ENDIF
GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
MINT(72)=1
MINT(73)=KFR1
VINT(73)=TAUR1
VINT(74)=GAMR1
ENDIF
IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368))
$THEN
KFR2=23
IF(ISUB.EQ.194) THEN
KFR2=KTECHN+223
ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN
KFR2=KTECHN+223
ENDIF
KCR2=PYCOMP(KFR2)
TAUR2=PMAS(KCR2,1)**2/VINT(2)
IF(KFR2.EQ.KTECHN+223) THEN
CALL PYTECM(S1,S2)
TAUR2=S2/VINT(2)
ENDIF
GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
& CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0
IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
MINT(72)=2
MINT(74)=KFR2
VINT(75)=TAUR2
VINT(76)=GAMR2
ELSEIF(KFR2.NE.0) THEN
KFR1=KFR2
TAUR1=TAUR2
GAMR1=GAMR2
MINT(72)=1
MINT(73)=KFR1
VINT(73)=TAUR1
VINT(74)=GAMR1
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.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
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)
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)
STOP
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)
STOP
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) 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) 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
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)
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)
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
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
CALL PYSHOW(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) 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
DATA PTEMAX /0D0/
DATA WTEMAX /0D0/
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
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 (KFLB.NE.21) 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 (KFLC.NE.21.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 (KFLA.NE.21) 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 (KFLB.NE.21) 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 (KFLC.NE.21.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 (KFLA.NE.21) 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 (KFLB.NE.21.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.
C...(Also update recoiler in documentation lines, if necessary.)
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)
IF (IR.EQ.MINT(84)+3-JS) CALL PYROBO(MINT(83)+7-JS,MINT(83)
& +7-JS,0D0,0D0,0D0,0D0,BETAZ)
C...Rotate back system in phi to compensate for subsequent rotation.
C...(not including the just added partons.)
IMIN=IMISEP(MI-1)+1
IF (MI.EQ.1) IMIN=MINT(83)+5
IMAX=IMISEP(MI)-2
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...Boost and rotate to new frame.
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+UH**2+2D0*SQM*TH)/((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
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
CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
ELSE
CALL PYSHOW(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/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.
GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
C... Reset counters.
NEVHEP=0
NHEP=0
NRESO=0
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=MAX(0,K(K(I,3),3)-(MINT(83)+6))
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)-(MINT(83)+6))
C...Update a product when a new copy of it has been created.
ELSE
IHIST=K(I,3)
IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(I-1-IHIST)
IR=0
DO 100 IRI=1,NRESO
IF(IHIST.EQ.IRESO(IRI)) IR=IRI
100 CONTINUE
C...Flavours must match, and exclude gluon and photon emission.
IF(K(IHIST,2).NE.K(I,2)) IR=0
IF(IR.GT.0.AND.I.LT.N) THEN
IF(K(I+1,3).EQ.K(I,3).AND.(K(I+1,2).EQ.21.OR.
& K(I+1,2).EQ.22)) IR=0
ENDIF
IF(IR.GT.0) THEN
ISTORE=1
II=IR
IRESO(IR)=I
IMOTH=JMOHEP(1,II)
ENDIF
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)=0
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
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)
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
IREF(1,4)=K(ITMPMO,3)
GOTO 110
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
CMRENNA++
C...1) Three-body decays of SUSY particles (plus special case top).
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
CALL PYTBDY(IDIN)
C...Set colour flow for t -> W + b + Z.
IF(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--
ENDIF
IF(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)
ENDIF
IF(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
ENDIF
NSAV=N
N=N+3
N=NSAV
CMRENNA--
IF(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
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
CALL PYSHOW(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))
IF((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) 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) 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
CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
ELSE
CALL PYSHOW(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)
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... 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 KCS not existing for this parton
KQ=KCHG(PYCOMP(K(I,2)),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')
RETURN
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
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 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))
CALL PYROBO(I1,I1,0D0,-PHI,0D0,0D0,0D0)
CALL PYROBO(I2,I2,0D0,-PHI,0D0,0D0,0D0)
CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
C...Now boost initiators + daughters back to LAB system
C...(also update documentation lines for MI = 1.)
VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
IMIN=IMISEP(IM-1)+1
IF (IM.EQ.1) IMIN=MINT(83)+5
IMAX=IMISEP(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
PRINT*, 'infinite loop!'
STOP
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) CALL PYSHOW(IPU3,ICOLR,QMAX)
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*0.0D0
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.91D0*(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-.
WDTP(I)=FAC*RTCM(3)**4*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
WID2=WIDS(24,1)
ELSEIF(I.EQ.2) THEN
C...rho_tc0 -> W+ + pi_tc-.
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
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*SQMW/SH)*
& (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)
ELSE
C...rho_tc0 -> f + fbar.
WID2=1D0
IF(I.LE.16) THEN
IA=I-8
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.91D0*(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
IF(I.EQ.1) THEN
C...rho_tc+ -> W+ + Z0.
WDTP(I)=FAC*RTCM(3)**4*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**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
ELSE
C...rho_tc+ -> f + fbar'.
IA=I-6
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.91D0*(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-.
WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
& SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**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)
ELSE
C...omega_tc0 -> f + fbar.
WID2=1D0
IF(I.LE.14) THEN
IA=I-8
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
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.91D0*(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
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
CALL PYSHOW(IQ1,IQ2,P(IW1,5))
CALL PYSHOW(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))
CALL PYSHOW(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))
CALL PYSHOW(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
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)
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) THEN
RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) 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
SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
&/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
&/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYSGCM/
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, 0, 0, 0,
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.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.102.OR.
& ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.ISUBSV.EQ.144.OR.
& ISUBSV.EQ.152.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)
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).EQ.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(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.'
STOP
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.'
STOP
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 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.379) THEN
SQTV=RTCM(12)**2
SQTA=RTCM(13)**2
SN2W=2D0*SQRT(PARU(102)*(1D0-PARU(102)))
CS2W=1D0-2D0*PARU(102)
TANW=SQRT(PARU(102)/(1D0-PARU(102)))
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
C... rho_tc0 -> W_L W_L
IF(ISUB.EQ.361) THEN
KFA=24
KFB=24
CAB2=RTCM(3)**4
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
VOGP=CSXI/RTCM(12)
C..........!!!
VRGP=VOGP*QUPD
AOGP=0D0
ARGP=0D0
VAGP=2D0*QUPD*CSXI
VZGP=QUPD*CSXI*(1D0-4D0*PARU(102))/SN2W
C... gamma pi_tc'
ELSEIF(ISUB.EQ.365) THEN
KFA=22
KFB=KTECHN+221
ISUB=364
VRGP=CSXIP/RTCM(12)
C..........!!!!
VOGP=VRGP*QUPD
AOGP=0D0
ARGP=0D0
VAGP=2D0*Q2UD*CSXIP
VZGP=CSXIP/SN2W*(1D0-4D0*PARU(102)*Q2UD)
C... Z pi_tc
ELSEIF(ISUB.EQ.366) THEN
KFA=23
KFB=KTECHN+111
ISUB=364
VOGP=CSXI*CT2W/RTCM(12)
VRGP=-QUPD*CSXI*TANW/RTCM(12)
AOGP=0D0
ARGP=0D0
VAGP=QUPD*CSXI*(1D0-4D0*PARU(102))/SN2W
VZGP=-QUPD*CSXI*CS2W/(1D0-PARU(102))
C... Z pi_tc'
ELSEIF(ISUB.EQ.367) THEN
KFA=23
KFB=KTECHN+221
ISUB=364
VRGP=CSXIP*CT2W/RTCM(12)
VOGP=-QUPD*CSXIP*TANW/RTCM(12)
AOGP=0D0
ARGP=0D0
VAGP=CSXIP*(1D0-4D0*Q2UD*PARU(102))/SN2W
VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*PARU(102)**2)/SN2W**2
C... W_T pi_tc
ELSEIF(ISUB.EQ.368) THEN
KFA=24
KFB=KTECHN+211
ISUB=364
VOGP=CSXI/(2D0*SQRT(PARU(102)))/RTCM(12)
VRGP=0D0
AOGP=0D0
C..........!!!!
ARGP=-CSXI/(2D0*SQRT(PARU(102)))/RTCM(13)
VAGP=QUPD*CSXI/(2D0*SQRT(PARU(102)))
VZGP=-QUPD*CSXI/(2D0*SQRT(1D0-PARU(102)))
C... rho_tc+ -> W_L Z_L
ELSEIF(ISUB.EQ.370) THEN
KFA=24
KFB=23
CAB2=RTCM(3)**4
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
VRGP=QUPD*CSXI
ARGP=0D0
VWGP=QUPD*CSXI/(2D0*SQRT(PARU(102)))
C... Z_T pi_tc+
ELSEIF(ISUB.EQ.375) THEN
KFA=KTECHN+211
KFB=23
ISUB=374
VRGP=-QUPD*CSXI*TANW
ARGP=CSXI/(2D0*SQRT(PARU(102)*(1D0-PARU(102))))
VWGP=-QUPD*CSXI/(2D0*SQRT(1D0-PARU(102)))
C... W_T pi_tc0
ELSEIF(ISUB.EQ.376) THEN
KFA=24
KFB=KTECHN+111
ISUB=374
VRGP=0D0
ARGP=-CSXI/(2D0*SQRT(PARU(102)))
VWGP=0D0
C... W_T pi_tc0'
ELSEIF(ISUB.EQ.377) THEN
KFA=24
KFB=KTECHN+221
ISUB=374
ARGP=0D0
VRGP=CSXIP/(2D0*SQRT(PARU(102)))
VWGP=CSXIP/(2D0*PARU(102))
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.91D0*(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.91D0*(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.91D0*(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.91D0*(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 and omega_tc.
KFA=KFPR(ISUBSV,1)
ALPRHT=2.91D0*(3D0/ITCM(1))
HP=AEM**2*COMFAC
TANW=SQRT(PARU(102)/(1D0-PARU(102)))
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
SFAR=FAR**2
SFAO=FAO**2
SFZR=FZR**2
SFZO=FZO**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)
DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
$ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
DAA=(-Sfzr*SSMO - Sfzo*SSMR + SSMO*SSMR*SSMZ)/DETD/SH
DZZ=(-Sfar*SSMO - Sfao*SSMR + SSMO*SSMR)/DETD/SH
DAZ=(far*fzr*SSMO + fao*fzo*SSMR)/DETD/SH
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+
KFA=KFPR(ISUBSV,1)
KFB=KFA+1
ALPRHT=2.91D0*(3D0/ITCM(1))
FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
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)
FCOF=1D0
IF(KFA.LE.8) FCOF=3D0
DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
HP=FACTC*ABS(SSMR/DETD)**2/SH**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
IF(ISUB.EQ.361) THEN
C...f + fbar -> W_L W_L, W_L pi_tc, pi_tc pi_tc
FACA=(SH**2*BE34**2-(TH-UH)**2)
ALPRHT=2.91D0*(3D0/ITCM(1))
HP=(1D0/12D0)*AEM**2*CAB2*COMFAC*FACA*3D0
FAR=SQRT(AEM/ALPRHT)
FAO=FAR*QUPD
FZR=FAR*CT2W
FZO=-FAO*TANW
SFAR=FAR**2
SFAO=FAO**2
SFZR=FZR**2
SFZO=FZO**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)
DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
$ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
DARHO=-(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
DAA=-(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)/DETD/SH
DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH
DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH
DO 360 I=MMINA,MMAXA
IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 360
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)
VARI=0.25D0*(VI-AI)
F2L=EI*(DARHO/FAR+DAA+CT2W*DAZ)+
$ VALI*(CT2W*DZRHO/FZR+CT2W*DZZ+DAZ)/SQRT(XW*XW1)
F2R=EI*(DARHO/FAR+DAA+CT2W*DAZ)+
$ VARI*(CT2W*DZRHO/FZR+CT2W*DZZ+DAZ)/SQRT(XW*XW1)
HI=ABS(F2L)**2+ABS(F2R)**2
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)
ELSE
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)
ENDIF
360 CONTINUE
ELSEIF(ISUB.EQ.364) THEN
C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
C...W pi_tc
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)
ALPRHT=2.91D0*(3D0/ITCM(1))
HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
FAR=SQRT(AEM/ALPRHT)
FAO=FAR*QUPD
FZR=FAR*CT2W
FZO=-FAO*TANW
SFAR=FAR**2
SFAO=FAO**2
SFZR=FZR**2
SFZO=FZO**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)
DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
$ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH
DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH
DAOME=(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)/DETD/SH
DZOME=(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH
DAA=(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)/DETD/SH
DZZ=(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH
DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/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)
VARI=0.25D0*(VI-AI)
C...........Add in anomaly contribution
F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
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+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
F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
HI=HI+HJ
IF(IA.LE.10) HI=HI/3D0
NCHN=NCHN+1
ISIG(NCHN,1)=I
ISIG(NCHN,2)=-I
ISIG(NCHN,3)=1
IF(ISUBSV.NE.368) THEN
SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
ELSE
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)
ENDIF
370 CONTINUE
ELSEIF(ISUB.EQ.370) THEN
C...f + fbar' -> W_L Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc
FACA=(SH**2*BE34**2-(TH-UH)**2)
ALPRHT=2.91D0*(3D0/ITCM(1))
HP=(1D0/96D0)*AEM**2*CAB2*COMFAC*FACA*3D0/XW**2
FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
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)
DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
DWW=SSMR/DETD/SH
DWRHO=-1D0/DETD/SH
HP=HP*ABS(DWW+DWRHO)**2
DO 390 I=MMIN1,MMAX1
IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 390
IA=IABS(I)
DO 380 J=MMIN2,MMAX2
IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 380
JA=IABS(J)
IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 380
IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
& GOTO 380
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(PYCOMP(KFA),(5-KCHR)/2)*
& WIDS(PYCOMP(KFB),2)
380 CONTINUE
390 CONTINUE
ELSEIF(ISUB.EQ.374) THEN
C...f + fbar' -> gamma pi_tc
FANOM=SQRT(AEM)*ITCM(1)/2D0/PARU(2)/RTCM(1)
VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*ARGP**2
ALPRHT=2.91D0*(3D0/ITCM(1))
HP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
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)
DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0)
DWW=SSMR/DETD/SH
DWRHO=-DCMPLX(FWR,0D0)/DETD/SH
HP=HP*(AFAC*ABS(DWRHO)**2+
$ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP/SQRT(SQTV))**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
SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
& WIDS(PYCOMP(KFB),2)
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/W50513/XMIN,XMAX,Q2MIN,Q2MAX
SAVE /W50513/
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(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/W50513/XMIN,XMAX,Q2MIN,Q2MAX
SAVE /W50513/
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...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)
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...Do nothing 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) 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.AND.IMSS(21).NE.0) THEN
C...First check for new states
CALL PYSLHA(0,0,IFAIL)
C...Then read spectrum
CALL PYSLHA(1,0,IFAIL)
ELSEIF (IMSS(21).NE.0) THEN
C...Check for new states but don't read spectrum
CALL PYSLHA(0,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 '
STOP
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 '
STOP
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) THEN
IFAIL=0
C...First look for MASS entry if not already done
IF (IMSS(1).NE.11.AND.IMSS(21).NE.0) CALL PYSLHA(5,KF,IFAIL)
C...Then look for decay info
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=1 : READ SPECTRUM ON LUN=IMSS(21)
C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
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 (WITH DECAY TABLE)
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
CHARACTER*40 ISAVER,VISAJE
COMMON/PYINT4/MWID(500),WIDS(500,5)
SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/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)
SAVE /PYLH3P/,/PYLH3C/
DIMENSION MMOD(100),MSPC(100),MDEC(100)
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 Mar 2007')
C...MQREAD(0): Number of entries I in MQREAD
C... (I): KF code for which a QNUMBERS block has been read.
DIMENSION IDC(5),KFSUSY(50),MQREAD(0:100)
SAVE KFSUSY,MQREAD
DATA VERBOS /1/
DATA NHELLO /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/
RMFUN(IP)=PMAS(PYCOMP(IP),1)
C...Hello World
IF (NHELLO.EQ.0) THEN
WRITE(MSTU(11),5000) DOC
NHELLO=1
ENDIF
C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
C...+MUPDA).
LFN=IMSS(20+MUPDA)
IF (MUPDA.EQ.5) LFN=IMSS(21)
IF (MUPDA.EQ.0) LFN=IMSS(21)
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 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
MDEC(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
PMAS(KC,2)=0D0
PMAS(KC,3)=0D0
PMAS(KC,4)=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...NB: RMSS array not zeroed.
WRITE(MSTU(11),*)
& '* (PYSLHA:) Reading in SLHA spectrum from unit ', LFN
C...If reading decays, reset PYTHIA decay counters.
ELSEIF (MUPDA.EQ.2) THEN
KCC=100
NDC=0
BRSUM=0D0
DO 140 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)
140 CONTINUE
ELSEIF (MUPDA.EQ.5) THEN
C...Zero block read flags
DO 150 M=1,100
MSPC(M)=0
150 CONTINUE
ENDIF
C............READ
C...(spectrum or look for 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
CPRO(MUPDA)=' '
CVER(MUPDA)=' '
C...Initialize read loop
MERR=0
NLINE=0
CHBLCK=' '
C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
160 CHINL=' '
READ(LFN,'(A120)',END=300) 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 160
C...We assume all upper case below. Rewrite CHINL to all upper case.
INL=0
IGOOD=0
170 INL=INL+1
IF (CHINL(INL:INL).NE.'#') THEN
DO 180 ICH=97,122
IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
180 CONTINUE
C...Extra safety. Chek for sensible input on line
IF (IGOOD.EQ.0) THEN
DO 190 ICH=48,90
IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
190 CONTINUE
ENDIF
IF (INL.LT.120) GOTO 170
ENDIF
IF (IGOOD.EQ.0) GOTO 160
C...Check for BLOCK begin statement (spectrum).
IF (CHINL(1:1).EQ.'B') THEN
MERR=0
READ(CHINL,'(A6,A)',ERR=460) 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 121 MQ=1,MQREAD(0)
IF (MQREAD(MQ).EQ.KFQ) THEN
MERR=17
GOTO 290
ENDIF
121 CONTINUE
WRITE(MSTU(11),'(A,I9,A,F12.3)')
& ' * (PYSLHA:) Reading in '//CHBLCK(1:8)//
& ' for KF =',KFQ
MQREAD(0)=MQREAD(0)+1
MQREAD(MQREAD(0))=KFQ
MSPC(19)=MSPC(19)+1
KCQ=PYCOMP(KFQ)
IF (KCQ.EQ.0) THEN
DO 123 KCT=100,MSTU(6)
IF(KCHG(KCT,4).GT.100) KCQ=KCT
123 CONTINUE
KCQ=KCQ+1
KCC=KCQ
KCHG(KCQ,4)=KFQ
C...First write PDG code as name
WRITE(CHTMP,*) KFQ
C...Then look for real name
ICMT=9
90 ICMT=ICMT+1
IF (CHBLCK(ICMT:ICMT).NE.'#'.AND.ICMT.LT.59) GOTO 90
IF (ICMT.LT.59) THEN
READ(CHBLCK(ICMT+1:60),'(A)',ERR=95) CHDUM
IF (CHDUM.NE.' ') CHTMP=CHDUM
ENDIF
95 IF (CHTMP(1:1).EQ.' ') THEN
READ(CHTMP,'(1x,A)') CHAF(KCQ,1)
ELSE
READ(CHTMP,'(A)') CHAF(KCQ,1)
ENDIF
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 290
C...Check for DECAY begin statement (decays).
ELSEIF (CHINL(1:1).EQ.'D') THEN
MERR=0
BRSUM=0D0
CHBLCK='DECAY'
C...Read KF code and WIDTH
MPSIGN=1
READ(CHINL(7:INL),*,ERR=470) KF, WIDTH
IF (KF.LE.0) THEN
KF=-KF
MPSIGN=-1
ENDIF
C...If this is not the KF we're looking for...
IF (KF.NE.KFORIG.OR.MUPDA.NE.2) THEN
C...Set block skip flag and read next line.
MERR=16
GOTO 290
ENDIF
C...Determine PYTHIA KC code of particle
KCREP=0
IF(KF.LE.100) THEN
KCREP=KF
ELSE
DO 200 KCR=101,KCC
IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
200 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: ',
& CHAF(KCREP,1)
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 290
ELSEIF (MOD(MERR,10).GE.6) THEN
C...If ignore block flag set, skip directly to next line.
GOTO 160
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.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
116 ILAST=ILAST-1
IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 116
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) THEN
C...Read in masses for anything
MERR=0
KC=PYCOMP(KF)
IF (KC.NE.0) THEN
MSPC(1)=MSPC(1)+1
PMAS(KC,1) = ABS(VAL)
IF (MUPDA.EQ.5) 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
ELSEIF (MUPDA.EQ.5) THEN
C...Only read MASS if MUPDA = 5. Skip any other blocks.
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... 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
MODSEL(INDX)=IVAL
MMOD(1)=MMOD(1)+1
IF (INDX.EQ.3.AND.IVAL.EQ.1) 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 234 KCT=100,MSTU(6)
IF(KCHG(KCT,4).GT.100) KCN=KCT
234 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
C...MINPAR: Minimal model parameters
ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
IF (MODSEL(1).NE.0) 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
ELSEIF (MMOD(3).NE.0) THEN
WRITE(MSTU(11),*)
& '* (PYSLHA:) MINPAR after EXTPAR !'
MERR=1
ELSE
WRITE(MSTU(11),*)
& '* (PYSLHA:) Reading MINPAR, but no MODSEL !'
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
250 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=510) 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=520) 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=510) 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=510) 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
260 IT=IT+1
IF (CHINL(IT:IT).EQ.' ') GOTO 260
C...Don't read index
IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
MIRD=1
GOTO 260
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=480) BRAT(NDC)
READ(CHINL(4:50),*,ERR=490) 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 chanel, set decays start point in decay table
IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
WRITE(MSTU(11),*)
& '* (PYSLHA:) Reading in SLHA decay table for ',
& CHAF(KCREP,1)
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...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=500) DUM,IDM, (IDC(IDA),IDA=1,NDA)
C... Flip sign if reading antiparticle decays (if antipartner exists)
DO 270 IDA=1,NDA
IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
& IDC(IDA)=MPSIGN*IDC(IDA)
270 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))
274 IFLIP=0
DO 277 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
277 CONTINUE
IF (IFLIP.GT.0) GOTO 274
C WRITE(MSTU(11),7510) BRAT(NDC), NDA, (IDC(IDA),IDA=1,NDA)
C...Treat as ordinary decay, no fancy stuff.
MDME(NDC,2)=0
DO 280 IDA=1,5
IF (IDA.LE.NDA) THEN
KFDP(NDC,IDA)=IDC(IDA)
ELSE
KFDP(NDC,IDA)=0
ENDIF
280 CONTINUE
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.
290 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:INL)//'... 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.IMSS(21).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... End of loop
GOTO 160
300 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 310 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 310
C...Only check gravitino in GMSB scenarios
IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 310
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
310 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 320 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
320 CONTINUE
C...Neutralinos + charginos
DO 340 J=1,4
CN1=0D0
CN2=0D0
CU1=0D0
CU2=0D0
CV1=0D0
CV2=0D0
DO 330 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
330 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
340 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) THEN
KF=KFORIG
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 360 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
IF(MDME(IDA,2).GT.80) GOTO 360
KQ=KCHG(KC,1)
PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
MERR=0
DO 350 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
350 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)
360 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
CALL PYERRM(7
& ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
& ' ; sum was'//CHTMP(9:16)//'.')
FAC=1D0/BRSUM
DO 370 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
IF(MDME(IDA,2).GT.80) GOTO 370
BRAT(IDA)=FAC*BRAT(IDA)
370 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
CALL PYERRM(7
& ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
& CHTMP(9:16)//'. Dummy mode will be inserted.')
C... Insert dummy mode
MDCY(KC,3)=MDCY(KC,3)+1
IDA=MDCY(KC,2)+MDCY(KC,3)-1
BRAT(IDA)=1D0-BRSUM
KFDP(IDA,1)=0
KFDP(IDA,2)=0
KFDP(IDA,3)=0
KFDP(IDA,4)=0
KFDP(IDA,5)=0
MDME(IDA,1)=0
BRSUM=1D0
ENDIF
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 380 I=1,36
KF=KFSUSY(I)
KC=PYCOMP(KF)
IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 380
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
380 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 400 I1=1,4
DO 390 I2=1,4
WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
390 CONTINUE
400 CONTINUE
WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
DO 420 I1=1,2
DO 410 I2=1,2
WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
410 CONTINUE
420 CONTINUE
WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
DO 440 I1=1,2
DO 430 I2=1,2
WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
430 CONTINUE
440 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
460 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
write(*,*) CHINL(1:80)
STOP
470 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
WRITE(*,*) CHINL(1:72)
STOP
480 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE
WRITE(*,*) CHINL(1:80)
STOP
490 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
WRITE(*,*) CHINL(1:80)
STOP
500 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
WRITE(*,*) CHINL(1:80)
510 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
STOP
520 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
WRITE(*,*) CHINL(1:80)
STOP
8300 FORMAT(I9)
8500 FORMAT(F16.5)
C...Formats for user information printout.
5000 FORMAT(1x,15('*'),1x,'PYSLHA v1.09: SUSY/BSM SPECTRUM '
& ,'INTERFACE',1x,15('*')/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,4x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
& 4x,'~c',2x,1x,1x,'~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,4x,'~e',2x,1x,2x,'~nu_e',2x,1x,3x,'~mu',2x
& ,1x,1x,'~nu_mu',1x,1x,'~tau(12)',1x,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,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 '
STOP
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 '
STOP
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 '
STOP
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'
STOP 99
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 '
STOP
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(4,4),WR(4),ZR(4,4),ZI(4,4),AI(4,4)
DOUBLE PRECISION WI(4),FV1(4),FV2(4),FV3(4)
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
STOP
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)
XMW=PMAS(24,1)
XMU=RMSS(4)
SINW=SQRT(PARU(102))
COSW=SQRT(1D0-PARU(102))
TANB=RMSS(5)
BETA=ATAN(TANB)
COSB=COS(BETA)
SINB=TANB*COSB
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(4,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
IF(IERR.NE.0) THEN
WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
ENDIF
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)
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^*
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(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
IF(IERR.NE.0) THEN
WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
ENDIF
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))
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
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))
ENDIF
PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
C.....Find eigenvectors of X^* X
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(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
IF(IERR.NE.0) THEN
WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM '
ENDIF
INDEX(1)=1
INDEX(2)=2
IF(WR(2).LT.WR(1)) THEN
INDEX(1)=2
INDEX(2)=1
ENDIF
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
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
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
STOP
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(1),XXc(2),XXc(3),XXc(4)
WRITE(MSTU(11),*) (XXc(I),I=5,8)
WRITE(MSTU(11),*) (XXc(I),I=9,12)
WRITE(MSTU(11),*) (XXc(I),I=13,16)
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) THEN
WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX '
WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GX2,GLR,XM1,XM2,XM3
STOP
ENDIF
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
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
IA=K(N+2,2)
JA=K(N+3,2)
ZM12=XM(5)**2
ZM22=XM(1)**2
EI=KCHG(IABS(IA),1)/3D0
T3I=SIGN(1D0,EI+1D-6)/2D0
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(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.
SUBROUTINE PYTECM(S1,S2)
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(4,4),WR(4),ZR(4,4),ZI(4,4),WORK(12,12),
&AT(4,4),WI(4),FV1(4),FV2(4),FV3(4),sh,aem,tanw,ct2w,qupd,alprht,
&far,fao,fzr,fzo,shr,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5)
INTEGER i,j,ierr
SH=PMAS(PYCOMP(KTECHN+113),1)**2
AEM=PYALEM(SH)
TANW=SQRT(PARU(102)/(1D0-PARU(102)))
CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
QUPD=2D0*RTCM(2)-1D0
ALPRHT=2.91D0*(3D0/DBLE(ITCM(1)))
FAR=SQRT(AEM/ALPRHT)
FAO=FAR*QUPD
FZR=FAR*CT2W
FZO=-FAO*TANW
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(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
CCCCCCCC
DO 110 I=1,4
DO 100 J=1,4
AT(I,J)=0D0
100 CONTINUE
110 CONTINUE
SHR=SQRT(SH)
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
CCCC
CALL PYEICG(4,4,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
DO 120 I=1,4
WI(I)=SQRT(ABS(SH-WR(I)))
WR(I)=ABS(WR(I))
120 CONTINUE
R1=MIN(WR(1),WR(2),WR(3),WR(4))
R2=1D20
S1=0D0
S2=0D0
DO 130 I=1,4
IF(ABS(WR(I)-R1).LT.1D-6) THEN
S1=WI(I)
GOTO 130
ENDIF
IF(WR(I).LE.R2) THEN
R2=WR(I)
S2=WI(I)
ENDIF
130 CONTINUE
S1=S1**2
S2=S2**2
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(4,4),AI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
X FV1(4),FV2(4),FV3(4)
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(4,4),HI(4,4),WR(4),WI(4)
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(4,4),HI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4),
X ORTR(4),ORTI(4)
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(4,4),AI(4,4),SCALE(4)
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(4),ZR(4,4),ZI(4,4)
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(4,4),AI(4,4),ORTR(4),ORTI(4)
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 110 I=0,200
WDTP(I)=0D0
DO 100 J=0,5
WDTE(I,J)=0D0
100 CONTINUE
110 CONTINUE
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:
ICASE=1
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
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))
WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
& BE34
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
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)
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(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
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)
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
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
CALL PYSHOW(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
CALL PYSHOW(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
CALL PYSHOW(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
CALL PYSHOW(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
CALL PYSHOW(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
CALL PYSHOW(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
CALL PYSHOW(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
CALL PYSHOW(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
CALL PYSHOW(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 Tune A
C 101 AW : Rick Field's Tune AW
C 102 BW : Rick Field's Tune BW
C 103 DW : Rick Field's Tune DW
C 104 DWT : Rick Field's Tune DW with slower UE energy scaling
C 105 QW : Rick Field's Tune QW (NB: needs CTEQ6.1 pdfs externally)
C 106 ATLAS : Arthur Moraes' ATLAS tune
C 107 ACR : Tune A modified with annealing CR
C ====== New UE, Q2-ordered showers ==========================================
C 200 IM 1 : Intermediate model: new UE, Q2-ordered showers, annealing CR
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 ======= 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.
C 403 SCI 1 : Soft-Colour-Interaction model. Tevatron MB retuned.
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 (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.408+ ***
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...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 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: (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...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 ?
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.000 ',CHDOC='Oct 2006')
CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
CHARACTER*40 CHMSTJ(20), 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',3*' '/
DATA (CHNAMS(I),I=300,310)/
& 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',5*' '/
DATA (CHNAMS(I),I=200,210)/
& 'IM Tune 1',10*' '/
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)/
& 5*' ','HAD treatment of small-mass systems',4*' '/
DATA (CHMSTP(I),I=51,100)/
5 'PDF set','PDF set internal (=1) or pdflib (=2)',
6 8*' ','ISR master switch',8*' ',
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',1*' ',
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*' ',10*' ',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 PYTHIA 6.402+ update notes,'
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.14D0
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.14D0
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.14D0
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 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.14D0
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.14D0
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) 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...Tunes A, AW, BW, DW, DWT, and QW (by R.D. Field, CDF) (100-105)
C...and ATLAS Tune (by A. Moraes, ATLAS) (106)
ELSEIF (ITUNE.GE.100.AND.ITUNE.LE.106) 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
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...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...ATLAS 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,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)
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
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...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,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)
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... 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,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...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 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 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,A40,5x,'*')
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
CALL PYSHOW(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
CALL PYSHOW(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 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 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(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 MSTJ(191)=1.
ELSEIF(MSTJ(49).EQ.0.AND.MSTP(148).EQ.1.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).EQ.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 irrelevent 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) K(I,5)=0
IF(K(I,2).LT.0.AND.K(I,2).GT.-6) K(I,4)=0
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...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
DO 230 I=1,N
IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
230 CONTINUE
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=K(IPART1,3)
IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,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(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
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)
STOP
ENDIF
C...Stop program in case of irreparable error.
ELSE
WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
STOP
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...PYR
C...Generates random numbers uniformly distributed between
C...0 and 1, excluding the endpoints.
FUNCTION PYR(IDUMMY)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDATR/MRPY(6),RRPY(100)
SAVE /PYDATR/
C...Equivalence between commonblock and local variables.
EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)),
&(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)),
&(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100))
C...Initialize generation from given seed.
IF(MRPY2.EQ.0) THEN
IJ=MOD(MRPY1/30082,31329)
KL=MOD(MRPY1,30082)
I=MOD(IJ/177,177)+2
J=MOD(IJ,177)+2
K=MOD(KL/169,178)+1
L=MOD(KL,169)
DO 110 II=1,97
S=0D0
T=0.5D0
DO 100 JJ=1,48
M=MOD(MOD(I*J,179)*K,179)
I=J
J=K
K=M
L=MOD(53*L+1,169)
IF(MOD(L*M,64).GE.32) S=S+T
T=0.5D0*T
100 CONTINUE
RRPY(II)=S
110 CONTINUE
TWOM24=1D0
DO 120 I24=1,24
TWOM24=0.5D0*TWOM24
120 CONTINUE
RRPY98=362436D0*TWOM24
RRPY99=7654321D0*TWOM24
RRPY00=16777213D0*TWOM24
MRPY2=1
MRPY3=0
MRPY4=97
MRPY5=33
ENDIF
C...Generate next random number.
130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
IF(RUNI.LT.0D0) RUNI=RUNI+1D0
RRPY(MRPY4)=RUNI
MRPY4=MRPY4-1
IF(MRPY4.EQ.0) MRPY4=97
MRPY5=MRPY5-1
IF(MRPY5.EQ.0) MRPY5=97
RRPY98=RRPY98-RRPY99
IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
RUNI=RUNI-RRPY98
IF(RUNI.LT.0D0) RUNI=RUNI+1D0
IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
C...Update counters. Random number to output.
MRPY3=MRPY3+1
IF(MRPY3.EQ.1000000000) THEN
MRPY2=MRPY2+1
MRPY3=0
ENDIF
PYR=RUNI
RETURN
END
C*********************************************************************
C...PYRGET
C...Dumps the state of the random number generator on a file
C...for subsequent startup from this state onwards.
SUBROUTINE PYRGET(LFN,MOVE)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDATR/MRPY(6),RRPY(100)
SAVE /PYDATR/
C...Local character variable.
CHARACTER CHERR*8
C...Backspace required number of records (or as many as there are).
IF(MOVE.LT.0) THEN
NBCK=MIN(MRPY(6),-MOVE)
DO 100 IBCK=1,NBCK
BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
100 CONTINUE
MRPY(6)=MRPY(6)-NBCK
ENDIF
C...Unformatted write on unit LFN.
WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
&(RRPY(I2),I2=1,100)
MRPY(6)=MRPY(6)+1
RETURN
C...Write error.
110 WRITE(CHERR,'(I8)') IERR
CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
&CHERR)
RETURN
END
C*********************************************************************
C...PYRSET
C...Reads a state of the random number generator from a file
C...for subsequent generation from this state onwards.
SUBROUTINE PYRSET(LFN,MOVE)
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
INTEGER PYK,PYCHGE,PYCOMP
C...Commonblocks.
COMMON/PYDATR/MRPY(6),RRPY(100)
SAVE /PYDATR/
C...Local character variable.
CHARACTER CHERR*8
C...Backspace required number of records (or as many as there are).
IF(MOVE.LT.0) THEN
NBCK=MIN(MRPY(6),-MOVE)
DO 100 IBCK=1,NBCK
BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
100 CONTINUE
MRPY(6)=MRPY(6)-NBCK
ENDIF
C...Unformatted read from unit LFN.
NFOR=1+MAX(0,MOVE)
DO 110 IFOR=1,NFOR
READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
& (RRPY(I2),I2=1,100)
110 CONTINUE
MRPY(6)=MRPY(6)+NFOR
RETURN
C...Write error.
120 WRITE(CHERR,'(I8)') IERR
CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
&CHERR)
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=20)
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;',
&' phone: + 1 - 630 - 840 - 2270; e-m',
&'ail: 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!'
STOP
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 /bin',10X,'',18X,'',
&18X,'',18X,''/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
CALL PYSHOW(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
CALL PYSHOW(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...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)
IF(PYR(0).LT.10D0) STOP
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)
IF(PYR(0).LT.10D0) STOP
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 "" or "'.AND.
&STRING(IBEG:IBEG+5).NE.'" or "'.AND.
&STRING(IBEG:IBEG+6).NE.'