C********************************************************************* C********************************************************************* C* ** C* July 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 PYSTOP routine to handle Fortran STOP condition * C * C S PYKCUT dummy routine for user kinematical cuts * C S PYEVWT dummy routine for weighting events * C S UPINIT dummy routine to initialize user processes * C S UPEVNT dummy routine to generate a user process event * C S UPVETO dummy routine to abort event at parton level * C S PDFSET dummy routine to be removed when using PDFLIB * C S STRUCTM dummy routine to be removed when using PDFLIB * C S STRUCTP dummy routine to be removed when using PDFLIB * C S SUGRA dummy routine to be removed when linking with ISAJET * C F VISAJE dummy functn. to be removed when linking with ISAJET * C S SSMSSM dummy routine to be removed when linking with ISAJET * C S FHSETFLAGS dummy routine -"- FEYNHIGGS * C S FHSETPARA dummy routine -"- FEYNHIGGS * C S FHHIGGSCORR dummy routine -"- FEYNHIGGS * C S PYTAUD dummy routine for interface to tau decay libraries * C S PYTIME dummy routine for giving date and time * C * C********************************************************************* C...PYDATA C...Default values for switches and parameters, C...and particle, decay and process data. BLOCK DATA PYDATA C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYDAT4/CHAF(500,2) CHARACTER CHAF*16 COMMON/PYDATR/MRPY(6),RRPY(100) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT6/PROC(0:500) CHARACTER PROC*28 COMMON/PYINT7/SIGT(0:6,0:6,0:5) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100), & AU(3,3),AD(3,3),AE(3,3) COMMON/PYLH3C/CPRO(2),CVER(2) CHARACTER CPRO*12,CVER*12 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/, &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/, &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/, &/PYBINS/,/PYLH3P/,/PYLH3C/ C...PYDAT1, containing status codes and most parameters. DATA MSTU/ & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2, 1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0, 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0, 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0, 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0, 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7 30*0, 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0, & 80*0/ DATA (PARU(I),I=1,100)/ & 3.141592653589793D0, 6.283185307179586D0, & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0, 1 0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0, 4 0D0, 0D0, 0.0001D0, 0D0, 0D0, 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0, 6 40*0D0/ DATA (PARU(I),I=101,200)/ & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5, & 0D0, 0D0, 0D0, 0D0, 0D0, 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0, 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0, 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0, 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0, 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/ DATA MSTJ/ & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0, 1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0, 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0, 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3, 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0, 6 40*0, & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2, 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 2 80*0/ DATA PARJ/ & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0, & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0, 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0, 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0, 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0, 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0, 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0, 5 0D0, 0D0, 0D0, 1.0D0, 0D0, 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0, 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0, 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4, 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0, 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0, 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0, 4 10*0D0, 5 10*0D0, 6 10*0D0, 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0, 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0, 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0, 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0, 9 5*0D0/ C...PYDAT2, with particle data and flavour treatment parameters. DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0, &-3,0,-3,6*0,3,9*0,3,2*0,3,4*0,-1,41*0,2,-1,20*0,3*3,7*0,3*3,3*0, &3*3,3*0,3*3,6*0,3*3,3*0,3*3,4*0,-2,-3,2*1,2*0,4,2*3,6,2*-2,2*-3, &0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,3,2*1,2*0, &2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,3,2*-2, &2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,-3,2*0, &2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,3*0,3,2*0,3,0,3,0,3, &2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,2,-1, &2,-1,2,-3,0,-3,0,-3,2*0,3,3*0,3,8*0,-1,2,-3,6*0,3,2*6,0,3,4*0,3, &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, 412, 2007, 07, 23, 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!' CALL PYSTOP(8) ENDIF RETURN END C********************************************************************* C...PYTEST C...A simple program (disguised as subroutine) to run at installation C...as a check that the program works as intended. SUBROUTINE PYTEST(MTEST) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/ C...Local arrays. DIMENSION PSUM(5),PINI(6),PFIN(6) C...Save defaults for values that are changed. MSTJ1=MSTJ(1) MSTJ3=MSTJ(3) MSTJ11=MSTJ(11) MSTJ42=MSTJ(42) MSTJ43=MSTJ(43) MSTJ44=MSTJ(44) PARJ17=PARJ(17) PARJ22=PARJ(22) PARJ43=PARJ(43) PARJ54=PARJ(54) MST101=MSTJ(101) MST104=MSTJ(104) MST105=MSTJ(105) MST107=MSTJ(107) MST116=MSTJ(116) C...First part: loop over simple events to be generated. IF(MTEST.GE.1) CALL PYTABU(20) NERR=0 DO 180 IEV=1,500 C...Reset parameter values. Switch on some nonstandard features. MSTJ(1)=1 MSTJ(3)=0 MSTJ(11)=1 MSTJ(42)=2 MSTJ(43)=4 MSTJ(44)=2 PARJ(17)=0.1D0 PARJ(22)=1.5D0 PARJ(43)=1D0 PARJ(54)=-0.05D0 MSTJ(101)=5 MSTJ(104)=5 MSTJ(105)=0 MSTJ(107)=1 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3 C...Ten events each for some single jets configurations. IF(IEV.LE.50) THEN ITY=(IEV+9)/10 MSTJ(3)=-1 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0) IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0) IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0) IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0) IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0) C...Ten events each for some simple jet systems; string fragmentation. ELSEIF(IEV.LE.130) THEN ITY=(IEV-41)/10 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0) IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0) IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0) IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0) IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0) IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0) IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0) IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0, & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) C...Seventy events with independent fragmentation and momentum cons. ELSEIF(IEV.LE.200) THEN ITY=1+(IEV-131)/16 MSTJ(2)=1+MOD(IEV-131,4) MSTJ(3)=1+MOD((IEV-131)/4,4) IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0) IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0) IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0, & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0, & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) C...A hundred events with random jets (check invariant mass). ELSEIF(IEV.LE.300) THEN 100 DO 110 J=1,5 PSUM(J)=0D0 110 CONTINUE NJET=2D0+6D0*PYR(0) DO 130 I=1,NJET KFL=21 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0)) IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0)) EJET=5D0+20D0*PYR(0) THETA=ACOS(2D0*PYR(0)-1D0) PHI=6.2832D0*PYR(0) IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI) IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI) IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL) DO 120 J=1,4 PSUM(J)=PSUM(J)+P(I,J) 120 CONTINUE 130 CONTINUE IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT. & (PSUM(5)+PARJ(32))**2) GOTO 100 C...Fifty e+e- continuum events with matrix elements. ELSEIF(IEV.LE.350) THEN MSTJ(101)=2 CALL PYEEVT(0,40D0) C...Fifty e+e- continuum event with varying shower options. ELSEIF(IEV.LE.400) THEN MSTJ(42)=1+MOD(IEV,2) MSTJ(43)=1+MOD(IEV/2,4) MSTJ(44)=MOD(IEV/8,3) CALL PYEEVT(0,90D0) C...Fifty e+e- continuum events with coherent shower. ELSEIF(IEV.LE.450) THEN CALL PYEEVT(0,500D0) C...Fifty Upsilon decays to ggg or gammagg with coherent shower. ELSE CALL PYONIA(5,9.46D0) ENDIF C...Generate event. Find total momentum, energy and charge. DO 140 J=1,4 PINI(J)=PYP(0,J) 140 CONTINUE PINI(6)=PYP(0,6) CALL PYEXEC DO 150 J=1,4 PFIN(J)=PYP(0,J) 150 CONTINUE PFIN(6)=PYP(0,6) C...Check conservation of energy, momentum and charge; C...usually exact, but only approximate for single jets. MERR=0 IF(IEV.LE.50) THEN IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0) & MERR=MERR+1 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3) IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1 ELSE DO 160 J=1,4 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1 160 CONTINUE IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1 ENDIF IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6), & (PFIN(J),J=1,4),PFIN(6) C...Check that all KF codes are known ones, and that partons/particles C...satisfy energy-momentum-mass relation. Store particle statistics. DO 170 I=1,N IF(K(I,1).GT.20) GOTO 170 IF(PYCOMP(K(I,2)).EQ.0) THEN WRITE(MSTU(11),5100) I MERR=MERR+1 ENDIF PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0) & THEN WRITE(MSTU(11),5200) I MERR=MERR+1 ENDIF 170 CONTINUE IF(MTEST.GE.1) CALL PYTABU(21) C...List all erroneous events and some normal ones. IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN IF(MERR.GE.1) WRITE(MSTU(11),6400) CALL PYLIST(2) ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN CALL PYLIST(1) ENDIF C...Stop execution if too many errors. IF(MERR.NE.0) NERR=NERR+1 IF(NERR.GE.10) THEN WRITE(MSTU(11),6300) CALL PYLIST(1) CALL PYSTOP(9) ENDIF 180 CONTINUE C...Summarize result of run. IF(MTEST.GE.1) CALL PYTABU(22) C...Reset commonblock variables changed during run. MSTJ(1)=MSTJ1 MSTJ(3)=MSTJ3 MSTJ(11)=MSTJ11 MSTJ(42)=MSTJ42 MSTJ(43)=MSTJ43 MSTJ(44)=MSTJ44 PARJ(17)=PARJ17 PARJ(22)=PARJ22 PARJ(43)=PARJ43 PARJ(54)=PARJ54 MSTJ(101)=MST101 MSTJ(104)=MST104 MSTJ(105)=MST105 MSTJ(107)=MST107 MSTJ(116)=MST116 C...Second part: complete events of various kinds. C...Common initial values. Loop over initiating conditions. MSTP(122)=MAX(0,MIN(2,MTEST)) MDCY(PYCOMP(111),1)=0 DO 230 IPROC=1,8 C...Reset process type, kinematics cuts, and the flags used. MSEL=0 DO 190 ISUB=1,500 MSUB(ISUB)=0 190 CONTINUE CKIN(1)=2D0 CKIN(3)=0D0 MSTP(2)=1 MSTP(11)=0 MSTP(33)=0 MSTP(81)=1 MSTP(82)=1 MSTP(111)=1 MSTP(131)=0 MSTP(133)=0 PARP(131)=0.01D0 C...Prompt photon production at fixed target. IF(IPROC.EQ.1) THEN PZSUM=300D0 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212) PQSUM=2D0 MSEL=10 CKIN(3)=5D0 CALL PYINIT('FIXT','pi+','p',PZSUM) C...QCD processes at ISR energies. ELSEIF(IPROC.EQ.2) THEN PESUM=63D0 PZSUM=0D0 PQSUM=2D0 MSEL=1 CKIN(3)=5D0 CALL PYINIT('CMS','p','p',PESUM) C...W production + multiple interactions at CERN Collider. ELSEIF(IPROC.EQ.3) THEN PESUM=630D0 PZSUM=0D0 PQSUM=0D0 MSEL=12 CKIN(1)=20D0 MSTP(82)=4 MSTP(2)=2 MSTP(33)=3 CALL PYINIT('CMS','p','pbar',PESUM) C...W/Z gauge boson pairs + pileup events at the Tevatron. ELSEIF(IPROC.EQ.4) THEN PESUM=1800D0 PZSUM=0D0 PQSUM=0D0 MSUB(22)=1 MSUB(23)=1 MSUB(25)=1 CKIN(1)=200D0 MSTP(111)=0 MSTP(131)=1 MSTP(133)=2 PARP(131)=0.04D0 CALL PYINIT('CMS','p','pbar',PESUM) C...Higgs production at LHC. ELSEIF(IPROC.EQ.5) THEN PESUM=15400D0 PZSUM=0D0 PQSUM=2D0 MSUB(3)=1 MSUB(102)=1 MSUB(123)=1 MSUB(124)=1 PMAS(25,1)=300D0 CKIN(1)=200D0 MSTP(81)=0 MSTP(111)=0 CALL PYINIT('CMS','p','p',PESUM) C...Z' production at SSC. ELSEIF(IPROC.EQ.6) THEN PESUM=40000D0 PZSUM=0D0 PQSUM=2D0 MSEL=21 PMAS(32,1)=600D0 CKIN(1)=400D0 MSTP(81)=0 MSTP(111)=0 CALL PYINIT('CMS','p','p',PESUM) C...W pair production at 1 TeV e+e- collider. ELSEIF(IPROC.EQ.7) THEN PESUM=1000D0 PZSUM=0D0 PQSUM=0D0 MSUB(25)=1 MSUB(69)=1 MSTP(11)=1 CALL PYINIT('CMS','e+','e-',PESUM) C...Deep inelastic scattering at a LEP+LHC ep collider. ELSEIF(IPROC.EQ.8) THEN P(1,1)=0D0 P(1,2)=0D0 P(1,3)=8000D0 P(2,1)=0D0 P(2,2)=0D0 P(2,3)=-80D0 PESUM=8080D0 PZSUM=7920D0 PQSUM=0D0 MSUB(10)=1 CKIN(3)=50D0 MSTP(111)=0 CALL PYINIT('3MOM','p','e-',PESUM) ENDIF C...Generate 20 events of each required type. DO 220 IEV=1,20 CALL PYEVNT PESUMM=PESUM IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM C...Check conservation of energy/momentum/flavour. PINI(1)=0D0 PINI(2)=0D0 PINI(3)=PZSUM PINI(4)=PESUMM PINI(6)=PQSUM DO 200 J=1,4 PFIN(J)=PYP(0,J) 200 CONTINUE PFIN(6)=PYP(0,6) MERR=0 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3)) DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2)) DEVQ=ABS(PFIN(6)-PINI(6)) IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR. & DEVQ.GT.0.1D0) MERR=1 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6), & (PFIN(J),J=1,4),PFIN(6) C...Check that all KF codes are known ones, and that partons/particles C...satisfy energy-momentum-mass relation. DO 210 I=1,N IF(K(I,1).GT.20) GOTO 210 IF(PYCOMP(K(I,2)).EQ.0) THEN WRITE(MSTU(11),5100) I MERR=MERR+1 ENDIF PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2* & SIGN(1D0,P(I,5)) IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2) & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN WRITE(MSTU(11),5200) I MERR=MERR+1 ENDIF 210 CONTINUE C...Listing of erroneous events, and first event of each type. IF(MERR.GE.1) NERR=NERR+1 IF(NERR.GE.10) THEN WRITE(MSTU(11),6300) CALL PYLIST(1) CALL PYSTOP(9) ENDIF IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN IF(MERR.GE.1) WRITE(MSTU(11),6400) CALL PYLIST(1) ENDIF 220 CONTINUE C...List statistics for each process type. IF(MTEST.GE.1) CALL PYSTAT(1) 230 CONTINUE C...Summarize result of run. IF(NERR.EQ.0) WRITE(MSTU(11),6500) IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR C...Format statements for output. 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ', &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X, &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X, &4(1X,F12.5),1X,F8.2) 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code') 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ', &'kinematics') 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ', &'wrong.'/5X,'Execution will be stopped after listing of event.') 6400 FORMAT(5X,'Faulty event follows:') 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.') 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/ &5X,'This should not have happened!') RETURN END C********************************************************************* C...PYHEPC C...Converts PYTHIA event record contents to or from C...the standard event record commonblock. SUBROUTINE PYHEPC(MCONV) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...HEPEVT commonblock. PARAMETER (NMXHEP=4000) COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) DOUBLE PRECISION PHEP,VHEP SAVE /HEPEVT/ C...Store HEPEVT commonblock size (for interfacing issues). MSTU(8)=NMXHEP C...Conversion from PYTHIA to standard, the easy part. IF(MCONV.EQ.1) THEN NEVHEP=0 IF(N.GT.NMXHEP) CALL PYERRM(8, & '(PYHEPC:) no more space in /HEPEVT/') NHEP=MIN(N,NMXHEP) DO 150 I=1,NHEP ISTHEP(I)=0 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1) IDHEP(I)=K(I,2) JMOHEP(1,I)=K(I,3) JMOHEP(2,I)=0 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN JDAHEP(1,I)=K(I,4) JDAHEP(2,I)=K(I,5) ELSE JDAHEP(1,I)=0 JDAHEP(2,I)=0 ENDIF DO 100 J=1,5 PHEP(J,I)=P(I,J) 100 CONTINUE DO 110 J=1,4 VHEP(J,I)=V(I,J) 110 CONTINUE C...Check if new event (from pileup). IF(I.EQ.1) THEN INEW=1 ELSE IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I ENDIF C...Fill in missing mother information. IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN IMO1=I-2 120 IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0) & THEN IMO1=IMO1-1 GOTO 120 ENDIF JMOHEP(1,I)=IMO1 JMOHEP(2,I)=IMO1+1 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN I1=K(I,3)-1 130 I1=I1+1 IF(I1.GE.I) CALL PYERRM(8, & '(PYHEPC:) translation of inconsistent event history') IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130 KC=PYCOMP(K(I1,2)) IF(I1.LT.I.AND.KC.EQ.0) GOTO 130 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130 JMOHEP(2,I)=I1 ELSEIF(K(I,2).EQ.94) THEN NJET=2 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5)) IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)= & MOD(K(I+1,4)/MSTU(5),MSTU(5)) ENDIF C...Fill in missing daughter information. IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN DO 140 I1=JDAHEP(1,I),JDAHEP(2,I) I2=MOD(K(I1,4)/MSTU(5),MSTU(5)) JDAHEP(1,I2)=I 140 CONTINUE ENDIF IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150 I1=JMOHEP(1,I) IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150 IF(JDAHEP(1,I1).EQ.0) THEN JDAHEP(1,I1)=I ELSE JDAHEP(2,I1)=I ENDIF 150 CONTINUE DO 160 I=1,NHEP IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I) 160 CONTINUE C...Conversion from standard to PYTHIA, the easy part. ELSE IF(NHEP.GT.MSTU(4)) CALL PYERRM(8, & '(PYHEPC:) no more space in /PYJETS/') N=MIN(NHEP,MSTU(4)) NKQ=0 KQSUM=0 DO 190 I=1,N K(I,1)=0 IF(ISTHEP(I).EQ.1) K(I,1)=1 IF(ISTHEP(I).EQ.2) K(I,1)=11 IF(ISTHEP(I).EQ.3) K(I,1)=21 K(I,2)=IDHEP(I) K(I,3)=JMOHEP(1,I) K(I,4)=JDAHEP(1,I) K(I,5)=JDAHEP(2,I) DO 170 J=1,5 P(I,J)=PHEP(J,I) 170 CONTINUE DO 180 J=1,4 V(I,J)=VHEP(J,I) 180 CONTINUE V(I,5)=0D0 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN I1=JDAHEP(1,I) IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))* & PHEP(5,I)/PHEP(4,I) ENDIF C...Fill in missing information on colour connection in jet systems. IF(ISTHEP(I).EQ.1) THEN KC=PYCOMP(K(I,2)) KQ=0 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) IF(KQ.NE.0) NKQ=NKQ+1 IF(KQ.NE.2) KQSUM=KQSUM+KQ IF(KQ.NE.0.AND.KQSUM.NE.0) THEN K(I,1)=2 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN IF(K(I+1,2).EQ.21) K(I,1)=2 ENDIF ENDIF 190 CONTINUE IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8, & '(PYHEPC:) input parton configuration not colour singlet') ENDIF END C********************************************************************* C...PYINIT C...Initializes the generation procedure; finds maxima of the C...differential cross-sections to be used for weighting. SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYDAT4/CHAF(500,2) CHARACTER CHAF*16 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/, &/PYINT1/,/PYINT2/,/PYINT5/ C...Local arrays and character variables. DIMENSION ALAMIN(20),NFIN(20) CHARACTER*(*) FRAME,BEAM,TARGET CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6 C...Interface to PDFLIB. COMMON/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS COMMON/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)) CALL PYSTOP(1) ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN WRITE(MSTU(11),5300) ISUB CALL PYSTOP(1) ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN WRITE(MSTU(11),5400) ISUB CALL PYSTOP(1) ELSEIF(MSUB(ISUB).EQ.1) THEN MINT(48)=MINT(48)+1 ENDIF 130 CONTINUE C...Stop or raise warning flag if no subprocesses on. IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN IF(MSTP(127).NE.1) THEN WRITE(MSTU(11),5500) CALL PYSTOP(1) ELSE WRITE(MSTU(11),5700) MSTI(53)=1 ENDIF ENDIF MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94) MSAV48=MSAV48+MINT(48) C...Reset variables for cross-section calculation. DO 150 I=0,500 DO 140 J=1,3 NGEN(I,J)=0 XSEC(I,J)=0D0 140 CONTINUE 150 CONTINUE C...Find parametrized total cross-sections. CALL PYXTOT VINT(318)=VINT(317) C...Maxima of differential cross-sections. IF(MSTP(121).LE.1) CALL PYMAXI C...Initialize possibility of pileup events. IF(MINT(121).GT.1) MSTP(131)=0 IF(MSTP(131).NE.0) CALL PYPILE(1) C...Initialize multiple interactions with variable impact parameter. IF(MINT(50).EQ.1) THEN PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR. & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82)) IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN MINT(35)=1 CALL PYMULT(1) MINT(35)=3 CALL PYMIGN(1) ENDIF ENDIF C...Save results for gamma-p and gamma-gamma alternatives. IF(MINT(121).GT.1) CALL PYSAVE(1,IGA) 160 CONTINUE C...Initialization finished. IF(MSAV48.EQ.0) THEN IF(MSTP(127).NE.1) THEN WRITE(MSTU(11),5500) CALL PYSTOP(1) ELSE WRITE(MSTU(11),5700) MSTI(53)=1 ENDIF ENDIF 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600) C...Formats for initialization information. 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ', &'routines',1X,17('*')) 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6, &'-',A6,' interactions.'/1X,'Execution stopped!') 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/ &1X,'Execution stopped!') 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/ &1X,'Execution stopped!') 5500 FORMAT(1X,'Error: no subprocess switched on.'/ &1X,'Execution stopped.') 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X, &22('*')) 5700 FORMAT(1X,'Error: no subprocess switched on.'/ &1X,'Execution will stop if you try to generate events.') RETURN END C********************************************************************* C...PYEVNT C...Administers the generation of a high-pT event via calls to C...a number of subroutines. SUBROUTINE PYEVNT C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYCTAG/NCT,MCT(4000,2) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/, &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/ C...Local array. DIMENSION VTX(4) C...Optionally let PYEVNW do the whole job. IF(MSTP(81).GE.20) THEN CALL PYEVNW RETURN ENDIF C...Stop if no subprocesses on. IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN WRITE(MSTU(11),5100) CALL PYSTOP(1) ENDIF C...Initial values for some counters. 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) CALL PYSTOP(1) 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 DO 360 MQGST=1,2 DO 350 I=MINT(84)+1,N C...Look for coloured string endpoint, or (later) leftover gluon. IF (K(I,1).NE.3) GOTO 350 KC=PYCOMP(K(I,2)) IF(KC.EQ.0) GOTO 350 KQ=KCHG(KC,2) IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350 C... Pick up loose string end with no previous tag. KCS=4 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5 IF(MCT(I,KCS-3).NE.0) GOTO 350 CALL PYCTTR(I,KCS,I) IF(MINT(51).NE.0) RETURN 350 CONTINUE 360 CONTINUE C...Now delete any colour processing information if set (since partons C...otherwise not FS showered!) DO 170 I=MINT(84)+1,N IF (I.LE.N) THEN K(I,4)=MOD(K(I,4),MSTU(5)**2) K(I,5)=MOD(K(I,5),MSTU(5)**2) ENDIF 170 CONTINUE ENDIF C...Showering of final state partons (optional). ALAMSV=PARJ(81) PARJ(81)=PARP(72) IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10) & THEN QMAX=VINT(55) IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55) CALL PYPTFS(1,QMAX,0D0,PTGEN) C...External processes: handle successive showers. ELSEIF(ISET(ISUB).EQ.11) THEN CALL PYADSH(NFIN) ENDIF PARJ(81)=ALAMSV C...Allow possibility for user to abort event generation. IVETO=0 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm IF(IVETO.EQ.1) GOTO 100 C...Decay of final state resonances. MINT(32)=0 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN CALL PYRESD(0) IF(MINT(51).NE.0) GOTO 100 ENDIF IF(MINT(51).EQ.1) GOTO 100 ELSEIF(ISUB.NE.99) THEN C...Diffractive and elastic scattering. CALL PYDIFF ELSE C...DIS scattering (photon flux external). CALL PYDISG IF(MINT(51).EQ.1) GOTO 100 ENDIF C...Check that no odd resonance left undecayed. MINT(54)=N IF(MSTP(111).GE.1) THEN NFIX=N DO 180 I=MINT(84)+1,NFIX IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND. & K(I,2).NE.22) THEN KCA=PYCOMP(K(I,2)) IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN CALL PYRESD(I) IF(MINT(51).EQ.1) GOTO 100 ENDIF ENDIF 180 CONTINUE ENDIF C...Boost hadronic subsystem to overall rest frame. C..(Only relevant when photon inside lepton beam.) IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA) C...Recalculate energies from momenta and masses (if desired). IF(MSTP(113).GE.1) THEN DO 190 I=MINT(83)+1,N IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+ & P(I,2)**2+P(I,3)**2+P(I,5)**2) 190 CONTINUE NRECAL=N ENDIF C...Colour reconnection before string formation CALL PYFSCR(MINT(84)+1) C...Rearrange partons along strings, check invariant mass cuts. MSTU(28)=0 IF(MSTP(111).LE.0) MSTJ(14)=-1 CALL PYPREP(MINT(84)+1) MSTJ(14)=MSTJ14 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN MSTU(24)=0 GOTO 100 ENDIF IF(MINT(51).EQ.1) GOTO 110 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN DO 220 I=MINT(84)+1,N IF(K(I,2).EQ.94) THEN DO 210 I1=I+1,MIN(N,I+10) IF(K(I1,3).EQ.I) THEN K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5)) IF(K(I1,3).EQ.0) THEN DO 200 II=MINT(84)+1,I-1 IF(K(II,2).EQ.K(I1,2)) THEN IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR. & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II ENDIF 200 CONTINUE IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3) ENDIF ENDIF 210 CONTINUE ENDIF 220 CONTINUE CALL PYEDIT(12) CALL PYEDIT(14) IF(MSTP(125).EQ.0) CALL PYEDIT(15) IF(MSTP(125).EQ.0) MINT(4)=0 DO 240 I=MINT(83)+1,N IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN DO 230 I1=I+1,N IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1 IF(K(I1,3).EQ.I) K(I,5)=I1 230 CONTINUE ENDIF 240 CONTINUE ENDIF C...Introduce separators between sections in PYLIST event listing. IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN MSTU70=1 MSTU(71)=N ELSEIF(IPILE.EQ.1) THEN MSTU70=3 MSTU(71)=2 MSTU(72)=MINT(4) MSTU(73)=N ENDIF C...Go back to lab frame (needed for vertices, also in fragmentation). CALL PYFRAM(1) C...Set nonvanishing production vertex (optional). IF(MSTP(151).EQ.1) THEN DO 250 J=1,4 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))* & SIN(PARU(2)*PYR(0)) 250 CONTINUE DO 270 I=MINT(83)+1,N DO 260 J=1,4 V(I,J)=V(I,J)+VTX(J) 260 CONTINUE 270 CONTINUE ENDIF C...Perform hadronization (if desired). IF(MSTP(111).GE.1) THEN CALL PYEXEC IF(MSTU(24).NE.0) GOTO 100 ENDIF IF(MSTP(113).GE.1) THEN DO 280 I=NRECAL,N IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+ & P(I,2)**2+P(I,3)**2+P(I,5)**2) 280 CONTINUE ENDIF IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14) C...Store event information and calculate Monte Carlo estimates of C...subprocess cross-sections. 290 IF(IPILE.EQ.1) CALL PYDOCU C...Set counters for current pileup event and loop to next one. MSTI(41)=IPILE IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB IF(MSTU70.LT.10) THEN MSTU70=MSTU70+1 MSTU(70+MSTU70)=N ENDIF MINT(83)=N MINT(84)=N+MSTP(126) IF(IPILE.LT.NPILE) CALL PYFRAM(2) 300 CONTINUE C...Generic information on pileup events. Reconstruct missing history. IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN PARI(91)=VINT(132) PARI(92)=VINT(133) PARI(93)=VINT(134) IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131) ENDIF CALL PYEDIT(16) C...Transform to the desired coordinate frame. 310 CALL PYFRAM(MSTP(124)) MSTU(70)=MSTU70 PARU(21)=VINT(1) C...Error messages 5100 FORMAT(1X,'Error: no subprocess switched on.'/ &1X,'Execution stopped.') RETURN END C*********************************************************************** C...PYSTAT C...Prints out information about cross-sections, decay widths, branching C...ratios, kinematical limits, status codes and parameter values. SUBROUTINE PYSTAT(MSTAT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) PARAMETER (EPS=1D-3) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT6/PROC(0:500) CHARACTER PROC*28, CHTMP*16 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/ C...Local arrays, character variables and data. DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10) CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16, &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28, &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28 CHARACTER*24 CHD0, CHDC(10) CHARACTER*6 DNAME(3) DATA PROGA/ &'VMD/hadron * VMD ','VMD/hadron * direct ', &'VMD/hadron * anomalous ','direct * direct ', &'direct * anomalous ','anomalous * anomalous '/ DATA DISGA/'e * VMD','e * anomalous'/ DATA PROGG9/ &'direct * direct ','direct * VMD ', &'direct * anomalous ','VMD * direct ', &'VMD * VMD ','VMD * anomalous ', &'anomalous * direct ','anomalous * VMD ', &'anomalous * anomalous ','DIS * VMD ', &'DIS * anomalous ','VMD * DIS ', &'anomalous * DIS '/ DATA PROGG4/ &'direct * direct ','direct * resolved ', &'resolved * direct ','resolved * resolved '/ DATA PROGG2/ &'direct * hadron ','resolved * hadron '/ DATA PROGP4/ &'VMD * hadron ','direct * hadron ', &'anomalous * hadron ','DIS * hadron '/ DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/, &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ', &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ', &' y*_small ',' eta*_large ',' eta*_small ', &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ', &' x_2 ',' x_F ',' cos(theta_hard) ', &'m''_hard (GeV/c^2) ',' tau ',' y* ', &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ', &' tau'' '/ DATA DNAME /'q ','lepton','nu '/ C...Cross-sections. IF(MSTAT.LE.1) THEN IF(MINT(121).GT.1) CALL PYSAVE(5,0) WRITE(MSTU(11),5000) WRITE(MSTU(11),5100) WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3) DO 100 I=1,500 IF(MSUB(I).NE.1) GOTO 100 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3) 100 CONTINUE IF(MINT(121).GT.1) THEN WRITE(MSTU(11),5300) DO 110 IGA=1,MINT(121) CALL PYSAVE(3,IGA) IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1), & XSEC(0,3) ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1), & XSEC(0,3) ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1), & XSEC(0,3) ELSEIF(MINT(121).EQ.4) THEN WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1), & XSEC(0,3) ELSEIF(MINT(121).EQ.2) THEN WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1), & XSEC(0,3) ELSE WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1), & XSEC(0,3) ENDIF 110 CONTINUE CALL PYSAVE(5,0) ENDIF WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27), & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2))) C...Decay widths and branching ratios. ELSEIF(MSTAT.EQ.2) THEN WRITE(MSTU(11),5500) WRITE(MSTU(11),5600) DO 140 KC=1,500 KF=KCHG(KC,4) CALL PYNAME(KF,CHKF) IOFF=0 IF(KC.LE.22) THEN IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1 ELSE IF(MWID(KC).LE.0) GOTO 140 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR. & KF/KSUSY1.EQ.2)) GOTO 140 ENDIF C...Off-shell branchings. IF(IOFF.EQ.1) THEN NGP=0 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10), & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0 DO 120 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 NGP1=0 IF(IABS(KFDP(IDC,1)).LE.20) NGP1= & (MOD(IABS(KFDP(IDC,1)),10)+1)/2 NGP2=0 IF(IABS(KFDP(IDC,2)).LE.20) NGP2= & (MOD(IABS(KFDP(IDC,2)),10)+1)/2 CALL PYNAME(KFDP(IDC,1),CHD1) CALL PYNAME(KFDP(IDC,2),CHD2) IF(KFDP(IDC,3).EQ.0) THEN IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND. & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10), & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0 ELSE CALL PYNAME(KFDP(IDC,3),CHD3) IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND. & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10), & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0 ENDIF 120 CONTINUE C...On-shell decays. ELSE CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE) BRFIN=1D0 IF(WDTE(0,0).LE.0D0) BRFIN=0D0 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0, & STATE(MDCY(KC,1)),BRFIN DO 130 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 NGP1=0 IF(IABS(KFDP(IDC,1)).LE.20) NGP1= & (MOD(IABS(KFDP(IDC,1)),10)+1)/2 NGP2=0 IF(IABS(KFDP(IDC,2)).LE.20) NGP2= & (MOD(IABS(KFDP(IDC,2)),10)+1)/2 BRPRI=0D0 IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0) BRFIN=0D0 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0) CALL PYNAME(KFDP(IDC,1),CHD1) CALL PYNAME(KFDP(IDC,2),CHD2) IF(KFDP(IDC,3).EQ.0) THEN IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1)) & WRITE(MSTU(11),5800) IDC,CHD1(1:10), & CHD2(1:10),WDTP(J),BRPRI, & STATE(MDME(IDC,1)),BRFIN ELSE CALL PYNAME(KFDP(IDC,3),CHD3) IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1)) & WRITE(MSTU(11),5900) IDC,CHD1(1:10), & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI, & STATE(MDME(IDC,1)),BRFIN ENDIF 130 CONTINUE ENDIF 140 CONTINUE WRITE(MSTU(11),6000) C...Allowed incoming partons/particles at hard interaction. ELSEIF(MSTAT.EQ.3) THEN WRITE(MSTU(11),6100) CALL PYNAME(MINT(11),CHAU) CHIN(1)=CHAU(1:12) CALL PYNAME(MINT(12),CHAU) CHIN(2)=CHAU(1:12) WRITE(MSTU(11),6200) CHIN(1),CHIN(2) DO 150 I=-20,22 IF(I.EQ.0) GOTO 150 IA=IABS(I) IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150 CALL PYNAME(I,CHAU) WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU, & STATE(KFIN(2,I)) 150 CONTINUE WRITE(MSTU(11),6400) C...User-defined limits on kinematical variables. ELSEIF(MSTAT.EQ.4) THEN WRITE(MSTU(11),6500) WRITE(MSTU(11),6600) SHRMAX=CKIN(2) IF(SHRMAX.LT.0D0) SHRMAX=VINT(1) WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX PTHMIN=MAX(CKIN(3),CKIN(5)) PTHMAX=CKIN(4) IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX WRITE(MSTU(11),6900) CHKIN(3),CKIN(6) DO 160 I=4,14 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I) 160 CONTINUE SPRMAX=CKIN(32) IF(SPRMAX.LT.0D0) SPRMAX=VINT(1) WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX WRITE(MSTU(11),7000) C...Status codes and parameter values. ELSEIF(MSTAT.EQ.5) THEN WRITE(MSTU(11),7100) WRITE(MSTU(11),7200) DO 170 I=1,100 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I), & PARP(100+I) 170 CONTINUE C...List of all processes implemented in the program. ELSEIF(MSTAT.EQ.6) THEN WRITE(MSTU(11),7400) WRITE(MSTU(11),7500) DO 180 I=1,500 IF(ISET(I).LT.0) GOTO 180 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2) 180 CONTINUE WRITE(MSTU(11),7700) ELSEIF(MSTAT.EQ.7) THEN WRITE (MSTU(11),8000) NMODES(0)=0 NMODES(10)=0 NMODES(9)=0 DO 290 ILR=1,2 DO 280 KFSM=1,16 KFSUSY=ILR*KSUSY1+KFSM NRVDC=0 C...SDOWN DECAYS IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN NRVDC=3 DO 190 I=1,NRVDC PBRAT(I)=0D0 NMODES(I)=0 190 CONTINUE CALL PYNAME(KFSUSY,CHTMP) CHD0=CHTMP//' ' CHDC(1)=DNAME(3) // ' + ' // DNAME(1) CHDC(2)=DNAME(2) // ' + ' // DNAME(1) CHDC(3)=DNAME(1) // ' + ' // DNAME(1) KC=PYCOMP(KFSUSY) DO 200 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 ID1=IABS(KFDP(IDC,1)) ID2=IABS(KFDP(IDC,2)) IF (KFDP(IDC,3).EQ.0) THEN IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN PBRAT(1)=PBRAT(1)+BRAT(IDC) NMODES(1)=NMODES(1)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN PBRAT(2)=PBRAT(2)+BRAT(IDC) NMODES(2)=NMODES(2)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN PBRAT(3)=PBRAT(3)+BRAT(IDC) NMODES(3)=NMODES(3)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ENDIF ENDIF 200 CONTINUE ENDIF C...SUP DECAYS IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN NRVDC=2 DO 210 I=1,NRVDC NMODES(I)=0 PBRAT(I)=0D0 210 CONTINUE CALL PYNAME(KFSUSY,CHTMP) CHD0=CHTMP//' ' CHDC(1)=DNAME(2) // ' + ' // DNAME(1) CHDC(2)=DNAME(1) // ' + ' // DNAME(1) KC=PYCOMP(KFSUSY) DO 220 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 ID1=IABS(KFDP(IDC,1)) ID2=IABS(KFDP(IDC,2)) IF (KFDP(IDC,3).EQ.0) THEN IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN PBRAT(1)=PBRAT(1)+BRAT(IDC) NMODES(1)=NMODES(1)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN PBRAT(2)=PBRAT(2)+BRAT(IDC) NMODES(2)=NMODES(2)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ENDIF ENDIF 220 CONTINUE ENDIF C...SLEPTON DECAYS IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN NRVDC=2 DO 230 I=1,NRVDC PBRAT(I)=0D0 NMODES(I)=0 230 CONTINUE CALL PYNAME(KFSUSY,CHTMP) CHD0=CHTMP//' ' CHDC(1)=DNAME(3) // ' + ' // DNAME(2) CHDC(2)=DNAME(1) // ' + ' // DNAME(1) KC=PYCOMP(KFSUSY) DO 240 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 ID1=IABS(KFDP(IDC,1)) ID2=IABS(KFDP(IDC,2)) IF (KFDP(IDC,3).EQ.0) THEN IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN PBRAT(1)=PBRAT(1)+BRAT(IDC) NMODES(1)=NMODES(1)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ENDIF IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN PBRAT(2)=PBRAT(2)+BRAT(IDC) NMODES(2)=NMODES(2)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ENDIF ENDIF 240 CONTINUE ENDIF C...SNEUTRINO DECAYS IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1) & THEN NRVDC=2 DO 250 I=1,NRVDC PBRAT(I)=0D0 NMODES(I)=0 250 CONTINUE CALL PYNAME(KFSUSY,CHTMP) CHD0=CHTMP//' ' CHDC(1)=DNAME(2) // ' + ' // DNAME(2) CHDC(2)=DNAME(1) // ' + ' // DNAME(1) KC=PYCOMP(KFSUSY) DO 260 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 ID1=IABS(KFDP(IDC,1)) ID2=IABS(KFDP(IDC,2)) IF (KFDP(IDC,3).EQ.0) THEN IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN PBRAT(1)=PBRAT(1)+BRAT(IDC) NMODES(1)=NMODES(1)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ENDIF IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN NMODES(2)=NMODES(2)+1 PBRAT(2)=PBRAT(2)+BRAT(IDC) IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ENDIF ENDIF 260 CONTINUE ENDIF IF (NRVDC.NE.0) THEN DO 270 I=1,NRVDC WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I) NMODES(0)=NMODES(0)+NMODES(I) 270 CONTINUE ENDIF 280 CONTINUE 290 CONTINUE DO 370 KFSM=21,37 KFSUSY=KSUSY1+KFSM NRVDC=0 C...NEUTRALINO DECAYS IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN NRVDC=4 DO 300 I=1,NRVDC PBRAT(I)=0D0 NMODES(I)=0 300 CONTINUE CALL PYNAME(KFSUSY,CHTMP) CHD0=CHTMP//' ' CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2) CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1) CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1) CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1) KC=PYCOMP(KFSUSY) DO 310 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 ID1=IABS(KFDP(IDC,1)) ID2=IABS(KFDP(IDC,2)) ID3=IABS(KFDP(IDC,3)) IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR & .ID3.EQ.13.OR.ID3.EQ.15)) THEN PBRAT(1)=PBRAT(1)+BRAT(IDC) NMODES(1)=NMODES(1)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN PBRAT(2)=PBRAT(2)+BRAT(IDC) NMODES(2)=NMODES(2)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN PBRAT(3)=PBRAT(3)+BRAT(IDC) NMODES(3)=NMODES(3)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN PBRAT(4)=PBRAT(4)+BRAT(IDC) NMODES(4)=NMODES(4)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ENDIF 310 CONTINUE ENDIF C...CHARGINO DECAYS IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN NRVDC=5 DO 320 I=1,NRVDC PBRAT(I)=0D0 NMODES(I)=0 320 CONTINUE CALL PYNAME(KFSUSY,CHTMP) CHD0=CHTMP//' ' CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2) CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2) CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1) CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1) CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1) KC=PYCOMP(KFSUSY) DO 330 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 ID1=IABS(KFDP(IDC,1)) ID2=IABS(KFDP(IDC,2)) ID3=IABS(KFDP(IDC,3)) IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR & .ID3.EQ.14.OR.ID3.EQ.16)) THEN PBRAT(1)=PBRAT(1)+BRAT(IDC) NMODES(1)=NMODES(1)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN PBRAT(1)=PBRAT(1)+BRAT(IDC) NMODES(1)=NMODES(1)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN PBRAT(2)=PBRAT(2)+BRAT(IDC) NMODES(2)=NMODES(2)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN PBRAT(3)=PBRAT(3)+BRAT(IDC) NMODES(3)=NMODES(3)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN PBRAT(3)=PBRAT(3)+BRAT(IDC) NMODES(3)=NMODES(3)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN PBRAT(4)=PBRAT(4)+BRAT(IDC) NMODES(4)=NMODES(4)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN PBRAT(4)=PBRAT(4)+BRAT(IDC) NMODES(4)=NMODES(4)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN PBRAT(5)=PBRAT(5)+BRAT(IDC) NMODES(5)=NMODES(5)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN PBRAT(5)=PBRAT(5)+BRAT(IDC) NMODES(5)=NMODES(5)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ENDIF 330 CONTINUE ENDIF C...GLUINO DECAYS IF (KFSM.EQ.21) THEN NRVDC=3 DO 340 I=1,NRVDC PBRAT(I)=0D0 NMODES(I)=0 340 CONTINUE CALL PYNAME(KFSUSY,CHTMP) CHD0=CHTMP//' ' CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1) CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1) CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1) KC=PYCOMP(KFSUSY) DO 350 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 ID1=IABS(KFDP(IDC,1)) ID2=IABS(KFDP(IDC,2)) ID3=IABS(KFDP(IDC,3)) IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR & .ID3.EQ.3.OR.ID3.EQ.5)) THEN PBRAT(1)=PBRAT(1)+BRAT(IDC) NMODES(1)=NMODES(1)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN PBRAT(2)=PBRAT(2)+BRAT(IDC) NMODES(2)=NMODES(2)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN PBRAT(3)=PBRAT(3)+BRAT(IDC) NMODES(3)=NMODES(3)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ENDIF 350 CONTINUE ENDIF IF (NRVDC.NE.0) THEN DO 360 I=1,NRVDC WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I) NMODES(0)=NMODES(0)+NMODES(I) 360 CONTINUE ENDIF 370 CONTINUE WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9) IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN WRITE (MSTU(11),8500) DO 400 IRV=1,3 DO 390 JRV=1,3 DO 380 KRV=1,3 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV) & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV) 380 CONTINUE 390 CONTINUE 400 CONTINUE WRITE (MSTU(11),8600) ENDIF ENDIF C...Formats for printouts. 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ', &'Events and Cross-sections',1X,9('*')) 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X, &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X, &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'), &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X, &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X, &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X, &'I',12X,'I') 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P, &D10.3,1X,'I') 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/ &1X,'I',34X,'I',28X,'I',12X,'I') 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')// &1X,'********* Total number of errors, excluding junctions =', &1X,I8,' *************'/ &1X,'********* Total number of errors, including junctions =', &1X,I8,' *************'/ &1X,'********* Total number of warnings = ', &1X,I8,' *************'/ &1X,'********* Fraction of events that fail fragmentation ', &'cuts =',1X,F8.5,' *********'/) 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ', &'Ratios',1X,27('*')) 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/ &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X, &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X, &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/ &1X,98('=')) 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X, &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X, &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I') 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X, &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X, &1P,D10.3,0P,1X,'I') 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X, &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X, &1P,D10.3,0P,1X,'I') 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('=')) 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/', &'Particles at Hard Interaction',1X,7('*')) 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X, &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X, &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X, &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X, &78('=')/1X,'I',38X,'I',37X,'I') 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I') 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('=')) 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ', &'Kinematical Variables',1X,12('*')) 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I') 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P, &16X,'I') 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A, &1X,'<',1X,1P,D10.3,0P,16X,'I') 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I') 7000 FORMAT(1X,'I',76X,'I'/1X,78('=')) 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ', &'Parameter Values',1X,12('*')) 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X, &'PARP(I)'/) 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3) 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes', &1X,13('*')) 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X, &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X, &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I') 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I') 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('=')) 8000 FORMAT(1X/ 1X/ & 17X,'Sums over R-Violating branching ratios',1X/ 1X & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X & ,'Mother --> Sum over final state flavours',4X,'I',2X & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I' & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I') 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/ & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I' & /1X,70('=')) 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X, & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I') 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I') 8500 FORMAT(1X/ 1X/ & 1X,'R-Violating couplings',1X/ 1X / & 1X,55('=')/ & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X & ,'I',15X,'I',15X,'I',15X,'I') 8600 FORMAT(1X,55('=')) 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I') RETURN END C********************************************************************* C...PYUPEV C...Administers the hard-process generation required for output to the C...Les Houches event record. SUBROUTINE PYUPEV C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYCTAG/NCT,MCT(4000,2) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT4/MWID(500),WIDS(500,5) SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/, &/PYINT1/,/PYINT2/,/PYINT4/ C...HEPEUP for output. INTEGER MAXNUP PARAMETER (MAXNUP=500) INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), &VTIMUP(MAXNUP),SPINUP(MAXNUP) SAVE /HEPEUP/ C...Stop if no subprocesses on. IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN WRITE(MSTU(11),5100) STOP ENDIF C...Special flags for hard-process generation only. MSTP71=MSTP(71) MSTP(71)=0 MST128=MSTP(128) MSTP(128)=1 C...Initial values for some counters. N=0 MINT(5)=MINT(5)+1 MINT(7)=0 MINT(8)=0 MINT(30)=0 MINT(83)=0 MINT(84)=MSTP(126) MSTU(24)=0 MSTU70=0 MSTJ14=MSTJ(14) C...Normally, use K(I,4:5) colour info rather than /PYCTAG/. MINT(33)=0 C...If variable energies: redo incoming kinematics and cross-section. MSTI(61)=0 IF(MSTP(171).EQ.1) THEN CALL PYINKI(1) IF(MSTI(61).EQ.1) THEN MINT(5)=MINT(5)-1 RETURN ENDIF IF(MINT(121).GT.1) CALL PYSAVE(3,1) CALL PYXTOT ENDIF C...Do not allow pileup events. MINT(82)=1 C...Generate variables of hard scattering. MINT(51)=0 MSTI(52)=0 100 CONTINUE IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1 MINT(31)=0 MINT(51)=0 MINT(57)=0 CALL PYRAND IF(MSTI(61).EQ.1) THEN MINT(5)=MINT(5)-1 RETURN ENDIF IF(MINT(51).EQ.2) RETURN ISUB=MINT(1) IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN C...Hard scattering (including low-pT): C...reconstruct kinematics and colour flow of hard scattering. MINT31=MINT(31) 110 MINT(31)=MINT31 MINT(51)=0 CALL PYSCAT IF(MINT(51).EQ.1) GOTO 100 IPU1=MINT(84)+1 IPU2=MINT(84)+2 C...Decay of final state resonances. MINT(32)=0 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95) & CALL PYRESD(0) IF(MINT(51).EQ.1) GOTO 100 MINT(52)=N C...Longitudinal boost of hard scattering. BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42)) CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ) ELSEIF(ISUB.NE.99) THEN C...Diffractive and elastic scattering. CALL PYDIFF ELSE C...DIS scattering (photon flux external). CALL PYDISG IF(MINT(51).EQ.1) GOTO 100 ENDIF C...Check that no odd resonance left undecayed. MINT(54)=N NFIX=N DO 120 I=MINT(84)+1,NFIX IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND. & K(I,2).NE.22) THEN KCA=PYCOMP(K(I,2)) IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN CALL PYRESD(I) IF(MINT(51).EQ.1) GOTO 100 ENDIF ENDIF 120 CONTINUE C...Boost hadronic subsystem to overall rest frame. C..(Only relevant when photon inside lepton beam.) IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA) C...Store event information and calculate Monte Carlo estimates of C...subprocess cross-sections. 130 CALL PYDOCU C...Transform to the desired coordinate frame. 140 CALL PYFRAM(MSTP(124)) MSTU(70)=MSTU70 PARU(21)=VINT(1) C...Restore special flags for hard-process generation only. MSTP(71)=MSTP71 MSTP(128)=MST128 C...Trace colour tags; convert to LHA style labels. NCT=100 DO 150 I=MINT(84)+1,N MCT(I,1)=0 MCT(I,2)=0 150 CONTINUE DO 160 I=MINT(84)+1,N KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2)) IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0) & THEN IMO=MOD(K(I,4)/MSTU(5),MSTU(5)) IDA=MOD(K(I,4),MSTU(5)) IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND. & MCT(IMO,2).NE.0) THEN MCT(I,1)=MCT(IMO,2) ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND. & MCT(IMO,1).NE.0) THEN MCT(I,1)=MCT(IMO,1) ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND. & MCT(IDA,2).NE.0) THEN MCT(I,1)=MCT(IDA,2) ELSE NCT=NCT+1 MCT(I,1)=NCT ENDIF ENDIF IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0) & THEN IMO=MOD(K(I,5)/MSTU(5),MSTU(5)) IDA=MOD(K(I,5),MSTU(5)) IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND. & MCT(IMO,1).NE.0) THEN MCT(I,2)=MCT(IMO,1) ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND. & MCT(IMO,2).NE.0) THEN MCT(I,2)=MCT(IMO,2) ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND. & MCT(IDA,1).NE.0) THEN MCT(I,2)=MCT(IDA,1) ELSE NCT=NCT+1 MCT(I,2)=NCT ENDIF ENDIF ENDIF 160 CONTINUE C...Put event in HEPEUP commonblock. NUP=N-MINT(84) IDPRUP=MINT(1) XWGTUP=1D0 SCALUP=VINT(53) AQEDUP=VINT(57) AQCDUP=VINT(58) DO 180 I=1,NUP IDUP(I)=K(I+MINT(84),2) IF(I.LE.2) THEN ISTUP(I)=-1 MOTHUP(1,I)=0 MOTHUP(2,I)=0 ELSEIF(K(I+4,3).EQ.0) THEN ISTUP(I)=1 MOTHUP(1,I)=1 MOTHUP(2,I)=2 ELSE ISTUP(I)=1 MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84) MOTHUP(2,I)=0 ENDIF IF(I.GE.3.AND.K(I+MINT(84),3).GT.0) & ISTUP(K(I+MINT(84),3)-MINT(84))=2 ICOLUP(1,I)=MCT(I+MINT(84),1) ICOLUP(2,I)=MCT(I+MINT(84),2) DO 170 J=1,5 PUP(J,I)=P(I+MINT(84),J) 170 CONTINUE VTIMUP(I)=V(I,5) SPINUP(I)=9D0 180 CONTINUE C...Optionally write out event to disk. Minimal size for time/spin fields. IF(MSTP(162).GT.0) THEN WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP DO 190 I=1,NUP IF(VTIMUP(I).EQ.0D0) THEN WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I), & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5), & ' 0. 9.' ELSE WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I), & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5), & VTIMUP(I),' 9.' ENDIF 190 CONTINUE C...Optional extra line with parton-density information. IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16), & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30) ENDIF C...Error messages and other print formats. 5100 FORMAT(1X,'Error: no subprocess switched on.'/ &1X,'Execution stopped.') 5200 FORMAT(1P,2I6,4E14.6) 5300 FORMAT(1P,I8,5I5,5E18.10,A6) 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3) 5500 FORMAT(1P,'#pdf ',2I5,5E18.10) RETURN END C********************************************************************* C...PYUPIN C...Fills the HEPRUP commonblock with info on incoming beams and allowed C...processes, and optionally stores that information on file. SUBROUTINE PYUPIN C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/ C...User process initialization commonblock. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) SAVE /HEPRUP/ C...Store info on incoming beams. IDBMUP(1)=K(1,2) IDBMUP(2)=K(2,2) EBMUP(1)=P(1,4) EBMUP(2)=P(2,4) PDFGUP(1)=0 PDFGUP(2)=0 PDFSUP(1)=MSTP(51) PDFSUP(2)=MSTP(51) C...Event weighting strategy. IDWTUP=3 C...Info on individual processes. NPRUP=0 DO 100 ISUB=1,500 IF(MSUB(ISUB).EQ.1) THEN NPRUP=NPRUP+1 XSECUP(NPRUP)=1D9*XSEC(ISUB,3) XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3)))) XMAXUP(NPRUP)=1D0 LPRUP(NPRUP)=ISUB ENDIF 100 CONTINUE C...Write info to file. IF(MSTP(161).GT.0) THEN WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2), & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP DO 110 IPR=1,NPRUP WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR), & LPRUP(IPR) 110 CONTINUE ENDIF C...Formats for printout. 5100 FORMAT(1P,2I8,2E14.6,6I6) 5200 FORMAT(1P,3E14.6,I6) RETURN END C********************************************************************* C...Combine the two old-style Pythia initialization and event files C...into a single Les Houches Event File. SUBROUTINE PYLHEF C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...PYTHIA commonblock: only used to provide read/write units and version. COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) SAVE /PYPARS/ C...User process initialization commonblock. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) SAVE /HEPRUP/ C...User process event common block. INTEGER MAXNUP PARAMETER (MAXNUP=500) INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), &VTIMUP(MAXNUP),SPINUP(MAXNUP) SAVE /HEPEUP/ C...Lines to read in assumed never longer than 200 characters. PARAMETER (MAXLEN=200) CHARACTER*(MAXLEN) STRING C...Format for reading lines. CHARACTER*6 STRFMT STRFMT='(A000)' WRITE(STRFMT(3:5),'(I3)') MAXLEN C...Rewind initialization and event files. REWIND MSTP(161) REWIND MSTP(162) C...Write header info. WRITE(MSTP(163),'(A)') '' 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) CALL PYSTOP(101) ENDIF PMAS(35,1)=SQRT(SQMHP) PMAS(36,1)=SQRT(SQMA) PMAS(37,1)=SQRT(SQMHC) ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)* & (SQMA-SQMZ))) BESU=ATAN(TANBE) PARU(142)=1D0 PARU(143)=1D0 PARU(161)=-SIN(ALSU)/COS(BESU) PARU(162)=COS(ALSU)/SIN(BESU) PARU(163)=PARU(161) PARU(164)=SIN(BESU-ALSU) PARU(165)=PARU(164) PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW PARU(171)=COS(ALSU)/COS(BESU) PARU(172)=SIN(ALSU)/SIN(BESU) PARU(173)=PARU(171) PARU(174)=COS(BESU-ALSU) PARU(175)=PARU(174) PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)* & SIN(BESU+ALSU) PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU) PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW PARU(181)=TANBE PARU(182)=1D0/TANBE PARU(183)=PARU(181) PARU(184)=0D0 PARU(185)=PARU(184) PARU(186)=COS(BESU-ALSU) PARU(187)=SIN(BESU-ALSU) PARU(188)=PARU(186) PARU(189)=PARU(187) PARU(190)=0D0 PARU(195)=COS(BESU-ALSU) ENDIF C...Reset effective widths of gauge bosons. DO 110 I=1,500 DO 100 J=1,5 WIDS(I,J)=1D0 100 CONTINUE 110 CONTINUE C...Order resonances by increasing mass (except Z0 and W+/-). NRES=0 DO 140 KC=1,500 KF=KCHG(KC,4) IF(KF.EQ.0) GOTO 140 IF(MWID(KC).EQ.0) GOTO 140 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN IF(MSTP(1).LE.3) GOTO 140 ENDIF IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN IF(IMSS(1).LE.0) GOTO 140 ENDIF NRES=NRES+1 PMRES=PMAS(KC,1) IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0 DO 120 I1=NRES-1,1,-1 IF(PMRES.GE.PMORD(I1)) GOTO 130 KCORD(I1+1)=KCORD(I1) PMORD(I1+1)=PMORD(I1) 120 CONTINUE 130 KCORD(I1+1)=KC PMORD(I1+1)=PMRES 140 CONTINUE C...Loop over possible resonances. DO 180 I=1,NRES KC=KCORD(I) KF=KCHG(KC,4) C...Check that no fourth generation channels on by mistake. IF(MSTP(1).LE.3) THEN DO 150 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 KFA1=IABS(KFDP(IDC,1)) KFA2=IABS(KFDP(IDC,2)) IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR. & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18) & MDME(IDC,1)=-1 150 CONTINUE ENDIF C...Check that no supersymmetric channels on by mistake. IF(IMSS(1).LE.0) THEN DO 160 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 KFA1S=IABS(KFDP(IDC,1))/KSUSY1 KFA2S=IABS(KFDP(IDC,2))/KSUSY1 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2) & MDME(IDC,1)=-1 160 CONTINUE ENDIF C...Find mass and evaluate width. PMR=PMAS(KC,1) IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1 IF(MWID(KC).EQ.3) MINT(63)=1 CALL PYWIDT(KF,PMR**2,WDTP,WDTE) MINT(51)=0 C...Evaluate suppression factors due to non-simulated channels. IF(KCHG(KC,3).EQ.0) THEN WDTP0I=0D0 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0) WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+ & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+ & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I WIDS(KC,3)=0D0 WIDS(KC,4)=0D0 WIDS(KC,5)=0D0 ELSE IF(MWID(KC).EQ.3) MINT(63)=1 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM) MINT(51)=0 WDTP0I=0D0 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0) WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+ & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+ & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+ & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+ & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+ & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+ & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+ & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2 ENDIF C...Set resonance widths and branching ratios; C...also on/off switch for decays. IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN PMAS(KC,2)=WDTP(0) PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2)) IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41) DO 170 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 BRAT(IDC)=0D0 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0) 170 CONTINUE ENDIF 180 CONTINUE C...Flavours of leptoquark: redefine charge and name. KFLQQ=KFDP(MDCY(42,2),1) KFLQL=KFDP(MDCY(42,2),2) KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+ &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL) LL=1 IF(IABS(KFLQL).EQ.13) LL=2 IF(IABS(KFLQL).EQ.15) LL=3 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)// &CHAF(IABS(KFLQL),1)(1:LL)//' ' CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar ' C...Special cases in treatment of gamma*/Z0: redefine process name. IF(MSTP(43).EQ.1) THEN PROC(1)='f + fbar -> gamma*' PROC(15)='f + fbar -> g + gamma*' PROC(19)='f + fbar -> gamma + gamma*' PROC(30)='f + g -> f + gamma*' PROC(35)='f + gamma -> f + gamma*' ELSEIF(MSTP(43).EQ.2) THEN PROC(1)='f + fbar -> Z0' PROC(15)='f + fbar -> g + Z0' PROC(19)='f + fbar -> gamma + Z0' PROC(30)='f + g -> f + Z0' PROC(35)='f + gamma -> f + Z0' ELSEIF(MSTP(43).EQ.3) THEN PROC(1)='f + fbar -> gamma*/Z0' PROC(15)='f + fbar -> g + gamma*/Z0' PROC(19)='f+ fbar -> gamma + gamma*/Z0' PROC(30)='f + g -> f + gamma*/Z0' PROC(35)='f + gamma -> f + gamma*/Z0' ENDIF C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name. IF(MSTP(44).EQ.1) THEN PROC(141)='f + fbar -> gamma*' ELSEIF(MSTP(44).EQ.2) THEN PROC(141)='f + fbar -> Z0' ELSEIF(MSTP(44).EQ.3) THEN PROC(141)='f + fbar -> Z''0' ELSEIF(MSTP(44).EQ.4) THEN PROC(141)='f + fbar -> gamma*/Z0' ELSEIF(MSTP(44).EQ.5) THEN PROC(141)='f + fbar -> gamma*/Z''0' ELSEIF(MSTP(44).EQ.6) THEN PROC(141)='f + fbar -> Z0/Z''0' ELSEIF(MSTP(44).EQ.7) THEN PROC(141)='f + fbar -> gamma*/Z0/Z''0' ENDIF C...Special cases in treatment of WW -> WW: redefine process name. IF(MSTP(45).EQ.1) THEN PROC(77)='W+ + W+ -> W+ + W+' ELSEIF(MSTP(45).EQ.2) THEN PROC(77)='W+ + W- -> W+ + W-' ELSEIF(MSTP(45).EQ.3) THEN PROC(77)='W+/- + W+/- -> W+/- + W+/-' ENDIF C...Format for error information. 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ', &'combination'/1X,'Execution stopped!') RETURN END C********************************************************************* C...PYINBM C...Identifies the two incoming particles and the choice of frame. SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...User process initialization commonblock. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) SAVE /HEPRUP/ C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/ C...Local arrays, character variables and data. CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26, &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16 DIMENSION LEN(3),KCDE(39),PM(2) DATA CHALP/'abcdefghijklmnopqrstuvwxyz', &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ DATA CHCDE/ 'e- ','e+ ','nu_e ', &'nu_ebar ','mu- ','mu+ ','nu_mu ', &'nu_mubar ','tau- ','tau+ ','nu_tau ', &'nu_taubar ','pi+ ','pi- ','n0 ', &'nbar0 ','p+ ','pbar- ','gamma ', &'lambda0 ','sigma- ','sigma0 ','sigma+ ', &'xi- ','xi0 ','omega- ','pi0 ', &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ', &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ', &'k+ ','k- ','ks0 ','kl0 '/ DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16, &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222, &3312,3322,3334,111,110,990,6*22,321,-321,310,130/ C...Store initial energy. Default frame. VINT(290)=WIN MINT(111)=0 C...Special user process initialization; convert to normal input. IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN MINT(111)=11 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12 CALL PYNAME(IDBMUP(1),CHNAME) CHBEAM=CHNAME(1:12) CALL PYNAME(IDBMUP(2),CHNAME) CHTARG=CHNAME(1:12) ENDIF C...Convert character variables to lowercase and find their length. CHCOM(1)=CHFRAM CHCOM(2)=CHBEAM CHCOM(3)=CHTARG DO 130 I=1,3 LEN(I)=12 DO 110 LL=12,1,-1 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1 DO 100 LA=1,26 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)= & CHALP(1)(LA:LA) 100 CONTINUE 110 CONTINUE CHIDNT(I)=CHCOM(I) C...Fix up bar, underscore and charge in particle name (if needed). DO 120 LL=1,10 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN CHTEMP=CHIDNT(I) CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' ' ENDIF 120 CONTINUE IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN CHTEMP=CHIDNT(I) CHIDNT(I)='nu_'//CHTEMP(3:7) ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN CHIDNT(I)(1:3)='n0 ' ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN CHIDNT(I)(1:5)='nbar0' ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN CHIDNT(I)(1:3)='p+ ' ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR. & CHIDNT(I)(1:2).EQ.'p-') THEN CHIDNT(I)(1:5)='pbar-' ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN CHIDNT(I)(7:7)='0' ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN CHIDNT(I)(1:7)='reggeon' ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN CHIDNT(I)(1:7)='pomeron' ENDIF 130 CONTINUE C...Identify free initialization. IF(CHCOM(1)(1:2).EQ.'no') THEN MINT(65)=1 RETURN ENDIF C...Identify incoming beam and target particles. DO 160 I=1,2 DO 140 J=1,39 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J) 140 CONTINUE PM(I)=PYMASS(MINT(10+I)) VINT(2+I)=PM(I) MINT(140+I)=0 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN CHTEMP=CHIDNT(I+1)(7:12)//' ' DO 150 J=1,12 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J) 150 CONTINUE PM(I)=PYMASS(MINT(140+I)) VINT(302+I)=PM(I) ENDIF 160 CONTINUE IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2)) IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3)) IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7) C...Identify choice of frame and input energies. CHINIT=' ' C...Events defined in the CM frame. IF(CHCOM(1)(1:2).EQ.'cm') THEN MINT(111)=1 S=WIN**2 IF(MSTP(122).GE.1) THEN IF(CHCOM(2)(1:1).NE.'e') THEN LOFFS=(31-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' collider'//' ' ELSE LOFFS=(30-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' collider'//' ' ENDIF WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),5300) WIN ENDIF C...Events defined in fixed target frame. ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN MINT(111)=2 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2) IF(MSTP(122).GE.1) THEN LOFFS=(29-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' fixed target'//' ' WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),5400) WIN WRITE(MSTU(11),5500) SQRT(S) ENDIF C...Frame defined by user three-vectors. ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN MINT(111)=3 P(1,5)=PM(1) P(2,5)=PM(2) P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2) P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2) S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2- & (P(1,3)+P(2,3))**2 IF(MSTP(122).GE.1) THEN LOFFS=(22-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' user configuration'//' ' WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),5600) WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4) WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4) WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) ENDIF C...Frame defined by user four-vectors. ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN MINT(111)=4 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1) PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2) S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2- & (P(1,3)+P(2,3))**2 IF(MSTP(122).GE.1) THEN LOFFS=(22-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' user configuration'//' ' WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),5600) WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4) WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4) WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) ENDIF C...Frame defined by user five-vectors. ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN MINT(111)=5 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2- & (P(1,3)+P(2,3))**2 IF(MSTP(122).GE.1) THEN LOFFS=(22-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' user configuration'//' ' WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),5600) WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4) WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4) WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) ENDIF C...Frame defined by HEPRUP common block. ELSEIF(MINT(111).GE.11) THEN S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))- & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2 IF(MSTP(122).GE.1) THEN LOFFS=(22-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' user configuration'//' ' WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2) WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) ENDIF C...Unknown frame. Error for too low CM energy. ELSE WRITE(MSTU(11),5800) CHFRAM(1:LEN(1)) CALL PYSTOP(7) ENDIF IF(S.LT.PARP(2)**2) THEN WRITE(MSTU(11),5900) SQRT(S) CALL PYSTOP(7) ENDIF C...Formats for initialization and error information. 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/ &1X,'Execution stopped!') 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/ &1X,'Execution stopped!') 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I') 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy', &19X,'I'/1X,'I',76X,'I'/1X,78('=')) 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I') 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X, &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('=')) 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X, &'pz (GeV/c)',6X,'E (GeV)',9X,'I') 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I') 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/ &1X,'Execution stopped!') 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ', &'generation.'/1X,'Execution stopped!') 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X, &'GeV beam energies',13X,'I') RETURN END C********************************************************************* C...PYINKI C...Sets up kinematics, including rotations and boosts to/from CM frame. SUBROUTINE PYINKI(MODKI) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...User process initialization commonblock. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) SAVE /HEPRUP/ C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/ C...Set initial flavour state. N=2 DO 100 I=1,2 K(I,1)=1 K(I,2)=MINT(10+I) IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I) 100 CONTINUE C...Reset boost. Do kinematics for various cases. DO 110 J=6,10 VINT(J)=0D0 110 CONTINUE C...Set up kinematics for events defined in CM frame. IF(MINT(111).EQ.1) THEN WIN=VINT(290) IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290) S=WIN**2 P(1,5)=VINT(3) P(2,5)=VINT(4) IF(MINT(141).NE.0) P(1,5)=VINT(303) IF(MINT(142).NE.0) P(2,5)=VINT(304) P(1,1)=0D0 P(1,2)=0D0 P(2,1)=0D0 P(2,2)=0D0 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/ & (4D0*S)) P(2,3)=-P(1,3) P(1,4)=SQRT(P(1,3)**2+P(1,5)**2) P(2,4)=SQRT(P(2,3)**2+P(2,5)**2) C...Set up kinematics for fixed target events. ELSEIF(MINT(111).EQ.2) THEN WIN=VINT(290) IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290) P(1,5)=VINT(3) P(2,5)=VINT(4) IF(MINT(141).NE.0) P(1,5)=VINT(303) IF(MINT(142).NE.0) P(2,5)=VINT(304) P(1,1)=0D0 P(1,2)=0D0 P(2,1)=0D0 P(2,2)=0D0 P(1,3)=WIN P(1,4)=SQRT(P(1,3)**2+P(1,5)**2) P(2,3)=0D0 P(2,4)=P(2,5) S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4) VINT(10)=P(1,3)/(P(1,4)+P(2,4)) CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10)) C...Set up kinematics for events in user-defined frame. ELSEIF(MINT(111).EQ.3) THEN P(1,5)=VINT(3) P(2,5)=VINT(4) IF(MINT(141).NE.0) P(1,5)=VINT(303) IF(MINT(142).NE.0) P(2,5)=VINT(304) P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2) P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2) DO 120 J=1,3 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4)) 120 CONTINUE CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) VINT(7)=PYANGL(P(1,1),P(1,2)) CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) VINT(6)=PYANGL(P(1,3),P(1,1)) CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3)) C...Set up kinematics for events with user-defined four-vectors. ELSEIF(MINT(111).EQ.4) THEN PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1) PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2) DO 130 J=1,3 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4)) 130 CONTINUE CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) VINT(7)=PYANGL(P(1,1),P(1,2)) CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) VINT(6)=PYANGL(P(1,3),P(1,1)) CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) S=(P(1,4)+P(2,4))**2 C...Set up kinematics for events with user-defined five-vectors. ELSEIF(MINT(111).EQ.5) THEN DO 140 J=1,3 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4)) 140 CONTINUE CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) VINT(7)=PYANGL(P(1,1),P(1,2)) CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) VINT(6)=PYANGL(P(1,3),P(1,1)) CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) S=(P(1,4)+P(2,4))**2 C...Set up kinematics for events with external user processes. ELSEIF(MINT(111).GE.11) THEN P(1,5)=VINT(3) P(2,5)=VINT(4) IF(MINT(141).NE.0) P(1,5)=VINT(303) IF(MINT(142).NE.0) P(2,5)=VINT(304) P(1,1)=0D0 P(1,2)=0D0 P(2,1)=0D0 P(2,2)=0D0 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2)) P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2)) P(1,4)=EBMUP(1) P(2,4)=EBMUP(2) VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4)) CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10)) S=(P(1,4)+P(2,4))**2 ENDIF C...Return or error for too low CM energy. IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN IF(MSTP(172).LE.1) THEN CALL PYERRM(23, & '(PYINKI:) too low invariant mass in this event') ELSE MSTI(61)=1 RETURN ENDIF ENDIF C...Save information on incoming particles. VINT(1)=SQRT(S) VINT(2)=S IF(MINT(111).GE.4) THEN IF(MINT(141).EQ.0) THEN VINT(3)=P(1,5) IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2 ELSE VINT(303)=P(1,5) ENDIF IF(MINT(142).EQ.0) THEN VINT(4)=P(2,5) IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2 ELSE VINT(304)=P(2,5) ENDIF ENDIF VINT(5)=P(1,3) IF(MODKI.EQ.0) VINT(289)=S DO 150 J=1,5 V(1,J)=0D0 V(2,J)=0D0 VINT(290+J)=P(1,J) VINT(295+J)=P(2,J) 150 CONTINUE C...Store pT cut-off and related constants to be used in generation. IF(MODKI.EQ.0) VINT(285)=CKIN(3) IF(MSTP(82).LE.1) THEN PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90) ELSE PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) ENDIF VINT(149)=4D0*PTMN**2/S VINT(154)=PTMN RETURN END C********************************************************************* C...PYINPR C...Selects partonic subprocesses to be included in the simulation. SUBROUTINE PYINPR C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...User process initialization commonblock. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) SAVE /HEPRUP/ C...Commonblocks and character variables. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT6/PROC(0:500) CHARACTER PROC*28 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/, &/PYINT6/ CHARACTER CHIPR*10 C...Reset processes to be included. IF(MSEL.NE.0) THEN DO 100 I=1,500 MSUB(I)=0 100 CONTINUE ENDIF C...Set running pTmin scale. IF(MSTP(82).LE.1) THEN PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90) ELSE PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) ENDIF C...Begin by assuming incoming photon to enter subprocess. IF(MINT(11).EQ.22) MINT(15)=22 IF(MINT(12).EQ.22) MINT(16)=22 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous. IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN MSUB(10)=1 MINT(123)=MINT(122)+1 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30 C...allow mixture. C...Here also set a few parameters otherwise normally not touched. ELSEIF(MINT(121).GT.1) THEN C...Parton distributions dampened at small Q2; go to low energies, C...alpha_s <1; no minimum pT cut-off a priori. IF(MSTP(18).EQ.2) THEN MSTP(57)=3 PARP(2)=2D0 PARU(115)=1D0 CKIN(5)=0.2D0 CKIN(6)=0.2D0 ENDIF C...Define pT cut-off parameters and whether run involves low-pT. PTMVMD=PTMRUN VINT(154)=PTMVMD PTMDIR=PTMVMD IF(MSTP(18).EQ.2) PTMDIR=PARP(15) PTMANO=PTMVMD IF(MSTP(15).EQ.5) PTMANO=0.60D0+ & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2 IPTL=1 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0 IF(MSEL.EQ.2) IPTL=1 C...Set up for p/gamma * gamma; real or virtual photons. IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND. & MSTP(14).EQ.30)) THEN C...Set up for p/VMD * VMD. IF(MINT(122).EQ.1) THEN MINT(123)=2 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 C...Set up for p/VMD * direct gamma. ELSEIF(MINT(122).EQ.2) THEN MINT(123)=0 IF(MINT(121).EQ.6) MINT(123)=5 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for p/VMD * anomalous gamma. ELSEIF(MINT(122).EQ.3) THEN MINT(123)=3 IF(MINT(121).EQ.6) MINT(123)=7 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 C...Set up for DIS * p. ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR. & IABS(MINT(12)).GT.100)) THEN MINT(123)=8 IF(IPTL.EQ.1) MSUB(99)=1 C...Set up for direct * direct gamma (switch off leptons). ELSEIF(MINT(122).EQ.4) THEN MINT(123)=0 MSUB(137)=1 MSUB(138)=1 MSUB(139)=1 MSUB(140)=1 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) 110 CONTINUE IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for direct * anomalous gamma. ELSEIF(MINT(122).EQ.5) THEN MINT(123)=6 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMANO C...Set up for anomalous * anomalous gamma. ELSEIF(MINT(122).EQ.6) THEN MINT(123)=3 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 ENDIF C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom. ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN C...Set up for direct * direct gamma (switch off leptons). IF(MINT(122).EQ.1) THEN MINT(123)=0 MSUB(137)=1 MSUB(138)=1 MSUB(139)=1 MSUB(140)=1 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) 120 CONTINUE IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for direct * VMD and VMD * direct gamma. ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN MINT(123)=5 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for direct * anomalous and anomalous * direct gamma. ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN MINT(123)=6 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMANO C...Set up for VMD*VMD. ELSEIF(MINT(122).EQ.5) THEN MINT(123)=2 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 C...Set up for VMD * anomalous and anomalous * VMD gamma. ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN MINT(123)=7 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 C...Set up for anomalous * anomalous gamma. ELSEIF(MINT(122).EQ.9) THEN MINT(123)=3 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 C...Set up for DIS * VMD and VMD * DIS gamma. ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN MINT(123)=8 IF(IPTL.EQ.1) MSUB(99)=1 C...Set up for DIS * anomalous and anomalous * DIS gamma. ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN MINT(123)=9 IF(IPTL.EQ.1) MSUB(99)=1 ENDIF C...Set up for gamma* * p; virtual photons = dir, res. ELSEIF(MINT(121).EQ.2) THEN C...Set up for direct * p. IF(MINT(122).EQ.1) THEN MINT(123)=0 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for resolved * p. ELSEIF(MINT(122).EQ.2) THEN MINT(123)=1 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 ENDIF C...Set up for gamma* * gamma*; virtual photons = dir, res. ELSEIF(MINT(121).EQ.4) THEN C...Set up for direct * direct gamma (switch off leptons). IF(MINT(122).EQ.1) THEN MINT(123)=0 MSUB(137)=1 MSUB(138)=1 MSUB(139)=1 MSUB(140)=1 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) 130 CONTINUE IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for direct * resolved and resolved * direct gamma. ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN MINT(123)=5 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for resolved * resolved gamma. ELSEIF(MINT(122).EQ.4) THEN MINT(123)=2 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 ENDIF C...End of special set up for gamma-p and gamma-gamma. ENDIF CKIN(1)=2D0*CKIN(3) ENDIF C...Flavour information for individual beams. DO 140 I=1,2 MINT(40+I)=1 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2 MINT(44+I)=MINT(40+I) IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR. & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3 140 CONTINUE C...If two real gammas, whereof one direct, pick the first. C...For two virtual photons, keep requested order. IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN MINT(41)=1 MINT(45)=1 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR. & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN MINT(41)=1 MINT(45)=1 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR. & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN MINT(42)=1 MINT(46)=1 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN MINT(41)=1 MINT(45)=1 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN MINT(42)=1 MINT(46)=1 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN MINT(41)=1 MINT(45)=1 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN MINT(42)=1 MINT(46)=1 ENDIF ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN IF(MINT(11).EQ.22) THEN MINT(41)=1 MINT(45)=1 ELSE MINT(42)=1 MINT(46)=1 ENDIF ENDIF IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26, & '(PYINPR:) unallowed MSTP(14) code for single photon') ENDIF C...Flavour information on combination of incoming particles. MINT(43)=2*MINT(41)+MINT(42)-2 MINT(44)=MINT(43) IF(MINT(123).LE.0) THEN IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1 ELSEIF(MINT(123).LE.3) THEN IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN MINT(43)=4 MINT(44)=1 ENDIF MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7 MINT(50)=0 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1 MINT(107)=0 MINT(108)=0 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12) & MINT(107)=2 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13) & MINT(107)=3 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR. & MINT(122).EQ.10) MINT(108)=2 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR. & MINT(122).EQ.11) MINT(108)=3 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN IF(MINT(122).GE.3) MINT(107)=1 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1 ELSEIF(MINT(121).EQ.2) THEN IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1 ELSE IF(MINT(11).EQ.22) THEN MINT(107)=MINT(123) IF(MINT(123).GE.4) MINT(107)=0 IF(MINT(123).EQ.7) MINT(107)=2 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4 IF(MSTP(14).EQ.28) MINT(107)=2 IF(MSTP(14).EQ.29) MINT(107)=3 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4) & MINT(107)=4 ENDIF IF(MINT(12).EQ.22) THEN MINT(108)=MINT(123) IF(MINT(123).GE.4) MINT(108)=MINT(123)-3 IF(MINT(123).EQ.7) MINT(108)=3 IF(MSTP(14).EQ.26) MINT(108)=2 IF(MSTP(14).EQ.27) MINT(108)=3 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4) & MINT(108)=4 ENDIF IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR. & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN MINTTP=MINT(107) MINT(107)=MINT(108) MINT(108)=MINTTP ENDIF ENDIF IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0 C...Select default processes according to incoming beams C...(already done for gamma-p and gamma-gamma with C...MSTP(14) = 10, 20, 25 or 30). IF(MINT(121).GT.1) THEN ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN IF(MINT(43).EQ.1) THEN C...Lepton + lepton -> gamma/Z0 or W. IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND. & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN C...Unresolved photon + lepton: Compton scattering. MSUB(133)=1 MSUB(134)=1 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22 & .OR.MINT(12).EQ.22)) THEN C...DIS as pure gamma* + f -> f process. MSUB(99)=1 ELSEIF(MINT(43).LE.3) THEN C...Lepton + hadron: deep inelastic scattering. MSUB(10)=1 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND. & MINT(12).EQ.22) THEN C...Two unresolved photons: fermion pair production, C...exclude lepton pairs. DO 150 ISUB=137,140 MSUB(ISUB)=1 150 CONTINUE DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) 160 CONTINUE PTMDIR=PTMRUN IF(MSTP(18).EQ.2) PTMDIR=PARP(15) IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR CKIN(1)=MAX(CKIN(1),2D0*CKIN(3)) ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22)) & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND. & MINT(12).EQ.22)) THEN C...Unresolved photon + hadron: photon-parton scattering. DO 170 ISUB=131,136 MSUB(ISUB)=1 170 CONTINUE ELSEIF(MSEL.EQ.1) THEN C...High-pT QCD processes: MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 PTMN=PTMRUN VINT(154)=PTMN IF(CKIN(3).LT.PTMN) MSUB(95)=1 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0 ELSE C...All QCD processes: MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 MSUB(95)=1 ENDIF ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN C...Heavy quark production. MSUB(81)=1 MSUB(82)=1 MSUB(84)=1 DO 180 J=1,MIN(8,MDCY(21,3)) MDME(MDCY(21,2)+J-1,1)=0 180 CONTINUE MDME(MDCY(21,2)+MSEL-1,1)=1 MSUB(85)=1 DO 190 J=1,MIN(12,MDCY(22,3)) MDME(MDCY(22,2)+J-1,1)=0 190 CONTINUE MDME(MDCY(22,2)+MSEL-1,1)=1 ELSEIF(MSEL.EQ.10) THEN C...Prompt photon production: MSUB(14)=1 MSUB(18)=1 MSUB(29)=1 ELSEIF(MSEL.EQ.11) THEN C...Z0/gamma* production: MSUB(1)=1 ELSEIF(MSEL.EQ.12) THEN C...W+/- production: MSUB(2)=1 ELSEIF(MSEL.EQ.13) THEN C...Z0 + jet: MSUB(15)=1 MSUB(30)=1 ELSEIF(MSEL.EQ.14) THEN C...W+/- + jet: MSUB(16)=1 MSUB(31)=1 ELSEIF(MSEL.EQ.15) THEN C...Z0 & W+/- pair production: MSUB(19)=1 MSUB(20)=1 MSUB(22)=1 MSUB(23)=1 MSUB(25)=1 ELSEIF(MSEL.EQ.16) THEN C...h0 production: MSUB(3)=1 MSUB(102)=1 MSUB(103)=1 MSUB(123)=1 MSUB(124)=1 ELSEIF(MSEL.EQ.17) THEN C...h0 & Z0 or W+/- pair production: MSUB(24)=1 MSUB(26)=1 ELSEIF(MSEL.EQ.18) THEN C...h0 production; interesting processes in e+e-. MSUB(24)=1 MSUB(103)=1 MSUB(123)=1 MSUB(124)=1 ELSEIF(MSEL.EQ.19) THEN C...h0, H0 and A0 production; interesting processes in e+e-. MSUB(24)=1 MSUB(103)=1 MSUB(123)=1 MSUB(124)=1 MSUB(153)=1 MSUB(171)=1 MSUB(173)=1 MSUB(174)=1 MSUB(158)=1 MSUB(176)=1 MSUB(178)=1 MSUB(179)=1 ELSEIF(MSEL.EQ.21) THEN C...Z'0 production: MSUB(141)=1 ELSEIF(MSEL.EQ.22) THEN C...W'+/- production: MSUB(142)=1 ELSEIF(MSEL.EQ.23) THEN C...H+/- production: MSUB(143)=1 ELSEIF(MSEL.EQ.24) THEN C...R production: MSUB(144)=1 ELSEIF(MSEL.EQ.25) THEN C...LQ (leptoquark) production. MSUB(145)=1 MSUB(162)=1 MSUB(163)=1 MSUB(164)=1 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN C...Production of one heavy quark (W exchange): MSUB(83)=1 DO 200 J=1,MIN(8,MDCY(21,3)) MDME(MDCY(21,2)+J-1,1)=0 200 CONTINUE MDME(MDCY(21,2)+MSEL-31,1)=1 CMRENNA++Define SUSY alternatives. ELSEIF(MSEL.EQ.39) THEN C...Turn on all SUSY processes. IF(MINT(43).EQ.4) THEN C...Hadron-hadron processes. DO 210 I=201,301 IF(ISET(I).GE.0) MSUB(I)=1 210 CONTINUE ELSEIF(MINT(43).EQ.1) THEN C...Lepton-lepton processes: QED production of squarks. DO 220 I=201,214 MSUB(I)=1 220 CONTINUE MSUB(210)=0 MSUB(211)=0 MSUB(212)=0 DO 230 I=216,228 MSUB(I)=1 230 CONTINUE DO 240 I=261,263 MSUB(I)=1 240 CONTINUE MSUB(277)=1 MSUB(278)=1 ENDIF ELSEIF(MSEL.EQ.40) THEN C...Gluinos and squarks. IF(MINT(43).EQ.4) THEN MSUB(243)=1 MSUB(244)=1 MSUB(258)=1 MSUB(259)=1 MSUB(261)=1 MSUB(262)=1 MSUB(264)=1 MSUB(265)=1 DO 250 I=271,296 MSUB(I)=1 250 CONTINUE ELSEIF(MINT(43).EQ.1) THEN MSUB(277)=1 MSUB(278)=1 ENDIF ELSEIF(MSEL.EQ.41) THEN C...Stop production. MSUB(261)=1 MSUB(262)=1 MSUB(263)=1 IF(MINT(43).EQ.4) THEN MSUB(264)=1 MSUB(265)=1 ENDIF ELSEIF(MSEL.EQ.42) THEN C...Slepton production. DO 260 I=201,214 MSUB(I)=1 260 CONTINUE IF(MINT(43).NE.4) THEN MSUB(210)=0 MSUB(211)=0 MSUB(212)=0 ENDIF ELSEIF(MSEL.EQ.43) THEN C...Neutralino/Chargino + Gluino/Squark. IF(MINT(43).EQ.4) THEN DO 270 I=237,242 MSUB(I)=1 270 CONTINUE DO 280 I=246,254 MSUB(I)=1 280 CONTINUE MSUB(256)=1 ENDIF ELSEIF(MSEL.EQ.44) THEN C...Neutralino/Chargino pair production. IF(MINT(43).EQ.4) THEN DO 290 I=216,236 MSUB(I)=1 290 CONTINUE ELSEIF(MINT(43).EQ.1) THEN DO 300 I=216,228 MSUB(I)=1 300 CONTINUE ENDIF ELSEIF(MSEL.EQ.45) THEN C...Sbottom production. MSUB(287)=1 MSUB(288)=1 IF(MINT(43).EQ.4) THEN DO 310 I=281,296 MSUB(I)=1 310 CONTINUE ENDIF ELSEIF(MSEL.EQ.50) THEN C...Pair production of technipions and gauge bosons. DO 320 I=361,368 MSUB(I)=1 320 CONTINUE IF(MINT(43).EQ.4) THEN DO 330 I=370,377 MSUB(I)=1 330 CONTINUE ENDIF ELSEIF(MSEL.EQ.51) THEN C...QCD 2 -> 2 processes with compositeness/technicolor modifications. DO 340 I=381,386 MSUB(I)=1 340 CONTINUE ELSEIF(MSEL.EQ.61) THEN C...Charmonium production in colour octet model, with recoiling parton. DO 342 I=421,439 MSUB(I)=1 342 CONTINUE ELSEIF(MSEL.EQ.62) THEN C...Bottomonium production in colour octet model, with recoiling parton. DO 344 I=461,479 MSUB(I)=1 344 CONTINUE ELSEIF(MSEL.EQ.63) THEN C...Charmonium and bottomonium production in colour octet model. DO 346 I=421,439 MSUB(I)=1 MSUB(I+40)=1 346 CONTINUE ENDIF C...Find heaviest new quark flavour allowed in processes 81-84. KFLQM=1 DO 350 I=1,MIN(8,MDCY(21,3)) IDC=I+MDCY(21,2)-1 IF(MDME(IDC,1).LE.0) GOTO 350 KFLQM=I 350 CONTINUE IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9)) &KFLQM=MSTP(7) MINT(55)=KFLQM KFPR(81,1)=KFLQM KFPR(81,2)=KFLQM KFPR(82,1)=KFLQM KFPR(82,2)=KFLQM KFPR(83,1)=KFLQM KFPR(84,1)=KFLQM KFPR(84,2)=KFLQM C...Find heaviest new fermion flavour allowed in process 85. KFLFM=1 DO 360 I=1,MIN(12,MDCY(22,3)) IDC=I+MDCY(22,2)-1 IF(MDME(IDC,1).LE.0) GOTO 360 KFLFM=KFDP(IDC,1) 360 CONTINUE IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND. &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7) MINT(56)=KFLFM KFPR(85,1)=KFLFM KFPR(85,2)=KFLFM C...Import relevant information on external user processes. IF(MINT(111).GE.11) THEN IPYPR=0 DO 390 IUP=1,NPRUP C...Find next empty PYTHIA process number slot and enable it. 370 IPYPR=IPYPR+1 IF(IPYPR.GT.500) CALL PYERRM(26, & '(PYINPR.) no more empty slots for user processes') IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370 ISET(IPYPR)=11 C...Overwrite KFPR with references back to process number and ID. KFPR(IPYPR,1)=IUP KFPR(IPYPR,2)=LPRUP(IUP) C...Process title. WRITE(CHIPR,'(I10)') LPRUP(IUP) ICHIN=1 DO 380 ICH=1,9 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1 380 CONTINUE PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' ' C...Switch on process. MSUB(IPYPR)=1 390 CONTINUE ENDIF RETURN END C********************************************************************* C...PYXTOT C...Parametrizes total, elastic and diffractive cross-sections C...for different energies and beams. Donnachie-Landshoff for C...total and Schuler-Sjostrand for elastic and diffractive. C...Process code IPROC: C...= 1 : p + p; C...= 2 : pbar + p; C...= 3 : pi+ + p; C...= 4 : pi- + p; C...= 5 : pi0 + p; C...= 6 : phi + p; C...= 7 : J/psi + p; C...= 11 : rho + rho; C...= 12 : rho + phi; C...= 13 : rho + J/psi; C...= 14 : phi + phi; C...= 15 : phi + J/psi; C...= 16 : J/psi + J/psi; C...= 21 : gamma + p (DL); C...= 22 : gamma + p (VDM). C...= 23 : gamma + pi (DL); C...= 24 : gamma + pi (VDM); C...= 25 : gamma + gamma (DL); C...= 26 : gamma + gamma (VDM). SUBROUTINE PYXTOT C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT7/SIGT(0:6,0:6,0:5) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/ C...Local arrays. DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20), &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8), &CEFFD(10,9),SIGTMP(6,0:5) C...Common constants. DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/, &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/, &FACDD/0.0084D0/ C...Number of multiple processes to be evaluated (= 0 : undefined). DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/ C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta). DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0, &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0, &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/ DATA YPAR/ &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0, &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0, &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/ C...Beam and target hadron class: C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi. DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/ DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/ C...Characteristic class masses, slope parameters, beta = sqrt(X). DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/ DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/ DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/ C...Fitting constants used in parametrizations of diffractive results. DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/ DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/ DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/ &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0, &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0, &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0, &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0, &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0, &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0, &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0, &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0, &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0, &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/ DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/ &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0, &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0, &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0, &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0, &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0, &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0, &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0, &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0, &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0, &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0, &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0, &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0, &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0, &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0, &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/ C...Parameters. Combinations of the energy. AEM=PARU(101) PMTH=PARP(102) S=VINT(2) SRT=VINT(1) SEPS=S**EPS SETA=S**ETA SLOG=LOG(S) C...Ratio of gamma/pi (for rescaling in parton distributions). VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/ &(XPAR(5)*SEPS+YPAR(5)*SETA) VINT(317)=1D0 IF(MINT(50).NE.1) RETURN C...Order flavours of incoming particles: KF1 < KF2. IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN KF1=IABS(MINT(11)) KF2=IABS(MINT(12)) IORD=1 ELSE KF1=IABS(MINT(12)) KF2=IABS(MINT(11)) IORD=2 ENDIF ISGN12=ISIGN(1,MINT(11)*MINT(12)) C...Find process number (for lookup tables). IF(KF1.GT.1000) THEN IPROC=1 IF(ISGN12.LT.0) IPROC=2 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN IPROC=3 IF(ISGN12.LT.0) IPROC=4 IF(KF1.EQ.111) IPROC=5 ELSEIF(KF1.GT.100) THEN IPROC=11 ELSEIF(KF2.GT.1000) THEN IPROC=21 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22 ELSEIF(KF2.GT.100) THEN IPROC=23 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24 ELSE IPROC=25 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26 ENDIF C... Number of multiple processes to be stored; beam/target side. NPR=NPROC(IPROC) MINT(101)=1 MINT(102)=1 IF(NPR.EQ.3) THEN MINT(100+IORD)=4 ELSEIF(NPR.EQ.6) THEN MINT(101)=4 MINT(102)=4 ENDIF N1=0 IF(MINT(101).EQ.4) N1=4 N2=0 IF(MINT(102).EQ.4) N2=4 C...Do not do any more for user-set or undefined cross-sections. IF(MSTP(31).LE.0) RETURN IF(NPR.EQ.0) CALL PYERRM(26, &'(PYXTOT:) cross section for this process not yet implemented') C...Parameters. Combinations of the energy. AEM=PARU(101) PMTH=PARP(102) S=VINT(2) SRT=VINT(1) SEPS=S**EPS SETA=S**ETA SLOG=LOG(S) C...Loop over multiple processes (for VDM). DO 110 I=1,NPR IF(NPR.EQ.1) THEN IPR=IPROC ELSEIF(NPR.EQ.3) THEN IPR=I+4 IF(KF2.LT.1000) IPR=I+10 ELSEIF(NPR.EQ.6) THEN IPR=I+10 ENDIF C...Evaluate hadron species, mass, slope contribution and fit number. IHA=IHADA(IPR) IHB=IHADB(IPR) PMA=PMHAD(IHA) PMB=PMHAD(IHB) BHA=BHAD(IHA) BHB=BHAD(IHB) ISD=IFITSD(IPR) IDD=IFITDD(IPR) C...Skip if energy too low relative to masses. DO 100 J=0,5 SIGTMP(I,J)=0D0 100 CONTINUE IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110 C...Total cross-section. Elastic slope parameter and cross-section. SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL C...Diffractive scattering A + B -> X + B. BSD=2D0*BHB SQML=(PMA+PMTH)**2 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2) SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/ & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP) BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/ & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB) SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2) C...Diffractive scattering A + B -> A + X. BSD=2D0*BHA SQML=(PMB+PMTH)**2 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6) SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/ & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP) BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/ & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX) SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2) C...Order single diffractive correctly. IF(IORD.EQ.2) THEN SIGSAV=SIGTMP(I,2) SIGTMP(I,2)=SIGTMP(I,3) SIGTMP(I,3)=SIGSAV ENDIF C...Double diffractive scattering A + B -> X1 + X2. YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2) DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP) IF(YEFF.LE.0) SUM1=0D0 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2) SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC)))) SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC)))) SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/ & (2D0*ALP) SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC)))) SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC)))) SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/ & (2D0*ALP) BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC))) SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)* & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX) SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4) C...Non-diffractive by unitarity. SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)- & SIGTMP(I,4) 110 CONTINUE C...Put temporary results in output array: only one process. IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN DO 120 J=0,5 SIGT(0,0,J)=SIGTMP(1,J) 120 CONTINUE C...Beam multiple processes. ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN IF(MINT(107).EQ.2) THEN VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2 ELSE VINT(317)=16D0*PARP(15)**2*VINT(154)**2/ & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307))) ENDIF IF(MSTP(20).GT.0) THEN VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20) ENDIF DO 140 I=1,4 IF(MINT(107).EQ.2) THEN CONV=(AEM/PARP(160+I))*VINT(317) ELSEIF(VINT(154).GT.PARP(15)) THEN CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2* & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317) ELSE CONV=0D0 ENDIF I1=MAX(1,I-1) DO 130 J=0,5 SIGT(I,0,J)=CONV*SIGTMP(I1,J) 130 CONTINUE 140 CONTINUE DO 150 J=0,5 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J) 150 CONTINUE C...Target multiple processes. ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN IF(MINT(108).EQ.2) THEN VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2 ELSE VINT(317)=16D0*PARP(15)**2*VINT(154)**2/ & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308))) ENDIF IF(MSTP(20).GT.0) THEN VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20) ENDIF DO 170 I=1,4 IF(MINT(108).EQ.2) THEN CONV=(AEM/PARP(160+I))*VINT(317) ELSEIF(VINT(154).GT.PARP(15)) THEN CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2* & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317) ELSE CONV=0D0 ENDIF IV=MAX(1,I-1) DO 160 J=0,5 SIGT(0,I,J)=CONV*SIGTMP(IV,J) 160 CONTINUE 170 CONTINUE DO 180 J=0,5 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J) 180 CONTINUE C...Both beam and target multiple processes. ELSE IF(MINT(107).EQ.2) THEN VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2 ELSE VINT(317)=16D0*PARP(15)**2*VINT(154)**2/ & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307))) ENDIF IF(MINT(108).EQ.2) THEN VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2 ELSE VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/ & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308))) ENDIF IF(MSTP(20).GT.0) THEN VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+ & VINT(308)))**MSTP(20) ENDIF DO 210 I1=1,4 DO 200 I2=1,4 IF(MINT(107).EQ.2) THEN CONV=(AEM/PARP(160+I1))*VINT(317) ELSEIF(VINT(154).GT.PARP(15)) THEN CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2* & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317) ELSE CONV=0D0 ENDIF IF(MINT(108).EQ.2) THEN CONV=CONV*(AEM/PARP(160+I2)) ELSEIF(VINT(154).GT.PARP(15)) THEN CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2* & (1D0/PARP(15)**2-1D0/VINT(154)**2) ELSE CONV=0D0 ENDIF IF(I1.LE.2) THEN IV=MAX(1,I2-1) ELSEIF(I2.LE.2) THEN IV=MAX(1,I1-1) ELSEIF(I1.EQ.I2) THEN IV=2*I1-2 ELSE IV=5 ENDIF DO 190 J=0,5 JV=J IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV) 190 CONTINUE 200 CONTINUE 210 CONTINUE DO 230 J=0,5 DO 220 I=1,4 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J) SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J) 220 CONTINUE SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J) 230 CONTINUE ENDIF C...Scale up uniformly for Donnachie-Landshoff parametrization. IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0) DO 260 I1=0,N1 DO 250 I2=0,N2 DO 240 J=0,5 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J) 240 CONTINUE 250 CONTINUE 260 CONTINUE ENDIF RETURN END C********************************************************************* C...PYMAXI C...Finds optimal set of coefficients for kinematical variable selection C...and the maximum of the part of the differential cross-section used C...in the event weighting. SUBROUTINE PYMAXI C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...User process initialization commonblock. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) SAVE /HEPRUP/ C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT6/PROC(0:500) CHARACTER PROC*28 COMMON/PYINT7/SIGT(0:6,0:6,0:5) 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) CALL PYSTOP(1) ELSE WRITE(MSTU(11),6400) MSTI(53)=1 ENDIF ENDIF IF(MSTP(122).GE.1) THEN WRITE(MSTU(11),6000) WRITE(MSTU(11),6100) DO 470 ISUB=1,500 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0) & GOTO 470 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1) 470 CONTINUE WRITE(MSTU(11),6300) ENDIF C...Format statements for maximization results. 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ', &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X, &'cth',9X,'tau''',7X,'sigma') 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ', &'phase space.'/1X,'Process switched off!') 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4) 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ', &'cross-section.'/1X,'Process switched off!') 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4) 5500 FORMAT(1X,1P,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) CALL PYSTOP(2) ENDIF ELSE IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN VINT(109)=VIOL IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21), & VINT(22),VINT(23),VINT(26) ENDIF ENDIF C...Weighting using estimate of maximum of differential cross-section. RATND=1D0 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN IF(VIOL.LT.PYR(0)) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0 GOTO 100 ENDIF ELSEIF(MFAIL.EQ.0) THEN RATND=SIGLPT/XSEC(95,1) VIOL=VIOL/RATND IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND. & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143) IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) ISUB=0 GOTO 100 ENDIF IF(VIOL.LT.PYR(0)) THEN GOTO 140 ENDIF ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN IF(VIOL.LT.PYR(0)) THEN MSTI(61)=1 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) RETURN ENDIF ELSE RATND=SIGLPT/XSEC(95,1) IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN MSTI(61)=1 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) RETURN ENDIF VIOL=VIOL/RATND IF(VIOL.LT.PYR(0)) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) GOTO 100 ENDIF ENDIF C...Check for possible violation of estimated maximum of differential C...cross-section used in weighting. IF(MSTP(123).LE.0) THEN IF(VIOL.GT.1D0) THEN WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21), & VINT(22),VINT(23),VINT(26) CALL PYSTOP(2) ENDIF ELSEIF(MSTP(123).EQ.1) THEN IF(VIOL.GT.VINT(108)) THEN VINT(108)=VIOL IF(VIOL.GT.1.0001D0) THEN MINT(10)=1 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21), & VINT(22),VINT(23),VINT(26) ENDIF ENDIF ELSEIF(VIOL.GT.VINT(108)) THEN VINT(108)=VIOL IF(VIOL.GT.1D0) THEN MINT(10)=1 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2)) & THEN XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1)) IF(KFPR(ISUB,1).LE.9) THEN IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1), & XMAXUP(KFPR(ISUB,1)) ELSEIF(KFPR(ISUB,1).LE.99) THEN IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1), & XMAXUP(KFPR(ISUB,1)) ELSE IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1), & XMAXUP(KFPR(ISUB,1)) ENDIF ENDIF IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN XDIF=XSEC(ISUB,1)*(VIOL-1D0) XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) & XSEC(0,1)=XSEC(0,1)+XDIF IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21), & VINT(22),VINT(23),VINT(26) IF(ISUB.LE.9) THEN IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1) ELSEIF(ISUB.LE.99) THEN IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1) ELSE IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1) ENDIF ENDIF VINT(108)=1D0 ENDIF ENDIF C...Multiple interactions: choose impact parameter (if not already done). IF(MINT(39).EQ.0) VINT(148)=1D0 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND. &MSTP(82).GE.3) THEN IF(MINT(35).LE.1) CALL PYMULT(5) IF(MINT(35).GE.2) CALL PYMIGN(5) IF(VINT(150).LT.PYR(0)) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(MFAIL.EQ.1) THEN MSTI(61)=1 RETURN ENDIF GOTO 100 ENDIF ENDIF IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143) IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1 ENDIF IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1 C...Choose flavour of reacting partons (and subprocess). IF(ISTSB.GE.11) GOTO 320 RSIGS=SIGS*PYR(0) QT2=VINT(48) RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)* &(VINT(1)/PARP(89))**PARP(90))**2))**2) IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR. &PYR(0).GT.RQQBAR)) THEN DO 310 ICHN=1,NCHN KFL1=ISIG(ICHN,1) KFL2=ISIG(ICHN,2) MINT(2)=ISIG(ICHN,3) RSIGS=RSIGS-SIGH(ICHN) IF(RSIGS.LE.0D0) GOTO 320 310 CONTINUE C...Multiple interactions: choose qqbar preferentially at small pT. ELSEIF(ISUB.EQ.96) THEN MINT(105)=MINT(103) MINT(109)=MINT(107) CALL PYSPLI(MINT(11),21,KFL1,KFLDUM) MINT(105)=MINT(104) MINT(109)=MINT(108) CALL PYSPLI(MINT(12),21,KFL2,KFLDUM) MINT(1)=11 MINT(2)=1 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2 C...Low-pT: choose string drawing configuration. ELSE KFL1=21 KFL2=21 RSIGS=6D0*PYR(0) MINT(2)=1 IF(RSIGS.GT.1D0) MINT(2)=2 IF(RSIGS.GT.2D0) MINT(2)=3 ENDIF C...Reassign QCD process. Partons before initial state radiation. 320 IF(MINT(2).GT.10) THEN MINT(1)=MINT(2)/10 MINT(2)=MOD(MINT(2),10) ENDIF IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)= &NGEN(MINT(1),2)+1 MINT(15)=KFL1 MINT(16)=KFL2 MINT(13)=MINT(15) MINT(14)=MINT(16) VINT(141)=VINT(41) VINT(142)=VINT(42) VINT(151)=0D0 VINT(152)=0D0 C...Calculate x value of photon for parton inside photon inside e. DO 350 JT=1,2 MINT(18+JT)=0 VINT(154+JT)=0D0 MSPLI=0 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1 IF(MSPLI.EQ.2) THEN KFLH=MINT(14+JT) XHRD=VINT(140+JT) Q2HRD=VINT(54) MINT(105)=MINT(102+JT) MINT(109)=MINT(106+JT) VINT(120)=VINT(2+JT) IF(MSTP(57).LE.1) THEN CALL PYPDFU(22,XHRD,Q2HRD,XPQ) ELSE CALL PYPDFL(22,XHRD,Q2HRD,XPQ) ENDIF WTMX=4D0*XPQ(KFLH) IF(MSTP(13).EQ.2) THEN Q2PMS=Q2HRD/PMAS(11,1)**2 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2)) ENDIF 330 XE=XHRD**PYR(0) XG=MIN(1D0-1D-10,XHRD/XE) IF(MSTP(57).LE.1) THEN CALL PYPDFU(22,XG,Q2HRD,XPQ) ELSE CALL PYPDFL(22,XG,Q2HRD,XPQ) ENDIF WT=(1D0+(1D0-XE)**2)*XPQ(KFLH) IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2)) IF(WT.LT.PYR(0)*WTMX) GOTO 330 MINT(18+JT)=1 VINT(154+JT)=XE DO 340 KFLS=-25,25 XSFX(JT,KFLS)=XPQ(KFLS) 340 CONTINUE ENDIF 350 CONTINUE C...Pick scale where photon is resolved. Q0S=PARP(15)**2 Q1S=VINT(154)**2 VINT(283)=0D0 IF(MINT(107).EQ.3) THEN IF(MSTP(66).EQ.1) THEN VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0) ELSEIF(MSTP(66).EQ.2) THEN PS=VINT(3)**2 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) Q2INT=SQRT(Q0S*Q2EFF) VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0) ELSEIF(MSTP(66).EQ.3) THEN VINT(283)=Q0S*(Q1S/Q0S)**PYR(0) ELSEIF(MSTP(66).GE.4) THEN PS=0.25D0*VINT(3)**2 VINT(283)=(Q0S+PS)*(Q1S+PS)/ & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS ENDIF ENDIF VINT(284)=0D0 IF(MINT(108).EQ.3) THEN IF(MSTP(66).EQ.1) THEN VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0) ELSEIF(MSTP(66).EQ.2) THEN PS=VINT(4)**2 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) Q2INT=SQRT(Q0S*Q2EFF) VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0) ELSEIF(MSTP(66).EQ.3) THEN VINT(284)=Q0S*(Q1S/Q0S)**PYR(0) ELSEIF(MSTP(66).GE.4) THEN PS=0.25D0*VINT(4)**2 VINT(284)=(Q0S+PS)*(Q1S+PS)/ & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS ENDIF ENDIF IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) C...Format statements for differential cross-section maximum violations. 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X, &'in event',1X,I7,'D0'/1X,'Execution stopped!') 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P, &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3) 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X, &'in event',1X,I7) 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X, &'in event',1X,I7,'D0'/1X,'Execution stopped!') 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X, &'in event',1X,I7) 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3) 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3) 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3) 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3) 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3) 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3) RETURN END C********************************************************************* C...PYSCAT C...Finds outgoing flavours and event type; sets up the kinematics C...and colour flow of the hard scattering SUBROUTINE PYSCAT C...Double precision and integer declarations IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Parameter statement for maximum size of showers. PARAMETER (MAXNUR=1000) C...User process event common block. INTEGER MAXNUP PARAMETER (MAXNUP=500) INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), &VTIMUP(MAXNUP),SPINUP(MAXNUP) SAVE /HEPEUP/ C...Commonblocks. COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/, &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/, &/PYTCSM/ C...Local arrays and saved variables DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2), &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100) SAVE VINTSV C...Read out process ISUB=MINT(1) ISUBSV=ISUB C...Restore information for low-pT processes IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN DO 100 J=41,66 100 VINT(J)=VINTSV(J) ENDIF C...Convert H' or A process into equivalent H one IHIGG=1 KFHIGG=25 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND. &ISUB.LE.190)) THEN IHIGG=2 IF(MOD(ISUB-1,10).GE.5) IHIGG=3 KFHIGG=33+IHIGG IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113 ENDIF IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1) C...Convert bottomonium process into equivalent charmonium ones. IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40 C...Choice of subprocess, number of documentation lines IDOC=6+ISET(ISUB) IF(ISUB.EQ.95) IDOC=8 IF(ISET(ISUB).EQ.5) IDOC=9 IF(ISET(ISUB).EQ.11) IDOC=4+NUP MINT(3)=IDOC-6 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2 MINT(4)=IDOC IPU1=MINT(84)+1 IPU2=MINT(84)+2 IPU3=MINT(84)+3 IPU4=MINT(84)+4 IPU5=MINT(84)+5 IPU6=MINT(84)+6 C...Reset K, P and V vectors. Store incoming particles DO 120 JT=1,MSTP(126)+100 I=MINT(83)+JT IF(I.GT.MSTU(4)) GOTO 120 DO 110 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 110 CONTINUE 120 CONTINUE DO 140 JT=1,2 I=MINT(83)+JT K(I,1)=21 K(I,2)=MINT(10+JT) DO 130 J=1,5 P(I,J)=VINT(285+5*JT+J) 130 CONTINUE 140 CONTINUE MINT(6)=2 KFRES=0 C...Store incoming partons in their CM-frame. Save pdf value. SH=VINT(44) SHR=SQRT(SH) SHP=VINT(26)*VINT(2) SHPR=SQRT(SHP) SHUSER=SHR IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR DO 150 JT=1,2 I=MINT(84)+JT K(I,1)=14 K(I,2)=MINT(14+JT) K(I,3)=MINT(83)+2+JT P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1) P(I,4)=0.5D0*SHUSER VINT(38+JT)=XSFX(JT,MINT(14+JT)) 150 CONTINUE C...Copy incoming partons to documentation lines DO 170 JT=1,2 I1=MINT(83)+4+JT I2=MINT(84)+JT K(I1,1)=21 K(I1,2)=K(I2,2) K(I1,3)=I1-2 DO 160 J=1,5 P(I1,J)=P(I2,J) 160 CONTINUE 170 CONTINUE C...Choose new quark/lepton flavour for relevant annihilation graphs IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR. &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN IGLGA=21 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22 CALL PYWIDT(IGLGA,SH,WDTP,WDTE) 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0) DO 190 I=1,MDCY(IGLGA,3) KFLF=KFDP(I+MDCY(IGLGA,2)-1,1) RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4)) IF(RKFL.LE.0D0) GOTO 200 190 CONTINUE 200 CONTINUE IF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.2) THEN IF(KFLF.GE.4) GOTO 180 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.4) THEN KFLF=4 MINT(2)=MINT(2)-2 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385) THEN KFLF=5 MINT(2)=MINT(2)-4 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2 & .AND.IABS(KFLF).GE.3) THEN FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/ & VINT(44)**2 FACCIB=VINT(46)**2/RTCM(41)**4 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN KFLF=5 MINT(2)=1 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN IF(KFLF.EQ.5) GOTO 180 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180 ENDIF ENDIF C...Final state flavours and colour flow: default values JS=1 MINT(21)=MINT(15) MINT(22)=MINT(16) MINT(23)=0 MINT(24)=0 KCC=20 KCS=ISIGN(1,MINT(15)) IF(ISET(ISUB).EQ.11) THEN C...User-defined processes: find products MINT(3)=0 DO 210 IUP=3,NUP IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN MINT(21+IUP)=IDUP(IUP) ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR. & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN ELSEIF(IDUP(IUP).EQ.0) THEN ELSE MINT(3)=MINT(3)+1 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP) ENDIF 210 CONTINUE ELSEIF(ISUB.LE.10) THEN IF(ISUB.EQ.1) THEN C...f + fbar -> gamma*/Z0 KFRES=23 ELSEIF(ISUB.EQ.2) THEN C...f + fbar' -> W+/- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) KFRES=ISIGN(24,KCH1+KCH2) ELSEIF(ISUB.EQ.3) THEN C...f + fbar -> h0 (or H0, or A0) KFRES=KFHIGG ELSEIF(ISUB.EQ.4) THEN C...gamma + W+/- -> W+/- ELSEIF(ISUB.EQ.5) THEN C...Z0 + Z0 -> h0 XH=SH/SHP MINT(21)=MINT(15) MINT(22)=MINT(16) PMQ(1)=PYMASS(MINT(21)) PMQ(2)=PYMASS(MINT(22)) 220 JT=INT(1.5D0+PYR(0)) ZMIN=2D0*PMQ(JT)/SHPR ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ & (SHPR*(SHPR-PMQ(3-JT))) ZMAX=MIN(1D0-XH,ZMAX) Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 220 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) Z(3-JT)=1D0-XH/(1D0-Z(JT)) SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 220 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) PHIR=PARU(2)*PYR(0) CPHI=COS(PHIR) ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* & SQRT(1D0-CTHE(2)**2)*CPHI Z1=2D0-Z(JT) Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* & PMQ(3-JT)**2/SHP)) ZMIN=2D0*PMQ(3-JT)/SHPR ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) ZMAX=MIN(1D0-XH,ZMAX) IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220 KCC=22 KFRES=25 ELSEIF(ISUB.EQ.6) THEN C...Z0 + W+/- -> W+/- ELSEIF(ISUB.EQ.7) THEN C...W+ + W- -> Z0 ELSEIF(ISUB.EQ.8) THEN C...W+ + W- -> h0 XH=SH/SHP 230 DO 260 JT=1,2 I=MINT(14+JT) IA=IABS(I) IF(IA.LE.10) THEN RVCKM=VINT(180+I)*PYR(0) DO 240 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240 MINT(20+JT)=ISIGN(IB,I) RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) IF(RVCKM.LE.0D0) GOTO 250 240 CONTINUE ELSE IB=2*((IA+1)/2)-1+MOD(IA,2) MINT(20+JT)=ISIGN(IB,I) ENDIF 250 PMQ(JT)=PYMASS(MINT(20+JT)) 260 CONTINUE JT=INT(1.5D0+PYR(0)) ZMIN=2D0*PMQ(JT)/SHPR ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ & (SHPR*(SHPR-PMQ(3-JT))) ZMAX=MIN(1D0-XH,ZMAX) IF(ZMIN.GE.ZMAX) GOTO 230 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 230 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) Z(3-JT)=1D0-XH/(1D0-Z(JT)) SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 230 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) PHIR=PARU(2)*PYR(0) CPHI=COS(PHIR) ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* & SQRT(1D0-CTHE(2)**2)*CPHI Z1=2D0-Z(JT) Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* & PMQ(3-JT)**2/SHP)) ZMIN=2D0*PMQ(3-JT)/SHPR ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) ZMAX=MIN(1D0-XH,ZMAX) IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230 KCC=22 KFRES=25 ELSEIF(ISUB.EQ.10) THEN C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2 IF(MINT(2).EQ.1) THEN KCC=22 ELSE C...W exchange: need to mix flavours according to CKM matrix DO 280 JT=1,2 I=MINT(14+JT) IA=IABS(I) IF(IA.LE.10) THEN RVCKM=VINT(180+I)*PYR(0) DO 270 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270 MINT(20+JT)=ISIGN(IB,I) RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) IF(RVCKM.LE.0D0) GOTO 280 270 CONTINUE ELSE IB=2*((IA+1)/2)-1+MOD(IA,2) MINT(20+JT)=ISIGN(IB,I) ENDIF 280 CONTINUE KCC=22 ENDIF ENDIF ELSEIF(ISUB.LE.20) THEN IF(ISUB.EQ.11) THEN C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2 KCC=MINT(2) IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 ELSEIF(ISUB.EQ.12) THEN C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2 MINT(21)=ISIGN(KFLF,MINT(15)) MINT(22)=-MINT(21) KCC=4 ELSEIF(ISUB.EQ.13) THEN C...f + fbar -> g + g; th arbitrary MINT(21)=21 MINT(22)=21 KCC=MINT(2)+4 ELSEIF(ISUB.EQ.14) THEN C...f + fbar -> g + gamma; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=21 MINT(23-JS)=22 KCC=17+JS ELSEIF(ISUB.EQ.15) THEN C...f + fbar -> g + Z0; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=21 MINT(23-JS)=23 KCC=17+JS ELSEIF(ISUB.EQ.16) THEN C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2 MINT(20+JS)=21 MINT(23-JS)=ISIGN(24,KCH1+KCH2) KCC=17+JS ELSEIF(ISUB.EQ.17) THEN C...f + fbar -> g + h0; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=21 MINT(23-JS)=25 KCC=17+JS ELSEIF(ISUB.EQ.18) THEN C...f + fbar -> gamma + gamma; th arbitrary MINT(21)=22 MINT(22)=22 ELSEIF(ISUB.EQ.19) THEN C...f + fbar -> gamma + Z0; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=22 MINT(23-JS)=23 ELSEIF(ISUB.EQ.20) THEN C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or C...(p(fbar')-p(W+))**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2 MINT(20+JS)=22 MINT(23-JS)=ISIGN(24,KCH1+KCH2) ENDIF ELSEIF(ISUB.LE.30) THEN IF(ISUB.EQ.21) THEN C...f + fbar -> gamma + h0; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=22 MINT(23-JS)=25 ELSEIF(ISUB.EQ.22) THEN C...f + fbar -> Z0 + Z0; th arbitrary MINT(21)=23 MINT(22)=23 ELSEIF(ISUB.EQ.23) THEN C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2 MINT(20+JS)=23 MINT(23-JS)=ISIGN(24,KCH1+KCH2) ELSEIF(ISUB.EQ.24) THEN C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=23 MINT(23-JS)=KFHIGG ELSEIF(ISUB.EQ.25) THEN C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2 MINT(21)=-ISIGN(24,MINT(15)) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.26) THEN C...f + fbar' -> W+/- + h0 (or H0, or A0); C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 MINT(20+JS)=ISIGN(24,KCH1+KCH2) MINT(23-JS)=KFHIGG ELSEIF(ISUB.EQ.27) THEN C...f + fbar -> h0 + h0 ELSEIF(ISUB.EQ.28) THEN C...f + g -> f + g; th = (p(f)-p(f))**2 IF(MINT(15).EQ.21) JS=2 KCC=MINT(2)+6 IF(MINT(15).EQ.21) KCC=KCC+2 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15)) IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16)) ELSEIF(ISUB.EQ.29) THEN C...f + g -> f + gamma; th = (p(f)-p(f))**2 IF(MINT(15).EQ.21) JS=2 MINT(23-JS)=22 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.30) THEN C...f + g -> f + Z0; th = (p(f)-p(f))**2 IF(MINT(15).EQ.21) JS=2 MINT(23-JS)=23 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ENDIF ELSEIF(ISUB.LE.40) THEN IF(ISUB.EQ.31) THEN C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f' IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I) RVCKM=VINT(180+I)*PYR(0) DO 290 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290 MINT(20+JS)=ISIGN(IB,I) RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) IF(RVCKM.LE.0D0) GOTO 300 290 CONTINUE 300 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.32) THEN C...f + g -> f + h0; th = (p(f)-p(f))**2 IF(MINT(15).EQ.21) JS=2 MINT(23-JS)=25 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.33) THEN C...f + gamma -> f + g; th=(p(f)-p(f))**2 IF(MINT(15).EQ.22) JS=2 MINT(23-JS)=21 KCC=24+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.34) THEN C...f + gamma -> f + gamma; th=(p(f)-p(f))**2 IF(MINT(15).EQ.22) JS=2 KCC=22 KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.35) THEN C...f + gamma -> f + Z0; th=(p(f)-p(f))**2 IF(MINT(15).EQ.22) JS=2 MINT(23-JS)=23 KCC=22 ELSEIF(ISUB.EQ.36) THEN C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2 IF(MINT(15).EQ.22) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I) IF(IA.LE.10) THEN RVCKM=VINT(180+I)*PYR(0) DO 310 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310 MINT(20+JS)=ISIGN(IB,I) RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) IF(RVCKM.LE.0D0) GOTO 320 310 CONTINUE ELSE IB=2*((IA+1)/2)-1+MOD(IA,2) MINT(20+JS)=ISIGN(IB,I) ENDIF 320 KCC=22 ELSEIF(ISUB.EQ.37) THEN C...f + gamma -> f + h0 ELSEIF(ISUB.EQ.38) THEN C...f + Z0 -> f + g ELSEIF(ISUB.EQ.39) THEN C...f + Z0 -> f + gamma ELSEIF(ISUB.EQ.40) THEN C...f + Z0 -> f + Z0 ENDIF ELSEIF(ISUB.LE.50) THEN IF(ISUB.EQ.41) THEN C...f + Z0 -> f' + W+/- ELSEIF(ISUB.EQ.42) THEN C...f + Z0 -> f + h0 ELSEIF(ISUB.EQ.43) THEN C...f + W+/- -> f' + g ELSEIF(ISUB.EQ.44) THEN C...f + W+/- -> f' + gamma ELSEIF(ISUB.EQ.45) THEN C...f + W+/- -> f' + Z0 ELSEIF(ISUB.EQ.46) THEN C...f + W+/- -> f' + W+/- ELSEIF(ISUB.EQ.47) THEN C...f + W+/- -> f' + h0 ELSEIF(ISUB.EQ.48) THEN C...f + h0 -> f + g ELSEIF(ISUB.EQ.49) THEN C...f + h0 -> f + gamma ELSEIF(ISUB.EQ.50) THEN C...f + h0 -> f + Z0 ENDIF ELSEIF(ISUB.LE.60) THEN IF(ISUB.EQ.51) THEN C...f + h0 -> f' + W+/- ELSEIF(ISUB.EQ.52) THEN C...f + h0 -> f + h0 ELSEIF(ISUB.EQ.53) THEN C...g + g -> f + fbar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFLF,KCS) MINT(22)=-MINT(21) KCC=MINT(2)+10 ELSEIF(ISUB.EQ.54) THEN C...g + gamma -> f + fbar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFLF,KCS) MINT(22)=-MINT(21) KCC=27 IF(MINT(16).EQ.21) KCC=28 ELSEIF(ISUB.EQ.55) THEN C...g + Z0 -> f + fbar ELSEIF(ISUB.EQ.56) THEN C...g + W+/- -> f + fbar' ELSEIF(ISUB.EQ.57) THEN C...g + h0 -> f + fbar ELSEIF(ISUB.EQ.58) THEN C...gamma + gamma -> f + fbar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFLF,KCS) MINT(22)=-MINT(21) KCC=21 ELSEIF(ISUB.EQ.59) THEN C...gamma + Z0 -> f + fbar ELSEIF(ISUB.EQ.60) THEN C...gamma + W+/- -> f + fbar' ENDIF ELSEIF(ISUB.LE.70) THEN IF(ISUB.EQ.61) THEN C...gamma + h0 -> f + fbar ELSEIF(ISUB.EQ.62) THEN C...Z0 + Z0 -> f + fbar ELSEIF(ISUB.EQ.63) THEN C...Z0 + W+/- -> f + fbar' ELSEIF(ISUB.EQ.64) THEN C...Z0 + h0 -> f + fbar ELSEIF(ISUB.EQ.65) THEN C...W+ + W- -> f + fbar ELSEIF(ISUB.EQ.66) THEN C...W+/- + h0 -> f + fbar' ELSEIF(ISUB.EQ.67) THEN C...h0 + h0 -> f + fbar ELSEIF(ISUB.EQ.68) THEN C...g + g -> g + g; th arbitrary KCC=MINT(2)+12 KCS=(-1)**INT(1.5D0+PYR(0)) ELSEIF(ISUB.EQ.69) THEN C...gamma + gamma -> W+ + W-; th arbitrary MINT(21)=24 MINT(22)=-24 KCC=21 ELSEIF(ISUB.EQ.70) THEN C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2 IF(MINT(15).EQ.22) MINT(21)=23 IF(MINT(16).EQ.22) MINT(22)=23 KCC=21 ENDIF ELSEIF(ISUB.LE.80) THEN IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W- XH=SH/SHP MINT(21)=MINT(15) MINT(22)=MINT(16) PMQ(1)=PYMASS(MINT(21)) PMQ(2)=PYMASS(MINT(22)) 330 JT=INT(1.5D0+PYR(0)) ZMIN=2D0*PMQ(JT)/SHPR ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ & (SHPR*(SHPR-PMQ(3-JT))) ZMAX=MIN(1D0-XH,ZMAX) Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 330 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) Z(3-JT)=1D0-XH/(1D0-Z(JT)) SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 330 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) PHIR=PARU(2)*PYR(0) CPHI=COS(PHIR) ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* & SQRT(1D0-CTHE(2)**2)*CPHI Z1=2D0-Z(JT) Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* & PMQ(3-JT)**2/SHP)) ZMIN=2D0*PMQ(3-JT)/SHPR ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) ZMAX=MIN(1D0-XH,ZMAX) IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330 KCC=22 ELSEIF(ISUB.EQ.73) THEN C...Z0 + W+/- -> Z0 + W+/- JS=MINT(2) XH=SH/SHP 340 JT=3-MINT(2) I=MINT(14+JT) IA=IABS(I) IF(IA.LE.10) THEN RVCKM=VINT(180+I)*PYR(0) DO 350 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350 MINT(20+JT)=ISIGN(IB,I) RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) IF(RVCKM.LE.0D0) GOTO 360 350 CONTINUE ELSE IB=2*((IA+1)/2)-1+MOD(IA,2) MINT(20+JT)=ISIGN(IB,I) ENDIF 360 PMQ(JT)=PYMASS(MINT(20+JT)) MINT(23-JT)=MINT(17-JT) PMQ(3-JT)=PYMASS(MINT(23-JT)) JT=INT(1.5D0+PYR(0)) ZMIN=2D0*PMQ(JT)/SHPR ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ & (SHPR*(SHPR-PMQ(3-JT))) ZMAX=MIN(1D0-XH,ZMAX) IF(ZMIN.GE.ZMAX) GOTO 340 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 340 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) Z(3-JT)=1D0-XH/(1D0-Z(JT)) SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 340 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) PHIR=PARU(2)*PYR(0) CPHI=COS(PHIR) ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* & SQRT(1D0-CTHE(2)**2)*CPHI Z1=2D0-Z(JT) Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* & PMQ(3-JT)**2/SHP)) ZMIN=2D0*PMQ(3-JT)/SHPR ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) ZMAX=MIN(1D0-XH,ZMAX) IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340 KCC=22 ELSEIF(ISUB.EQ.74) THEN C...Z0 + h0 -> Z0 + h0 ELSEIF(ISUB.EQ.75) THEN C...W+ + W- -> gamma + gamma ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W- XH=SH/SHP 370 DO 400 JT=1,2 I=MINT(14+JT) IA=IABS(I) IF(IA.LE.10) THEN RVCKM=VINT(180+I)*PYR(0) DO 380 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380 MINT(20+JT)=ISIGN(IB,I) RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) IF(RVCKM.LE.0D0) GOTO 390 380 CONTINUE ELSE IB=2*((IA+1)/2)-1+MOD(IA,2) MINT(20+JT)=ISIGN(IB,I) ENDIF 390 PMQ(JT)=PYMASS(MINT(20+JT)) 400 CONTINUE JT=INT(1.5D0+PYR(0)) ZMIN=2D0*PMQ(JT)/SHPR ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ & (SHPR*(SHPR-PMQ(3-JT))) ZMAX=MIN(1D0-XH,ZMAX) IF(ZMIN.GE.ZMAX) GOTO 370 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 370 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) Z(3-JT)=1D0-XH/(1D0-Z(JT)) SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 370 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) PHIR=PARU(2)*PYR(0) CPHI=COS(PHIR) ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* & SQRT(1D0-CTHE(2)**2)*CPHI Z1=2D0-Z(JT) Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* & PMQ(3-JT)**2/SHP)) ZMIN=2D0*PMQ(3-JT)/SHPR ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) ZMAX=MIN(1D0-XH,ZMAX) IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370 KCC=22 ELSEIF(ISUB.EQ.78) THEN C...W+/- + h0 -> W+/- + h0 ELSEIF(ISUB.EQ.79) THEN C...h0 + h0 -> h0 + h0 ELSEIF(ISUB.EQ.80) THEN C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2 IF(MINT(15).EQ.22) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I) IB=3-IA MINT(20+JS)=ISIGN(IB,I) KCC=22 ENDIF ELSEIF(ISUB.LE.90) THEN IF(ISUB.EQ.81) THEN C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2 MINT(21)=ISIGN(MINT(55),MINT(15)) MINT(22)=-MINT(21) KCC=4 ELSEIF(ISUB.EQ.82) THEN C...g + g -> Q + Qbar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(MINT(55),KCS) MINT(22)=-MINT(21) KCC=MINT(2)+10 ELSEIF(ISUB.EQ.83) THEN C...f + q -> f' + Q; th = (p(f) - p(f'))**2 KFOLD=MINT(16) IF(MINT(2).EQ.2) KFOLD=MINT(15) KFAOLD=IABS(KFOLD) IF(KFAOLD.GT.10) THEN KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1 ELSE RCKM=VINT(180+KFOLD)*PYR(0) IPM=(5-ISIGN(1,KFOLD))/2 KFANEW=-MOD(KFAOLD+1,2) 410 KFANEW=KFANEW+2 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM- & VCKM(KFAOLD/2,(KFANEW+1)/2) IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM- & VCKM(KFANEW/2,(KFAOLD+1)/2) ENDIF IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410 ENDIF IF(MINT(2).EQ.1) THEN MINT(21)=ISIGN(MINT(55),MINT(15)) MINT(22)=ISIGN(KFANEW,MINT(16)) ELSE MINT(21)=ISIGN(KFANEW,MINT(15)) MINT(22)=ISIGN(MINT(55),MINT(16)) JS=2 ENDIF KCC=22 ELSEIF(ISUB.EQ.84) THEN C...g + gamma -> Q + Qbar; th arbitary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(MINT(55),KCS) MINT(22)=-MINT(21) KCC=27 IF(MINT(16).EQ.21) KCC=28 ELSEIF(ISUB.EQ.85) THEN C...gamma + gamma -> F + Fbar; th arbitary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(MINT(56),KCS) MINT(22)=-MINT(21) KCC=21 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g MINT(21)=KFPR(ISUB,1) MINT(22)=KFPR(ISUB,2) KCC=24 KCS=(-1)**INT(1.5D0+PYR(0)) ENDIF ELSEIF(ISUB.LE.100) THEN IF(ISUB.EQ.95) THEN C...Low-pT ( = energyless g + g -> g + g) KCC=MINT(2)+12 KCS=(-1)**INT(1.5D0+PYR(0)) ELSEIF(ISUB.EQ.96) THEN C...Multiple interactions (should be reassigned to QCD process) ENDIF ELSEIF(ISUB.LE.110) THEN IF(ISUB.EQ.101) THEN C...g + g -> gamma*/Z0 KCC=21 KFRES=22 ELSEIF(ISUB.EQ.102) THEN C...g + g -> h0 (or H0, or A0) KCC=21 KFRES=KFHIGG ELSEIF(ISUB.EQ.103) THEN C...gamma + gamma -> h0 (or H0, or A0) KCC=21 KFRES=KFHIGG ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN C...g + g -> chi_0c or chi_2c. KCC=21 KFRES=KFPR(ISUB,1) ELSEIF(ISUB.EQ.106) THEN C...g + g -> J/Psi + gamma MINT(21)=KFPR(ISUB,1) MINT(22)=KFPR(ISUB,2) KCC=21 ELSEIF(ISUB.EQ.107) THEN C...g + gamma -> J/Psi + g MINT(21)=KFPR(ISUB,1) MINT(22)=KFPR(ISUB,2) KCC=22 IF(MINT(16).EQ.22) KCC=33 ELSEIF(ISUB.EQ.108) THEN C...gamma + gamma -> J/Psi + gamma MINT(21)=KFPR(ISUB,1) MINT(22)=KFPR(ISUB,2) ELSEIF(ISUB.EQ.110) THEN C...f + fbar -> gamma + h0; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=22 MINT(23-JS)=KFHIGG ENDIF ELSEIF(ISUB.LE.120) THEN IF(ISUB.EQ.111) THEN C...f + fbar -> g + h0; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=21 MINT(23-JS)=KFHIGG KCC=17+JS ELSEIF(ISUB.EQ.112) THEN C...f + g -> f + h0; th = (p(f) - p(f))**2 IF(MINT(15).EQ.21) JS=2 MINT(23-JS)=KFHIGG KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.113) THEN C...g + g -> g + h0; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(23-JS)=KFHIGG KCC=22+JS KCS=(-1)**INT(1.5D0+PYR(0)) ELSEIF(ISUB.EQ.114) THEN C...g + g -> gamma + gamma; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(21)=22 MINT(22)=22 KCC=21 ELSEIF(ISUB.EQ.115) THEN C...g + g -> g + gamma; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(23-JS)=22 KCC=22+JS KCS=(-1)**INT(1.5D0+PYR(0)) ELSEIF(ISUB.EQ.116) THEN C...g + g -> gamma + Z0 ELSEIF(ISUB.EQ.117) THEN C...g + g -> Z0 + Z0 ELSEIF(ISUB.EQ.118) THEN C...g + g -> W+ + W- ENDIF ELSEIF(ISUB.LE.140) THEN IF(ISUB.EQ.121) THEN C...g + g -> Q + Qbar + h0 KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS) MINT(22)=-MINT(21) KCC=11+INT(0.5D0+PYR(0)) KFRES=KFHIGG ELSEIF(ISUB.EQ.122) THEN C...q + qbar -> Q + Qbar + h0 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15)) MINT(22)=-MINT(21) KCC=4 KFRES=KFHIGG ELSEIF(ISUB.EQ.123) THEN C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as C...inner process) KCC=22 KFRES=KFHIGG ELSEIF(ISUB.EQ.124) THEN C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as C...inner process) DO 430 JT=1,2 I=MINT(14+JT) IA=IABS(I) IF(IA.LE.10) THEN RVCKM=VINT(180+I)*PYR(0) DO 420 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420 MINT(20+JT)=ISIGN(IB,I) RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) IF(RVCKM.LE.0D0) GOTO 430 420 CONTINUE ELSE IB=2*((IA+1)/2)-1+MOD(IA,2) MINT(20+JT)=ISIGN(IB,I) ENDIF 430 CONTINUE KCC=22 KFRES=KFHIGG ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2 IF(MINT(15).EQ.22) JS=2 MINT(23-JS)=21 KCC=24+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2 IF(MINT(15).EQ.22) JS=2 KCC=22 KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN C...g + gamma*_(T,L) -> f + fbar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFLF,KCS) MINT(22)=-MINT(21) KCC=27 IF(MINT(16).EQ.21) KCC=28 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFLF,KCS) MINT(22)=-MINT(21) KCC=21 ENDIF ELSEIF(ISUB.LE.160) THEN IF(ISUB.EQ.141) THEN C...f + fbar -> gamma*/Z0/Z'0 KFRES=32 ELSEIF(ISUB.EQ.142) THEN C...f + fbar' -> W'+/- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) KFRES=ISIGN(34,KCH1+KCH2) ELSEIF(ISUB.EQ.143) THEN C...f + fbar' -> H+/- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) KFRES=ISIGN(37,KCH1+KCH2) ELSEIF(ISUB.EQ.144) THEN C...f + fbar' -> R KFRES=ISIGN(41,MINT(15)+MINT(16)) ELSEIF(ISUB.EQ.145) THEN C...q + l -> LQ (leptoquark) IF(IABS(MINT(16)).LE.8) JS=2 KFRES=ISIGN(42,MINT(14+JS)) KCC=28+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.146) THEN C...e + gamma -> e* (excited lepton) IF(MINT(15).EQ.22) JS=2 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS)) KCC=22 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN C...q + g -> q* (excited quark) IF(MINT(15).EQ.21) JS=2 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS)) KCC=30+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.149) THEN C...g + g -> eta_tc KFRES=KTECHN+331 KCC=23 KCS=(-1)**INT(1.5D0+PYR(0)) ENDIF ELSEIF(ISUB.LE.200) THEN IF(ISUB.EQ.161) THEN C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I) IB=IA+MOD(IA,2)-MOD(IA+1,2) MINT(20+JS)=ISIGN(IB,I) KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.162) THEN C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2 IF(MINT(15).EQ.21) JS=2 MINT(20+JS)=ISIGN(42,MINT(14+JS)) KFLQL=KFDP(MDCY(42,2),2) MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS)) KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.163) THEN C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(42,KCS) MINT(22)=-MINT(21) KCC=MINT(2)+10 ELSEIF(ISUB.EQ.164) THEN C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2 MINT(21)=ISIGN(42,MINT(15)) MINT(22)=-MINT(21) KCC=4 ELSEIF(ISUB.EQ.165) THEN C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.166) THEN C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2 IF(MOD(MINT(15),2).EQ.0) THEN MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15)) MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16)) ELSE MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16)) ENDIF ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN C...q + q' -> q" + q* (excited quark) KFQSTR=KFPR(ISUB,2) KFQEXC=MOD(KFQSTR,KEXCIT) JS=MINT(2) MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS)) IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC) & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS)) KCC=22 JS=3-JS ELSEIF(ISUB.EQ.169) THEN C...q + qbar -> e + e* (excited lepton) KFQSTR=KFPR(ISUB,2) KFQEXC=MOD(KFQSTR,KEXCIT) JS=MINT(2) MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS)) MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS)) JS=3-JS ELSEIF(ISUB.EQ.191) THEN C...f + fbar -> rho_tc0. KFRES=KTECHN+113 ELSEIF(ISUB.EQ.192) THEN C...f + fbar' -> rho_tc+/- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) KFRES=ISIGN(KTECHN+213,KCH1+KCH2) ELSEIF(ISUB.EQ.193) THEN C...f + fbar -> omega_tc0. KFRES=KTECHN+223 ELSEIF(ISUB.EQ.194) THEN C...f + fbar -> f' + fbar' via mixture of s-channel C...rho_tc and omega_tc; th=(p(f)-p(f'))**2 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.195) THEN C...f + fbar' -> f'' + fbar''' via s-channel C...rho_tc+ th=(p(f)-p(f'))**2 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2 IF(MOD(MINT(15),2).EQ.0) THEN MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15)) MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16)) ELSE MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16)) ENDIF ENDIF CMRENNA++ ELSEIF(ISUB.LE.215) THEN IF(ISUB.EQ.201) THEN C...f + fbar -> ~e_L + ~e_Lbar MINT(21)=ISIGN(KSUSY1+11,KCS) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.202) THEN C...f + fbar -> ~e_R + ~e_Rbar MINT(21)=ISIGN(KSUSY2+11,KCS) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.203) THEN C...f + fbar -> ~e_L + ~e_Rbar IF(MINT(15).LT.0) JS=2 IF(MINT(2).EQ.1) THEN MINT(20+JS)=KFPR(ISUB,1) MINT(23-JS)=-KFPR(ISUB,2) ELSE MINT(20+JS)=-KFPR(ISUB,1) MINT(23-JS)=KFPR(ISUB,2) ENDIF ELSEIF(ISUB.EQ.204) THEN C...f + fbar -> ~mu_L + ~mu_Lbar MINT(21)=ISIGN(KSUSY1+13,KCS) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.205) THEN C...f + fbar -> ~mu_R + ~mu_Rbar MINT(21)=ISIGN(KSUSY2+13,KCS) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.206) THEN C...f + fbar -> ~mu_L + ~mu_Rbar IF(MINT(15).LT.0) JS=2 IF(MINT(2).EQ.1) THEN MINT(20+JS)=KFPR(ISUB,1) MINT(23-JS)=-KFPR(ISUB,2) ELSE MINT(20+JS)=-KFPR(ISUB,1) MINT(23-JS)=KFPR(ISUB,2) ENDIF ELSEIF(ISUB.EQ.207) THEN C...f + fbar -> ~tau_1 + ~tau_1bar MINT(21)=ISIGN(KSUSY1+15,KCS) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.208) THEN C...f + fbar -> ~tau_2 + ~tau_2bar MINT(21)=ISIGN(KSUSY2+15,KCS) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.209) THEN C...f + fbar -> ~tau_1 + ~tau_2bar IF(MINT(15).LT.0) JS=2 IF(MINT(2).EQ.1) THEN MINT(20+JS)=KFPR(ISUB,1) MINT(23-JS)=-KFPR(ISUB,2) ELSE MINT(20+JS)=-KFPR(ISUB,1) MINT(23-JS)=KFPR(ISUB,2) ENDIF ELSEIF(ISUB.EQ.210) THEN C...q + qbar' -> ~l_L + ~nulbar; th arbitrary KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2) MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2) ELSEIF(ISUB.EQ.211) THEN C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2) MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2) ELSEIF(ISUB.EQ.212) THEN C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2) MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2) ELSEIF(ISUB.EQ.213) THEN C...f + fbar -> ~nul + ~nulbar MINT(21)=ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.214) THEN C...f + fbar -> ~nutau + ~nutaubar MINT(21)=ISIGN(KSUSY1+16,KCS) MINT(22)=-MINT(21) ENDIF ELSEIF(ISUB.LE.225) THEN IF(ISUB.EQ.216) THEN C...f + fbar -> ~chi01 + ~chi01 MINT(21)=KSUSY1+22 MINT(22)=KSUSY1+22 ELSEIF(ISUB.EQ.217) THEN C...f + fbar -> ~chi02 + ~chi02 MINT(21)=KSUSY1+23 MINT(22)=KSUSY1+23 ELSEIF(ISUB.EQ.218 ) THEN C...f + fbar -> ~chi03 + ~chi03 MINT(21)=KSUSY1+25 MINT(22)=KSUSY1+25 ELSEIF(ISUB.EQ.219 ) THEN C...f + fbar -> ~chi04 + ~chi04 MINT(21)=KSUSY1+35 MINT(22)=KSUSY1+35 ELSEIF(ISUB.EQ.220 ) THEN C...f + fbar -> ~chi01 + ~chi02 IF(MINT(15).LT.0) JS=2 C IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+22 MINT(23-JS)=KSUSY1+23 ELSEIF(ISUB.EQ.221 ) THEN C...f + fbar -> ~chi01 + ~chi03 IF(MINT(15).LT.0) JS=2 C IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+22 MINT(23-JS)=KSUSY1+25 ELSEIF(ISUB.EQ.222) THEN C...f + fbar -> ~chi01 + ~chi04 IF(MINT(15).LT.0) JS=2 C IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+22 MINT(23-JS)=KSUSY1+35 ELSEIF(ISUB.EQ.223) THEN C...f + fbar -> ~chi02 + ~chi03 IF(MINT(15).LT.0) JS=2 C IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+23 MINT(23-JS)=KSUSY1+25 ELSEIF(ISUB.EQ.224) THEN C...f + fbar -> ~chi02 + ~chi04 IF(MINT(15).LT.0) JS=2 C IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+23 MINT(23-JS)=KSUSY1+35 ELSEIF(ISUB.EQ.225) THEN C...f + fbar -> ~chi03 + ~chi04 IF(MINT(15).LT.0) JS=2 C IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+25 MINT(23-JS)=KSUSY1+35 ENDIF ELSEIF(ISUB.LE.236) THEN IF(ISUB.EQ.226) THEN C...f + fbar -> ~chi+-1 + ~chi-+1 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) MINT(21)=ISIGN(KSUSY1+24,KCH1) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.227) THEN C...f + fbar -> ~chi+-2 + ~chi-+2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) MINT(21)=ISIGN(KSUSY1+37,KCH1) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.228) THEN C...f + fbar -> ~chi+-1 + ~chi-+2 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2 C...js=1 if pyr<.5, js=2 if pyr>.5 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=INT(1-KCH1)/2 IF(MINT(2).EQ.1) THEN MINT(21)= ISIGN(KSUSY1+24,KCH1) MINT(22)= -ISIGN(KSUSY1+37,KCH1) c IF(KCH2.EQ.0) JS=2 ELSE MINT(21)= ISIGN(KSUSY1+37,KCH1) MINT(22)= -ISIGN(KSUSY1+24,KCH1) JS=2 c IF(KCH2.EQ.1) JS=2 ENDIF ELSEIF(ISUB.EQ.229) THEN C...q + qbar' -> ~chi01 + ~chi+-1 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) C...CHECK THIS IF(MOD(MINT(15),2).EQ.0) JS=2 MINT(20+JS)=KSUSY1+22 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) ELSEIF(ISUB.EQ.230) THEN C...q + qbar' -> ~chi02 + ~chi+-1 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MOD(MINT(15),2).EQ.0) JS=2 MINT(20+JS)=KSUSY1+23 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) ELSEIF(ISUB.EQ.231) THEN C...q + qbar' -> ~chi03 + ~chi+-1 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MOD(MINT(15),2).EQ.0) JS=2 MINT(20+JS)=KSUSY1+25 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) ELSEIF(ISUB.EQ.232) THEN C...q + qbar' -> ~chi04 + ~chi+-1 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MOD(MINT(15),2).EQ.0) JS=2 MINT(20+JS)=KSUSY1+35 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) ELSEIF(ISUB.EQ.233) THEN C...q + qbar' -> ~chi01 + ~chi+-2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MOD(MINT(15),2).EQ.0) JS=2 MINT(20+JS)=KSUSY1+22 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) ELSEIF(ISUB.EQ.234) THEN C...q + qbar' -> ~chi02 + ~chi+-2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MOD(MINT(15),2).EQ.0) JS=2 MINT(20+JS)=KSUSY1+23 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) ELSEIF(ISUB.EQ.235) THEN C...q + qbar' -> ~chi03 + ~chi+-2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MOD(MINT(15),2).EQ.0) JS=2 MINT(20+JS)=KSUSY1+25 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) ELSEIF(ISUB.EQ.236) THEN C...q + qbar' -> ~chi04 + ~chi+-2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MOD(MINT(15),2).EQ.0) JS=2 MINT(20+JS)=KSUSY1+35 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) ENDIF ELSEIF(ISUB.LE.245) THEN IF(ISUB.EQ.237) THEN C...q + qbar -> ~chi01 + ~g C...th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+21 MINT(23-JS)=KSUSY1+22 KCC=17+JS ELSEIF(ISUB.EQ.238) THEN C...q + qbar -> ~chi02 + ~g C...th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+21 MINT(23-JS)=KSUSY1+23 KCC=17+JS ELSEIF(ISUB.EQ.239) THEN C...q + qbar -> ~chi03 + ~g C...th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+21 MINT(23-JS)=KSUSY1+25 KCC=17+JS ELSEIF(ISUB.EQ.240) THEN C...q + qbar -> ~chi04 + ~g C...th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+21 MINT(23-JS)=KSUSY1+35 KCC=17+JS ELSEIF(ISUB.EQ.241) THEN C...q + qbar' -> ~chi+-1 + ~g C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+ C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi- C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi- C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+ C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) JS=1 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 MINT(20+JS)=KSUSY1+21 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) KCC=17+JS ELSEIF(ISUB.EQ.242) THEN C...q + qbar' -> ~chi+-2 + ~g C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+ C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi- C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi- C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+ C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) JS=1 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 MINT(20+JS)=KSUSY1+21 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) KCC=17+JS ELSEIF(ISUB.EQ.243) THEN C...q + qbar -> ~g + ~g ; th arbitrary MINT(21)=KSUSY1+21 MINT(22)=KSUSY1+21 KCC=MINT(2)+4 ELSEIF(ISUB.EQ.244) THEN C...g + g -> ~g + ~g ; th arbitrary KCC=MINT(2)+12 KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=KSUSY1+21 MINT(22)=KSUSY1+21 ENDIF ELSEIF(ISUB.LE.260) THEN IF(ISUB.EQ.246) THEN C...qj + g -> ~qj_L + ~chi01 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY1+IA,I) MINT(23-JS)=KSUSY1+22 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.247) THEN C...qj + g -> ~qj_R + ~chi01 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY2+IA,I) MINT(23-JS)=KSUSY1+22 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.248) THEN C...qj + g -> ~qj_L + ~chi02 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY1+IA,I) MINT(23-JS)=KSUSY1+23 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.249) THEN C...qj + g -> ~qj_R + ~chi02 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY2+IA,I) MINT(23-JS)=KSUSY1+23 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.250) THEN C...qj + g -> ~qj_L + ~chi03 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY1+IA,I) MINT(23-JS)=KSUSY1+25 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.251) THEN C...qj + g -> ~qj_R + ~chi03 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY2+IA,I) MINT(23-JS)=KSUSY1+25 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.252) THEN C...qj + g -> ~qj_L + ~chi04 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY1+IA,I) MINT(23-JS)=KSUSY1+35 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.253) THEN C...qj + g -> ~qj_R + ~chi04 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY2+IA,I) MINT(23-JS)=KSUSY1+35 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.254) THEN C...qj + g -> ~qk_L + ~chi+-1 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I) IB=-IA+INT((IA+1)/2)*4-1 MINT(20+JS)=ISIGN(KSUSY1+IB,I) KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.255) THEN C...qj + g -> ~qk_L + ~chi+-1 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I) IB=-IA+INT((IA+1)/2)*4-1 MINT(20+JS)=ISIGN(KSUSY2+IB,I) KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.256) THEN C...qj + g -> ~qk_L + ~chi+-2 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) IB=-IA+INT((IA+1)/2)*4-1 MINT(20+JS)=ISIGN(KSUSY1+IB,I) MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I) KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.257) THEN C...qj + g -> ~qk_R + ~chi+-2 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) IB=-IA+INT((IA+1)/2)*4-1 MINT(20+JS)=ISIGN(KSUSY2+IB,I) MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I) KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.258) THEN C...qj + g -> ~qj_L + ~g IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY1+IA,I) MINT(23-JS)=KSUSY1+21 KCC=MINT(2)+6 IF(JS.EQ.2) KCC=KCC+2 KCS=ISIGN(1,I) ELSEIF(ISUB.EQ.259) THEN C...qj + g -> ~qj_R + ~g IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY2+IA,I) MINT(23-JS)=KSUSY1+21 KCC=MINT(2)+6 IF(JS.EQ.2) KCC=KCC+2 KCS=ISIGN(1,I) ENDIF ELSEIF(ISUB.LE.270) THEN IF(ISUB.EQ.261) THEN C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2 ISGN=1 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) C...Correct color combination IF(MINT(43).EQ.4) KCC=4 ELSEIF(ISUB.EQ.262) THEN C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2 ISGN=1 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) C...Correct color combination IF(MINT(43).EQ.4) KCC=4 ELSEIF(ISUB.EQ.263) THEN C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR. & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN MINT(21)=ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-ISIGN(KFPR(ISUB,2),KCS) ELSE JS=2 MINT(21)=ISIGN(KFPR(ISUB,2),KCS) MINT(22)=-ISIGN(KFPR(ISUB,1),KCS) ENDIF C...Correct color combination IF(MINT(43).EQ.4) KCC=4 ELSEIF(ISUB.EQ.264) THEN C...g + g -> ~t_1 + ~t_1bar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) KCC=MINT(2)+10 ELSEIF(ISUB.EQ.265) THEN C...g + g -> ~t_2 + ~t_2bar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) KCC=MINT(2)+10 ENDIF ELSEIF(ISUB.LE.296) THEN IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN C...qi + qj -> ~qi_L + ~qj_L KCC=MINT(2) IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15)) MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16)) ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN C...qi + qj -> ~qi_R + ~qj_R KCC=MINT(2) IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15)) MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16)) ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN C...qi + qj -> ~qi_L + ~qj_R MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16)) KCC=MINT(2) IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15)) MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16)) KCC=MINT(2) IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15)) MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16)) KCC=MINT(2) IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16)) KCC=MINT(2) IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2 ISGN=1 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) IF(MINT(43).EQ.4) KCC=4 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2 ISGN=1 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) IF(MINT(43).EQ.4) KCC=4 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary C...pure LL + RR KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) KCC=MINT(2)+10 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) KCC=MINT(2)+10 ELSEIF(ISUB.EQ.294) THEN C...qj + g -> ~qj_L + ~g IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY1+IA,I) MINT(23-JS)=KSUSY1+21 KCC=MINT(2)+6 IF(JS.EQ.2) KCC=KCC+2 KCS=ISIGN(1,I) ELSEIF(ISUB.EQ.295) THEN C...qj + g -> ~qj_R + ~g IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY2+IA,I) MINT(23-JS)=KSUSY1+21 KCC=MINT(2)+6 IF(JS.EQ.2) KCC=KCC+2 KCS=ISIGN(1,I) ENDIF ELSEIF(ISUB.LE.340) THEN IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN C...q + qbar' -> H+ + H0 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 MINT(20+JS)=ISIGN(37,KCH1+KCH2) MINT(23-JS)=KFPR(ISUB,2) ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN C...f + fbar -> A0 + H0; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KFPR(ISUB,1) MINT(23-JS)=KFPR(ISUB,2) ELSEIF(ISUB.EQ.301) THEN C...f + fbar -> H+ H- MINT(21)=ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) ENDIF CMRENNA-- ELSEIF(ISUB.LE.360) THEN IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN C...l + l -> H_L++/--, H_R++/-- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2) ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2 IF(MINT(15).EQ.22) JS=2 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS)) MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS)) KCC=22 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15)) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- C...as inner process). DO 450 JT=1,2 I=MINT(14+JT) IA=IABS(I) IF(IA.LE.10) THEN RVCKM=VINT(180+I)*PYR(0) DO 440 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440 MINT(20+JT)=ISIGN(IB,I) RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) IF(RVCKM.LE.0D0) GOTO 450 440 CONTINUE ELSE IB=2*((IA+1)/2)-1+MOD(IA,2) MINT(20+JT)=ISIGN(IB,I) ENDIF 450 CONTINUE KCC=22 KFRES=ISIGN(KFPR(ISUB,1),MINT(15)) IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES ELSEIF(ISUB.EQ.353) THEN C...f + fbar -> Z_R0 KFRES=KFPR(ISUB,1) ELSEIF(ISUB.EQ.354) THEN C...f + fbar' -> W+/- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2) ENDIF ELSEIF(ISUB.LE.380) THEN IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN C...f + fbar -> charged+ charged- technicolor KSW=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFPR(ISUB,1),KSW) MINT(22)=-ISIGN(KFPR(ISUB,2),KSW) ELSEIF(ISUB.LE.367) 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 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3 ENDIF C...Initialize QCD evolution and check phase space. Q2MNC=PARP(62)**2 Q2MNCS(1)=Q2MNC Q2MNCS(2)=Q2MNC IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN Q0S=PARP(15)**2 PS=VINT(3)**2 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) Q2INT=SQRT(Q0S*Q2EFF) Q2MNCS(1)=MAX(Q2MNC,Q2INT) ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN Q2MNCS(1)=MAX(Q2MNC,VINT(283)) ENDIF IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN Q0S=PARP(15)**2 PS=VINT(4)**2 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) Q2INT=SQRT(Q0S*Q2EFF) Q2MNCS(2)=MAX(Q2MNC,Q2INT) ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN Q2MNCS(2)=MAX(Q2MNC,VINT(284)) ENDIF MCEV=0 ALAMS=PARU(112) PARU(112)=PARP(61) FQ2C=1D0 TCMX=0D0 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN MCEV=1 IF(MSTP(64).EQ.1) FQ2C=PARP(63) IF(MSTP(64).EQ.2) FQ2C=PARP(64) TCMX=LOG(FQ2C*Q2MX/PARP(61)**2) IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0) & MCEV=0 ENDIF C...Initialize QED evolution and check phase space. MEEV=0 XEE=1D-10 SPME=PMAS(11,1)**2 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13) &SPME=PMAS(13,1)**2 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15) &SPME=PMAS(15,1)**2 Q2MNE=MAX(PARP(68)**2,2D0*SPME) TEMX=0D0 FWTE=10D0 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN MEEV=1 TEMX=LOG(Q2MX/SPME) IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0 ENDIF IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN MEEV=2 TEMX=TCMX FWTE=1D0 ENDIF IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN C...Loopback point in case of failure to reconstruct kinematics. NS=N LOOP=0 MNT352=MINT(352) MNT353=MINT(353) VNT352=VINT(352) VNT353=VINT(353) 100 LOOP=LOOP+1 IF(LOOP.GT.100) THEN MINT(51)=1 RETURN ENDIF N=NS MINT(352)=MNT352 MINT(353)=MNT353 VINT(352)=VNT352 VINT(353)=VNT353 C...Initial values: flavours, momenta, virtualities. DO 120 JT=1,2 MORE(JT)=1 KFBEAM(JT)=MINT(10+JT) IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22 KFLS(JT)=MINT(14+JT) KFLS(JT+2)=KFLS(JT) XS(JT)=VINT(40+JT) IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT) IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT) ZS(JT)=1D0 Q2S(JT)=FCQ2MX*Q2MX DQ2(JT)=0D0 TEVCSV(JT)=TCMX ALAM(JT)=PARP(61) THE2(JT)=1D0 TEVESV(JT)=TEMX MCESV(JT)=0 C...Calculate initial parton distribution weights. MINT(105)=MINT(102+JT) MINT(109)=MINT(106+JT) VINT(120)=VINT(2+JT) 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 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3 C...Calculate preweighting factor for ME-corrected processes. IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG) ENDIF C...Basic info on daughter for which to find mother. KFLB=K(IMI(JS,MI,1),2) KFLBA=IABS(KFLB) C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for C...second companion. KSVCB=MAX(-1,IMI(JS,MI,2)) C...Treat "first" companion of a pair like an ordinary sea quark C...(except that creation diagram is not allowed) IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1 C...X (rescaled to [0,1]) XB=XMI(JS,MI)/VINT(142+JS) C...Massive quarks (use physical masses.) RMQ2=0D0 MQMASS=0 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN RMQ2=RMC2 IF (KFLBA.EQ.5) RMQ2=RMB2 C...Special threshold treatment for non-photon beams IF (KFBEAM(JS).NE.22) MQMASS=KFLBA ENDIF C...Flags for parton distribution calls. MINT(105)=MINT(102+JS) MINT(109)=MINT(106+JS) VINT(120)=VINT(2+JS) C...Calculate initial parton distribution weights. IF(XB.GE.XMXC) THEN RETURN ELSEIF(MQMASS.EQ.0) THEN CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB) ELSE C...Initialize massive quark PT2 dependent pdf underestimate. PT20=PT2 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB) C.!.Tentative treatment of massive valence quarks. XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB)) XG0=XFB(21) TPM0=LOG(PT20/RMQ2) WPDF0=TPM0*XG0/XQ0 ENDIF IF (KFLBA.LE.6) THEN C...For quarks, only include respective sea, val, or cmp part. IF (KSVCB.LE.0) THEN XFB(KFLB)=XPSVC(KFLB,KSVCB) ELSE C...Find companion's companion MISEA=0 120 MISEA=MISEA+1 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120 XS=XMI(JS,MISEA) XREM=VINT(142+JS) YS=XS/(XREM+XS) C...Momentum fraction of the companion quark. C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS). YB=XB*(1D0-YS) XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87)) ENDIF ENDIF C...Determine overestimated z range: switch at c and b masses. 130 IF (PT2.GT.TMIN*RMB2) THEN IZRG=3 PT2MNE=MAX(TMIN*RMB2,PT2CUT) B0=23D0/6D0 ALAM2=ALAM5**2 ELSEIF(PT2.GT.TMIN*RMC2) THEN IZRG=2 PT2MNE=MAX(TMIN*RMC2,PT2CUT) B0=25D0/6D0 ALAM2=ALAM4**2 ELSE IZRG=1 PT2MNE=PT2CUT B0=27D0/6D0 ALAM2=ALAM3**2 ENDIF C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64)) ALAM2=ALAM2/PARP(64) C...Overestimated ZMAX: IF (MQMASS.EQ.0) THEN C...Massless ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI) & /PT2MNE)-1D0) ELSE C...Massive (limit for bremsstrahlung diagram > creation) FMQ=SQRT(RMQ2/SHTNOW(MI)) ZMAX=1D0/(1D0+FMQ) ENDIF ZMIN=XB/XMXC C...If kinematically impossible then do not evolve. IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN C...Reset Altarelli-Parisi and PDF weights. DO 140 KFL=-5,5 WTAP(KFL)=0D0 WTPDF(KFL)=0D0 140 CONTINUE WTAP(21)=0D0 WTPDF(21)=0D0 C...Zero joining weights and compute X(partner) and X(mother) values. IF (MSTP(96).NE.0) THEN NJN=0 DO 150 MJ=1,MINT(31) WTAPJ(MJ)=0D0 WTPDFJ(MJ)=0D0 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ)) Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ) & +XMI(JS,MI)) 150 CONTINUE ENDIF C...Approximate Altarelli-Parisi weights (integrated AP dz). C...q -> q, g -> q or q -> q + gamma (already set which). IF(KFLBA.LE.5) THEN C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps. IF (KSVCB.LT.0) THEN WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX)) ELSE RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN)) RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX)) WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN) ENDIF WTAP(21)=0.5D0*(ZMAX-ZMIN) WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX)) IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN WTAP(KFLB)=WTFF*WTAP(KFLB) WTAP(21)=WTGF*WTAP(21) WTAPE=WTFF*WTAPE ENDIF IF (KSVCB.GE.1) THEN C...Kill normal creation but add joining diagrams for cmp quark. WTAP(21)=0D0 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'// & " quark here. Not handled yet, giving up!") PT2=0D0 MINT(51)=1 RETURN ENDIF C...Check for possible joinings IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN C...Find companion's companion. MJ=0 160 MJ=MJ+1 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160 IF (MJOIND(JS,MJ).EQ.0) THEN Y(MI)=YB+YS Z=YB/Y(MI) WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2) IF (WTAPJ(MJ).GT.1D-6) THEN NJN=1 ELSE WTAPJ(MJ)=0D0 ENDIF ENDIF C...Add trial gluon joinings. DO 170 MJ=1,MINT(31) KFLC=K(IMI(JS,MJ,1),2) IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ)) WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2) IF (WTAPJ(MJ).GT.1D-6) THEN NJN=NJN+1 ELSE WTAPJ(MJ)=0D0 ENDIF 170 CONTINUE ENDIF ELSEIF (IMI(JS,MI,2).GE.0) THEN C...Kill creation diagram for val quarks and sea quarks with companions. WTAP(21)=0D0 ELSEIF (MQMASS.EQ.0) THEN C...Extra safety factor for massless sea quark creation. WTAP(21)=WTAP(21)*1.25D0 ENDIF C... q -> g, g -> g. ELSEIF(KFLB.EQ.21) THEN C...Here we decide later whether a quark picked up is valence or C...sea, so we maintain the extra factor sqrt(z) since we deal C...with the *sum* of sea and valence in this context. WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX)) C...new: do not allow backwards evol to pick up heavy flavour. DO 180 KFL=1,MIN(3,MSTP(58)) WTAP(KFL)=WTAPQ WTAP(-KFL)=WTAPQ 180 CONTINUE WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX))) IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN WTAPQ=WTFG*WTAPQ WTAP(21)=WTGG*WTAP(21) ENDIF C...Check for possible joinings (companions handled separately above) IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0) & THEN DO 190 MJ=1,MINT(31) IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190 KSVCC=IMI(JS,MJ,2) IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1 IF (KSVCC.GE.1) GOTO 190 KFLC=K(IMI(JS,MJ,1),2) C...Only try g -> g + g once. IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ)) IF (KFLC.EQ.21) THEN WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2) ELSE WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2) ENDIF IF (WTAPJ(MJ).GT.1D-6) THEN NJN=NJN+1 ELSE WTAPJ(MJ)=0D0 ENDIF 190 CONTINUE ENDIF ENDIF C...Initialize massive quark evolution IF (MQMASS.NE.0) THEN RML=(RMQ2+VINT(18))/ALAM2 TML=LOG(RML) TPL=LOG((PT2+VINT(18))/ALAM2) TPM=LOG((PT2+VINT(18))/RMQ2) WN=WTAP(21)*WPDF0/B0 ENDIF C...Loopback point for iteration NTRY=0 NTHRES=0 200 NTRY=NTRY+1 IF(NTRY.GT.500) THEN CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.') MINT(51)=1 RETURN ENDIF C... Calculate PDF weights and sum for evolution rate. WTSUM=0D0 XFBO=MAX(1D-10,XFB(KFLB)) DO 210 KFL=-5,5 WTPDF(KFL)=XFB(KFL)/XFBO WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL) 210 CONTINUE C...Only add gluon mother diagram for massless KFLB. IF(MQMASS.EQ.0) THEN WTPDF(21)=XFB(21)/XFBO WTSUM=WTSUM+WTAP(21)*WTPDF(21) ENDIF WTSUM=MAX(0.0001D0,WTSUM) WTSUMS=WTSUM C...Add joining diagrams where applicable. WTJOIN=0D0 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN DO 220 MJ=1,MINT(31) IF (WTAPJ(MJ).LT.1D-3) GOTO 220 WTPDFJ(MJ)=1D0/XFBO C...x and x*pdf (+ sea/val) for parton C. KFLC=K(IMI(JS,MJ,1),2) KFLCA=IABS(KFLC) KSVCC=MAX(-1,IMI(JS,MJ,2)) IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1 MINT(30)=JS MINT(36)=MJ CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ) MINT(36)=MI IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN XFJ(KFLC)=XPSVC(KFLC,KSVCC) ELSEIF (KSVCC.GE.1) THEN print*, 'error! parton C is companion!' ENDIF WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC) C...x and x*pdf (+ sea/val) for parton A. KFLA=21 KSVCA=0 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN KFLA=KFLB KSVCA=KSVCB ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN KFLA=KFLC KSVCA=KSVCC ENDIF MINT(30)=JS IF (KSVCA.LE.0) THEN C...Consider C the "evolved" parton if B is gluon. Val/sea C...counting will then be done correctly in PYPDFU. IF (KFLBA.EQ.21) MINT(36)=MJ CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ) MINT(36)=MI IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA) ELSE C...If parton A is companion, use Y(MI) and YS in call to PYFCMP. XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87)) ENDIF WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ) WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ) 220 CONTINUE ENDIF C...Pick normal pT2 (in overestimated z range). 230 PT2OLD=PT2 WTSUM=WTSUMS PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18) KFLC=21 C...Evolve q -> q gamma separately, pick it if larger pT. IF(KFLBA.LE.5) THEN PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18) IF(PT2QED.GT.PT2) THEN PT2=PT2QED KFLC=22 KFLA=KFLB ENDIF ENDIF C... Evolve massive quark creation separately. MCRQQ=0 IF (MQMASS.NE.0) THEN PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM))) & -VINT(18) C... Ensure mininimum PT2CR and force creation near threshold. IF (PT2CR.LT.TMIN*RMQ2) THEN NTHRES=NTHRES+1 IF (NTHRES.GT.50) THEN CALL PYERRM(9,'(PYPTIS:) no phase space left for '// & 'massive quark creation. Gave up trying.') MINT(51)=1 RETURN ENDIF PT2=0D0 PT2CR=TMIN*RMQ2 MCRQQ=2 ENDIF C... Select largest PT2 (brems or creation): IF (PT2CR.GT.PT2) THEN MCRQQ=MAX(MCRQQ,1) WTSUM=0D0 PT2=PT2CR KFLA=21 ELSE MCRQQ=0 KFLA=KFLB ENDIF C... Compute logarithms for this PT2 TPL=LOG((PT2+VINT(18))/ALAM2) TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18))) WTCRQQ=TPM/LOG(PT2/RMQ2) ENDIF C...Evolve joining separately MJOIN=0 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN)) & -VINT(18) IF (PT2JN.GE.PT2) THEN MJOIN=1 PT2=PT2JN ENDIF ENDIF C...Loopback if crossed c/b mass thresholds. IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN PT2=RMB2 GOTO 130 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN PT2=RMC2 GOTO 130 ENDIF C...Speed up shower. Skip if higher-PT acceptable branching C...already found somewhere else. C...Also finish if below lower cutoff. IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN C...Select parton A flavour (massive Q handled above.) IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN WTRAN=PYR(0)*WTSUM KFLA=-6 240 KFLA=KFLA+1 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA) IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240 IF(KFLA.EQ.6) KFLA=21 ELSEIF (MJOIN.EQ.1) THEN C...Tentative joining accept/reject. WTRAN=PYR(0)*WTJOIN MJ=0 250 MJ=MJ+1 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ) IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'// & ' Rejected.') GOTO 230 ENDIF C...x*pdf (+ sea/val) at new pT2 for parton B. IF (KSVCB.LE.0) THEN MINT(30)=JS CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB) IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB) ELSE C...Companion distributions do not evolve. XFB(KFLB)=XFBO ENDIF WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB) KFLC=K(IMI(JS,MJ,1),2) KFLCA=IABS(KFLC) KSVCC=MAX(-1,IMI(JS,MJ,2)) IF (KSVCB.GE.1) KSVCC=-1 C...x*pdf (+ sea/val) at new pT2 for parton C. MINT(30)=JS MINT(36)=MJ CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ) MINT(36)=MI IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC) WTVETO=WTVETO/XFJ(KFLC) C...x and x*pdf (+ sea/val) at new pT2 for parton A. KFLA=21 KSVCA=0 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN KFLA=KFLB KSVCA=KSVCB ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN KFLA=KFLC KSVCA=KSVCC ENDIF IF (KSVCA.LE.0) THEN MINT(30)=JS IF (KFLB.EQ.21) MINT(36)=MJ CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ) MINT(36)=MI IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA) ELSE XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87)) ENDIF WTVETO=WTVETO*XFJ(KFLA) C...Monte Carlo veto. IF (WTVETO.LT.PYR(0)) GOTO 200 C...If accept, save PT2 of this joining. IF (PT2.GT.PT2MX) THEN PT2MX=PT2 JSMX=2+JS MJN1MX=MJ MJN2MX=MI WTAPJ(MJ)=0D0 NJN=0 ENDIF C...Exit and continue evolution. GOTO 380 ENDIF KFLAA=IABS(KFLA) C...Choose z value (still in overestimated range) and corrective weight. C...Unphysical z will be rejected below when Q2 has is computed. WTZ=0D0 C...Note: ME and MQ>0 give corrections to overall weights, not shapes. C...q -> q + g or q -> q + gamma (already set which). IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN IF (KSVCB.LT.0) THEN Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0) ELSE ZFAC=RMIN*(RMAX/RMIN)**PYR(0) Z=((1-ZFAC)/(1+ZFAC))**2 ENDIF WTZ=0.5D0*(1D0+Z**2) C...Massive weight correction. IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2 C...Valence quark weight correction (extra sqrt) IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z) C...q -> g + q. C...NB: MQ>0 not yet implemented. Forced absent above. ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN KFLC=KFLA Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z) C...g -> q + qbar. ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN KFLC=-KFLB Z=ZMIN+PYR(0)*(ZMAX-ZMIN) WTZ=Z**2+(1D0-Z)**2 C...Massive correction IF (MQMASS.NE.0) THEN WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2 C...Extra safety margin for light sea quark creation ELSEIF (KSVCB.LT.0) THEN WTZ=WTZ/1.25D0 ENDIF C...g -> g + g. ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN KFLC=21 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/ & (ZMAX*(1D0-ZMIN)))**PYR(0)) WTZ=(1D0-Z*(1D0-Z))**2 ENDIF C...Derive Q2 from pT2. Q2B=PT2/(1D0-Z) IF (KFLBA.GE.4) Q2B=Q2B-RMQ2 C...Loopback if outside allowed z range for given pT2. RM2C=PYMASS(KFLC)**2 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI) IF (PT2ADJ.LT.1D-6) GOTO 230 C...Loopback if nonordered in angle/rapidity. IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI)) & GOTO 230 ENDIF C...Select phi angle of branching at random. PHI=PARU(2)*PYR(0) C...Matrix-element corrections for some processes. IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME) WTZ=WTZ*WTME/WTFF ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME) WTZ=WTZ*WTME/WTGF ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME) WTZ=WTZ*WTME/WTFG ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME) WTZ=WTZ*WTME/WTGG ENDIF ENDIF C...Parton distributions at new pT2 but old x. MINT(30)=JS CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN) C...Treat val and cmp separately IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB) IF (KSVCB.GE.1) & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87)) XFBN=XFN(KFLB) IF(XFBN.LT.1D-20) THEN IF(KFLA.EQ.KFLB) THEN WTAP(KFLB)=0D0 GOTO 200 ELSE XFBN=1D-10 XFN(KFLB)=XFBN ENDIF ENDIF DO 260 KFL=-5,5 XFB(KFL)=XFN(KFL) 260 CONTINUE XFB(21)=XFN(21) C...Parton distributions at new pT2 and new x. XA=XB/Z MINT(30)=JS CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA) IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN C...q -> q + g: only consider respective sea, val, or cmp content. IF (KSVCB.LE.0) THEN XFA(KFLA)=XPSVC(KFLA,KSVCB) ELSE YA=XA*(1D0-YS) XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87)) ENDIF ENDIF XFAN=XFA(KFLA) IF(XFAN.LT.1D-20) THEN GOTO 200 ENDIF C...If weighting fails continue evolution. WTTOT=0D0 IF (MCRQQ.EQ.0) THEN WTPDFA=1D0/WTPDF(KFLA) WTTOT=WTZ*XFAN/XFBN*WTPDFA ELSEIF(MCRQQ.EQ.1) THEN WTPDFA=TPM/WPDF0 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA XBEST=TPM/TPM0*XQ0 ELSEIF(MCRQQ.EQ.2) THEN C...Force massive quark creation. WTTOT=1D0 ENDIF C...Loop back if trial emission fails. IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200 WTACC=((1D0+PT2)/(0.25D0+PT2))**2 IF(WTTOT.LT.0D0) THEN WRITE(CHWT,'(1P,E12.4)') WTTOT CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative') ELSEIF(WTTOT.GT.WTACC) THEN WRITE(CHWT,'(1P,E12.4)') WTTOT IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN C...Too high weight: write out as error, but do not update error counter. IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1 CALL PYERRM(19, & '(PYPTIS:) Weight '//CHWT//' above unity') IF (PT2.GT.PTEMAX) PTEMAX=PT2 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT ELSE CALL PYERRM(9, & '(PYPTIS:) Weight '//CHWT//' above unity') ENDIF C...Useful for debugging but commented out for distribution: C print*, 'JS, MI',JS, MI C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ C print*, 'A -> B C',KFLA, KFLB, KFLC C XFAO=XFBO/WTPDFA C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN ENDIF C...Save acceptable branching. IF(PT2.GT.PT2MX) THEN MIMX=MINT(36) JSMX=JS PT2MX=PT2 KFLAMX=KFLA KFLCMX=KFLC RM2CMX=RM2C Q2BMX=Q2B ZMX=Z PT2AMX=PT2ADJ PHIMX=PHI ENDIF C---------------------------------------------------------------------- C...MODE= 1: Accept stored shower branching. Update event record etc. ELSEIF (MODE.EQ.1) THEN MI=MIMX JS=JSMX SHAT=SHTNOW(MI) SIDE=3D0-2D0*JS C...Shift down rest of event record to make room for insertion. IT=IMISEP(MI)+1 IM=IT+1 IS=IMI(JS,MI,1) DO 280 I=N,IT,-1 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2 KT1=K(I,4)/MSTU(5)**2 KT2=K(I,5)/MSTU(5)**2 ID1=MOD(K(I,4),MSTU(5)) ID2=MOD(K(I,5),MSTU(5)) IM1=MOD(K(I,4)/MSTU(5),MSTU(5)) IM2=MOD(K(I,5)/MSTU(5),MSTU(5)) IF (ID1.GE.IT) ID1=ID1+2 IF (ID2.GE.IT) ID2=ID2+2 IF (IM1.GE.IT) IM1=IM1+2 IF (IM2.GE.IT) IM2=IM2+2 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2 DO 270 IX=1,5 K(I+2,IX)=K(I,IX) P(I+2,IX)=P(I,IX) V(I+2,IX)=V(I,IX) 270 CONTINUE MCT(I+2,1)=MCT(I,1) MCT(I+2,2)=MCT(I,2) 280 CONTINUE N=N+2 C...Also update shifted-down pointers in IMI, IMISEP, and IPART. DO 290 JI=1,MINT(31) IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2 C...Also update companion pointers to the present mother. IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM 290 CONTINUE DO 300 IFS=1,NPART IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2 300 CONTINUE C...Zero entries dedicated for new timelike and mother partons. DO 320 I=IT,IT+1 DO 310 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 310 CONTINUE MCT(I,1)=0 MCT(I,2)=0 320 CONTINUE C...Define timelike and new mother partons. History. K(IT,1)=3 K(IT,2)=KFLCMX K(IM,1)=14 K(IM,2)=KFLAMX K(IS,3)=IM K(IT,3)=IM C...Set mother origin = side. K(IM,3)=MINT(83)+JS+2 IF(MI.GE.2) K(IM,3)=MINT(83)+JS C...Define colour flow of branching. IM1=IM IM2=IM C...q -> q + gamma. IF(K(IT,2).EQ.22) THEN K(IT,1)=1 ID1=IS ID2=IS C...q -> q + g. ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN ID1=IT ID2=IS C...q -> g + q. ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN ID1=IS ID2=IT C...qbar -> qbar + g. ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN ID1=IS ID2=IT C...qbar -> g + qbar. ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN ID1=IT ID2=IS C...g -> g + g; g -> q + qbar.. ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN ID1=IS ID2=IT ELSE ID1=IT ID2=IS ENDIF IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2 IF(ID1.NE.ID2) THEN K(ID1,5)=K(ID1,5)+MSTU(5)*ID2 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1 ENDIF IF(K(IT,1).EQ.1) THEN K(IT,4)=0 K(IT,5)=0 ENDIF C...Update IMI and colour tag arrays. IMI(JS,MI,1)=IM DO 330 MC=1,2 MCT(IT,MC)=0 MCT(IM,MC)=0 330 CONTINUE DO 340 JCS=4,5 KCS=JCS C...If mother flag not yet set for spacelike parton, trace it. IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM) IF(MINT(51).NE.0) RETURN 340 CONTINUE DO 350 JCS=4,5 KCS=JCS C...If mother flag not yet set for timelike parton, trace it. IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM) IF(MINT(51).NE.0) RETURN 350 CONTINUE C...Boost recoiling parton to compensate for Q2 scale. 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 C...Matrix-element corrections for q + qbar -> Higgs (h0) ELSEIF(MECOR.EQ.3) THEN IF(IFLCB.EQ.2) THEN WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/ 1 (SH**2+2D0*SQM*(SQM-SH)) ENDIF ENDIF RETURN END C********************************************************************* C...PYPTMI C...Handles the generation of additional interactions in the new C...multiple interactions framework. C...MODE=-1 : Initalize MI from scratch. C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve C... Sudakov for PT2, abort if below PT2CUT. C...MODE= 1 : Accept interaction at PT2NOW and store variables. C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW C...PT2NOW : Starting (max) PT2 scale for evolution. C...PT2CUT : Lower limit for evolution. C...PT2 : Result of evolution. Generated PT2 for trial interaction. C...IFAIL : Status return code. C... = 0: All is well. C... < 0: Phase space exhausted, generation to be terminated. C... > 0: Additional interaction vetoed, but continue evolution. SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement for maximum size of showers. PARAMETER (MAXNUR=1000) C...Commonblocks. COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT7/SIGT(0:6,0:6,0:5) COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), & XMI(2,240),PT2MI(240),IMISEP(0:240) COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240), & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX COMMON/PYCTAG/NCT,MCT(4000,2) C...Local arrays and saved variables. DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25) SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/, & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/, & /PYISMX/,/PYCTAG/ SAVE XT2FAC,SIGS IFAIL=0 C...Set MI subprocess = QCD 2 -> 2. ISUB=96 C---------------------------------------------------------------------- C...MODE=-1: Initialize from scratch IF (MODE.EQ.-1) THEN C...Initialize PT2 array. PT2MI(1)=VINT(54) C...Initialize list of incoming beams and partons from two sides. DO 110 JS=1,2 DO 100 MI=1,240 IMI(JS,MI,1)=0 IMI(JS,MI,2)=0 100 CONTINUE NMI(JS)=1 IMI(JS,1,1)=MINT(84)+JS IMI(JS,1,2)=0 XMI(JS,1)=VINT(40+JS) C...Rescale x values to fractions of photon energy. IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS) C...Hard reset: hard interaction initiators motherless by definition. K(MINT(84)+JS,3)=2+JS K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5)) K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5)) 110 CONTINUE IMISEP(0)=MINT(84) IMISEP(1)=N IF (MOD(MSTP(81),10).GE.1) THEN IF(MSTP(82).LE.1) THEN SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0 & ,5)) IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT* & VINT(317)/(VINT(318)*VINT(320)) XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149)) ELSE XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/ & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149)) ENDIF ENDIF C...Zero entries relating to scatterings beyond the first. DO 120 MI=2,240 IMI(1,MI,1)=0 IMI(2,MI,1)=0 IMI(1,MI,2)=0 IMI(2,MI,2)=0 IMISEP(MI)=IMISEP(1) PT2MI(MI)=0D0 XMI(1,MI)=0D0 XMI(2,MI)=0D0 120 CONTINUE C...Initialize factors for PDF reshaping. DO 140 JS=1,2 KFBEAM(JS)=MINT(10+JS) IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22 KFABM=IABS(KFBEAM(JS)) KFSBM=ISIGN(1,KFBEAM(JS)) C...Zero flavour content of incoming beam particle. KFIVAL(JS,1)=0 KFIVAL(JS,2)=0 KFIVAL(JS,3)=0 C... Flavour content of baryon. IF(KFABM.GT.1000) THEN KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10) KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10) KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10) C... Flavour content of pi+-, K+-. ELSEIF(KFABM.EQ.211) THEN KFIVAL(JS,1)=KFSBM*2 KFIVAL(JS,2)=-KFSBM ELSEIF(KFABM.EQ.321) THEN KFIVAL(JS,1)=-KFSBM*3 KFIVAL(JS,2)=KFSBM*2 C... Flavour content of pi0, gamma, K0S, K0L not defined yet. ENDIF C...Zero initial valence and companion content. DO 130 IFL=-6,6 NVC(JS,IFL)=0 130 CONTINUE 140 CONTINUE C...Set up colour line tags starting from hard interaction initiators. NCT=0 C...Reset colour tag array and colour processing flags. DO 150 I=IMISEP(0)+1,N MCT(I,1)=0 MCT(I,2)=0 K(I,4)=MOD(K(I,4),MSTU(5)**2) K(I,5)=MOD(K(I,5),MSTU(5)**2) 150 CONTINUE C... Consider each side in turn. DO 170 JS=1,2 I1=IMI(JS,1,1) I2=IMI(3-JS,1,1) DO 160 JCS=4,5 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2))) & GOTO 160 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160 KCS=JCS CALL PYCTTR(I1,KCS,I2) IF(MINT(51).NE.0) RETURN 160 CONTINUE 170 CONTINUE C...Range checking for companion quark pdf large-x param. IF (MSTP(87).LT.0) THEN CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'// & ' MSTP(87)=0') MSTP(87)=0 ELSEIF (MSTP(87).GT.4) THEN CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'// & ' MSTP(87)=4') MSTP(87)=4 ENDIF C---------------------------------------------------------------------- C...MODE=0: Generate trial interaction. Return codes: C...IFAIL < 0: Phase space exhausted, generation to be terminated. C...IFAIL = 0: Additional interaction generated at PT2. C...IFAIL > 0: Additional interaction vetoed, but continue evolution. ELSEIF (MODE.EQ.0) THEN C...Abolute MI max scale = VINT(62) XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2) 180 IF(MSTP(82).LE.1) THEN XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) IF(XT2.LT.VINT(149)) IFAIL=-2 ELSE IF(XT2.LE.0.01001D0*VINT(149)) THEN IFAIL=-3 ELSE XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))* & LOG(PYR(0)))-VINT(149) ENDIF ENDIF C...Also exit if below lower limit or if higher trial branching C...already found. PT2=0.25D0*VINT(2)*XT2 IF (PT2.LE.PT2CUT) IFAIL=-4 IF (PT2.LE.PT2MX) IFAIL=-5 IF (IFAIL.NE.0) THEN PT2=0D0 RETURN ENDIF IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2) VINT(25)=4D0*PT2/VINT(2) XT2=VINT(25) C...Choose tau and y*. Calculate cos(theta-hat). IF(PYR(0).LE.COEF(ISUB,1)) THEN TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) ELSE TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) ENDIF VINT(21)=TAU C...New: require shat > 1. IF(TAU*VINT(2).LT.1D0) GOTO 180 CALL PYKLIM(2) RYST=PYR(0) MYST=1 IF(RYST.GT.COEF(ISUB,8)) MYST=2 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 CALL PYKMAP(2,MYST,PYR(0)) VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) C...Check that x not used up. Accept or reject kinematical variables. X1M=SQRT(TAU)*EXP(VINT(22)) X2M=SQRT(TAU)*EXP(-VINT(22)) IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180 VINT(71)=0.5D0*VINT(1)*SQRT(XT2) CALL PYSIGH(NCHN,SIGS) IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320) IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320) C...Save if highest PT so far. IF (PT2.GT.PT2MX) THEN JSMX=0 MIMX=MINT(31)+1 PT2MX=PT2 ENDIF C---------------------------------------------------------------------- C...MODE=1: Generate and save accepted scattering. ELSEIF (MODE.EQ.1) THEN PT2=PT2NOW C...Reset K, P, V, and MCT vectors. DO 200 I=N+1,N+4 DO 190 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 190 CONTINUE MCT(I,1)=0 MCT(I,2)=0 200 CONTINUE NTRY=0 C...Choose flavour of reacting partons (and subprocess). 210 NTRY=NTRY+1 IF (NTRY.GT.50) THEN CALL PYERRM(9,'(PYPTMI:) Unable to generate additional ' & //'interaction. Giving up!') MINT(51)=1 RETURN ENDIF RSIGS=SIGS*PYR(0) DO 220 ICHN=1,NCHN KFL1=ISIG(ICHN,1) KFL2=ISIG(ICHN,2) ICONMI=ISIG(ICHN,3) RSIGS=RSIGS-SIGH(ICHN) IF(RSIGS.LE.0D0) GOTO 230 220 CONTINUE C...Reassign to appropriate process codes. 230 ISUBMI=ICONMI/10 ICONMI=MOD(ICONMI,10) C...Choose new quark flavour for annihilation graphs IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN SH=VINT(21)*VINT(2) CALL PYWIDT(21,SH,WDTP,WDTE) 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0) DO 250 I=1,MDCY(21,3) KFLF=KFDP(I+MDCY(21,2)-1,1) RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4)) IF(RKFL.LE.0D0) GOTO 260 250 CONTINUE 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN IF(KFLF.GE.4) GOTO 240 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN KFLF=4 ICONMI=ICONMI-2 ELSEIF(ISUBMI.EQ.53) THEN KFLF=5 ICONMI=ICONMI-4 ENDIF ENDIF C...Final state flavours and colour flow: default values JS=1 KFL3=KFL1 KFL4=KFL2 KCC=20 KCS=ISIGN(1,KFL1) IF(ISUBMI.EQ.11) THEN C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2 KCC=ICONMI IF(KFL1*KFL2.LT.0) KCC=KCC+2 ELSEIF(ISUBMI.EQ.12) THEN C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2 KFL3=ISIGN(KFLF,KFL1) KFL4=-KFL3 KCC=4 ELSEIF(ISUBMI.EQ.13) THEN C...f + fbar -> g + g; th arbitrary KFL3=21 KFL4=21 KCC=ICONMI+4 ELSEIF(ISUBMI.EQ.28) THEN C...f + g -> f + g; th = (p(f)-p(f))**2 IF(KFL1.EQ.21) JS=2 KCC=ICONMI+6 IF(KFL1.EQ.21) KCC=KCC+2 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1) IF(KFL2.NE.21) KCS=ISIGN(1,KFL2) ELSEIF(ISUBMI.EQ.53) THEN C...g + g -> f + fbar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) KFL3=ISIGN(KFLF,KCS) KFL4=-KFL3 KCC=ICONMI+10 ELSEIF(ISUBMI.EQ.68) THEN C...g + g -> g + g; th arbitrary KCC=ICONMI+12 KCS=(-1)**INT(1.5D0+PYR(0)) ENDIF C...Check that massive sea quarks have non-zero phase space for g -> Q Q IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5 & .OR.IABS(KFL4).EQ.5) THEN RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2 IF (PT2.LE.1.05*RMMAX2) THEN IF (NTRY.EQ.1) CALL PYERRM(9,'(PYPTMI:) Heavy quarks' & //' created below threshold. Rejected.') GOTO 210 ENDIF ENDIF C...Store flavours of scattering. MINT(13)=KFL1 MINT(14)=KFL2 MINT(15)=KFL1 MINT(16)=KFL2 MINT(21)=KFL3 MINT(22)=KFL4 C...Set flavours and mothers of scattering partons. K(N+1,1)=14 K(N+2,1)=14 K(N+3,1)=3 K(N+4,1)=3 K(N+1,2)=KFL1 K(N+2,2)=KFL2 K(N+3,2)=KFL3 K(N+4,2)=KFL4 K(N+1,3)=MINT(83)+1 K(N+2,3)=MINT(83)+2 K(N+3,3)=N+1 K(N+4,3)=N+2 C...Store colour connection indices. DO 270 J=1,2 JC=J IF(KCS.EQ.-1) JC=3-J IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC) IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC) IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC)) IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC)) 270 CONTINUE C...Store incoming and outgoing partons in their CM-frame. SHR=SQRT(VINT(21))*VINT(1) P(N+1,3)=0.5D0*SHR P(N+1,4)=0.5D0*SHR P(N+2,3)=-0.5D0*SHR P(N+2,4)=0.5D0*SHR P(N+3,5)=PYMASS(K(N+3,2)) P(N+4,5)=PYMASS(K(N+4,2)) IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN IFAIL=1 RETURN ENDIF P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR) P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2)) P(N+4,4)=SHR-P(N+3,4) P(N+4,3)=-P(N+3,3) C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4) PHI=PARU(2)*PYR(0) CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0) C...Global statistics. MINT(351)=MINT(351)+1 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2) IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2) C...Keep track of loose colour ends and information on scattering. MINT(31)=MINT(31)+1 MINT(36)=MINT(31) PT2MI(MINT(36))=PT2 IMISEP(MINT(31))=N+4 DO 280 JS=1,2 IMI(JS,MINT(31),1)=N+JS IMI(JS,MINT(31),2)=0 XMI(JS,MINT(31))=VINT(40+JS) NMI(JS)=NMI(JS)+1 C...Update cumulative counters VINT(142+JS)=VINT(142+JS)-VINT(40+JS) VINT(150+JS)=VINT(150+JS)+VINT(40+JS) 280 CONTINUE C...Add to list of final state partons IPART(NPART+1)=N+3 IPART(NPART+2)=N+4 PTPART(NPART+1)=SQRT(PT2) PTPART(NPART+2)=SQRT(PT2) NPART=NPART+2 C...Initialize ISR NISGEN(1,MINT(31))=0 NISGEN(2,MINT(31))=0 C...Update ER N=N+4 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS') MINT(51)=1 RETURN ENDIF C...Finally, assign colour tags to new partons DO 300 JS=1,2 I1=IMI(JS,MINT(31),1) I2=IMI(3-JS,MINT(31),1) DO 290 JCS=4,5 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2))) & GOTO 290 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290 KCS=JCS CALL PYCTTR(I1,KCS,I2) IF(MINT(51).NE.0) RETURN 290 CONTINUE 300 CONTINUE C---------------------------------------------------------------------- C...MODE=2: Decide whether quarks in last scattering were valence, C...companion, or sea. ELSEIF (MODE.EQ.2) THEN JS=MINT(30) MI=MINT(36) PT2=PT2NOW KFSBM=ISIGN(1,MINT(10+JS)) IFL=K(IMI(JS,MI,1),2) IMI(JS,MI,2)=0 IF (IABS(IFL).GE.6) THEN IF (IABS(IFL).EQ.6) THEN CALL PYERRM(29,'(PYPTMI:) top in initial state!') ENDIF RETURN ENDIF C...Get PDFs at X(rescaled) and PT2 of the current initiator. C...(Do not include the parton itself in the X rescaling.) X=XMI(JS,MI) XRSC=X/(VINT(142+JS)+X) C...Note: XPSVC = x*pdf. MINT(30)=JS CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ) SEA=XPSVC(IFL,-1) VAL=XPSVC(IFL,0) CMP=0D0 DO 310 IVC=1,NVC(JS,IFL) CMP=CMP+XPSVC(IFL,IVC) 310 CONTINUE C...Decide (Extra factor x cancels in the dvision). 320 RVCS=PYR(0)*(SEA+VAL+CMP) IVNOW=1 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN C...Safety check that valence present; pi0/gamma/K0S/K0L special cases. IVNOW=0 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1 IF(KFIVAL(JS,1).EQ.0) THEN IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND. & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1 ELSE C...Count down valence remaining. Do not count current scattering. DO 340 I1=1,NMI(JS) IF (I1.EQ.MINT(36)) GOTO 340 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0) & IVNOW=IVNOW-1 340 CONTINUE ENDIF IF(IVNOW.EQ.0) GOTO 330 C...Mark valence. IMI(JS,MI,2)=0 C...Sets valence content of gamma, pi0, K0S, K0L if not done. IF(KFIVAL(JS,1).EQ.0) THEN IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN KFIVAL(JS,1)=IFL KFIVAL(JS,2)=-IFL ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN KFIVAL(JS,1)=IFL IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL) IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL) ENDIF ENDIF ELSEIF (RVCS.LE.VAL+SEA) THEN C...If sea, add opposite sign companion parton. Store X and I. NVC(JS,-IFL)=NVC(JS,-IFL)+1 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI) C...Set pointer to companion IMI(JS,MI,2)=-NVC(JS,-IFL) ELSE C...If companion, decide which one. IF (NVC(JS,IFL).EQ.0) THEN CMP=0D0 CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!') GOTO 320 ENDIF CMPSUM=VAL+SEA ISEL=0 350 ISEL=ISEL+1 CMPSUM=CMPSUM+XPSVC(IFL,ISEL) IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350 C...Find original sea (anti-)quark. Do not consider current scattering. IASSOC=0 DO 360 I1=1,NMI(JS) IF (I1.EQ.MINT(36)) GOTO 360 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360 IF (-IMI(JS,I1,2).EQ.ISEL) THEN IMI(JS,MI,2)=IMI(JS,I1,1) IMI(JS,I1,2)=IMI(JS,MI,1) ENDIF 360 CONTINUE C...Mark companion "out-kicked". XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL) ENDIF ENDIF RETURN END C********************************************************************* C...PYFCMP: Auxiliary to PYPDFU and PYPTIS. C...Giving the x*f pdf of a companion quark, with its partner at XS, C...using an approximate gluon density like (1-X)^NPOW/X. The value C...corresponds to an unrescaled range between 0 and 1-X. FUNCTION PYFCMP(XC,XS,NPOW) IMPLICIT NONE DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC INTEGER NPOW PYFCMP=0D0 C...Parent gluon momentum fraction Y=XC+XS IF (Y.GE.1D0) RETURN C...Common factor (includes factor XC, since PYFCMP=x*f) FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4) C...Store normalized companion x*f distribution. IF (NPOW.LE.0) THEN PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS))) ELSEIF (NPOW.EQ.1) THEN PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS)) ELSEIF (NPOW.EQ.2) THEN PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS)) & +3D0*XS*(1D0+XS)*LOG(XS))) ELSEIF (NPOW.EQ.3) THEN PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS))) ELSEIF (NPOW.GE.4) THEN PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+ & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS))) ENDIF RETURN END C********************************************************************* C...PYPCMP: Auxiliary to PYPDFU. C...Giving the momentum integral of a companion quark, with its C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x. C...The value corresponds to an unrescaled range between 0 and 1-XS. FUNCTION PYPCMP(XS,NPOW) IMPLICIT NONE DOUBLE PRECISION XS, PYPCMP INTEGER NPOW IF (XS.GE.1D0.OR.XS.LE.0D0) THEN PYPCMP=0D0 ELSEIF (NPOW.LE.0) THEN PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS)) PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS))) ELSEIF (NPOW.EQ.1) THEN PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2)) & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS)) ELSEIF (NPOW.EQ.2) THEN PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS)) & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2)) PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS)) & -3D0*XS*LOG(XS)*(1+XS))) ELSEIF (NPOW.EQ.3) THEN PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS)) & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS)))) PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS))) ELSE PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS) & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS))) PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS)) & -6D0*XS*LOG(XS)*(1D0+XS))) ENDIF RETURN END C********************************************************************* C...PYUPRE C...Rearranges contents of the HEPEUP commonblock so that C...mothers precede daughters and daughters of a decay are C...listed consecutively. SUBROUTINE PYUPRE C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...User process event common block. INTEGER MAXNUP PARAMETER (MAXNUP=500) INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), &VTIMUP(MAXNUP),SPINUP(MAXNUP) SAVE /HEPEUP/ C...Local arrays. DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP), &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP), &VTIUPT(MAXNUP),SPIUPT(MAXNUP) C...Check whether a rearrangement is required. NEED=0 DO 100 IUP=1,NUP IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1 100 CONTINUE DO 110 IUP=2,NUP IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1 110 CONTINUE IF(NEED.NE.0) THEN C...Find the new order that particles should have. NEWPOS(0)=0 NNEW=0 INEW=-1 120 INEW=INEW+1 DO 130 IUP=1,NUP IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN NNEW=NNEW+1 NEWPOS(NNEW)=IUP ENDIF 130 CONTINUE IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120 IF(NNEW.NE.NUP) THEN CALL PYERRM(2, & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP') RETURN ENDIF C...Copy old info into temporary storage. DO 150 I=1,NUP IDUPT(I)=IDUP(I) ISTUPT(I)=ISTUP(I) MOTUPT(1,I)=MOTHUP(1,I) MOTUPT(2,I)=MOTHUP(2,I) ICOUPT(1,I)=ICOLUP(1,I) ICOUPT(2,I)=ICOLUP(2,I) DO 140 J=1,5 PUPT(J,I)=PUP(J,I) 140 CONTINUE VTIUPT(I)=VTIMUP(I) SPIUPT(I)=SPINUP(I) 150 CONTINUE C...Copy info back into HEPEUP in right order. DO 180 I=1,NUP IOLD=NEWPOS(I) IDUP(I)=IDUPT(IOLD) ISTUP(I)=ISTUPT(IOLD) MOTHUP(1,I)=0 MOTHUP(2,I)=0 DO 160 IMOT=1,I-1 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT 160 CONTINUE IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN MOTHSW=MOTHUP(1,I) MOTHUP(1,I)=MOTHUP(2,I) MOTHUP(2,I)=MOTHSW ENDIF ICOLUP(1,I)=ICOUPT(1,IOLD) ICOLUP(2,I)=ICOUPT(2,IOLD) DO 170 J=1,5 PUP(J,I)=PUPT(J,IOLD) 170 CONTINUE VTIMUP(I)=VTIUPT(IOLD) SPINUP(I)=SPIUPT(IOLD) 180 CONTINUE ENDIF c...If incoming particles are massive recalculate to put them massless. IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2)) PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2)) PUP(4,1)=0.5D0*PPLUS PUP(3,1)=PUP(4,1) PUP(5,1)=0D0 PUP(4,2)=0.5D0*PMINUS PUP(3,2)=-PUP(4,2) PUP(5,2)=0D0 ENDIF RETURN END C********************************************************************* C...PYADSH C...Administers the generation of successive final-state showers C...in external processes. SUBROUTINE PYADSH(NFIN) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement for maximum size of showers. PARAMETER (MAXNUR=1000) C...Commonblocks. COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYCTAG/NCT,MCT(4000,2) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/ C...Local array. DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3) C...Set primary vertex. DO 100 J=1,5 V(MINT(83)+5,J)=0D0 V(MINT(83)+6,J)=0D0 V(MINT(84)+1,J)=0D0 V(MINT(84)+2,J)=0D0 100 CONTINUE C...Isolate systems of particles with the same mother. NSYS=0 IMS=-1 DO 140 I=MINT(84)+3,NFIN IM=K(I,3) IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3) IF(IM.NE.IMS) THEN NSYS=NSYS+1 IBEG(NSYS)=I IMS=IM ENDIF C...Set production vertices. IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2)) & THEN DO 110 J=1,4 V(I,J)=0D0 110 CONTINUE ELSE DO 120 J=1,4 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5) 120 CONTINUE ENDIF IF(MSTP(125).GE.1) THEN IDOC=I-MSTP(126)+4 DO 130 J=1,5 V(IDOC,J)=V(I,J) 130 CONTINUE ENDIF 140 CONTINUE C...End loop over systems. Return if no showers to be performed. IBEG(NSYS+1)=NFIN+1 IF(MSTP(71).LE.0) RETURN C...Loop through systems of particles; check that sensible size. DO 270 ISYS=1,NSYS NSIZ=IBEG(ISYS+1)-IBEG(ISYS) IF(MINT(35).LE.1) THEN IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN GOTO 270 ELSEIF(NSIZ.LE.1) THEN CALL PYERRM(2,'(PYADSH:) only one particle in system') GOTO 270 ELSEIF(NSIZ.GT.80) THEN CALL PYERRM(2,'(PYADSH:) more than 80 particles in system') GOTO 270 ENDIF ENDIF C...Save status codes and daughters of showering particles; reset them. DO 150 J=1,4 PSUM(J)=0D0 150 CONTINUE DO 170 II=1,NSIZ I=IBEG(ISYS)-1+II KSAV(II,1)=K(I,1) IF(K(I,1).GT.10) THEN K(I,1)=1 IF(KSAV(II,1).EQ.14) K(I,1)=3 ENDIF IF(KSAV(II,1).LE.10) THEN ELSEIF(K(I,1).EQ.1) THEN KSAV(II,4)=K(I,4) KSAV(II,5)=K(I,5) K(I,4)=0 K(I,5)=0 ELSE KSAV(II,4)=MOD(K(I,4),MSTU(5)) KSAV(II,5)=MOD(K(I,5),MSTU(5)) K(I,4)=K(I,4)-KSAV(II,4) K(I,5)=K(I,5)-KSAV(II,5) ENDIF DO 160 J=1,4 PSUM(J)=PSUM(J)+P(I,J) 160 CONTINUE 170 CONTINUE C...Perform shower. QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2- & PSUM(3)**2)) IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55)) NSAV=N IF(MINT(35).LE.1) THEN IF(NSIZ.EQ.2) THEN 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/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYPARS/,/PYINT1/ C...HEPEVT commonblock. PARAMETER (NMXHEP=4000) COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) DOUBLE PRECISION PHEP,VHEP SAVE /HEPEVT/ C...Local array. DIMENSION IRESO(100) C...Define longitudinal boost from initiator rest frame to cm frame. 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...Oth pass: identify beam and incoming partons DO 140 I=MINT(83)+1,MINT(83)+6 ISTORE=0 IF(K(I,2).EQ.94) THEN ELSE ISTORE=1 NHEP=NHEP+1 II=NHEP NRESO=NRESO+1 IRESO(NRESO)=I IMOTH=K(I,3) ENDIF IF(ISTORE.EQ.1) THEN C...Copy parton info, boosting momenta along z axis to cm frame. ISTHEP(II)=2 IDHEP(II)=K(I,2) PHEP(1,II)=P(I,1) PHEP(2,II)=P(I,2) 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 140 CONTINUE C...First pass: identify final locations of resonances C...and of their daughters before showering. DO 150 I=MINT(84)+3,N ISTORE=0 IMOTH=0 C...Skip shower CM frame documentation lines. IF(K(I,2).EQ.94) THEN C... Store a new intermediate product, when mother in documentation. ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND. & K(I,3).LE.MINT(84)) THEN ISTORE=1 NHEP=NHEP+1 II=NHEP NRESO=NRESO+1 IRESO(NRESO)=I IMOTH=K(K(I,3),3) C... Store a new intermediate product, when mother in main section. ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND. & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN ISTORE=1 NHEP=NHEP+1 II=NHEP NRESO=NRESO+1 IRESO(NRESO)=I IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)) ENDIF IF(ISTORE.EQ.1) THEN C...Copy parton info, boosting momenta along z axis to cm frame. ISTHEP(II)=2 IDHEP(II)=K(I,2) PHEP(1,II)=P(I,1) PHEP(2,II)=P(I,2) PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4) PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3) PHEP(5,II)=P(I,5) C...Store one mother. Rest of history and vertex info zeroed. JMOHEP(1,II)=IMOTH JMOHEP(2,II)=0 JDAHEP(1,II)=I JDAHEP(2,II)=0 VHEP(1,II)=0D0 VHEP(2,II)=0D0 VHEP(3,II)=0D0 VHEP(4,II)=0D0 ENDIF 150 CONTINUE C...Second pass: identify current set of "final" partons. DO 200 I=MINT(84)+3,N ISTORE=0 IMOTH=0 C...Store a final parton. IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN ISTORE=1 NHEP=NHEP+1 II=NHEP C..Trace it back through shower, to check if from documented particle. IHIST=I ISAVE=IHIST 160 CONTINUE IF(IHIST.GT.MINT(84)) THEN IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST) DO 170 IRI=1,NRESO IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI 170 CONTINUE ISAVE=IHIST IHIST=K(IHIST,3) IF(IMOTH.EQ.0) GOTO 160 ELSEIF(IHIST.LE.4) THEN IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN ISTORE=0 NHEP=NHEP-1 ELSE IMOTH=IHIST ENDIF ENDIF ENDIF IF(ISTORE.EQ.1) THEN C...Copy parton info, boosting momenta along z axis to cm frame. ISTHEP(II)=1 IDHEP(II)=K(I,2) PHEP(1,II)=P(I,1) PHEP(2,II)=P(I,2) PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4) PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3) PHEP(5,II)=P(I,5) C...Store one mother. Rest of history and vertex info zeroed. JMOHEP(1,II)=IMOTH JMOHEP(2,II)=0 JDAHEP(1,II)=0 JDAHEP(2,II)=0 VHEP(1,II)=0D0 VHEP(2,II)=0D0 VHEP(3,II)=0D0 VHEP(4,II)=0D0 ENDIF 200 CONTINUE C...Call user-written routine to decide whether to keep events. CALL UPVETO(IVETO) RETURN END C********************************************************************* C...PYRESD C...Allows resonances to decay (including parton showers for hadronic C...channels). SUBROUTINE PYRESD(IRES) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Parameter statement for maximum size of showers. PARAMETER (MAXNUR=1000) C...Commonblocks. COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYCTAG/NCT,MCT(4000,2) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT4/MWID(500),WIDS(500,5) SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/, &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/ C...Local arrays and complex and character variables. DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3), &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6), &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3), &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4), &ITJUNC(3),CTM2(3) COMPLEX FGK,HA(6,6),HC(6,6) REAL TIR,UIR CHARACTER CODE*9,MASS*9 C...The F, Xi and Xj functions of Gunion and Kunszt C...(Phys. Rev. D33, 665, plus errata from the authors). FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)* &HC(I1,I4)+HA(I3,I5)*HC(I3,I4)) DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/ &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34)) DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU- &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+ &2D0*(D34/D56+D56/D34)) C...Some general constants. XW=PARU(102) XWV=XW IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2 XW1=1D0-XW SQMZ=PMAS(23,1)**2 GMMZ=PMAS(23,1)*PMAS(23,2) SQMW=PMAS(24,1)**2 GMMW=PMAS(24,1)*PMAS(24,2) SH=VINT(44) C...Boost and rotate to rest frame of incoming partons, C...to get proper amount of smearing of decay angles. IBST=0 IF(IRES.EQ.0) THEN IBST=1 ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4) BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN) PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2)) CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0) THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1)) CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0) ENDIF C...Reset original resonance configuration. DO 100 JT=1,8 IREF(1,JT)=0 100 CONTINUE C...Define initial one, two or three objects for subprocess. IHDEC=0 IF(IRES.EQ.0) THEN ISUB=MINT(1) IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN IREF(1,1)=MINT(84)+2+ISET(ISUB) IREF(1,4)=MINT(83)+6+ISET(ISUB) JTMAX=1 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN IREF(1,1)=MINT(84)+1+ISET(ISUB) IREF(1,2)=MINT(84)+2+ISET(ISUB) IREF(1,4)=MINT(83)+5+ISET(ISUB) IREF(1,5)=MINT(83)+6+ISET(ISUB) JTMAX=2 ELSEIF(ISET(ISUB).EQ.5) THEN IREF(1,1)=MINT(84)+3 IREF(1,2)=MINT(84)+4 IREF(1,3)=MINT(84)+5 IREF(1,4)=MINT(83)+7 IREF(1,5)=MINT(83)+8 IREF(1,6)=MINT(83)+9 JTMAX=3 ENDIF C...Define original resonance for odd cases. ELSE ISUB=0 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36) & IHDEC=1 IF(IHDEC.EQ.1) ISUB=3 IREF(1,1)=IRES IREF(1,4)=K(IRES,3) IRESTM=IRES IF(IREF(1,4).GT.MINT(84)) THEN 110 ITMPMO=IREF(1,4) IF(K(ITMPMO,2).EQ.94) THEN IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1) IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3) ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN IRESTM=ITMPMO C...Explicitly check that reference particle exists, otherwise stop recursion IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN IREF(1,4)=K(ITMPMO,3) GOTO 110 ENDIF ENDIF ENDIF IF(IREF(1,4).GT.MINT(84)) THEN EMATCH=1D10 IREF14=IREF(1,4) DO 120 II=MINT(83)+7,MINT(83)+MINT(4) IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT. & EMATCH) THEN IREF(1,4)=II EMATCH=ABS(P(II,4)-P(IREF14,4)) ENDIF 120 CONTINUE ENDIF JTMAX=1 ENDIF C...Check if initial resonance has been moved (in resonance + jet). DO 140 JT=1,3 IF(IREF(1,JT).GT.0) THEN IF(K(IREF(1,JT),1).GT.10) THEN KFA=IABS(K(IREF(1,JT),2)) IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN KDA1=MOD(K(IREF(1,JT),4),MSTU(5)) KDA2=MOD(K(IREF(1,JT),5),MSTU(5)) IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5) ENDIF IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5) ENDIF DO 130 I=IREF(1,JT)+1,N IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR. & I.EQ.KDA2)) THEN IREF(1,JT)=I KDA1=MOD(K(IREF(1,JT),4),MSTU(5)) KDA2=MOD(K(IREF(1,JT),5),MSTU(5)) IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5) ENDIF IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5) ENDIF ENDIF 130 CONTINUE ELSE KDA=MOD(K(IREF(1,JT),4),MSTU(5)) IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA ENDIF ENDIF ENDIF 140 CONTINUE C...Set decay vertex for initial resonances DO 160 JT=1,JTMAX DO 150 I=1,4 V(IREF(1,JT),I)=0D0 150 CONTINUE 160 CONTINUE C...Loop over decay history. NP=1 IP=0 170 IP=IP+1 NINH=0 JTMAX=2 IF(IREF(IP,2).EQ.0) JTMAX=1 IF(IREF(IP,3).NE.0) JTMAX=3 IT4=0 NSAV=N C...Check for Higgs which appears as decay product of user-process. IF(ISUB.EQ.0) THEN IHDEC=0 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7) & .EQ.36) IHDEC=1 IF(IHDEC.EQ.1) ISUB=3 ENDIF C...Start treatment of one, two or three resonances in parallel. 180 N=NSAV DO 340 JT=1,JTMAX ID=IREF(IP,JT) KDCY(JT)=0 KFL1(JT)=0 KFL2(JT)=0 KFL3(JT)=0 KEQL(JT)=0 NSD(JT)=ID ITJUNC(JT)=0 C...Check whether particle can/is allowed to decay. IF(ID.EQ.0) GOTO 330 KFA=IABS(K(ID,2)) KCA=PYCOMP(KFA) IF(MWID(KCA).EQ.0) GOTO 330 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR. & KFA.EQ.18) IT4=IT4+1 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5)) K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5)) C...Choose lifetime and determine decay vertex. IF(K(ID,1).EQ.5) THEN V(ID,5)=0D0 ELSEIF(K(ID,1).NE.4) THEN V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0)) ENDIF DO 190 J=1,4 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5) 190 CONTINUE C...Determine whether decay allowed or not. MOUT=0 IF(MSTJ(22).EQ.2) THEN IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1 ELSEIF(MSTJ(22).EQ.3) THEN IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1 ELSEIF(MSTJ(22).EQ.4) THEN IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1 ENDIF IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN K(ID,1)=4 GOTO 330 ENDIF C...Info for selection of decay channel: sign, pairings. IF(KCHG(KCA,3).EQ.0) THEN IPM=2 ELSE IPM=(5-ISIGN(1,K(ID,2)))/2 ENDIF KFB=0 IF(JTMAX.EQ.2) THEN KFB=IABS(K(IREF(IP,3-JT),2)) ELSEIF(JTMAX.EQ.3) THEN JT2=JT+1-3*(JT/3) KFB=IABS(K(IREF(IP,JT2),2)) IF(KFB.NE.KFA) THEN JT2=JT+2-3*((JT+1)/3) KFB=IABS(K(IREF(IP,JT2),2)) ENDIF ENDIF C...Select decay channel. IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR. & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE) WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4) IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5) IF(WDTE0S.LE.0D0) GOTO 330 RKFL=WDTE0S*PYR(0) IDL=0 200 IDL=IDL+1 IDC=IDL+MDCY(KCA,2)-1 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4)) IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5) IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200 C...Read out flavours and colour charges of decay channel chosen. KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2)) IF(KCQM(JT).EQ.-2) KCQM(JT)=2 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2)) KFC1A=PYCOMP(IABS(KFL1(JT))) IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT)) KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT)) IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2)) KFC2A=PYCOMP(IABS(KFL2(JT))) IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT)) KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT)) IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2)) KCQ3(JT)=0 IF(KFL3(JT).NE.0) THEN KFC3A=PYCOMP(IABS(KFL3(JT))) IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT)) KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT)) IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2 ENDIF C...Set/save further info on channel. KDCY(JT)=1 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1) NSD(JT)=N HGZ(JT,1)=VINT(111) HGZ(JT,2)=VINT(112) HGZ(JT,3)=VINT(114) JTZ=JT C...Select masses; to begin with assume resonances narrow. DO 220 I=1,3 P(N+I,5)=0D0 PMMN(I)=0D0 IF(I.EQ.1) THEN KFLW=IABS(KFL1(JT)) KCW=KFC1A ELSEIF(I.EQ.2) THEN KFLW=IABS(KFL2(JT)) KCW=KFC2A ELSEIF(I.EQ.3) THEN IF(KFL3(JT).EQ.0) GOTO 220 KFLW=IABS(KFL3(JT)) KCW=KFC3A ENDIF P(N+I,5)=PMAS(KCW,1) CMRENNA++ C...This prevents SUSY/t particles from becoming too light. IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN PMMN(I)=PMAS(KCW,1) DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+ & PMAS(PYCOMP(KFDP(IDC,2)),1) IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+ & PMAS(PYCOMP(KFDP(IDC,3)),1) PMMN(I)=MIN(PMMN(I),PMSUM) ENDIF 210 CONTINUE CMRENNA-- ELSEIF(KFLW.EQ.6) THEN PMMN(I)=PMAS(24,1)+PMAS(5,1) ENDIF 220 CONTINUE C...Check which two out of three are widest. IWID1=1 IWID2=2 PWID1=PMAS(KFC1A,2) PWID2=PMAS(KFC2A,2) KFLW1=IABS(KFL1(JT)) KFLW2=IABS(KFL2(JT)) IF(KFL3(JT).NE.0) THEN PWID3=PMAS(KFC3A,2) IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN IWID1=3 PWID1=PWID3 KFLW1=IABS(KFL3(JT)) ELSEIF(PWID3.GT.PWID2) THEN IWID2=3 PWID2=PWID3 KFLW2=IABS(KFL3(JT)) ENDIF ENDIF C...If all narrow then only check that masses consistent. IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND. & PWID2.LT.PARP(41))) THEN CMRENNA++ C....Handle near degeneracy cases. IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0 ENDIF ENDIF CMRENNA-- IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN CALL PYERRM(13,'(PYRESD:) daughter masses too large') MINT(51)=1 GOTO 720 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN CALL PYERRM(3,'(PYRESD:) daughter masses too large') MINT(51)=1 GOTO 720 ENDIF C...For three wide resonances select narrower of three C...according to BW decoupled from rest. ELSE PMTOT=P(ID,5) IF(KFL3(JT).NE.0) THEN IWID3=6-IWID1-IWID2 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))- & KFLW1-KFLW2 LOOP=0 230 LOOP=LOOP+1 P(N+IWID3,5)=PYMASS(KFLW3) IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230 PMTOT=PMTOT-P(N+IWID3,5) ENDIF C...Select other two correlated within remaining phase space. IF(IP.EQ.1) THEN CKIN45=CKIN(45) CKIN47=CKIN(47) CKIN(45)=MAX(PMMN(IWID1),CKIN(45)) CKIN(47)=MAX(PMMN(IWID2),CKIN(47)) CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5), & P(N+IWID2,5)) CKIN(45)=CKIN45 CKIN(47)=CKIN47 ELSE CKIN(49)=PMMN(IWID1) CKIN(50)=PMMN(IWID2) CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5), & P(N+IWID2,5)) CKIN(49)=0D0 CKIN(50)=0D0 ENDIF IF(MINT(51).EQ.1) GOTO 720 ENDIF C...Begin fill decay products, with colour flow for coloured objects. MSTU10=MSTU(10) MSTU(10)=1 MSTU(19)=1 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) C...Allow FSR for UE IF(MSTP(152).EQ.1) CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT) 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 parton not existing or does not have KCS IF (K(I,1).LE.0) GOTO 120 KC=PYCOMP(K(I,2)) IF (KC.EQ.0) GOTO 120 KQ=KCHG(KC,2) IF (KQ.EQ.0) GOTO 120 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2))) & GOTO 120 IF (KCS.GT.0) THEN NCT=NCT+1 C...Set colour tag of first parton. MCT(I,KCS-3)=NCT NCS=NCT ELSE KCS=-KCS NCS=MCT(I,KCS-3) IF (NCS.EQ.0) GOTO 120 ENDIF IA=I NSTP=0 100 NSTP=NSTP+1 IF(NSTP.GT.4*N) THEN CALL PYERRM(14,'(PYCTTR:) caught in infinite loop') GOTO 120 ENDIF C...Finished if reached final-state triplet. IF(K(IA,1).EQ.3) THEN IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120 ENDIF C...Also finished if reached junction. IF(K(IA,1).EQ.42) THEN GOTO 120 ENDIF C...GOTO next parton in colour space. 110 IB=IA C...If IB's KCS daughter not traced and exists, goto KCS daughter. IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5)) & .NE.0) THEN IA=MOD(K(IB,KCS),MSTU(5)) K(IB,KCS)=K(IB,KCS)+MSTU(5)**2 MREV=0 ELSE C...If KCS mother traced or KCS mother nonexistent, switch colour. IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5), & MSTU(5)).EQ.0) THEN KCS=9-KCS NCT=NCT+1 NCS=NCT C...Assign new colour tag on other side of old parton. MCT(IB,KCS-3)=NCT ENDIF C...Goto (new) KCS mother, set mother traced tag IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5)) K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2 MREV=1 ENDIF IF(IA.LE.0.OR.IA.GT.N) THEN CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed') IF(NERRPR.LT.5) THEN write(*,*) 'began at ',I write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS, & ' NCS=',NCS,' MREV=',MREV CALL PYLIST(4) NERRPR=NERRPR+1 ENDIF MINT(51)=1 RETURN ENDIF IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5), & MSTU(5)).EQ.IB) THEN IF(MREV.EQ.1) KCS=9-KCS IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS C...Set KSC mother traced tag for IA K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2 ELSE IF(MREV.EQ.0) KCS=9-KCS IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS C...Set KCS daughter traced tag for IA K(IA,KCS)=K(IA,KCS)+MSTU(5)**2 ENDIF C...Assign new colour tag MCT(IA,KCS-3)=NCS IF(IA.NE.I.AND.IA.NE.IEND) GOTO 100 120 RETURN END ********************************************************************* C...PYMIHG C...Collapse JCP1 and connecting tags to JCG1. C...Collapse JCP2 and connecting tags to JCG2. SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...The event record COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) C...Parameters COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYINT1/ C...Local variables COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT COMMON /PYCTAG/NCT,MCT(4000,2) SAVE /PYCBLS/,/PYCTAG/ C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags C...in temporary tag collapse array JCCN. Only break up one connection. MACCPT=1 MCLPS=0 DO 100 ICC=1,NCC JCCN(ICC,1)=JCCO(ICC,1) JCCN(ICC,2)=JCCO(ICC,2) C...If there was a mother, it was previously connected to JCP1. C...Should be changed to JCP2. IF (MCLPS.EQ.0) THEN IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1 & ,JCP2)) THEN JCCN(ICC,1)=MAX(JCG2,JCP2) JCCN(ICC,2)=MIN(JCG2,JCP2) MCLPS=1 ENDIF ENDIF 100 CONTINUE C...Also collapse colours on JCP1 side of JCG1 IF (JCP1.NE.0) THEN JCCN(NCC+1,1)=MAX(JCP1,JCG1) JCCN(NCC+1,2)=MIN(JCP1,JCG1) ELSE JCCN(NCC+1,1)=MAX(JCP2,JCG2) JCCN(NCC+1,2)=MIN(JCP2,JCG2) ENDIF C...Initialize event record colour tag array MCT array to MCO. DO 110 I=MINT(84)+1,N MCT(I,1)=MCO(I,1) MCT(I,2)=MCO(I,2) 110 CONTINUE C...Collapse tags: C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1 C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2 C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1 C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2 DO 160 IS=1,4 C...Skip if junction. IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160 C...Define starting point in tag space. C...JCA = previous tag C...JCO = present tag C...JCN = new tag IF (MOD(IS,2).EQ.1) THEN JCO=JCP1 JCN=JCG1 JCALL=JCG1 ELSEIF (MOD(IS,2).EQ.0) THEN JCO=JCP2 JCN=JCG2 JCALL=JCG2 ENDIF ITRACE=0 120 ITRACE=ITRACE+1 IF (ITRACE.GT.1000) THEN C...NB: Proper error message should be defined here. CALL PYERRM(14 & ,'(PYMIHG:) Inf loop when collapsing colours.') MINT(57)=MINT(57)+1 MINT(51)=1 RETURN ENDIF C...Collapse all JCN tags to JCALL DO 130 I=MINT(84)+1,N IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL 130 CONTINUE C...IS = 1,2: first step forward. IS = 3,4: first step backward. IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN JCA=JCN JCN=JCO ELSE JCA=JCO JCO=JCN ENDIF C...If possible, step from JCO to new tag JCN not equal to JCA. DO 140 ICC=1,NCC+1 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN= & JCCN(ICC,2) IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN= & JCCN(ICC,1) 140 CONTINUE C...Iterate if new colour was arrived at, but don't go in circles. IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120 C...Change all JCN tags in MCO to JCALL in MCT. DO 150 I=MINT(84)+1,N IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL C...If gluon and colour tag = anticolour tag (and not = 0) try again. IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1) & .NE.0) MACCPT=0 150 CONTINUE 160 CONTINUE DO 200 JCL=NCT,1,-1 JCA=0 JCN=JCL 170 JCO=JCN DO 180 ICC=1,NCC+1 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN & =JCCN(ICC,2) IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN & =JCCN(ICC,1) 180 CONTINUE C...Overpaint all JCN with JCL IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN DO 190 I=MINT(84)+1,N IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL C...If gluon and colour tag = anticolour tag (and not = 0) try again. IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1) & .NE.0) MACCPT=0 190 CONTINUE JCA=JCO GOTO 170 ENDIF 200 CONTINUE RETURN END C********************************************************************* C...PYMIRM C...Picks primordial kT and shares longitudinal momentum among C...beam remnants. SUBROUTINE PYMIRM C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...The event record COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) C...Parameters COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) C...The common block of colour tags. COMMON/PYCTAG/NCT,MCT(4000,2) C...The common block of dangling ends COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), & XMI(2,240),PT2MI(240),IMISEP(0:240) SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/ C...Local variables DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2) C...W(I,J)| J=0 | 1 | 2 | C... I=0 | Wrem**2 | W+ | W- | C... 1 | W1**2 | W1+ | W1- | C... 2 | W2**2 | W2+ | W2- | C...4-product FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) C...Tentative parametrization of 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 CALL PYERRM(31,' PYFSCR: infinite loop in color annealing') CALL PYSTOP(11) ENDIF ELSE C...Save and exit. First check for leftover gluon(s) DO 260 I=MAX(1,IP),N C...Check colour charge MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2)) IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN C...Decide where to put left-over gluon (minimal insertion) ILMAX=0 RLMAX=1D19 DO 250 KCT=NCT+1,LCT DO 240 IT=MAX(1,IP),N IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240 IF (MCN(IT,1).EQ.KCT) IC=IT IF (MCN(IT,2).EQ.KCT) IA=IT 240 CONTINUE RL=FOUR(IC,I)*FOUR(IA,I) IF (RL.LT.RLMAX) THEN RLMAX=RL ICMAX=IC IAMAX=IA ENDIF 250 CONTINUE LCT=LCT+1 MCN(I,1)=MCN(ICMAX,1) MCN(I,2)=LCT MCN(ICMAX,1)=LCT ENDIF 260 CONTINUE DO 270 I=MAX(1,IP),N C...Do not erase parton shower colour history IF (K(I,1).NE.3) GOTO 270 C...Check colour charge MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2)) IF (MCI.EQ.0) GOTO 270 IF (MCN(I,1).NE.0) MCT(I,1)=MCN(I,1) IF (MCN(I,2).NE.0) MCT(I,2)=MCN(I,2) 270 CONTINUE ENDIF 9999 RETURN END C********************************************************************* C...PYDIFF C...Handles diffractive and elastic scattering. SUBROUTINE PYDIFF C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/ C...Reset K, P and V vectors. Store incoming particles. DO 110 JT=1,MSTP(126)+10 I=MINT(83)+JT DO 100 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 100 CONTINUE 110 CONTINUE N=MINT(84) MINT(3)=0 MINT(21)=0 MINT(22)=0 MINT(23)=0 MINT(24)=0 MINT(4)=4 DO 130 JT=1,2 I=MINT(83)+JT K(I,1)=21 K(I,2)=MINT(10+JT) DO 120 J=1,5 P(I,J)=VINT(285+5*JT+J) 120 CONTINUE 130 CONTINUE MINT(6)=2 C...Subprocess; kinematics. SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64) PZ=SQRT(SQLAM)/(2D0*VINT(1)) DO 200 JT=1,2 I=MINT(83)+JT PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1)) KFH=MINT(102+JT) C...Elastically scattered particle. (Except elastic GVMD states.) IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR. & MINT(106+JT).NE.3)) THEN N=N+1 K(N,1)=1 K(N,2)=KFH K(N,3)=I+2 P(N,3)=PZ*(-1)**(JT+1) P(N,4)=PE P(N,5)=SQRT(VINT(62+JT)) C...Decay rho from elastic scattering of gamma with sin**2(theta) C...distribution of decay products (in rho rest frame). IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN NSAV=N DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2) P(N,3)=0D0 P(N,4)=P(N,5) CALL PYDECY(NSAV) IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2)) CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0) THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1)) CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0) 140 CTHE=2D0*PYR(0)-1D0 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0) ENDIF CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ) ENDIF C...Diffracted particle: low-mass system to two particles. ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN N=N+2 K(N-1,1)=1 K(N,1)=1 K(N-1,3)=I+2 K(N,3)=I+2 PMMAS=SQRT(VINT(62+JT)) NTRY=0 150 NTRY=NTRY+1 IF(NTRY.LT.20) THEN MINT(105)=MINT(102+JT) MINT(109)=MINT(106+JT) CALL PYSPLI(KFH,21,KFL1,KFL2) CALL PYKFDI(KFL1,0,KFL3,KF1) IF(KF1.EQ.0) GOTO 150 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2) IF(KF2.EQ.0) GOTO 150 ELSE KF1=KFH KF2=111 ENDIF PM1=PYMASS(KF1) PM2=PYMASS(KF2) IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150 K(N-1,2)=KF1 K(N,2)=KF2 P(N-1,5)=PM1 P(N,5)=PM2 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2- & 4D0*PM1**2*PM2**2))/(2D0*PMMAS) P(N-1,3)=PZP P(N,3)=-PZP P(N-1,4)=SQRT(PM1**2+PZP**2) P(N,4)=SQRT(PM2**2+PZP**2) CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0), & 0D0,0D0,0D0) DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2) CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ) C...Diffracted particle: valence quark kicked out. ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT. & PARP(101))) THEN N=N+2 K(N-1,1)=2 K(N,1)=1 K(N-1,3)=I+2 K(N,3)=I+2 MINT(105)=MINT(102+JT) MINT(109)=MINT(106+JT) CALL PYSPLI(KFH,21,K(N,2),K(N-1,2)) P(N-1,5)=PYMASS(K(N-1,2)) P(N,5)=PYMASS(K(N,2)) SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2- & 4D0*P(N-1,5)**2*P(N,5)**2 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2- & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1) P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2) P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3) P(N,4)=SQRT(P(N,3)**2+P(N,5)**2) C...Diffracted particle: gluon kicked out. ELSE N=N+3 K(N-2,1)=2 K(N-1,1)=2 K(N,1)=1 K(N-2,3)=I+2 K(N-1,3)=I+2 K(N,3)=I+2 MINT(105)=MINT(102+JT) MINT(109)=MINT(106+JT) CALL PYSPLI(KFH,21,K(N,2),K(N-2,2)) K(N-1,2)=21 P(N-2,5)=PYMASS(K(N-2,2)) P(N-1,5)=0D0 P(N,5)=PYMASS(K(N,2)) C...Energy distribution for particle into two jets. 160 IMB=1 IF(MOD(KFH/1000,10).NE.0) IMB=2 CHIK=PARP(92+2*IMB) IF(MSTP(92).LE.1) THEN IF(IMB.EQ.1) CHI=PYR(0) IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0)) ELSEIF(MSTP(92).EQ.2) THEN CHI=1D0-PYR(0)**(1D0/(1D0+CHIK)) ELSEIF(MSTP(92).EQ.3) THEN CUT=2D0*0.3D0/VINT(1) 170 CHI=PYR(0)**2 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT. & PYR(0)) GOTO 170 ELSEIF(MSTP(92).EQ.4) THEN CUT=2D0*0.3D0/VINT(1) CUTR=(1D0+SQRT(1D0+CUT**2))/CUT 180 CHIR=CUT*CUTR**PYR(0) CHI=(CHIR**2-CUT**2)/(2D0*CHIR) IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180 ELSE CUT=2D0*0.3D0/VINT(1) CUTA=CUT**(1D0-PARP(98)) CUTB=(1D0+CUT)**(1D0-PARP(98)) 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98))) IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))** & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190 ENDIF IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/ & VINT(62+JT)) GOTO 160 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/ & (2D0*VINT(62+JT)) PEI=SQRT(PZI**2+SQM) PQQP=(1D0-CHI)*(PEI+PZI) P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1) P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2) P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI) P(N-1,3)=P(N-1,4)*(-1)**JT P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3) P(N,4)=SQRT(P(N,3)**2+P(N,5)**2) ENDIF C...Documentation lines. K(I+2,1)=21 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND. & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10) K(I+2,3)=I P(I+2,3)=PZ*(-1)**(JT+1) P(I+2,4)=PE P(I+2,5)=SQRT(VINT(62+JT)) 200 CONTINUE C...Rotate outgoing partons/particles using cos(theta). IF(VINT(23).LT.0.9D0) THEN CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0) ELSE CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0) ENDIF RETURN END C********************************************************************* C...PYDISG C...Set up a DIS process as gamma* + f -> f, with beam remnant C...and showering added consecutively. Photon flux by the PYGAGA C...routine (if at all). SUBROUTINE PYDISG C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/ C...Local arrays. DIMENSION PMS(4) C...Choice of subprocess, number of documentation lines IDOC=7 MINT(3)=IDOC-6 MINT(4)=IDOC IPU1=MINT(84)+1 IPU2=MINT(84)+2 IPU3=MINT(84)+3 ISIDE=1 IF(MINT(107).EQ.4) ISIDE=2 C...Reset K, P and V vectors. Store incoming particles DO 110 JT=1,MSTP(126)+20 I=MINT(83)+JT DO 100 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 100 CONTINUE 110 CONTINUE DO 130 JT=1,2 I=MINT(83)+JT K(I,1)=21 K(I,2)=MINT(10+JT) DO 120 J=1,5 P(I,J)=VINT(285+5*JT+J) 120 CONTINUE 130 CONTINUE MINT(6)=2 C...Store incoming partons in hadronic CM-frame DO 140 JT=1,2 I=MINT(84)+JT K(I,1)=14 K(I,2)=MINT(14+JT) K(I,3)=MINT(83)+2+JT 140 CONTINUE IF(MINT(15).EQ.22) THEN P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1)) P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1)) P(MINT(84)+1,5)=-SQRT(VINT(307)) P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1) P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1) KFRES=MINT(16) ISIDE=2 ELSE P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1) P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1) P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1)) P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1)) P(MINT(84)+1,5)=-SQRT(VINT(308)) KFRES=MINT(15) ISIDE=1 ENDIF SIDESG=(-1D0)**(ISIDE-1) C...Copy incoming partons to documentation lines. DO 170 JT=1,2 I1=MINT(83)+4+JT I2=MINT(84)+JT K(I1,1)=21 K(I1,2)=K(I2,2) K(I1,3)=I1-2 DO 150 J=1,5 P(I1,J)=P(I2,J) 150 CONTINUE C...Second copy for partons before ISR shower, since no such. I1=MINT(83)+2+JT K(I1,1)=21 K(I1,2)=K(I2,2) K(I1,3)=I1-2 DO 160 J=1,5 P(I1,J)=P(I2,J) 160 CONTINUE 170 CONTINUE C...Define initial partons. NTRY=0 180 NTRY=NTRY+1 IF(NTRY.GT.100) THEN MINT(51)=1 RETURN ENDIF C...Scattered quark in hadronic CM frame. I=MINT(83)+7 K(IPU3,1)=3 K(IPU3,2)=KFRES K(IPU3,3)=I P(IPU3,5)=PYMASS(KFRES) P(IPU3,3)=P(IPU1,3)+P(IPU2,3) P(IPU3,4)=P(IPU1,4)+P(IPU2,4) P(IPU3,5)=0D0 K(I,1)=21 K(I,2)=KFRES K(I,3)=MINT(83)+4+ISIDE P(I,3)=P(IPU3,3) P(I,4)=P(IPU3,4) P(I,5)=P(IPU3,5) N=IPU3 MINT(21)=KFRES MINT(22)=0 C...No primordial kT, or chosen according to truncated Gaussian or C...exponential, or (for photon) predetermined or power law. 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN IF(MSTP(91).LE.0) THEN PT=0D0 ELSEIF(MSTP(91).EQ.1) THEN PT=PARP(91)*SQRT(-LOG(PYR(0))) ELSE RPT1=PYR(0) RPT2=PYR(0) PT=-PARP(92)*LOG(RPT1*RPT2) ENDIF IF(PT.GT.PARP(93)) GOTO 190 ELSEIF(MINT(106+ISIDE).EQ.3) THEN PTA=SQRT(VINT(282+ISIDE)) PTB=0D0 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN PTB=PARP(99)*SQRT(-LOG(PYR(0))) ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN RPT1=PYR(0) RPT2=PYR(0) PTB=-PARP(99)*LOG(RPT1*RPT2) ENDIF IF(PTB.GT.PARP(100)) GOTO 190 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0))) IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10) ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN IF(MSTP(93).LE.0) THEN PT=0D0 ELSEIF(MSTP(93).EQ.1) THEN PT=PARP(99)*SQRT(-LOG(PYR(0))) ELSEIF(MSTP(93).EQ.2) THEN RPT1=PYR(0) RPT2=PYR(0) PT=-PARP(99)*LOG(RPT1*RPT2) ELSEIF(MSTP(93).EQ.3) THEN HA=PARP(99)**2 HB=PARP(100)**2 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA)) ELSE HA=PARP(99)**2 HB=PARP(100)**2 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2) PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA)) ENDIF IF(PT.GT.PARP(100)) GOTO 190 ELSE PT=0D0 ENDIF VINT(156+ISIDE)=PT PHI=PARU(2)*PYR(0) P(IPU3,1)=PT*COS(PHI) P(IPU3,2)=PT*SIN(PHI) P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2) PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2 PCP=P(IPU3,4)+ABS(P(IPU3,3)) C...Find one or two beam remnants. MINT(105)=MINT(102+ISIDE) MINT(109)=MINT(106+ISIDE) CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP) IF(MINT(51).NE.0) THEN MINT(51)=0 GOTO 180 ENDIF C...Store first remnant parton, with colour info and kinematics. I=N+1 K(I,1)=1 K(I,2)=KFLSP K(I,3)=MINT(83)+ISIDE P(I,5)=PYMASS(K(I,2)) KCOL=KCHG(PYCOMP(KFLSP),2) IF(KCOL.NE.0) THEN K(I,1)=3 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2 K(I,KFLS+3)=MSTU(5)*IPU3 K(IPU3,6-KFLS)=MSTU(5)*I ICOLR=I ENDIF IF(KFLCH.EQ.0) THEN P(I,1)=-P(IPU3,1) P(I,2)=-P(IPU3,2) PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2 P(I,3)=-P(IPU3,3) P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2) PRP=P(I,4)+ABS(P(I,3)) C...When extra remnant parton or hadron: store extra remnant. ELSE I=I+1 K(I,1)=1 K(I,2)=KFLCH K(I,3)=MINT(83)+ISIDE P(I,5)=PYMASS(K(I,2)) KCOL=KCHG(PYCOMP(KFLCH),2) IF(KCOL.NE.0) THEN K(I,1)=3 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2 K(I,KFLS+3)=MSTU(5)*IPU3 K(IPU3,6-KFLS)=MSTU(5)*I ICOLR=I ENDIF C...Relative transverse momentum when two remnants. LOOP=0 200 LOOP=LOOP+1 CALL PYPTDI(1,P(I-1,1),P(I-1,2)) P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1) P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2) PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2 P(I,1)=-P(IPU3,1)-P(I-1,1) P(I,2)=-P(IPU3,2)-P(I-1,2) PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2 C...Relative distribution of energy for particle into jet plus particle. IMB=1 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2 IF(MSTP(94).LE.1) THEN IF(IMB.EQ.1) CHI=PYR(0) IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0)) IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI ELSEIF(MSTP(94).EQ.2) THEN CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB))) IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI ELSEIF(MSTP(94).EQ.3) THEN CALL PYZDIS(1,0,PMS(4),ZZ) CHI=ZZ ELSE CALL PYZDIS(1000,0,PMS(4),ZZ) CHI=ZZ ENDIF C...Construct total transverse mass; reject if too large. CHI=MAX(1D-8,MIN(1D0-1D-8,CHI)) PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI) IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN IF(LOOP.LT.10) GOTO 200 GOTO 180 ENDIF VINT(158+ISIDE)=CHI C...Subdivide longitudinal momentum according to value selected above. PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3)) PW1=(1D0-CHI)*PRP P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1) P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG PW2=CHI*PRP P(I,4)=0.5D0*(PW2+PMS(4)/PW2) P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG ENDIF N=I C...Boost current and remnant systems to correct frame. IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2))) DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/ &(2D0*VINT(1)*PCP) DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/ &(2D0*VINT(1)*PRP) DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0) DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0) CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC) CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER) C...Let current quark shower; recoil but no showering by colour partner. QMAX=2D0*SQRT(VINT(309-ISIDE)) MSTJ48=MSTJ(48) MSTJ(48)=1 PARJ86=PARJ(86) PARJ(86)=0D0 IF(MSTP(71).EQ.1) 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 IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14) IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13) ELSEIF(ILIM.EQ.4) THEN C...Calculate limits on tau' C...0) due to kinematics TAPMN0=TAU IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN PQRAT=(VINT(201)+VINT(206))/VINT(1) TAPMN0=(SQRT(TAU)+PQRAT)**2 ENDIF TAPMX0=1D0 C...1) due to explicit limits TAPMN1=CKIN(31)**2/VINT(2) TAPMX1=1D0 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2) C...Net effect of all separate limits. VINT(16)=MAX(TAPMN0,TAPMN1) VINT(36)=MIN(TAPMX0,TAPMX1) IF(MINT(47).EQ.1) THEN VINT(16)=1D0-1D-9 VINT(36)=1D0+1D-9 ELSEIF(MINT(47).EQ.5) THEN VINT(36)=MIN(VINT(36),1D0-2D-10) ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN VINT(36)=MIN(VINT(36),1D0-1D-10) ENDIF IF(VINT(36).LE.VINT(16)) MINT(51)=1 ENDIF RETURN C...Special case for low-pT and multiple interactions: C...effective kinematical limits for tau, y*, cos(theta-hat). 100 IF(ILIM.EQ.0) THEN ELSEIF(ILIM.EQ.1) THEN IF(MSTP(82).LE.1) THEN VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/ & VINT(2) ELSE VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2) ENDIF VINT(31)=1D0 ELSEIF(ILIM.EQ.2) THEN VINT(12)=0.5D0*LOG(VINT(21)) VINT(32)=-VINT(12) ELSEIF(ILIM.EQ.3) THEN IF(MSTP(82).LE.1) THEN ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/ & (VINT(21)*VINT(2)) ELSE ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/ & (VINT(21)*VINT(2)) ENDIF VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF)) VINT(33)=0D0 VINT(14)=0D0 VINT(34)=-VINT(13) ENDIF RETURN END C********************************************************************* C...PYKMAP C...Maps a uniform distribution into a distribution of a kinematical C...variable according to one of the possibilities allowed. It is C...assumed that kinematical limits have been set by a PYKLIM call. SUBROUTINE PYKMAP(IVAR,MVAR,VVAR) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/ C...Convert VVAR to tau variable. ISUB=MINT(1) ISTSB=ISET(ISUB) IF(IVAR.EQ.1) THEN TAUMIN=VINT(11) TAUMAX=VINT(31) IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN TAURE=VINT(73) GAMRE=VINT(74) ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN TAURE=VINT(75) GAMRE=VINT(76) 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.3.OR. & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR. & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR. & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR. & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1 IF (ISTSB.EQ.9) ISQCD=1 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR. & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND. & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR. & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR. & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR. & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND. & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR. & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1 C...WBF is special case of ISJETS IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR. & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR. & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR. & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR. & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR. & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR. & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR. & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR. & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2 C...Some processes with photons also belong here. IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR. & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR. & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR. & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR. & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR. & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3 C...Choice of Q2 scale for parton-shower activity. IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND. &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN XBJ=X(2) IF(MINT(43).EQ.3) XBJ=X(1) IF(MSTP(22).EQ.1) THEN Q2PS=-TH ELSEIF(MSTP(22).EQ.2) THEN Q2PS=((1D0-XBJ)/XBJ)*(-TH) ELSEIF(MSTP(22).EQ.3) THEN Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH) ELSE Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH) ENDIF ENDIF C...For multiple interactions, start from scale defined above C...For all other QCD or "+jets"-type events, start shower from pThard. IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN C...Max shower scale = s for ME corrected processes. C...(pT-ordering: max pT2 is s/4) Q2PS=VINT(2) IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN C...Max shower scale = s for all non-QCD, non-"+ jet" type processes. C...(pT-ordering: max pT2 is s/4) Q2PS=VINT(2) IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0 ENDIF IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH C...Elastic and diffractive events not associated with scales so set 0. IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN Q2SF=0D0 Q2PS=0D0 ENDIF C...Store derived kinematical quantities VINT(41)=X(1) VINT(42)=X(2) VINT(44)=SH VINT(43)=SQRT(SH) VINT(45)=TH VINT(46)=UH IF(ISTSB.NE.8) VINT(48)=SQPTH IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH) VINT(50)=TAUP*VINT(2) VINT(49)=SQRT(MAX(0D0,VINT(50))) VINT(52)=Q2 VINT(51)=SQRT(Q2) VINT(54)=Q2SF VINT(53)=SQRT(Q2SF) VINT(56)=Q2PS VINT(55)=SQRT(Q2PS) C...Set starting scale for multiple interactions IF (ISUBSV.EQ.95) THEN XT2GMX=0D0 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND. & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND. & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND. & ISUBSV.NE.96)) THEN C...All accessible phase space allowed. XT2GMX=(1D0-VINT(41))*(1D0-VINT(42)) ELSE C...Scale of hard process sets limit. C...2 -> 1. Limit is tau = x1*x2. C...2 -> 2. Limit is XT2 for hard process + FS masses. C...2 -> n > 2. Limit is tau' = tau of outer process. XT2GMX=VINT(25) IF(ISTSB.EQ.1) XT2GMX=VINT(21) IF(ISTSB.EQ.2) & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2) IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26) ENDIF VINT(62)=0.25D0*XT2GMX*VINT(2) VINT(61)=SQRT(MAX(0D0,VINT(62))) C...Calculate parton distributions IF(ISTSB.LE.0) GOTO 160 IF(MINT(47).GE.2) THEN DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46)) XSF=X(I) IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I) IF(ISUB.EQ.99) THEN IF(MINT(140+I).EQ.0) THEN XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2) ELSE XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308)) ENDIF VINT(40+I)=XSF Q2SF=VINT(309-I) ENDIF MINT(105)=MINT(102+I) MINT(109)=MINT(106+I) VINT(120)=VINT(2+I) 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.' CALL PYSTOP(108) END IF 560 CONTINUE ELSEIF(ISUB.EQ.402) THEN C... q + qbar -> t + bbar + H- IA=KFPR(ISUBSV,2) CALL PYSTBH(WTTBH) CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2) IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) & FACBW=0D0 DO 570 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW c Since we don't know yet if H+ or H-, assume H+ c when calculating suppression due to closed channels. SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3) IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3)) & .GE.1D-6.OR. & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3)) & .GE.1D-6) THEN WRITE(*,*)'Error: Process 402 cannot handle different' WRITE(*,*)'decays for H+ and H- or t and tbar.' WRITE(*,*)'Execution stopped.' CALL PYSTOP(108) END IF 570 CONTINUE ENDIF ENDIF RETURN END C********************************************************************* C...PYSGSU C...Subprocess cross sections for SUSY processes, C...including Higgs pair production. C...Auxiliary to PYSIGH. SUBROUTINE PYSGSU(NCHN,SIGS) C...Double precision and integer declarations IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/, &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/ C...Local arrays and complex variables DIMENSION WDTP(0:400),WDTE(0:400,0:5) COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2) CMRENNA++ C...Z and W width, combinations of weak mixing angle ZWID=PMAS(23,2) WWID=PMAS(24,2) TANW=SQRT(XW/XW1) CT2W=(1D0-2D0*XW)/(2D0*XW/TANW) C...Convert almost equivalent SUSY processes into each other C...Extract differences in flavours and couplings C...Sleptons and sneutrinos IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN KFID=MOD(KFPR(ISUB,1),KSUSY1) ISUB=201 ILR=0 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN KFID=MOD(KFPR(ISUB,1),KSUSY1) ISUB=201 ILR=1 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN KFID=MOD(KFPR(ISUB,1),KSUSY1) ISUB=203 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN IF(ISUB.EQ.210) THEN RKF=2.0D0 ELSEIF(ISUB.EQ.211) THEN RKF=SFMIX(15,1)**2 ELSEIF(ISUB.EQ.212) THEN RKF=SFMIX(15,2)**2 ENDIF ISUB=210 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN IF(ISUB.EQ.213) THEN KFID=MOD(KFPR(ISUB,1),KSUSY1) RKF=2.0D0 ELSEIF(ISUB.EQ.214) THEN KFID=16 RKF=1.0D0 ENDIF ISUB=213 C...Neutralinos ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN IF(ISUB.EQ.216) THEN IZID1=1 IZID2=1 ELSEIF(ISUB.EQ.217) THEN IZID1=2 IZID2=2 ELSEIF(ISUB.EQ.218) THEN IZID1=3 IZID2=3 ELSEIF(ISUB.EQ.219) THEN IZID1=4 IZID2=4 ELSEIF(ISUB.EQ.220) THEN IZID1=1 IZID2=2 ELSEIF(ISUB.EQ.221) THEN IZID1=1 IZID2=3 ELSEIF(ISUB.EQ.222) THEN IZID1=1 IZID2=4 ELSEIF(ISUB.EQ.223) THEN IZID1=2 IZID2=3 ELSEIF(ISUB.EQ.224) THEN IZID1=2 IZID2=4 ELSEIF(ISUB.EQ.225) THEN IZID1=3 IZID2=4 ENDIF ISUB=216 C...Charginos ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN IF(ISUB.EQ.226) THEN IZID1=1 IZID2=1 ELSEIF(ISUB.EQ.227) THEN IZID1=2 IZID2=2 ELSEIF(ISUB.EQ.228) THEN IZID1=1 IZID2=2 ENDIF ISUB=226 C...Neutralino + chargino ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN IF(ISUB.EQ.229) THEN IZID1=1 IZID2=1 ELSEIF(ISUB.EQ.230) THEN IZID1=1 IZID2=2 ELSEIF(ISUB.EQ.231) THEN IZID1=1 IZID2=3 ELSEIF(ISUB.EQ.232) THEN IZID1=1 IZID2=4 ELSEIF(ISUB.EQ.233) THEN IZID1=2 IZID2=1 ELSEIF(ISUB.EQ.234) THEN IZID1=2 IZID2=2 ELSEIF(ISUB.EQ.235) THEN IZID1=2 IZID2=3 ELSEIF(ISUB.EQ.236) THEN IZID1=2 IZID2=4 ENDIF ISUB=229 C...Gluino + neutralino ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN IF(ISUB.EQ.237) THEN IZID=1 ELSEIF(ISUB.EQ.238) THEN IZID=2 ELSEIF(ISUB.EQ.239) THEN IZID=3 ELSEIF(ISUB.EQ.240) THEN IZID=4 ENDIF ISUB=237 C...Gluino + chargino ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN IF(ISUB.EQ.241) THEN IZID=1 ELSEIF(ISUB.EQ.242) THEN IZID=2 ENDIF ISUB=241 C...Squark + neutralino ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN ILR=0 IF(MOD(ISUB,2).NE.0) ILR=1 IF(ISUB.LE.247) THEN IZID=1 ELSEIF(ISUB.LE.249) THEN IZID=2 ELSEIF(ISUB.LE.251) THEN IZID=3 ELSEIF(ISUB.LE.253) THEN IZID=4 ENDIF ISUB=246 RKF=5D0 C...Squark + chargino ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN IF(ISUB.LE.255) THEN IZID=1 ELSEIF(ISUB.LE.257) THEN IZID=2 ENDIF IF(MOD(ISUB,2).EQ.0) THEN ILR=0 ELSE ILR=1 ENDIF ISUB=254 RKF=5D0 C...Squark + gluino ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN ISUB=258 RKF=4D0 C...Stops ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN ILR=0 IF(ISUB.EQ.262) ILR=1 ISUB=261 ELSEIF(ISUB.EQ.265) THEN ISUB=264 C...Squarks ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN ILR=0 IF(ISUB.LE.273) THEN IF(ISUB.EQ.273) ILR=1 ISUB=271 RKF=16D0 ELSEIF(ISUB.LE.276) THEN IF(ISUB.EQ.276) ILR=1 ISUB=274 RKF=16D0 ELSEIF(ISUB.LE.278) THEN IF(ISUB.EQ.278) ILR=1 ISUB=277 RKF=4D0 ELSE IF(ISUB.EQ.280) ILR=1 ISUB=279 RKF=4D0 ENDIF C...Sbottoms ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN ILR=0 IF(ISUB.LE.283) THEN IF(ISUB.EQ.283) ILR=1 ISUB=271 RKF=4D0 ELSEIF(ISUB.LE.286) THEN IF(ISUB.EQ.286) ILR=1 ISUB=274 RKF=4D0 ELSEIF(ISUB.LE.288) THEN IF(ISUB.EQ.288) ILR=1 ISUB=277 RKF=1D0 ELSEIF(ISUB.LE.290) THEN IF(ISUB.EQ.290) ILR=1 ISUB=279 RKF=1D0 ELSEIF(ISUB.LE.293) THEN IF(ISUB.EQ.293) ILR=1 ISUB=271 RKF=1D0 ELSEIF(ISUB.EQ.296) THEN ILR=1 ISUB=274 RKF=1D0 C...Squark + gluino ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN ISUB=258 RKF=1D0 ENDIF C...H+/- + H0 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN IF(ISUB.EQ.297) THEN RKF=.5D0*PARU(195)**2 ELSEIF(ISUB.EQ.298) THEN RKF=.5D0*(1D0-PARU(195)**2) ENDIF ISUB=210 C...A0 + H0 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN IF(ISUB.EQ.299) THEN RKF=PARU(186)**2 KFID=25 ELSEIF(ISUB.EQ.300) THEN RKF=PARU(187)**2 KFID=35 ENDIF ISUB=213 C...H+ + H- ELSEIF(ISUB.EQ.301) THEN KFID=37 RKF=1D0 ISUB=201 ENDIF C...Supersymmetric processes - all of type 2 -> 2 : C...correct final-state Breit-Wigners from fixed to running width. IF(MSTP(42).GT.0) THEN DO 100 I=1,2 KFLW=KFPR(ISUBSV,I) KCW=PYCOMP(KFLW) IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100 IF(I.EQ.1) SQMI=SQM3 IF(I.EQ.2) SQMI=SQM4 SQMS=PMAS(KCW,1)**2 GMMS=PMAS(KCW,1)*PMAS(KCW,2) HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2) CALL PYWIDT(KFLW,SQMI,WDTP,WDTE) GMMI=SQRT(SQMI)*WDTP(0) HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2) COMFAC=COMFAC*(HBWI/HBWS) 100 CONTINUE ENDIF C...Differential cross section expressions. IF(ISUB.LE.210) THEN IF(ISUB.EQ.201) THEN C...f + fbar -> e_L + e_Lbar COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) DO 130 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130 EI=KCHG(IA,1)/3D0 TT3I=SIGN(1D0,EI+1D-6)/2D0 EJ=-1D0 TT3J=-1D0/2D0 FCOL=1D0 C...Color factor for e+ e- IF(IA.GE.11) FCOL=3D0 IF(ISUBSV.EQ.301) THEN A1=1D0 A2=0D0 ELSEIF(ILR.EQ.1) THEN A1=SFMIX(KFID,3)**2 A2=SFMIX(KFID,4)**2 ELSEIF(ILR.EQ.0) THEN A1=SFMIX(KFID,1)**2 A2=SFMIX(KFID,2)**2 ENDIF XLQ=(TT3J-EJ*XW)*A1 XRQ=(-EJ*XW)*A2 XLF=(TT3I-EI*XW) XRF=(-EI*XW) TAA=(EI*EJ)**2*(POLL+POLR) TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2) TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH) TNN=0.0D0 TAN=0.0D0 TZN=0.0D0 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN FAC2=SQRT(2D0) TNN1=0D0 TNN2=0D0 TNN3=0D0 DO 120 II=1,4 DK=1D0/(TH-SMZ(II)**2) FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)* & ZMIX(II,1)) FREK=FAC2*TANW*EI*ZMIX(II,1) TNN1=TNN1+FLEK**2*DK TNN2=TNN2+FREK**2*DK DO 110 JJ=1,4 DL=1D0/(TH-SMZ(JJ)**2) FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)* & ZMIX(JJ,1)) FREL=FAC2*TANW*EJ*ZMIX(JJ,1) TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ) 110 CONTINUE 120 CONTINUE TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+ & A2**2*TNN2**2*POLR) TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+ & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)* & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR) TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)* & (1D0-SQMZ/SH)/SH TZN=TZN/XW**2/XW1 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+ & A2*TNN2*POLR)/XW ENDIF FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1+FACQQ2 130 CONTINUE ELSEIF(ISUB.EQ.203) THEN C...f + fbar -> e_L + e_Rbar DO 160 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160 EI=KCHG(IABS(I),1)/3D0 TT3I=SIGN(1D0,EI)/2D0 EJ=-1 TT3J=-1D0/2D0 FCOL=1D0 C...Color factor for e+ e- IF(IA.GE.11) FCOL=3D0 A1=SFMIX(KFID,1)**2 A2=SFMIX(KFID,2)**2 XLQ=(TT3J-EJ*XW) XRQ=(-EJ*XW) XLF=(TT3I-EI*XW) XRF=(-EI*XW) TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2 & /XW**2/XW1**2*A1*A2 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2) TNN=0.0D0 TZN=0.0D0 TNNA=0D0 TNNB=0D0 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN FAC2=SQRT(2D0) TNN1=0D0 TNN2=0D0 TNN3=0D0 DO 150 II=1,4 DK=1D0/(TH-SMZ(II)**2) FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)* & ZMIX(II,1)) FREK=FAC2*TANW*EI*ZMIX(II,1) TNN1=TNN1+FLEK**2*DK TNN2=TNN2+FREK**2*DK DO 140 JJ=1,4 DL=1D0/(TH-SMZ(JJ)**2) FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)* & ZMIX(JJ,1)) FREL=FAC2*TANW*EJ*ZMIX(JJ,1) TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ) 140 CONTINUE 150 CONTINUE TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL) TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0 TZN=(UH*TH-SQM3*SQM4)*A1*A2 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)* & (1D0-SQMZ/SH)/SH ENDIF FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0 C%%%%%%%%%%% NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),3) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=2 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) 160 CONTINUE ELSEIF(ISUB.EQ.210) THEN C...q + qbar' -> W*- > ~l_L + ~nu_L FAC0=RKF*COMFAC*AEM**2/XW**2/12D0 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW) DO 180 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180 DO 170 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170 FCKM=3D0 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J) KCHW=2 IF(KCHSUM.LT.0) KCHW=3 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) ELSE FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW) ENDIF SIGH(NCHN)=FAC0*FAC1*FCKM*FACR 170 CONTINUE 180 CONTINUE ENDIF ELSEIF(ISUB.LE.220) THEN IF(ISUB.EQ.213) THEN C...f + fbar -> ~nu_L + ~nu_Lbar IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) ELSE FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1) ENDIF COMFAC=COMFAC*FACR PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ XLL=0.5D0 XLR=0.0D0 DO 190 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190 EI=KCHG(IA,1)/3D0 FCOL=1D0 C...Color factor for e+ e- IF(IA.GE.11) FCOL=3D0 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0 XRQ=-EI*XW TZC=0.0D0 TCC=0.0D0 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/ & (TH-SMW(2)**2) TCC=TZC**2 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL ENDIF FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2 FACQQ2=TZC+TCC/4D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC & *AEM**2*FCOL/3D0/XW**2 190 CONTINUE ELSEIF(ISUB.EQ.216) THEN C...q + qbar -> ~chi0_1 + ~chi0_1 IF(IZID1.EQ.IZID2) THEN COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) ELSE COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) ENDIF FACXX=COMFAC*AEM**2/3D0/XW**2 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0 ZM12=SQM3 ZM22=SQM4 WU2 = (UH-ZM12)*(UH-ZM22) WT2 = (TH-ZM12)*(TH-ZM22) WS2 = SMZ(IZID1)*SMZ(IZID2)*SH PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2) DO 200 I=1,4 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I)) IF(IZID2.NE.IZID1) THEN ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I)) ENDIF 200 CONTINUE OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))- & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0 ORPP=DCONJG(OLPP) DO 210 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210 EI=KCHG(IABS(I),1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))* & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1)) GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2) QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ) & /DCMPLX(TH-XML2) QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2) QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ & -DCONJG(GRIJ)/DCMPLX(UH-XMR2) FCOL=1D0 IF(IABS(I).GE.11) FCOL=3D0 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+ & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+ & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+ & QRL*DCONJG(QRR)*POLR)*WS2 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACXX*FACGG1*FCOL 210 CONTINUE ENDIF ELSEIF(ISUB.LE.230) THEN IF(ISUB.EQ.226) THEN C...f + fbar -> ~chi+_1 + ~chi-_1 FACXX=COMFAC*AEM**2/3D0 ZM12=SQM3 ZM22=SQM4 WU2 = (UH-ZM12)*(UH-ZM22) WT2 = (TH-ZM12)*(TH-ZM22) WS2 = SMW(IZID1)*SMW(IZID2)*SH PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2) DIFF=0D0 IF(IZID1.EQ.IZID2) DIFF=1D0 DO 220 I=1,2 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I)) UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I)) IF(IZID2.NE.IZID1) THEN VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I)) UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I)) ENDIF 220 CONTINUE OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))- & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF) ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))- & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF) DO 230 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230 EI=KCHG(IABS(I),1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP IF(MOD(I,2).EQ.0) THEN XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)* & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))* & DCMPLX(T3I/XW/(TH-XML2)) ELSE XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)* & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))* & DCMPLX(T3I/XW/(TH-XML2)) ENDIF FCOL=1D0 IF(IABS(I).GE.11) FCOL=3D0 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+ & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+ & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+ & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 IF(IZID1.EQ.IZID2) THEN SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) ELSE SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=2 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),3) ENDIF 230 CONTINUE ELSEIF(ISUB.EQ.229) THEN C...q + qbar' -> ~chi0_1 + ~chi+-_1 FACXX=COMFAC*AEM**2/6D0/XW**2 ZM12=SQM3 ZM22=SQM4 WU2 = (UH-ZM12)*(UH-ZM22) WT2 = (TH-ZM12)*(TH-ZM22) WS2 = SMW(IZID1)*SMZ(IZID2)*SH RT2I = 1D0/SQRT(2D0) PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/ & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0) DO 240 I=1,2 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I)) UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I)) 240 CONTINUE DO 250 I=1,4 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I)) 250 CONTINUE OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)- & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+ & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW DO 270 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270 EI=KCHG(IA,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 DO 260 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260 EJ=KCHG(JA,1)/3D0 T3J=SIGN(1D0,EJ+1D-6)/2D0 FCKM=3D0 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J) KCHW=2 IF(KCHSUM.LT.0) KCHW=3 IF(MOD(IA,2).EQ.0) THEN ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)* & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2) QLR=OR-DCONJG(UMIXC(IZID1,1))*( & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J) & /DCMPLX(TH-ZMJ2) ELSE ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)* & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2) QLR=OR-DCONJG(UMIXC(IZID1,1))*( & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I) & /DCMPLX(TH-ZMI2) ENDIF ZINTR=DBLE(QLR*DCONJG(QLL)) FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+ & 2D0*ZINTR*WS2) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW) 260 CONTINUE 270 CONTINUE ENDIF ELSEIF(ISUB.LE.240) THEN IF(ISUB.EQ.237) THEN C...q + qbar -> gluino + ~chi0_1 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) ASYUK=RMSS(42)*AS FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW GM2=SQM3 ZM2=SQM4 DO 280 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280 EI=KCHG(IABS(I),1)/3D0 IA=IABS(I) XLQC = -TANW*EI*ZMIX(IZID,1) XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW* & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0 XLQ2=XLQC**2 XRQ2=XRQC**2 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2) SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN) ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2) SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR) 280 CONTINUE ENDIF ELSEIF(ISUB.LE.250) THEN IF(ISUB.EQ.241) THEN C...q + qbar' -> ~chi+-_1 + gluino FACWG=COMFAC*AS*AEM/XW*2D0/9D0 GM2=SQM3 ZM2=SQM4 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1) FAC0=UMIX(IZID,1)**2 FAC1=VMIX(IZID,1)**2 DO 300 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300 DO 290 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290 FCKM=1D0 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J) KCHW=2 IF(KCHSUM.LT.0) KCHW=3 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2) XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)* & SH/(TH-XMU2)/(UH-XMD2))/2D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN- & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW) 290 CONTINUE 300 CONTINUE ELSEIF(ISUB.EQ.243) THEN C...q + qbar -> gluino + gluino COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) XMT=SQM3-TH XMU=SQM3-UH DO 310 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310 NCHN=NCHN+1 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+ & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+ & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*( & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU )) XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+ & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+ & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*( & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU )) ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 C...1/2 for identical particles SIGH(NCHN)=0.25D0*(FACGG1+FACGG2) 310 CONTINUE ELSEIF(ISUB.EQ.244) THEN C...g + g -> gluino + gluino COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) XMT=SQM3-TH XMU=SQM3-UH FACQQ1=COMFAC*AS**2*9D0/4D0*( & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 - & (XMT*XMU+SQM3*(UH-TH))/SH/XMT ) FACQQ2=COMFAC*AS**2*9D0/4D0*( & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 - & (XMU*XMT+SQM3*(TH-UH))/SH/XMU ) FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 + & SQM3*(SH-4D0*SQM3)/XMT/XMU) IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1/2D0 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=2 SIGH(NCHN)=FACQQ2/2D0 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=3 SIGH(NCHN)=FACQQ3/2D0 320 CONTINUE ELSEIF(ISUB.EQ.246) THEN C...g + q_j -> ~chi0_1 + ~q_j FAC0=COMFAC*AS*AEM/6D0/XW ZM2=SQM4 QM2=SQM3 FACZQ0=FAC0*( (ZM2-TH)/SH + & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 - & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) ) KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1) DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340 EI=KCHG(IABS(I),1)/3D0 IA=IABS(I) XRQZ = -TANW*EI*ZMIX(IZID,1) XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW* & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0 IF(ILR.EQ.0) THEN BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2 ELSE BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2 ENDIF FACZQ=FACZQ0*BS KCHQ=2 IF(I.LT.0) KCHQ=3 DO 330 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) 330 CONTINUE 340 CONTINUE ENDIF ELSEIF(ISUB.LE.260) THEN IF(ISUB.EQ.254) THEN C...g + q_j -> ~chi1_1 + ~q_i FAC0=COMFAC*AS*AEM/12D0/XW ZM2=SQM4 QM2=SQM3 AU=UMIX(IZID,1)**2 AD=VMIX(IZID,1)**2 FACZQ0=FAC0*( (ZM2-TH)/SH + & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 - & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) ) KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1) IF(MOD(KFNSQ1,2).EQ.0) THEN KFNSQ=KFNSQ1-1 KCHW=2 ELSE KFNSQ=KFNSQ1+1 KCHW=3 ENDIF DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360 IA=IABS(I) IF(MOD(IA,2).EQ.0) THEN FACZQ=FACZQ0*AU ELSE FACZQ=FACZQ0*AD ENDIF FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2 KCHQ=2 IF(I.LT.0) KCHQ=3 KCHWQ=KCHW IF(I.LT.0) KCHWQ=5-KCHW DO 350 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ) 350 CONTINUE 360 CONTINUE ELSEIF(ISUB.EQ.258) THEN C...g + q_j -> gluino + ~q_i XG2=SQM4 XQ2=SQM3 XMT=XG2-TH XMU=XG2-UH XST=XQ2-TH XSU=XQ2-UH FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 - & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) + & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) + & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0* & (SH*(UH+XG2) & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH + & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+ & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU ASYUK=RMSS(42)*AS FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1) DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380 KCHQ=2 IF(I.LT.0) KCHQ=3 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) DO 370 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQG1*FACSEL NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=2 SIGH(NCHN)=FACQG2*FACSEL 370 CONTINUE 380 CONTINUE ENDIF ELSEIF(ISUB.LE.270) THEN IF(ISUB.EQ.261) THEN C...q_i + q_ibar -> ~t_1 + ~t_1bar FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )* & WIDS(PYCOMP(KFPR(ISUBSV,1)),1) KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1) FAC0=AS**2*4D0/9D0 DO 390 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390 IF(IA.GE.11.AND.IA.LE.18) THEN EI=KCHG(IA,1)/3D0 EJ=KCHG(KFNSQ,1)/3D0 T3I=SIGN(1D0,EI)/2D0 T3J=SIGN(1D0,EJ)/2D0 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2 XLF=2D0*(T3I-EI*XW) XRF=2D0*(-EI*XW) TAA=0.5D0*(EI*EJ)**2 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2) TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH) FAC0=AEM**2*12D0*(TAA+TZZ+TAZ) ENDIF NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1*FAC0 390 CONTINUE ELSEIF(ISUB.EQ.263) THEN C...f + fbar -> ~t1 + ~t2bar DO 400 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400 EI=KCHG(IABS(I),1)/3D0 TT3I=SIGN(1D0,EI)/2D0 EJ=2D0/3D0 TT3J=1D0/2D0 FCOL=1D0 C...Color factor for e+ e- IF(IA.GE.11) FCOL=3D0 XLQ=2D0*(TT3J-EJ*XW) XRQ=2D0*(-EJ*XW) XLF=2D0*(TT3I-EI*XW) XRF=2D0*(-EI*XW) TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2) C...Factor of 2 for t1 t2bar + t2 t1bar FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),3) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=2 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) 400 CONTINUE ELSEIF(ISUB.EQ.264) THEN C...g + g -> ~t_1 + ~t_1bar XSU=SQM3-UH XST=SQM3-TH FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0* & WIDS(PYCOMP(KFPR(ISUBSV,1)),1) FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST) FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST) IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=2 SIGH(NCHN)=FACQQ2 410 CONTINUE ENDIF ELSEIF(ISUB.LE.280) THEN IF(ISUB.EQ.271) THEN C...q + q' -> ~q + ~q' (~g exchange) XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2 XMT=XMG2-TH XMU=XMG2-UH XSU1=SQM3-UH XSU2=SQM4-UH XST1=SQM3-TH XST2=SQM4-TH ASYUK=RMSS(42)*AS IF(ILR.EQ.1) THEN FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 ) FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 ) FACQQB=0.0D0 ELSE FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 ) FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 ) FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/ & XMT/XMU ) ENDIF KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1) KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1) DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430 KCHQ=2 IF(I.LT.0) KCHQ=3 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420 IF(I*J.LT.0) GOTO 420 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ) IF(I.EQ.J) THEN IF(ILR.EQ.0) THEN SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF* & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2) ELSE SIGH(NCHN)=0.5D0*FACQQ1*RKF* & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ) ENDIF NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=2 IF(ILR.EQ.0) THEN SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF* & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2) ELSE SIGH(NCHN)=0.5D0*FACQQ2*RKF* & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ) ENDIF ENDIF 420 CONTINUE 430 CONTINUE ELSEIF(ISUB.EQ.274) THEN C...q + qbar' -> ~q + ~qbar' XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2 XMT=XMG2-TH XMU=XMG2-UH IF(ILR.EQ.0) THEN C...Mrenna...Normalization.and.1/XMT FACQQ1=COMFAC*AS**2*2D0/9D0*( & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2 FACQQB=COMFAC*AS**2*4D0/9D0*( & (UH*TH-SQM3*SQM4)/SH2 ) FACQQI=-COMFAC*AS**2*4D0/27D0*( & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42) FACQQB=FACQQB+FACQQ1+FACQQI ELSE FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2 FACQQB=FACQQ1 ENDIF KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1) KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1) DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450 KCHQ=2 IF(I.LT.0) KCHQ=3 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440 IF(I*J.GT.0) GOTO 440 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ) IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF* & WIDS(PYCOMP(KFPR(ISUBSV,1)),1) 440 CONTINUE 450 CONTINUE ELSEIF(ISUB.EQ.277) THEN C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j C...if i .eq. j covered in 274 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 ) KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1) FAC0=0D0 DO 460 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460 IF(IA.EQ.KFNSQ) GOTO 460 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN EI=KCHG(IA,1)/3D0 EJ=KCHG(KFNSQ,1)/3D0 T3J=SIGN(0.5D0,EJ) T3I=SIGN(1D0,EI)/2D0 IF(ILR.EQ.0) THEN XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1) XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2) ELSE XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3) XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4) ENDIF XLF=2D0*(T3I-EI*XW) XRF=2D0*(-EI*XW) IF(ILR.EQ.0) THEN XRQ=0D0 ELSE XLQ=0D0 ENDIF TAA=0.5D0*(EI*EJ)**2 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2) TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH) FAC0=AEM**2*12D0*(TAA+TZZ+TAZ) ELSEIF(IA.LE.6) THEN FAC0=AS**2*8D0/9D0/2D0 ENDIF NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) 460 CONTINUE ELSEIF(ISUB.EQ.279) THEN C...g + g -> ~q_j + ~q_jbar XSU=SQM3-UH XST=SQM3-TH C...5=RKF because ~t ~tbar treated separately FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 ) FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST) FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST) IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=2 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) 470 CONTINUE ENDIF ENDIF CMRENNA-- RETURN END C********************************************************************* C...PYSGTC C...Subprocess cross sections for Technicolor processes. C...Auxiliary to PYSIGH. SUBROUTINE PYSGTC(NCHN,SIGS) C...Double precision and integer declarations IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/, &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/ C...Local arrays and complex variables DIMENSION WDTP(0:400),WDTE(0:400,0:5) COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME COMPLEX*16 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...Special case for extracting photon from baryon without splitting C...the latter. (Currently only used by external programs.) ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then KFLSP=KFA KFLCH=0 C...Subdivide baryon. ELSE NAGR=0 DO 120 J=1,3 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1 120 CONTINUE IF(NAGR.GE.1) THEN RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0) IAGR=0 DO 130 J=1,3 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J 130 CONTINUE ELSE IAGR=1.00001D0+2.99998D0*PYR(0) ENDIF ID1=1 IF(IAGR.EQ.1) ID1=2 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3 ID2=6-IAGR-ID1 KSP=3 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1 ELSEIF(MOD(KFA,10).EQ.2) THEN IF(IAGR.EQ.1) KSP=1 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1 ENDIF KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP IF(KFLR.EQ.21) THEN KFLCH=KFL(IAGR) ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN NTRY=0 140 NTRY=NTRY+1 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH) IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN GOTO 140 ELSEIF(KFLCH.EQ.0) THEN CALL PYERRM(14,'(PYSPLI:) caught in infinite loop') MINT(51)=1 RETURN ENDIF ELSEIF(NAGR.EQ.0) THEN NTRY=0 150 NTRY=NTRY+1 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH) IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN GOTO 150 ELSEIF(KFLCH.EQ.0) THEN CALL PYERRM(14,'(PYSPLI:) caught in infinite loop') MINT(51)=1 RETURN ENDIF KFLSP=KFL(IAGR) ENDIF ENDIF C...Add on correct sign for result. KFLCH=KFLCH*KFS KFLSP=KFLSP*KFS RETURN END C********************************************************************* C...PYGAMM C...Gives ordinary Gamma function Gamma(x) for positive, real arguments; C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions C...(Dover, 1965) 6.1.36. FUNCTION PYGAMM(X) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Local array and data. DIMENSION B(8) DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0, &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/ NX=INT(X) DX=X-NX PYGAMM=1D0 DXP=1D0 DO 100 I=1,8 DXP=DXP*DX PYGAMM=PYGAMM+B(I)*DXP 100 CONTINUE IF(X.LT.1D0) THEN PYGAMM=PYGAMM/X ELSE DO 110 IX=1,NX-1 PYGAMM=(X-IX)*PYGAMM 110 CONTINUE ENDIF RETURN END C*********************************************************************** C...PYWAUX C...Calculates real and imaginary parts of the auxiliary functions W1 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van C...der Bij, Nucl. Phys. B297 (1988) 221. SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ ASINH(X)=LOG(X+SQRT(X**2+1D0)) ACOSH(X)=LOG(X+SQRT(X**2-1D0)) IF(EPS.LT.0D0) THEN IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS)) IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2 WIM=0D0 ELSEIF(EPS.LT.1D0) THEN IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS)) IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS) IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS)) ELSE IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS)) IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2 WIM=0D0 ENDIF RETURN END C*********************************************************************** C...PYI3AU C...Calculates real and imaginary parts of the auxiliary function I3; C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij, C...Nucl. Phys. B297 (1988) 221. SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS)) IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS)) IF(EPS.LT.0D0) THEN IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)- & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+ & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)- & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2- & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)* & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+ & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)* & EPS)) ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)- & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+ & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)- & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+ & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+ & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+ & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS)) ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)- & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+ & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)- & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+ & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+ & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+ & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS)) ELSE F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)- & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)- & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2- & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+ & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0)) ENDIF F3IM=0D0 ELSEIF(EPS.LT.1D0) THEN IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)- & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+ & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)- & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/ & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/ & (0.25D0*(RAT+1D0)*EPS)) F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/ & (0.25D0*(RAT+1D0)*EPS)) ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)- & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+ & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)- & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+ & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))* & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS)) F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS)) ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)- & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+ & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)- & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+ & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/ & (1D0+0.25D0*RAT*EPS-GA)) F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/ & (1D0+0.25D0*RAT*EPS-GA)) ELSE F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)- & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)- & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))* & LOG((GA+BE-1D0)/(BE-GA)) F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA)) ENDIF ELSE RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2) RCTHE=RSQ*(1D0-2D0*BE/EPS) RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2)) RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS) RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2)) R=SQRT(RSQ) THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R))) PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R))) F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)- & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+ & (PHI-THE)*(PHI+THE-PARU(1)) F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)- & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2) ENDIF Y3RE=2D0/(2D0*BE-1D0)*F3RE Y3IM=2D0/(2D0*BE-1D0)*F3IM RETURN END C*********************************************************************** C...PYSPEN C...Calculates real and imaginary part of Spence function; see C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365. FUNCTION PYSPEN(XREIN,XIMIN,IREIM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Local array and data. DIMENSION B(0:14) DATA B/ &1.000000D+00, -5.000000D-01, 1.666667D-01, &0.000000D+00, -3.333333D-02, 0.000000D+00, &2.380952D-02, 0.000000D+00, -3.333333D-02, &0.000000D+00, 7.575757D-02, 0.000000D+00, &-2.531135D-01, 0.000000D+00, 1.166667D+00/ XRE=XREIN XIM=XIMIN IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0 IF(IREIM.EQ.2) PYSPEN=0D0 RETURN ENDIF XMOD=SQRT(XRE**2+XIM**2) IF(XMOD.LT.1D-6) THEN IF(IREIM.EQ.1) PYSPEN=0D0 IF(IREIM.EQ.2) PYSPEN=0D0 RETURN ENDIF XARG=SIGN(ACOS(XRE/XMOD),XIM) SP0RE=0D0 SP0IM=0D0 SGN=1D0 IF(XMOD.GT.1D0) THEN ALGXRE=LOG(XMOD) ALGXIM=XARG-SIGN(PARU(1),XARG) SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0 SP0IM=-ALGXRE*ALGXIM SGN=-1D0 XMOD=1D0/XMOD XARG=-XARG XRE=XMOD*COS(XARG) XIM=XMOD*SIN(XARG) ENDIF IF(XRE.GT.0.5D0) THEN ALGXRE=LOG(XMOD) ALGXIM=XARG XRE=1D0-XRE XIM=-XIM XMOD=SQRT(XRE**2+XIM**2) XARG=SIGN(ACOS(XRE/XMOD),XIM) ALGYRE=LOG(XMOD) ALGYIM=XARG SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM)) SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE) SGN=-SGN ENDIF XRE=1D0-XRE XIM=-XIM XMOD=SQRT(XRE**2+XIM**2) XARG=SIGN(ACOS(XRE/XMOD),XIM) ZRE=-LOG(XMOD) ZIM=-XARG SPRE=0D0 SPIM=0D0 SAVERE=1D0 SAVEIM=0D0 DO 100 I=0,14 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1) TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1) SAVERE=TERMRE SAVEIM=TERMIM SPRE=SPRE+B(I)*TERMRE SPIM=SPIM+B(I)*TERMIM 100 CONTINUE 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM RETURN END C*********************************************************************** C...PYQQBH C...Calculates the matrix element for the processes C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t). C...REDUCE output and part of the rest courtesy Z. Kunszt, see C...Z. Kunszt, Nucl. Phys. B247 (1984) 339. SUBROUTINE PYQQBH(WTQQBH) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/ C...Local arrays and function. DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8) DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)- &PP(I,3)*PP(J,3) C...Mass parameters. WTQQBH=0D0 ISUB=MINT(1) SHPR=SQRT(VINT(26))*VINT(1) PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1) PH=SQRT(VINT(21))*VINT(1) SPQ=PQ**2 SPH=PH**2 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H. DO 100 I=1,2 PT=SQRT(MAX(0D0,VINT(197+5*I))) PP(I,1)=PT*COS(VINT(198+5*I)) PP(I,2)=PT*SIN(VINT(198+5*I)) 100 CONTINUE PP(3,1)=-PP(1,1)-PP(2,1) PP(3,2)=-PP(1,2)-PP(2,2) PMS1=SPQ+PP(1,1)**2+PP(1,2)**2 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2 PMS3=SPH+PP(3,1)**2+PP(3,2)**2 PMT3=SQRT(PMS3) PP(3,3)=PMT3*SINH(VINT(211)) PP(3,4)=PMT3*COSH(VINT(211)) PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+ &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12) PP(2,3)=-PP(1,3)-PP(3,3) PP(1,4)=SQRT(PMS1+PP(1,3)**2) PP(2,4)=SQRT(PMS2+PP(2,3)**2) C...Set up incoming kinematics and derived momentum combinations. DO 110 I=4,5 PP(I,1)=0D0 PP(I,2)=0D0 PP(I,3)=-0.5D0*SHPR*(-1)**I PP(I,4)=-0.5D0*SHPR 110 CONTINUE DO 120 J=1,4 PP(6,J)=PP(1,J)+PP(2,J) PP(7,J)=PP(1,J)+PP(3,J) PP(8,J)=PP(1,J)+PP(4,J) PP(9,J)=PP(1,J)+PP(5,J) PP(10,J)=-PP(2,J)-PP(3,J) PP(11,J)=-PP(2,J)-PP(4,J) PP(12,J)=-PP(2,J)-PP(5,J) PP(13,J)=-PP(4,J)-PP(5,J) 120 CONTINUE C...Derived kinematics invariants. X1=DOT(1,2) X2=DOT(1,3) X3=DOT(1,4) X4=DOT(1,5) X5=DOT(2,3) X6=DOT(2,4) X7=DOT(2,5) X8=DOT(3,4) X9=DOT(3,5) X10=DOT(4,5) C...Propagators. SS1=DOT(7,7)-SPQ SS2=DOT(8,8)-SPQ SS3=DOT(9,9)-SPQ SS4=DOT(10,10)-SPQ SS5=DOT(11,11)-SPQ SS6=DOT(12,12)-SPQ SS7=DOT(13,13) DX(1)=SS1*SS6 DX(2)=SS2*SS6 DX(3)=SS2*SS4 DX(4)=SS1*SS5 DX(5)=SS3*SS5 DX(6)=SS3*SS4 DX(7)=SS7*SS1 DX(8)=SS7*SS4 C...Define colour coefficients for g + g -> Q + Qbar + H. IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN DO 140 I=1,3 DO 130 J=1,3 CLR(I,J)=16D0/3D0 CLR(I+3,J+3)=16D0/3D0 CLR(I,J+3)=-2D0/3D0 CLR(I+3,J)=-2D0/3D0 130 CONTINUE 140 CONTINUE DO 160 L=1,2 DO 150 I=1,3 CLR(I,6+L)=-6D0 CLR(I+3,6+L)=6D0 CLR(6+L,I)=-6D0 CLR(6+L,I+3)=6D0 150 CONTINUE 160 CONTINUE DO 180 K1=1,2 DO 170 K2=1,2 CLR(6+K1,6+K2)=12D0 170 CONTINUE 180 CONTINUE C...Evaluate matrix elements for g + g -> Q + Qbar + H. FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2* & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2* & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2* & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+ & X10) FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4* & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+ & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6) FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10- & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+ & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2* & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6) FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1* & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1* & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1** & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4* & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5- & X4*X6*X5) FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4- & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3* & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5 & +X4*X9*X5+X4*X5**2) FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2* & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1* & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3* & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7* & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7- & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5) FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2* & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+ & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8* & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8* & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4* & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2* & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+ & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2) FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*( & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3* & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+ & X6) FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1* & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1* & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3* & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6* & X5+X4*X6*X5) FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3- & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4- & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1* & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4* & X6**2) FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1* & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1* & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4* & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1** & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4* & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5- & X4*X6*X5) FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3- & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2* & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3* & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*( & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1* & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1* & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3* & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5) FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3- & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2* & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2* & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5- & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*( & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9- & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10* & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3* & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5) FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3* & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3- & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3* & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5 & +X3*X8*X5+X3*X5**2) FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1* & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1* & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3* & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7* & X5+X4*X6*X5) FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+ & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2* & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2* & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10) FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2* & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4* & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+ & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4* & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+ & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3* & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5) FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2* & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+ & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9* & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8) FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2* & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2* & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+ & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+ & X10) FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2* & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+ & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7) FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1* & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3* & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7* & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2* & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5) FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4* & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9* & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2) FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*( & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4* & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+ & X7) FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+ & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2* & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+ & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+ & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+ & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(- & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10* & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2* & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5) FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+ & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2* & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+ & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2* & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+ & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*( & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3* & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10* & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+ & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5) FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4* & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+ & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+ & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5) FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1* & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12* & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2* & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8) FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9* & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7* & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8 & *X6) FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+ & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4* & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9* & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3* & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+ & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5) FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2* & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4* & X8) FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+ & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6 & )+2*X2*(-X10*X5+X9*X6+X8*X7) FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2* & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3* & X9*X5) FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2* & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4* & X8*X5) FM(9,10)=0.5D0*(FMXX+FM(9,10)) FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+ & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6 & )+2*X5*(-X10*X2+X9*X3+X8*X4) C...Repackage matrix elements. DO 200 I=1,8 DO 190 J=I,8 RM(I,J)=FM(I,J) 190 CONTINUE 200 CONTINUE RM(7,7)=FM(7,7)-2D0*FM(9,9) RM(7,8)=FM(7,8)-2D0*FM(9,10) RM(8,8)=FM(8,8)-2D0*FM(10,10) C...Produce final result: matrix elements * colours * propagators. DO 220 I=1,8 DO 210 J=I,8 FAC=8D0 IF(I.EQ.J)FAC=4D0 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J)) 210 CONTINUE 220 CONTINUE WTQQBH=-WTQQBH/256D0 ELSE C...Evaluate matrix elements for q + qbar -> Q + Qbar + H. A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9 & *X6+X8*X7) A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8- & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8* & X5) A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3* & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3 & *X9+X4*X8) C...Produce final result: matrix elements * propagators. A11=A11/DX(7)**2 A12=A12/(DX(7)*DX(8)) A22=A22/DX(8)**2 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0 ENDIF RETURN END C********************************************************************* C...PYSTBH (and auxiliaries) C.. Evaluates the matrix elements for t + b + H production. SUBROUTINE PYSTBH(WTTBH) C...DOUBLE PRECISION AND INTEGER DECLARATIONS IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...COMMONBLOCKS COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A DOUBLE PRECISION MW2 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/, &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/ C...LOCAL ARRAYS AND COMPLEX VARIABLES DIMENSION QQ(4,2),PP(4,3) DATA QQ/8*0D0/ WTTBH=0D0 C...KINEMATIC PARAMETERS. SHPR=SQRT(VINT(26))*VINT(1) PH=SQRT(VINT(21))*VINT(1) SPH=PH**2 C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H. DO 100 I=1,2 PT=SQRT(MAX(0D0,VINT(197+5*I))) PP(1,I)=PT*COS(VINT(198+5*I)) PP(2,I)=PT*SIN(VINT(198+5*I)) 100 CONTINUE PP(1,3)=-PP(1,1)-PP(1,2) PP(2,3)=-PP(2,1)-PP(2,2) PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2 PMS3=SPH+PP(1,3)**2+PP(2,3)**2 PMT3=SQRT(PMS3) PP(3,3)=PMT3*SINH(VINT(211)) PP(4,3)=PMT3*COSH(VINT(211)) PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+ &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12) PP(3,2)=-PP(3,1)-PP(3,3) PP(4,1)=SQRT(PMS1+PP(3,1)**2) PP(4,2)=SQRT(PMS2+PP(3,2)**2) C...CM SYSTEM, INGOING QUARKS/GLUONS QQ(3,1) = SHPR/2.D0 QQ(4,1) = QQ(3,1) QQ(3,2) = -QQ(3,1) QQ(4,2) = QQ(4,1) C...PARAMETERS FOR AMPLITUDE METHOD ALPHA = AEM ALPHAS = AS SW2 = PARU(102) MW2 = PMAS(24,1)**2 TANB = PARU(141) VTB = VCKM(3,3) RMB=PYMRUN(5,VINT(52)) ISUB=MINT(1) IF (ISUB.EQ.401) THEN CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3), & VINT(201),VINT(206),RMB,VINT(43),WTTBH) ELSE IF (ISUB.EQ.402) THEN CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3), & VINT(201),VINT(206),RMB,VINT(43),WTTBH) END IF RETURN END C------------------------------------------------------------------ SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT) C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+ IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A SAVE /PYCTBH/ C TOP WIDTH CALCULATION C VTB = 0.99 MW=DSQRT(MW2) XB=(MB/MT)**2 XW=(MW/MT)**2 XH =(MHP/MT)**2 GAMTBH = 0D0 IF (MT .LT. (MHP+MB)) THEN C T ->B W ONLY BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2) GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW* & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) ) GAMT = GAMTBW ELSE C T ->BW +T ->B H^+ BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2) GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW* & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) ) C KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2 & -4.D0*(MHP*MB/MT**2)**2 ) GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT * & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2)) GAMT = GAMTBW+GAMTBH ENDIF C THUS BR IS BR=GAMTBH/GAMT RETURN END C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES: C GG->TBH^+, QQBAR->TBH^+ C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE C (FOR INSTANCE WITH PYTHIA) C------------------------------------------------------------ C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443, C PHYS REV. D 60 (1999) 115011 C (THESE FILES PREPARED BY J.-L. KNEUR) C------------------------------------------------------------ C 1) GG->TBH^+ SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2) C C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS: C C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS; C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA; C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA. C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT) C "PHYSICAL PARAMETERS" INPUT: C MT,MB TOP AND BOTTOM MASSES; C MHP CHARGED HIGGS MASS C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW) C C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+ C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL C CROSS-SECTION SHOULD BE (SYMBOLICALLY): C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ] C IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) DOUBLE PRECISION MW2,MT,MB,MHP,MW DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/ C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES: C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB C (TAN BETA) VALUES C C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..). PI = 4*DATAN(1.D0) MW = DSQRT(MW2) C C COLLECTING THE RELEVANT OVERALL FACTORS: C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE PS=1.D0/(8.D0*8.D0 *2.D0*2.D0) C COUPLING CONSTANT (OVERALL NORMALIZATION) FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI: C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI C ALPHAS IS ALPHA_STRONG; C SW2 IS SIN(THETA_W)**2. C C VTB=.998D0 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE) C V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS C C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS) DO 100 KK=1,4 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK) 100 CONTINUE C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS: S = 2*PYTBHS(Q1,Q2) P1Q1=PYTBHS(Q1,P1) P1Q2=PYTBHS(P1,Q2) P2Q1=PYTBHS(P2,Q1) P2Q2=PYTBHS(P2,Q2) P1P2=PYTBHS(P1,P2) C C TOP WIDTH CALCULATION CALL PYTBHB(MT,MB,MHP,BR,GAMT) C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+ C THEN DEFINE TOP (RESONANT) PROPAGATOR: A1INV= S -2*P1Q1 -2*P1Q2 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2) C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE) C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF C THE TOP WIDTH A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2) A2 =1.D0/(S +2*P2Q1 +2*P2Q2) C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH C NOW COMES THE AMP**2: C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN C THE EXPRESSIONS BELOW V18=0.D0 A18=0.D0 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT- &512*A1*A2*MB*MT/3- &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+ &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+ &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+ &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+ &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+ &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+ &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+ &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+ &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)- &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1- &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+ &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+ &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+ &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+ &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2) V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+ &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+ &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+ &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)- &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2- &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+ &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)- &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+ &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)- &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)- &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+ &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2- &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+ &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+ &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)- &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)- &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1- &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+ &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+ &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+ &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)- &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)- &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)- &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+ &64*MB**3*MT/(3*P1Q2*P2Q1**2)+ &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+ &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+ &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+ &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+ &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)- &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1- &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+ &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1) V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+ &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)- &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1- &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)- &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)- &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)- &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+ &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+ &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)- &64*MB*MT**3/(3*P1Q2**2*P2Q1)- &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)- &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+ &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)- &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)- &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)- &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+ &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1) V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)- &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)- &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)- &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)- &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+ &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+ &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)- &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+ &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)- &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+ &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)- &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+ &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)- &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+ &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+ &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+ &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1) V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+ &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+ &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+ &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+ &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+ &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+ &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)- &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)- &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)- &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+ &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+ &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+ &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+ &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+ &256*A12*MT**4*P2Q1/(3*P1Q2**2)+ &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+ &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2) V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+ &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+ &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+ &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+ &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)- &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)- &256*A2**2*MB**4*P1P2/(3*P2Q2**2)- &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)- &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+ &64*MB**3*MT/(3*P1Q1*P2Q2**2)+ &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+ &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)- &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)- &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)- &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+ &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+ &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2) V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)- &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+ &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+ &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)- &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)- &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)- &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+ &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)- &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)- &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+ &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)- &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2- &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)- &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+ &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)- &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)- &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2) V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)- &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)- &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)- &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)- &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)- &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+ &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+ &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+ &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+ &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)- &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)- &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)- &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)- &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)- &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+ &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)- &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2) V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+ &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)- &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)- &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)- &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+ &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+ &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+ &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)- &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)- &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)- &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)- &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+ &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)- &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+ &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+ &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+ &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2) V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+ &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+ &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+ &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)- &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+ &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+ &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+ &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)- &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+ &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)- &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)- &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+ &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)- &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+ &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)- &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+ &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2) V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)- &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)- &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)- &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+ &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2- &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)- &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+ &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+ &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)- &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+ &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+ &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)- &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)- &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)- &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)- &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)- &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2) V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+ &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+ &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)- &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+ &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)- &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+ &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+ &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)- &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)- &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)- &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)- &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)- &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)- &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)- &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+ &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+ &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2) V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+ &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+ &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+ &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+ &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+ &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+ &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+ &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+ &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+ &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+ &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+ &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+ &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)- &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+ &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+ &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)- &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2) V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)- &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)- &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+ &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+ &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1- &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)- &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+ &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+ &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+ &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+ &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)- &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+ &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+ &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)- &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+ &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+ &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1) V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)- &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)- &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)- &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+ &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)- &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)- &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)- &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)- &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)- &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)- &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+ &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)- &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)- &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+ &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+ &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+ &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1) V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+ &384*A12*MB*MT*P1Q1**2/S**2+ &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+ &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+ &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+ &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+ &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2- &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+ &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+ &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2- &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+ &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+ &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+ &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2- &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+ &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+ &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+ &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2- &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S- &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S- &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S- &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S- &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)- &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S- &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S- &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S- &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S- &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)- &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)- &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)- &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)- &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+ &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)- &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S) V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+ &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+ &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S- &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S- &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S- &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S- &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)- &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)- &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+ &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S- &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)- &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)- &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+ &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+ &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+ &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+ &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+ &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S) V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+ &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+ &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+ &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+ &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+ &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+ &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+ &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+ &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+ &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+ &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)- &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)- &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S- &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+ &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+ &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+ &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S) V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+ &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+ &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)- &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+ &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)- &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)- &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)- &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)- &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)- &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)- &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)- &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S- &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+ &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)- &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)- &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+ &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)- &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S) V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S- &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+ &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+ &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+ &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+ &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)- &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)- &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+ &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+ &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+ &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+ &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+ &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+ &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+ &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+ &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+ &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S) V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+ &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+ &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)- &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+ &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+ &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)- &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)- &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)- &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)- &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+ &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+ &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+ &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+ &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)- &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+ &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+ &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S) V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)- &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+ &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+ &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)- &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)- &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)- &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+ &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)- &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+ &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)- &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)- &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+ &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+ &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+ &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+ &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)- &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S) V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+ &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+ &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S- &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+ &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+ &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+ &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)- &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)- &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S- &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+ &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+ &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+ &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+ &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)- &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)- &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+ &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S) V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)- &192*A12*P1Q1**2*P2Q2/(P1Q2*S)- &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S- &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)- &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)- &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)- &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)- &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+ &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)- &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+ &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+ &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)- &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+ &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+ &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+ &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)- &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S) V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)- &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)- &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)- &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+ &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S) V18BIS= &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)- &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+ &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+ &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+ &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+ &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+ &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+ &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)- &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)- &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+ &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)- &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)- &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S) V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)- &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+ &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+ &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+ &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+ &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+ &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)- &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3- &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)- &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+ &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)- &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)- &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)- &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+ &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)- &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)- &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2) V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+ &272*A1*A2*P1Q1*S/(3*P1Q2)+ &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)- &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+ &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)- &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)- &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)- &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)- &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+ &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)- &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)- &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+ &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+ &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+ &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)- &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+ &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1) V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+ &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)- &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+ &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+ &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+ &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+ &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)- &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+ &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)- &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)- &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)- &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+ &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)- &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)- &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)- &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)- &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1) V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)- &32*A12*P2Q1*S/(3*P1Q1)- &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)- &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+ &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)- &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)- &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)- &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+ &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)- &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)- &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)- &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+ &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+ &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+ &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+ &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+ &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2) V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)- &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)- &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+ &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)- &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)- &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)- &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+ &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+ &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+ &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)- &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+ &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+ &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+ &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+ &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)- &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+ &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2) V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)- &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)- &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)- &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+ &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)- &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)- &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+ &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)- &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+ &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2) V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+ &272*A1*A2*P2Q1*S/(3*P2Q2)- &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+ &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+ &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+ &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)- &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+ &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+ &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)- &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)- &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)- &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)- &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+ &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+ &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+ &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+ &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1) V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+ &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)- &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)- &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+ &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)- &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)- &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+ &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2) C A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+ &512*A1*A2*MB*MT/3+ &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+ &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+ &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+ &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+ &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+ &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1- &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+ &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1- &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)- &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1- &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+ &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+ &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+ &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+ &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2) A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2- &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+ &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2- &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)- &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+ &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)- &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)- &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+ &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)- &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+ &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+ &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2- &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+ &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+ &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)- &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+ &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1- &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)- &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+ &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+ &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+ &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)- &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)- &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)- &64*MB**3*MT/(3*P1Q2*P2Q1**2)- &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+ &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)- &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+ &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+ &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)- &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1- &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1- &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1) A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+ &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+ &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1- &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+ &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+ &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)- &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+ &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)- &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+ &64*MB*MT**3/(3*P1Q2**2*P2Q1)+ &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)- &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+ &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)- &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+ &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)- &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)- &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1) A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)- &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)- &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+ &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)- &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)- &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+ &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)- &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)- &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)- &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+ &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)- &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)- &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)- &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+ &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)- &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+ &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1) A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+ &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)- &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+ &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+ &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)- &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+ &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)- &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+ &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)- &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+ &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+ &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)- &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+ &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+ &256*A12*MT**4*P2Q1/(3*P1Q2**2)+ &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)- &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2) A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+ &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+ &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+ &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+ &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+ &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)- &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+ &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)- &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)- &64*MB**3*MT/(3*P1Q1*P2Q2**2)- &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+ &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)- &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)- &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)- &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)- &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+ &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2) A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)- &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+ &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+ &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+ &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)- &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)- &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+ &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)- &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)- &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)- &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+ &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2- &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)- &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+ &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+ &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)- &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2) A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)- &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)- &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)- &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+ &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)- &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)- &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+ &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+ &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)- &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)- &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+ &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+ &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)- &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)- &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)- &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)- &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2) A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+ &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)- &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+ &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)- &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+ &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)- &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+ &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)- &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+ &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)- &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)- &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)- &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)- &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+ &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)- &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+ &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2) A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+ &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)- &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+ &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+ &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+ &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+ &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)- &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+ &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+ &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)- &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)- &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+ &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+ &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+ &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)- &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)- &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2) A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)- &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)- &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)- &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+ &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+ &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)- &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+ &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+ &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+ &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+ &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+ &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+ &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)- &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)- &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)- &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)- &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2) A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+ &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+ &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)- &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+ &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)- &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+ &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+ &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)- &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+ &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)- &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)- &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)- &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)- &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)- &272*A1*P2Q1**2/(3*P1Q1*P2Q2)- &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+ &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2) A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+ &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+ &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+ &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+ &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+ &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+ &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)- &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+ &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+ &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+ &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+ &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+ &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)- &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+ &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+ &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+ &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2) A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)- &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)- &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+ &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+ &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+ &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)- &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+ &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)- &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+ &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+ &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)- &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+ &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+ &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+ &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+ &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+ &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1) A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)- &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)- &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)- &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+ &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)- &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+ &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)- &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)- &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)- &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)- &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+ &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)- &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)- &272*A1*P2Q2**2/(3*P1Q2*P2Q1)- &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+ &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+ &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1) A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)- &384*A12*MB*MT*P1Q1**2/S**2+ &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+ &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+ &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+ &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+ &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2- &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+ &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+ &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2- &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+ &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+ &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+ &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2- &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+ &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+ &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2- &384*A2**2*MB*MT*P2Q2**2/S**2+ &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2- &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+ &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S- &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S- &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+ &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)- &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S- &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+ &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S- &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+ &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)- &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+ &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)- &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)- &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S) A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)- &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+ &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+ &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S- &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+ &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S- &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+ &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)- &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)- &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+ &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S- &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)- &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+ &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+ &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+ &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+ &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S) A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)- &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+ &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+ &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)- &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+ &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)- &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+ &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+ &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+ &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)- &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+ &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+ &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)- &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)- &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+ &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+ &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S- &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+ &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+ &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)- &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+ &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+ &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)- &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+ &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)- &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)- &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)- &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)- &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S- &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+ &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+ &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)- &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S) A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)- &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)- &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S- &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+ &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+ &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+ &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+ &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)- &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)- &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+ &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)- &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+ &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)- &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+ &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)- &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+ &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S) A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+ &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)- &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+ &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)- &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)- &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)- &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+ &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+ &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+ &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)- &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)- &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+ &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+ &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)- &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+ &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)- &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S) A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)- &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+ &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)- &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)- &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)- &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)- &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)- &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)- &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+ &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)- &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+ &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+ &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)- &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)- &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+ &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+ &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S) A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)- &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)- &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)- &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+ &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+ &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+ &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+ &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+ &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+ &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)- &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S- &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S- &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+ &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+ &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+ &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+ &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S) A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+ &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)- &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)- &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S- &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)- &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)- &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)- &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)- &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)- &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)- &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)- &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+ &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)- &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+ &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)- &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+ &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S) A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+ &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)- &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)- &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)- &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)- &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)- &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+ &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+ &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)- &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+ &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+ &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+ &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S) A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)- &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+ &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+ &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)- &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)- &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)- &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+ &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+ &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+ &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+ &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)- &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3- &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)- &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)- &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)- &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)- &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2) A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)- &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)- &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+ &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)- &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+ &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+ &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+ &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2) A18BIS= &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)- &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)- &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)- &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+ &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)- &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+ &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+ &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+ &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)- &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)- &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)- &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+ &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+ &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)- &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)- &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1) A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)- &12*S/(P1Q2*P2Q1)+ &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+ &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+ &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+ &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+ &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)- &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)- &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)- &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)- &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)- &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+ &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)- &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+ &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)- &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)- &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2) A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+ &32*MB**2*S/(3*P1Q1*P2Q2**2)+ &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)- &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)- &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+ &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)- &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)- &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+ &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+ &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+ &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)- &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+ &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+ &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+ &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+ &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+ &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2) A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)- &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)- &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)- &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+ &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)- &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)- &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)- &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+ &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+ &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)- &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)- &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+ &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+ &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+ &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)- &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)- &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2) A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+ &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+ &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+ &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+ &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)- &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+ &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)- &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)- &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+ &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2) A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)- &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+ &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+ &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)- &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)- &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)- &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)- &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)- &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+ &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+ &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+ &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+ &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)- &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)- &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)- &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)- &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2) A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)- &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+ &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2) C V18=V18+V18BIS A18=A18+A18BIS V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2- &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2- &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+ &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2- &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+ &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2- &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2- &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+ &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2- &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2- &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2- &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+ &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+ &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+ &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S- &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+ &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S V910=V910+96*A1*A2*P1P2*P2Q1/S- &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+ &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+ &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+ &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+ &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S C A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+ &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+ &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+ &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2- &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+ &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+ &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2- &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+ &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+ &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2- &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2- &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+ &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2- &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+ &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+ &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S- &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S A910=A910+96*A1*A2*P1P2*P2Q1/S- &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+ &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S- &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+ &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+ &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S C C FINAL RESULT; C AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) ) END C--------------------------------------------------------- C 2) Q QBAR ->TBH^+ SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2) C C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+ C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE) IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) DOUBLE PRECISION MW2,MT,MB,MHP,MW DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/ C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES: C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES C C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..). C DIMENSION YY(2,2) PI = 4*DATAN(1.D0) MW = DSQRT(MW2) C COLLECTING THE RELEVANT OVERALL FACTORS: C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE PS=1.D0/(3.D0*3.D0 *2.D0*2.D0) C COUPLING CONSTANT (OVERALL NORMALIZATION) FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0 C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI: C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI C ALPHAS IS ALPHA_STRONG; C SW2 IS SIN(THETA_W)**2. C C VTB=.998D0 C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE) C V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0 C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS C C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS) DO 100 KK=1,4 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK) 100 CONTINUE C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS: S = 2*PYTBHS(Q1,Q2) P1Q1=PYTBHS(Q1,P1) P1Q2=PYTBHS(P1,Q2) P2Q1=PYTBHS(P2,Q1) P2Q2=PYTBHS(P2,Q2) P1P2=PYTBHS(P1,P2) C C TOP WIDTH CALCULATION CALL PYTBHB(MT,MB,MHP,BR,GAMT) C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+ C THEN DEFINE TOP (RESONANT) PROPAGATOR: A1INV= S -2*P1Q1 -2*P1Q2 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2) C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE) C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2) A2 =1.D0/(S +2*P2Q1 +2*P2Q2) C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH C NOW COMES THE AMP**2: C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN C THE EXPRESSIONS BELOW YY(1, 1) = -16*A**2*A2**2*MB*MT+ &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+ &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2- &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2- &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2- &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+ &64*A**2*A2**2*P1Q1*P2Q2**2/S**2- &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+ &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S- &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S- &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+ &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2- &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2- &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2- &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2- &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+ &64*A2**2*P1Q1*P2Q2**2*V**2/S**2 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+ &32*A2**2*MB**2*P1P2*V**2/S+ &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S- &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S- &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S YY(1, 1)=2*YY(1, 1) YY(1, 2) = -32*A**2*A1*A2*MB*MT+ &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2- &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+ &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2- &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+ &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+ &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2- &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2- &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+ &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2- &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2- &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+ &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2- &64*A**2*A1*A2*MB*MT*P1P2/S+ &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+ &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+ &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S- &64*A**2*A1*A2*P1Q1*P2Q1/S- &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S- &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2- &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 - &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+ &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2- &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+ &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2- &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2- &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2- &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+ &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2- &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2- &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+ &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+ &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+ &32*A1*A2*P1P2*P1Q1*V**2/S+ &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S- &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S- &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S- &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S YY(2, 2) =-16*A**2*A12*MB*MT+ &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2- &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+ &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2- &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+ &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+ &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+ &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S- &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S- &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2- &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2- &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+ &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2- &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+ &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+ &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+ &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S- &32*A12*MT**2*P2Q2*V**2/S- &32*A12*P1Q2*P2Q2*V**2/S YY(2, 2)=2*YY(2, 2) RES=YY(1,1)+2*YY(1,2)+YY(2,2) AMP2= FACT*PS*VTB**2*RES END C===================================================================== C ************* FUNCTION SCALAR PRODUCTS ************************* DOUBLE PRECISION FUNCTION PYTBHS(A,B) IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) DIMENSION A(4),B(4) DUM=A(4)*B(4) DO 100 ID=1,3 DUM=DUM-A(ID)*B(ID) 100 CONTINUE PYTBHS=DUM RETURN END C********************************************************************* C...PYMSIN C...Initializes supersymmetry: finds sparticle masses and C...branching ratios and stores this information. C...AUTHOR: STEPHEN MRENNA C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM) SUBROUTINE PYMSIN C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYDAT4/CHAF(500,2) CHARACTER CHAF*16 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) COMMON/PYHTRI/HHH(7) 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 ' CALL PYSTOP(104) ENDIF SGNMU=SIGN(1D0,RMSS(4)) RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2) ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG) ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG) ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG) ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG) ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG) IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW ' CALL PYSTOP(104) ENDIF RMSS(19)=SQRT(RMSS(19)**2+DMA2) RMSS(6)=SQRT(RMSS(6)**2+DL2) RMSS(7)=SQRT(RMSS(7)**2+DE2) WRITE(MSTU(11),*) ' MTL = ',RMSS(10) WRITE(MSTU(11),*) ' MBR = ',RMSS(11) WRITE(MSTU(11),*) ' MTR = ',RMSS(12) WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13) WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14) ENDIF C...Fix the third generation sfermions. CALL PYTHRG C...Fix the neutralino--chargino--gluino sector. CALL PYINOM C...Fix the Higgs sector. CALL PYHGGM(ALFA) C...Choose the Gunion-Haber convention. ALFA=-ALFA RMSS(18)=ALFA C...Print information on mass parameters. IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS ' WRITE(MSTU(11),*) ' M0 = ',RMSS(8) WRITE(MSTU(11),*) ' M1/2=',RMSS(1) WRITE(MSTU(11),*) ' TANB=',RMSS(5) WRITE(MSTU(11),*) ' MU = ',RMSS(4) WRITE(MSTU(11),*) ' AT = ',RMSS(16) WRITE(MSTU(11),*) ' MA = ',RMSS(19) WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1) WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' ENDIF IF(IMSS(20).EQ.1) THEN WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' WRITE(MSTU(11),*) ' DEBUG MODE ' WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2), & UMIX(2,1),UMIX(2,2) WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2), & UMIXI(2,1),UMIXI(2,2) WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2), & VMIX(2,1),VMIX(2,2) WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2), & VMIXI(2,1),VMIXI(2,2) WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4) WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4) WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4) WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4) WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4) WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4) WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4) WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4) WRITE(MSTU(11),*) ' ALFA = ',ALFA WRITE(MSTU(11),*) ' BETA = ',BETA WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4) WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4) WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' ENDIF C...Set up the Higgs couplings - needed here since initialization C...in PYINRE did not yet occur when PYWIDT is called below. 170 AL=ALFA BE=BETA SINA=SIN(AL) COSA=COS(AL) COSB=COS(BE) SINB=TANB*COSB SBMA=SIN(BE-AL) SAPB=SIN(AL+BE) CAPB=COS(AL+BE) CBMA=COS(BE-AL) C2A=COS(2D0*AL) C2B=COSB**2-SINB**2 C...tanb (used for H+) PARU(141)=TANB C...Firstly: h C...Coupling to d-type quarks PARU(161)=SINA/COSB C...Coupling to u-type quarks PARU(162)=-COSA/SINB C...Coupling to leptons PARU(163)=PARU(161) C...Coupling to Z PARU(164)=SBMA C...Coupling to W PARU(165)=PARU(164) C...Secondly: H C...Coupling to d-type quarks PARU(171)=-COSA/COSB C...Coupling to u-type quarks PARU(172)=-SINA/SINB C...Coupling to leptons PARU(173)=PARU(171) C...Coupling to Z PARU(174)=CBMA C...Coupling to W PARU(175)=PARU(174) C...Coupling to h IF(IMSS(4).GE.2) THEN PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL) ELSE HHH(3)=HHH(3)+HHH(4)+HHH(5) PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+ 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB- 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+ 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB)) ENDIF C...Coupling to H+ C...Define later IF(IMSS(4).GE.2) THEN PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW) ELSE PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA- 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+ 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)- 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA) ENDIF C...Coupling to A IF(IMSS(4).GE.2) THEN PARU(177)=COS(2D0*BE)*COS(BE+AL) ELSE PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+ 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)- 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+ 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B)) ENDIF C...Coupling to H+ IF(IMSS(4).GE.2) THEN PARU(178)=PARU(177) ELSE PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA ENDIF C...Thirdly, A C...Coupling to d-type quarks PARU(181)=TANB C...Coupling to u-type quarks PARU(182)=1D0/PARU(181) C...Coupling to leptons PARU(183)=PARU(181) PARU(184)=0D0 PARU(185)=0D0 C...Coupling to Z h PARU(186)=COS(BE-AL) C...Coupling to Z H PARU(187)=SIN(BE-AL) PARU(188)=0D0 PARU(189)=0D0 PARU(190)=0D0 C...Finally: H+ C...Coupling to W h PARU(195)=COS(BE-AL) C...Tell that all Higgs couplings have been set. MSTP(4)=1 C...Set R-Violating couplings. C...Set lambda couplings to common value or "natural values". IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN VIR3=1D0/(126D0)**3 DO 200 IRK=1,3 DO 190 IRI=1,3 DO 180 IRJ=1,3 IF (IRI.NE.IRJ) THEN IF (IRI.LT.IRJ) THEN RVLAM(IRI,IRJ,IRK)=RMSS(51) IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)* & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)* & PMAS(9+2*IRK,1)*VIR3) ELSE RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK) ENDIF ELSE RVLAM(IRI,IRJ,IRK)=0D0 ENDIF 180 CONTINUE 190 CONTINUE 200 CONTINUE ENDIF C...Set lambda' couplings to common value or "natural values". IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN VIR3=1D0/(126D0)**3 DO 230 IRI=1,3 DO 220 IRJ=1,3 DO 210 IRK=1,3 RVLAMP(IRI,IRJ,IRK)=RMSS(52) IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)* & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+ & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3) 210 CONTINUE 220 CONTINUE 230 CONTINUE ENDIF C...Set lambda'' couplings to common value or "natural values". IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN VIR3=1D0/(126D0)**3 DO 260 IRI=1,3 DO 250 IRJ=1,3 DO 240 IRK=1,3 IF (IRJ.NE.IRK) THEN IF (IRJ.LT.IRK) THEN RVLAMB(IRI,IRJ,IRK)=RMSS(53) IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)= & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)* & PMAS(2*IRK-1,1)*VIR3) ELSE RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ) ENDIF ELSE RVLAMB(IRI,IRJ,IRK) = 0D0 ENDIF 240 CONTINUE 250 CONTINUE 260 CONTINUE ENDIF C...Antisymmetrize couplings set by user IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN DO 290 IRI=1,3 DO 280 IRJ=1,3 DO 270 IRK=1,3 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK) IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0 ENDIF IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK) IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0 ENDIF 270 CONTINUE 280 CONTINUE 290 CONTINUE ENDIF C...Write spectrum to SLHA file IF (IMSS(23).NE.0) THEN IFAIL=0 CALL PYSLHA(3,0,IFAIL) ENDIF C...Second part of routine: set decay modes and branching ratios. C...Allow chi10 -> gravitino + gamma or not. KC=PYCOMP(KSUSY1+39) IF( IMSS(11) .NE. 0 ) THEN PMAS(KC,1)=RMSS(21)/1D9 PMAS(KC,2)=0D0 IRPRTY=0 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS ' ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN IRPRTY=0 IF (IMSS(51).GE.1) WRITE(MSTU(11),*) & ' ALLOWING SUSY LLE DECAYS' IF (IMSS(52).GE.1) WRITE(MSTU(11),*) & ' ALLOWING SUSY LQD DECAYS' IF (IMSS(53).GE.1) WRITE(MSTU(11),*) & ' ALLOWING SUSY UDD DECAYS' IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*) & ' --- Warning: R-Violating couplings possibly', & ' incompatible with proton decay' ELSE PMAS(KC,1)=9999D0 IRPRTY=1 ENDIF C...Loop over sparticle and Higgs species. PMCHI1=PMAS(PYCOMP(KSUSY1+22),1) C...Find the LSP or NLSP for a gravitino LSP ILSP=0 PMLSP=1D20 DO 300 I=1,36 KF=KFSUSY(I) IF(KF.EQ.1000039) GOTO 300 KC=PYCOMP(KF) IF(PMAS(KC,1).LT.PMLSP) THEN ILSP=I PMLSP=PMAS(KC,1) ENDIF 300 CONTINUE DO 370 I=1,50 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370 KF=KFSUSY(I) IF (KF.EQ.0) GOTO 370 KC=PYCOMP(KF) LKNT=0 C...Check if there are any decays listed for this sparticle C...in a file IF (IMSS(22).NE.0) 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 IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN CPRO(MUPDA)=' ' CVER(MUPDA)=' ' ENDIF C...Initialize read loop MERR=0 NLINE=0 CHBLCK=' ' C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE. 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) CALL PYSTOP(106) 470 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE WRITE(*,*) CHINL(1:72) CALL PYSTOP(106) 480 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE WRITE(*,*) CHINL(1:80) CALL PYSTOP(106) 490 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE WRITE(*,*) CHINL(1:80) CALL PYSTOP(106) 500 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE WRITE(*,*) CHINL(1:80) 510 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK CALL PYSTOP(106) 520 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':' WRITE(*,*) CHINL(1:80) CALL PYSTOP(106) 8300 FORMAT(I9) 8500 FORMAT(F16.5) C...Formats for user information printout. 5000 FORMAT(1x,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 ' CALL PYSTOP(102) ENDIF ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM IF(ARG.GT.0D0) THEN RMSS(14)=SQRT(ARG) ELSE WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 ' CALL PYSTOP(102) ENDIF ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM IF(ARG.GT.0D0) THEN RMSS(13)=SQRT(ARG) ELSE WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 ' CALL PYSTOP(102) ENDIF ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0) IF(ARG.GT.0D0) THEN RMSS(10)=SQRT(ARG) ELSE RMSS(10)=-SQRT(-ARG) ENDIF ARG=PYRNMQ(2,-2D0*XTOP/3D0) IF(ARG.GT.0D0) THEN RMSS(12)=SQRT(ARG) ELSE RMSS(12)=-SQRT(-ARG) ENDIF ARG=PYRNMQ(3,-2D0*XBOT/3D0) IF(ARG.GT.0D0) THEN RMSS(11)=SQRT(ARG) ELSE RMSS(11)=-SQRT(-ARG) ENDIF RETURN END C********************************************************************* C...PYSUGI C...Interface to ISASUSY version 7.71. C...Warning: this interface should not be used with earlier versions C...of ISASUSY, since common block incompatibilities may then arise. C...Calls SUGRA (in ISAJET) to perform RGE evolution. C...Then converts to Gunion-Haber conventions. SUBROUTINE PYSUGI IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Date of Change CHARACTER DOC*11 PARAMETER (DOC='01 May 2006') C...ISASUGRA Input: REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP C...XISAIN contains the MSSMi inputs in natural order. COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4), $XAMIN(7) REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN SAVE /SUGXIN/ C...ISASUGRA Output CHARACTER*40 ISAVER,VISAJE REAL SUPER COMMON /SSPAR/ SUPER(72) COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT, $FBGUT,FTAGUT,FNGUT REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW, $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ, $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3, $VUMT,VDMT,ASMTP,ASMSS,M3Q REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW, $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ, $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG INTEGER IALLOW SAVE /SUGMG/,/SSPAR/ C SUPER: Filled by ISASUGRA. C SUPER(1) = mass of ~g C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2 C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1 C ,~tau_2 C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau C SUPER(29) = Higgsino mass = - mu C SUPER(30) = ratio v2/v1 of vev's C SUPER(31:34) = Signed neutralino masses C SUPER(35:50) = Neutralino mixing matrix C SUPER(51:52) = Signed chargino masses C SUPER(53:54) = Chargino left, right mixing angles C SUPER(55:58) = mass of h0, H0, A0, H+ C SUPER(59) = Higgs mixing angle alpha C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau C SUPER(66) = Gravitino mass C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used) C SUPER(70) = b-Yukawa at mA scale (not used) C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used) C GSS: Filled by ISASUGRA C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3 C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3 C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2 C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2 C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2 C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2 C GSS(25) = mu GSS(26) = B GSS(27) = Y_N C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq) C GSS(31) = log(vuq) C MSS: Filled by ISASUGRA C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1 C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl C MSS(16) = nutl MSS(17) = el- MSS(18) = er- C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1 C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0 C MSS(31) = ha0 MSS(32) = h+ C Unification, filled by ISASUGRA if applicable. C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC C...SPYTHIA Input/Output INTEGER IMSS DOUBLE PRECISION RMSS COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) C...SLHA Input/Output COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100), & AU(3,3),AD(3,3),AE(3,3) C...PYTHIA common blocks COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/ CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC INTEGER IMODEL REAL M0,MHF,A0,MT CHARACTER*20 CHMOD(5) CHARACTER*32 FNAME COMMON /SUGNU/ XNUSUG(18) REAL XNUSUG SAVE /SUGNU/ DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA', & 'truly unified SUGRA', 'non-minimal GMSB'/ C...Start by checking for incompatibilities/inconsistencies: DO 100 ICHK=2,9 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK) & ,' option not used by PYSUGI' ENDIF 100 CONTINUE C...ISAJET works with REAL numbers. MZERO=REAL(RMSS(8)) MHLF=REAL(RMSS(1)) AZERO=REAL(RMSS(16)) TANB=REAL(RMSS(5)) SGNMU=REAL(RMSS(4)) MTOP=REAL(PMAS(6,1)) IMODEL=0 IF (IMSS(1).EQ.12) THEN IMODEL=1 GOTO 130 ELSEIF(IMSS(1).EQ.13) THEN C...Read from isajet par file in IMSS(20) LFN=IMSS(20) C...STOP IF LFN IS ZERO (i.e. if no LFN was given). IF (LFN.EQ.0) THEN WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)' GOTO 9999 ENDIF WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...' CMrenna change to allow any susy model WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:' WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:' WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:' WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'// & ' gauge couplings:' WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:' READ(LFN,*) IMODEL IF (IMODEL.EQ.4) THEN IAL3UN=1 IMODEL=1 ENDIF IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),' & //' sgn(mu), M_t:' READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT IF (IMODEL.EQ.3) THEN IMODEL=1 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;' & //' 0 to continue:' WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses' WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms' WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses' WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd' & //' generation masses' WRITE(MSTU(11),*) & ' NUSUG5 = GUT scale 3rd generation masses' READ(LFN,*) INUSUG IF (INUSUG.EQ.0) THEN GOTO 120 ELSEIF (INUSUG.EQ.1) THEN WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:' READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3) IF (XNUSUG(3).LE.0.) THEN WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED' CALL PYSTOP(109) END IF ELSEIF (INUSUG.EQ.2) THEN WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:' READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4) ELSEIF (INUSUG.EQ.3) THEN WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:' READ(LFN,*) XNUSUG(7),XNUSUG(8) ELSEIF (INUSUG.EQ.4) THEN WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),' & //' M(ur), M(el), M(er):' READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12), & XNUSUG(10),XNUSUG(9) ELSEIF (INUSUG.EQ.5) THEN WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),' & //' M(Ll), M(Lr):' READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17), & XNUSUG(15),XNUSUG(14) ENDIF GOTO 110 ENDIF ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN IMSS(11)=1 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),' & ,' sgn(mu), M_t, C_gv:' READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV XGMIN(7)=XCMGV XGMIN(8)=1. C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2} AMPL=2.4D18 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL IF (IMODEL.EQ.5) THEN IMODEL=2 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino' & ,' masses at M_mes' WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2' & ,' shifts at M_mes' WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to', & ' Y at M_mes' WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),' & ,'SU(2),SU(3)' WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,' & ,' n5_2, n5_3' READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12), $ XGMIN(13),XGMIN(14) ENDIF ELSE WRITE(MSTU(11),*) 'Invalid model choice.' GOTO 9999 ENDIF ENDIF 120 MZERO=M0 MHLF=MHF AZERO=A0 C TANB=REAL(RMSS(5)) C SGNMU=REAL(RMSS(4)) MTOP=MT C...Initialize MSSM parameter array 130 DO 140 IPAR=1,72 SUPER(IPAR)=0.0 140 CONTINUE C...Call ISASUGRA CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL) C...Check whether ISASUSY thought the model was OK. IF (NOGOOD.NE.0) THEN IF (NOGOOD.EQ.1) CALL PYERRM(26 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.') IF (NOGOOD.EQ.2) CALL PYERRM(26 & ,'(PYSUGI:) SUSY parameters give no EWSB.') IF (NOGOOD.EQ.3) CALL PYERRM(26 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.') IF (NOGOOD.EQ.4) CALL PYERRM(26 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.') IF (NOGOOD.EQ.7) CALL PYERRM(26 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.') IF (NOGOOD.EQ.8) CALL PYERRM(26 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.') C...Give warning, but don't stop, if LSP not ~chi_10. IF (NOGOOD.EQ.5) CALL PYERRM(16 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.') ENDIF C...Warn about possible GUT scale tachyons. IF (ITACHY.NE.0) CALL PYERRM(16, & '(PYSUGI:) Tachyonic sleptons at GUT scale.') C...Finalize spectrum (last iteration) C...(Thanks to A. Raklev for pointing this out.) C...NB: SSMSSM also calculates decays, but these are not used by Pythia. CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3), $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9), $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14), $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19), $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24), $ MTOP,IALLOW,1) C...M1, M2, M3. RMSS(1)=dble(GSS(7)) RMSS(2)=dble(GSS(8)) RMSS(3)=dble(GSS(9)) RMSOFT(1)=dble(GSS(7)) RMSOFT(2)=dble(GSS(8)) RMSOFT(3)=dble(GSS(9)) C...Mu = - Higgsino mass. RMSS(4)=-SUPER(29) RMSS(5)=TANB C...Slepton and squark masses. 2 first generations. RMSS(6)=0.5*(SUPER(18)+SUPER(20)) RMSS(7)=0.5*(SUPER(19)+SUPER(21)) RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8)) RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9)) C...Third generation. RMSS(10)=0.5*(SUPER(14)+SUPER(10)) RMSS(11)=SUPER(11) RMSS(12)=SUPER(15) RMSS(13)=SUPER(22) RMSS(14)=SUPER(23) C...SLHA: store exact soft spectrum in RMSOFT RMSOFT(31)=SUPER(18) RMSOFT(32)=SUPER(20) RMSOFT(33)=SUPER(22) RMSOFT(34)=SUPER(19) RMSOFT(35)=SUPER(21) RMSOFT(36)=SUPER(23) RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4)) RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8)) RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14)) RMSOFT(44)=SUPER(3) RMSOFT(45)=SUPER(9) RMSOFT(46)=SUPER(15) RMSOFT(47)=SUPER(5) RMSOFT(48)=SUPER(7) RMSOFT(49)=SUPER(11) C...~b, ~t, and ~tau trilinear couplings and mixing angles. RMSS(15)=SUPER(62) RMSS(16)=SUPER(60) RMSS(17)=SUPER(64) RMSS(26)=SUPER(63) RMSS(27)=SUPER(61) RMSS(28)=SUPER(65) C...SLHA trilinears DO 142 K1=1,3 DO 141 K2=1,3 AE(K1,K2)=0D0 AU(K1,K2)=0D0 AD(K1,K2)=0D0 141 CONTINUE 142 CONTINUE AE(3,3)=SUPER(64) AU(3,3)=SUPER(60) AD(3,3)=SUPER(62) C...Higgs mixing angle alpha (Gunion-Haber convention). RMSS(18)=-SUPER(59) C...A0 mass. RMSS(19)=SUPER(57) C...GUT scale coupling RMSS(20)=AGUTSS C...Gravitino mass (for future compatibility) RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66))) C...Now we're done with RMSS. Time to fill PMAS (m > 0 required). C...Higgs sector. PMAS(PYCOMP(25),1)=ABS(SUPER(55)) PMAS(PYCOMP(35),1)=ABS(SUPER(56)) PMAS(PYCOMP(36),1)=ABS(SUPER(57)) PMAS(PYCOMP(37),1)=ABS(SUPER(58)) C...Gluino. PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1)) C...Squarks and Sleptons. DO 150 ILR=1,2 ILRM=ILR-1 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM)) PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM)) PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM)) PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM)) PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM)) PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM)) PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM)) PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM)) PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM)) 150 CONTINUE PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26)) PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27)) PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28)) C...Neutralinos. PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31)) PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32)) PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33)) PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34)) C...Signed masses (extra minus from going to G-H convention). SMZ(1)=-SUPER(31) SMZ(2)=-SUPER(32) SMZ(3)=-SUPER(33) SMZ(4)=-SUPER(34) C...Charginos PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51)) PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52)) C...Signed masses (extra minus from going to G-H convention). SMW(1)=-SUPER(51) SMW(2)=-SUPER(52) C... Neutralino Mixing. DO 160 IN=1,4 ZMIX(IN,1)= SUPER(38+4*(IN-1)) ZMIX(IN,2)= SUPER(37+4*(IN-1)) ZMIX(IN,3)=-SUPER(36+4*(IN-1)) ZMIX(IN,4)=-SUPER(35+4*(IN-1)) 160 CONTINUE C...Chargino Mixing (PYTHIA same angle as HERWIG). THX=1D0 THY=1D0 IF (SUPER(53).GT.0) THX=-1D0 IF (SUPER(54).GT.0) THY=-1D0 UMIX(1,1) = -SIN(SUPER(53)) UMIX(1,2) = -COS(SUPER(53)) UMIX(2,1) = -THX*COS(SUPER(53)) UMIX(2,2) = THX*SIN(SUPER(53)) VMIX(1,1) = -SIN(SUPER(54)) VMIX(1,2) = -COS(SUPER(54)) VMIX(2,1) = -THY*COS(SUPER(54)) VMIX(2,2) = THY*SIN(SUPER(54)) C...Sfermion mixing (PYTHIA same angle as ISAJET) SFMIX(5,1)=COS(SUPER(63)) SFMIX(5,2)=SIN(SUPER(63)) SFMIX(5,3)=-SIN(SUPER(63)) SFMIX(5,4)=COS(SUPER(63)) SFMIX(6,1)=COS(SUPER(61)) SFMIX(6,2)=SIN(SUPER(61)) SFMIX(6,3)=-SIN(SUPER(61)) SFMIX(6,4)=COS(SUPER(61)) SFMIX(15,1)=COS(SUPER(65)) SFMIX(15,2)=SIN(SUPER(65)) SFMIX(15,3)=-SIN(SUPER(65)) SFMIX(15,4)=COS(SUPER(65)) IF (MSTP(122).NE.0) THEN C...Print a few lines to make the user know what's happening ISAVER=VISAJE() WRITE(MSTU(11),5000) DOC, ISAVER WRITE(MSTU(11),5100) IF (IMODEL.EQ.1) THEN WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU), & MTOP WRITE(MSTU(11),5300) ENDIF WRITE(MSTU(11),5500) 'Pole masses' WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2) WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28) & ,(SUPER(IP),IP=19,25,2) WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP) & ,IP=1,2) WRITE(MSTU(11),5400) WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58) WRITE(MSTU(11),5400) WRITE(MSTU(11),5500) 'EW scale mixing structure' WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4) WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2) & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2) WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2) & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4 & ),(SFMIX(15,J),J=3,4) WRITE(MSTU(11),5400) WRITE(MSTU(11),6450) RMSS(18) WRITE(MSTU(11),5400) WRITE(MSTU(11),5500) 'Couplings' WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20) WRITE(MSTU(11),5400) ENDIF C...Call FeynHiggs to improve Higgs sector if requested IF (IMSS(4).EQ.3) THEN IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)') & ' (PYSUGI:) Now calling FeynHiggs.' CALL PYFEYN(IERR) IF (IERR.EQ.0) THEN IMSS(4)=2 IF (MSTP(122).NE.0) THEN WRITE(MSTU(11),5400) WRITE(MSTU(11),5500) & 'Corrected Higgs masses and mixing' WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1), & PMAS(37,1) WRITE(MSTU(11),6450) RMSS(18) WRITE(MSTU(11),5400) ENDIF ENDIF ENDIF IF (MSTP(122).NE.0) WRITE(MSTU(11),6500) C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle C...output by ISASUSY. IMSS(4)=MAX(2,IMSS(4)) 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY ' & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*') 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------') 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)', & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2) 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x & ,'----------------') 5400 FORMAT(1x,'*',1x,A) 5500 FORMAT(1x,'*',1x,A,':') 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/ & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2) 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x, & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x, & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2 & ,1x)) 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8 & .2,1x)) 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20' & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x)) 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x)) 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)') 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|' & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|' & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|' & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|' & ,1x,F6.3,1x),'|') 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|' & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|') 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/ & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|' & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/ & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|' & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|') 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2 & ,4x,'Alpha_GUT = ',F8.2) 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4) 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*')) 9999 RETURN END C********************************************************************* C...PYFEYN C...Interface to FeynHiggs for MSSM Higgs sector. C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX C...P. Skands SUBROUTINE PYFEYN(IERR) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) C...SUSY blocks COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) C...FeynHiggs variables DOUBLE PRECISION RMHIGG(4) DOUBLE COMPLEX SAEFF, UHIGGS(3,3) DOUBLE COMPLEX DMU, & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11, & DM1, DM2, DM3 C...SLHA Common Block COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100), & AU(3,3),AD(3,3),AE(3,3) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/ IERR=0 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1) IF (IERR.NE.0) THEN CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.' & //'Will not use FeynHiggs for this run.') RETURN ENDIF Q=RMSOFT(0) DMB=PMAS(5,1) DMT=PMAS(6,1) DMZ=PMAS(23,1) DMW=PMAS(24,1) DMA=PMAS(36,1) DM1=RMSOFT(1) DM2=RMSOFT(2) DM3=RMSOFT(3) DTANB=RMSS(5) DMU=RMSS(4) DM3SL=RMSOFT(33) DM3SE=RMSOFT(36) DM3SQ=RMSOFT(43) DM3SU=RMSOFT(46) DM3SD=RMSOFT(49) DM2SL=RMSOFT(32) DM2SE=RMSOFT(35) DM2SQ=RMSOFT(42) DM2SU=RMSOFT(45) DM2SD=RMSOFT(48) DM1SL=RMSOFT(31) DM1SE=RMSOFT(34) DM1SQ=RMSOFT(41) DM1SU=RMSOFT(44) DM1SD=RMSOFT(47) AE33=AE(3,3) AE22=AE(2,2) AE11=AE(1,1) AU33=AU(3,3) AU22=AU(2,2) AU11=AU(1,1) AD33=AD(3,3) AD22=AD(2,2) AD11=AD(1,1) CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB, & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD, & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD, & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU, & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11, & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q) IF (IERR.NE.0) THEN CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.' & //' Will not use FeynHiggs for this run.') RETURN ENDIF C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV) SAEFF=0D0 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS) IF (IERR.NE.0) THEN CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'// & 'GSCORR. Will not use FeynHiggs for this run.') RETURN ENDIF ALPHA = ASIN(DBLE(SAEFF)) R=RMSS(18)/ALPHA IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.') WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18) WRITE(MSTU(11),*) ' New Alpha:', ALPHA ENDIF IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT. & 1.15D0*PMAS(25,1)) THEN CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.') WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1) WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1) ENDIF RMSS(18)=ALPHA PMAS(25,1)=RMHIGG(1) PMAS(35,1)=RMHIGG(2) PMAS(36,1)=RMHIGG(3) PMAS(37,1)=RMHIGG(4) RETURN END C********************************************************************* C...PYRNMQ C...Determines the running mass of Squarks. FUNCTION PYRNMQ(ID,DTERM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblock. COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) SAVE /PYMSSM/ C...Local variables. DOUBLE PRECISION PI,R DOUBLE PRECISION TOL DOUBLE PRECISION CI(3) EXTERNAL PYALPS DOUBLE PRECISION PYALPS DATA TOL/0.001D0/ DATA PI,R/3.141592654D0,.61803399D0/ DATA CI/0.47D0,0.07D0,0.02D0/ C=1D0-R CA=CI(ID) AG=(0.71D0)**2/4D0/PI AG=RMSS(20) XM0=RMSS(8) XMG=RMSS(1) XM02=XM0*XM0 XMG2=XMG*XMG AS=PYALPS(XM02+6D0*XMG2) CG=8D0/9D0*((AS/AG)**2-1D0) BX=XM02+(CA+CG)*XMG2+DTERM AX=MIN(50D0**2,0.5D0*BX) CX=MAX(2000D0**2,2D0*BX) X0=AX X3=CX IF(ABS(CX-BX).GT.ABS(BX-AX))THEN X1=BX X2=BX+C*(CX-BX) ELSE X2=BX X1=BX-C*(BX-AX) ENDIF AS1=PYALPS(X1) CG=8D0/9D0*((AS1/AG)**2-1D0) F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1) AS2=PYALPS(X2) CG=8D0/9D0*((AS2/AG)**2-1D0) F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2) 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN IF(F2.LT.F1) THEN X0=X1 X1=X2 X2=R*X1+C*X3 F1=F2 AS2=PYALPS(X2) CG=8D0/9D0*((AS2/AG)**2-1D0) F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2) ELSE X3=X2 X2=X1 X1=R*X2+C*X0 F2=F1 AS1=PYALPS(X1) CG=8D0/9D0*((AS1/AG)**2-1D0) F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1) ENDIF GOTO 100 ENDIF IF(F1.LT.F2) THEN PYRNMQ=X1 XMIN=X1 ELSE PYRNMQ=X2 XMIN=X2 ENDIF RETURN END C********************************************************************* C...PYTHRG C...Calculates the mass eigenstates of the third generation sfermions. C...Created: 5-31-96 SUBROUTINE PYTHRG C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ C...Local variables. DOUBLE PRECISION BETA DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2) DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL DOUBLE PRECISION ATR,AMQR,AMQL INTEGER ID1(3),ID2(3),ID3(3),ID4(3) INTEGER IF,I,J,II,JJ,IT,L LOGICAL DTERM DATA SMALL/1D-3/ DATA ID1/10,10,13/ DATA ID2/5,6,15/ DATA ID3/15,16,17/ DATA ID4/11,12,14/ DATA DTERM/.TRUE./ XMZ2=PMAS(23,1)**2 XMW2=PMAS(24,1)**2 TANB=RMSS(5) XMU=-RMSS(4) BETA=ATAN(TANB) COS2B=COS(2D0*BETA) C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS IOPT=IMSS(5) IF(IOPT.EQ.1) THEN CTT=DCOS(RMSS(27)) CTT2=CTT**2 STT=DSIN(RMSS(27)) STT2=STT**2 XM12=RMSS(10)**2 XM22=RMSS(12)**2 XMQL2=CTT2*XM12+STT2*XM22 XMQR2=STT2*XM12+CTT2*XM22 XMF2=PYMRUN(6,PMAS(6,1)**2)**2 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2) RMSS(16)=ATOP C......SUBTRACT OUT D-TERM AND FERMION MASS XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0 IF(XMQL2.GE.0D0) THEN RMSS(10)=SQRT(XMQL2) ELSE RMSS(10)=-SQRT(-XMQL2) ENDIF IF(XMQR2.GE.0D0) THEN RMSS(12)=SQRT(XMQR2) ELSE RMSS(12)=-SQRT(-XMQR2) ENDIF C SAME FOR BOTTOM SQUARK CTT=DCOS(RMSS(26)) CTT2=CTT**2 STT=DSIN(RMSS(26)) STT2=STT**2 XM22=RMSS(11)**2 XMF2=PYMRUN(5,PMAS(6,1)**2)**2 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2 IF(ABS(CTT).GE..9999D0) THEN ABOT=-XMU*TANB XMQR2=RMSS(11)**2 ELSEIF(ABS(CTT).LE.1D-4) THEN ABOT=-XMU*TANB XMQR2=RMSS(11)**2 ELSE XM12=(XMQL2-STT2*XM22)/CTT2 XMQR2=STT2*XM12+CTT2*XM22 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2) ENDIF RMSS(15)=ABOT C......SUBTRACT OUT D-TERM AND FERMION MASS XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2 IF(XMQR2.GE.0D0) THEN RMSS(11)=SQRT(XMQR2) ELSE RMSS(11)=-SQRT(-XMQR2) ENDIF C SAME FOR TAU SLEPTON CTT=DCOS(RMSS(28)) CTT2=CTT**2 STT=DSIN(RMSS(28)) STT2=STT**2 XM12=RMSS(13)**2 XM22=RMSS(14)**2 XMQL2=CTT2*XM12+STT2*XM22 XMQR2=STT2*XM12+CTT2*XM22 XMFR=PMAS(15,1) XMF2=XMFR**2 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2) RMSS(17)=ATAU C......SUBTRACT OUT D-TERM AND FERMION MASS XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B IF(XMQL2.GE.0D0) THEN RMSS(13)=SQRT(XMQL2) ELSE RMSS(13)=-SQRT(-XMQL2) ENDIF IF(XMQR2.GE.0D0) THEN RMSS(14)=SQRT(XMQR2) ELSE RMSS(14)=-SQRT(-XMQR2) ENDIF ENDIF DO 170 L=1,3 AMQL=RMSS(ID1(L)) IF(AMQL.LT.0D0) THEN XMQL2=-AMQL**2 ELSE XMQL2=AMQL**2 ENDIF ATR=RMSS(ID3(L)) AMQR=RMSS(ID4(L)) IF(AMQR.LT.0D0) THEN XMQR2=-AMQR**2 ELSE XMQR2=AMQR**2 ENDIF IF=ID2(L) XMF=PYMRUN(IF,PMAS(6,1)**2) XMF2=XMF**2 AM2(1,1)=XMQL2+XMF2 AM2(2,2)=XMQR2+XMF2 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0 IF(DTERM) THEN IF(L.EQ.1) THEN AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0 AM2(1,2)=XMF*(ATR+XMU*TANB) ELSEIF(L.EQ.2) THEN AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0 AM2(1,2)=XMF*(ATR+XMU/TANB) ELSEIF(L.EQ.3) THEN IF(IMSS(8).EQ.1) THEN AM2(1,1)=RMSS(6)**2 AM2(2,2)=RMSS(7)**2 AM2(1,2)=0D0 RMSS(13)=RMSS(6) RMSS(14)=RMSS(7) ELSE AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B AM2(1,2)=XMF*(ATR+XMU*TANB) ENDIF ENDIF ENDIF AM2(2,1)=AM2(1,2) DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2 IF(DETM.LT.0D0) THEN WRITE(MSTU(11),*) ID2(L),DETM,AM2 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ') ENDIF SAME=0.5D0*(AM2(1,1)+AM2(2,2)) DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1)) XMF12=SAME-DIFF XMF22=SAME+DIFF IT=0 IF(XMF22-XMF12.GT.0D0) THEN RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12))) RT(2,2) = RT(1,1) RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)), & AM2(1,2)/(XMF22-XMF12)) RT(2,1) = -RT(1,2) ELSE RT(1,1) = 1D0 RT(2,2) = RT(1,1) RT(1,2) = 0D0 RT(2,1) = -RT(1,2) ENDIF 100 CONTINUE IT=IT+1 DO 140 I=1,2 DO 130 JJ=1,2 DI(I,JJ)=0D0 DO 120 II=1,2 DO 110 J=1,2 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II) 110 CONTINUE 120 CONTINUE 130 CONTINUE 140 CONTINUE IF(DI(1,1).GT.DI(2,2)) THEN WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION ' WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22) WRITE(MSTU(11),*) AM2 WRITE(MSTU(11),*) DI WRITE(MSTU(11),*) RT DI(1,1)=-RT(2,1) DI(2,2)=RT(1,2) DI(1,2)=-RT(2,2) DI(2,1)=RT(1,1) DO 160 I=1,2 DO 150 J=1,2 RT(I,J)=DI(I,J) 150 CONTINUE 160 CONTINUE GOTO 100 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'// & ' OFF DIAGONAL ELEMENTS ' WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22) WRITE(MSTU(11),*) DI WRITE(MSTU(11),*) ' ROTATION = ',RT C...STOP ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'// & ' NEGATIVE MASSES ' CALL PYSTOP(111) ENDIF PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12) PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22) SFMIX(IF,1)=RT(1,1) SFMIX(IF,2)=RT(1,2) SFMIX(IF,3)=RT(2,1) SFMIX(IF,4)=RT(2,2) 170 CONTINUE C.....TAU SNEUTRINO MASS...L=3 XARG=AM2(1,1)+XMW2*COS2B IF(XARG.LT.0D0) THEN WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'// & ' FROM THE SUM RULE. ' WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). ' RETURN ELSE PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG) ENDIF RETURN END C********************************************************************* C...PYINOM C...Finds the mass eigenstates and mixing matrices for neutralinos C...and charginos. SUBROUTINE PYINOM C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ C...Local variables. DOUBLE PRECISION XMW,XMZ,XM(4) DOUBLE PRECISION AR(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 CALL PYSTOP(105) ENDIF ENDIF C...GLUINO MASS IF(IMSS(3).EQ.1) THEN PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3) ELSE AQ=0D0 DO 110 I=1,4 DO 100 ILR=1,2 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0) & +(1D0-RM1)**2*LOG(ABS(1D0-RM1))) 100 CONTINUE 110 CONTINUE DO 130 I=5,6 DO 120 ILR=1,2 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2 RM2=PMAS(I,1)**2/XM3**2 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2 IF(ARG.GE.0D0) THEN X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG)) AX0=ABS(X0) X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG)) AX1=ABS(X1) IF(X0.EQ.1D0) THEN AT=-1D0 BT=0.25D0 ELSEIF(X0.EQ.0D0) THEN AT=0D0 BT=-0.25D0 ELSE AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+ & 0.5D0*X0**2*LOG(AX0) BT=(-1D0-2D0*X0)/4D0 ENDIF IF(X1.EQ.1D0) THEN AT=-1D0+AT BT=0.25D0+BT ELSEIF(X1.EQ.0D0) THEN AT=0D0+AT BT=-0.25D0+BT ELSE AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0* & X1**2*LOG(AX1)+AT BT=(-1D0-2D0*X1)/4D0+BT ENDIF AQ=AQ+AT+BT ELSE X0=0.5D0*(1D0+RM2-RM1) Y0=-0.5D0*SQRT(-ARG) AMGX0=SQRT(X0**2+Y0**2) AM1X0=SQRT((1D0-X0)**2+Y0**2) ARGX0=ATAN2(-X0,-Y0) AR1X0=ATAN2(1D0-X0,Y0) X1=X0 Y1=-Y0 AMGX1=AMGX0 AM1X1=AM1X0 ARGX1=ATAN2(-X1,-Y1) AR1X1=ATAN2(1D0-X1,Y1) AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2) & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0) BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 ) AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2) & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1) BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 ) AQ=AQ+AT+BT ENDIF 120 CONTINUE 130 CONTINUE PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2) & /(2D0*PARU(2))*(15D0+AQ)) ENDIF C...NEUTRALINO MASSES DO 150 I=1,4 DO 140 J=1,4 AI(I,J)=0D0 140 CONTINUE 150 CONTINUE XMZ=PMAS(23,1) 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 CALL PYSTOP(107) END C********************************************************************* C...PYRGHM C...Auxiliary to PYPOLE. SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU, * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB) IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z) DIMENSION VH(2,2),M2(2,2),M2P(2,2) C...Parameters. INTEGER MSTU,MSTJ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ MZ = 91.18D0 PI = PARU(1) V = 174.1D0 ALPHA1 = 0.0101D0 ALPHA2 = 0.0337D0 ALPHA3Z = 0.12D0 TANBA = TANB TANBT = TANB C MBOTTOM(MTOP) = 3. GEV MB = PYMRUN(5,MTOP**2) ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z* *LOG(MTOP**2/MZ**2)) C RMTOP= RUNNING TOP QUARK MASS RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI) TQ = LOG((MQ**2+MTOP**2)/MTOP**2) TU = LOG((MUR**2 + MTOP**2)/MTOP**2) TD = LOG((MD**2 + MTOP**2)/MTOP**2) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C NEW DEFINITION, TGLU. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC TGLU = LOG(MGLU**2/MTOP**2) SINB = TANB/DSQRT(1D0 + TANB**2) COSB = SINB/TANB IF(MA.GT.MTOP) *TANBA = TANB*(1D0-3D0/32D0/PI**2* *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)* *LOG(MA**2/MTOP**2)) IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA SINB = TANBT/SQRT(1D0 + TANBT**2) COSB = 1D0/DSQRT(1D0 + TANBT**2) G1 = SQRT(ALPHA1*4D0*PI) G2 = SQRT(ALPHA2*4D0*PI) G3 = SQRT(ALPHA3*4D0*PI) HU = RMTOP/V/SINB HD = MB/V/COSB CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2, *SBOT1,SBOT2,DELTAMT,DELTAMB) IF(MQ.GT.MUR) TP = TQ - TU IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ IF(MQ.GT.MUR) TDP = TU IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ IF(MQ.GT.MD) TPD = TQ - TD IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ IF(MQ.GT.MD) TDPD = TD IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2* * HD**2*(G1**2/3D0+G2**2)*TPD IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2* * HU**2*(-G1**2/3D0+G2**2)*TP CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL, C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE C TWO STOPS. C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC DLAMBDAP2 = 0D0 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2) ENDIF IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2) ENDIF IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2) ENDIF IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2) ENDIF IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2) ENDIF IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2) ENDIF ENDIF DLAMBDA3 = 0D0 DLAMBDA4 = 0D0 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2* *(G2**2-G1**2/3D0)*TPD IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 - *1D0/16D0/PI**2*G1**2*HU**2*TP IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 + * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2* *HD**2*TPD LAMBDA1 = ((G1**2 + G2**2)/4D0)* * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2) *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0 *+ (3D0*HD**2/2D0 + HU**2/2D0 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2) *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2* *(TP + TDP)/8D0/PI**2) *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0 *+ (3D0*HU**2/2D0 + HD**2/2D0 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2) *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0* *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0* *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3 LAMBDA4 = (- G2**2/2D0)*(1D0 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4 LAMBDA5 = 0D0 LAMBDA6 = 0D0 LAMBDA7 = 0D0 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6* *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7* *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)* *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB M2(2,1) = M2(1,2) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2) IF(MCHI.GT.MSSUSY) GOTO 100 IF(MCHI.LT.MTOP) MCHI=MTOP TCHAR=LOG(MSSUSY**2/MCHI**2) DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR DELTAM112=2D0*DELTAL12*V**2*COSB**2 DELTAM222=2D0*DELTAL12*V**2*SINB**2 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB M2(1,1)=M2(1,1)+DELTAM112 M2(2,2)=M2(2,2)+DELTAM222 M2(1,2)=M2(1,2)+DELTAM122 M2(2,1)=M2(2,1)+DELTAM122 100 CONTINUE CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCC END OF CHARGINOS/NEUTRALINOS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC DO 120 I = 1,2 DO 110 J = 1,2 M2P(I,J) = M2(I,J) + VH(I,J) 110 CONTINUE 120 CONTINUE TRM2P = M2P(1,1) + M2P(2,2) DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1) MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0 HMP = DSQRT(HM2P) MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2 MCH=DSQRT(MCH2) IF(MH2P.LT.0.) GOTO 130 MHP = SQRT(MH2P) SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P) COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P) IF(COS2ALPHA.GE.0.) THEN ALPHA = ASIN(SIN2ALPHA)/2D0 ELSE ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0 ENDIF SA = SIN(ALPHA) CA = COS(ALPHA) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK. C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB)) CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB)) 130 CONTINUE RETURN END C********************************************************************* C...PYGFXX C...Auxiliary to PYRGHM. SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH, * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB) IMPLICIT DOUBLE PRECISION(A-H,M,O-Z) DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2) C...Commonblocks. INTEGER MSTU,MSTJ,KCHG COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y) T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2) * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2)) IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0 MQ2 = MQ**2 MUR2 = MUR**2 MD2 = MD**2 TANBA = TANB SINBA = TANBA/DSQRT(TANBA**2+1D0) COSBA = SINBA/TANBA SINB = TANB/DSQRT(TANB**2+1D0) COSB = SINB/TANB PI = PARU(1) MZ = PMAS(23,1) MW = PMAS(24,1) SW = 1D0-MW**2/MZ**2 V = 174.1D0 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2)) G2 = DSQRT(0.0336D0*4D0*PI) G1 = DSQRT(0.0101D0*4D0*PI) IF(MQ.GT.MUR) MST = MQ IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR MSUSYT = DSQRT(MST**2 + MTOP**2) IF(MQ.GT.MD) MSB = MQ IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD MB = PYMRUN(5,MSB**2) MSUSYB = DSQRT(MSB**2 + MB**2) TT = LOG(MSUSYT**2/MTOP**2) TB = LOG(MSUSYB**2/MTOP**2) RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI) HT = RMTOP/(V*SINB) HTST = RMTOP/V HB = MB/V/COSB G32 = ALPHA3*4D0*PI BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2 AL2 = 3D0/8D0/PI**2*HT**2 C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2 C ALST = 3./8./PI**2*HTST**2 AL1 = 3D0/8D0/PI**2*HB**2 AL(1,1) = AL1 AL(1,2) = (AL2+AL1)/2D0 AL(2,1) = (AL2+AL1)/2D0 AL(2,2) = AL2 IF(MA.GT.MTOP) THEN VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2* * LOG(MTOP**2/MA**2)) H1I = VI* COSBA H2I = VI*SINBA H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0 ELSE VI = V H1I = VI*COSB H2I = VI*SINB H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0 ENDIF TANBST = H2T/H1T SINBT = TANBST/DSQRT(1D0+TANBST**2) TANBSB = H2B/H1B SINBB = TANBSB/DSQRT(1D0+TANBSB**2) COSBB = SINBB/TANBSB DELTAMT = 0D0 DELTAMB = 0D0 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT) MTOP2 = DSQRT(MTOP4) MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB) * /(1D0+DELTAMB)**4 MBOT2 = DSQRT(MBOT4) STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2) STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + * MQ2 - MUR2)**2*0.25D0 * + MTOP2*(AT-XMU/TANBST)**2) IF(STOP22.LT.0.) GOTO 120 SBOT12 = (MQ2 + MD2)*.5D0 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2) SBOT22 = (MQ2 + MD2)*.5D0 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2) IF(SBOT22.LT.0.) SBOT22 = 10000D0 STOP1 = DSQRT(STOP12) STOP2 = DSQRT(STOP22) SBOT1 = DSQRT(SBOT12) SBOT2 = DSQRT(SBOT22) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING C INDUCED CORRECTIONS. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC X=SBOT1 Y=SBOT2 Z=XMGL IF(X.EQ.Y) X = X - 0.00001D0 IF(X.EQ.Z) X = X - 0.00002D0 IF(Y.EQ.Z) Y = Y - 0.00003D0 T1=T(X,Y,Z) X=STOP1 Y=STOP2 Z=XMU IF(X.EQ.Y) X = X - 0.00001D0 IF(X.EQ.Z) X = X - 0.00002D0 IF(Y.EQ.Z) Y = Y - 0.00003D0 T2=T(X,Y,Z) DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2 X=STOP1 Y=STOP2 Z=XMGL IF(X.EQ.Y) X = X - 0.00001D0 IF(X.EQ.Z) X = X - 0.00002D0 IF(Y.EQ.Z) Y = Y - 0.00003D0 T3=T(X,Y,Z) DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB. C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA, C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA, C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES ! C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT) MTOP2 = DSQRT(MTOP4) MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB) * /(1D0+DELTAMB)**4 MBOT2 = DSQRT(MBOT4) STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2) STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + * MQ2 - MUR2)**2*0.25D0 * + MTOP2*(AT-XMU/TANBST)**2) IF(STOP22.LT.0.) GOTO 120 SBOT12 = (MQ2 + MD2)*.5D0 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2) SBOT22 = (MQ2 + MD2)*.5D0 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2) IF(SBOT22.LT.0.) GOTO 120 STOP1 = DSQRT(STOP12) STOP2 = DSQRT(STOP22) SBOT1 = DSQRT(SBOT12) SBOT2 = DSQRT(SBOT22) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCC D-TERMS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC STW=SW F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)* * LOG(STOP1/STOP2) * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2)) * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2)) F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)* * LOG(SBOT1/SBOT2) * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2)) * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2)) F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)* * (-.5D0*LOG(STOP12/STOP22) * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)* * G(STOP12,STOP22)) F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)* * (.5D0*LOG(SBOT12/SBOT22) * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)* * G(SBOT12,SBOT22)) VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/ * (MQ2+MBOT2)/(MD2+MBOT2)) * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))* * LOG(SBOT1**2/SBOT2**2)) + * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/ * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22) VH3T(1,1) = * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2 * -STOP2**2))**2*G(STOP12,STOP22) VH3B(1,1)=VH3B(1,1)+ * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B) VH3T(1,1) = VH3T(1,1) + * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T) VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/ * (MQ2+MTOP2)/(MUR2+MTOP2)) * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))* * LOG(STOP1**2/STOP2**2)) + * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/ * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22) VH3B(2,2) = * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2 * -SBOT2**2))**2*G(SBOT12,SBOT22) VH3T(2,2)=VH3T(2,2)+ * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T) VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B VH3T(1,2) = - * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/ * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT* * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22)) VH3B(1,2) = * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/ * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB* * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22)) VH3T(1,2)=VH3T(1,2) + *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T) VH3B(1,2)=VH3B(1,2) + *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B) VH3T(2,1) = VH3T(1,2) VH3B(2,1) = VH3B(1,2) C TQ = LOG((MQ2 + MTOP2)/MTOP2) C TU = LOG((MUR2+MTOP2)/MTOP2) C TQD = LOG((MQ2 + MB**2)/MB**2) C TD = LOG((MD2+MB**2)/MB**2) DO 110 I = 1,2 DO 100 J = 1,2 VH(I,J) = * 6D0/(8D0*PI**2*(H1T**2+H2T**2)) * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) + * 6D0/(8D0*PI**2*(H1B**2+H2B**2)) * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0) 100 CONTINUE 110 CONTINUE GOTO 150 120 DO 140 I =1,2 DO 130 J = 1,2 VH(I,J) = -1D15 130 CONTINUE 140 CONTINUE 150 RETURN END C********************************************************************* C...PYFINT C...Auxiliary routine to PYPOLE for SUSY Higgs calculations. FUNCTION PYFINT(A,B,C) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblock. COMMON/PYINTS/XXM(20) SAVE/PYINTS/ C...Local variables. EXTERNAL PYFISB DOUBLE PRECISION PYFISB XXM(1)=A XXM(2)=B XXM(3)=C XLO=0D0 XHI=1D0 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3) RETURN END C********************************************************************* C...PYFISB C...Auxiliary routine to PYFINT for SUSY Higgs calculations. FUNCTION PYFISB(X) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblock. COMMON/PYINTS/XXM(20) SAVE/PYINTS/ PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/ &(X*(XXM(2)-XXM(3))+XXM(3))) RETURN END C********************************************************************* C...PYSFDC C...Calculates decays of sfermions. SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ C...Local variables. COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2) COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB INTEGER KFIN,KCIN DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP DOUBLE PRECISION PYLAMF,XL DOUBLE PRECISION TANW,XW,AEM,C1,AS DOUBLE PRECISION AL,AR,BL,BR DOUBLE PRECISION CH1,CH2,CH3,CH4 DOUBLE PRECISION XMBOT,XMTOP DOUBLE PRECISION XLAM(0:400) INTEGER IDLAM(400,3) INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II DOUBLE PRECISION SR2 DOUBLE PRECISION CBETA,SBETA DOUBLE PRECISION CW DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL DOUBLE PRECISION COSA,SINA,TANB DOUBLE PRECISION PYALEM,PI,PYALPS,EI DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR INTEGER IG,KF1,KF2 INTEGER IGG(4),KFNCHI(4),KFCCHI(2) DATA IGG/23,25,35,36/ DATA PI/3.141592654D0/ DATA SR2/1.4142136D0/ DATA KFNCHI/1000022,1000023,1000025,1000035/ DATA KFCCHI/1000024,1000037/ C...COUNT THE NUMBER OF DECAY MODES LKNT=0 C...NO NU_R DECAYS IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR. &KFIN.EQ.KSUSY2+16) RETURN XMW=PMAS(24,1) XMW2=XMW**2 XMZ=PMAS(23,1) XW=PARU(102) TANW = SQRT(XW/(1D0-XW)) CW=SQRT(1D0-XW) DO 110 I=1,4 DO 100 J=1,4 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I)) 100 CONTINUE 110 CONTINUE DO 130 I=1,2 DO 120 J=1,2 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I)) UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I)) 120 CONTINUE 130 CONTINUE C...KCIN KCIN=PYCOMP(KFIN) C...ILR is 1 for left and 2 for right. ILR=KFIN/KSUSY1 C...IFL is matching non-SUSY flavour. IFL=MOD(KFIN,KSUSY1) C...IDU is weak isospin, 1 for down and 2 for up. IDU=2-MOD(IFL,2) XMI=PMAS(KCIN,1) XMI2=XMI**2 AEM=PYALEM(XMI2) AS =PYALPS(XMI2) C1=AEM/XW XMI3=XMI**3 EI=KCHG(IFL,1)/3D0 XMBOT=PYMRUN(5,XMI2) XMTOP=PYMRUN(6,XMI2) TANB=RMSS(5) BETA=ATAN(TANB) ALFA=RMSS(18) CBETA=COS(BETA) SBETA=TANB*CBETA SINA=SIN(ALFA) COSA=COS(ALFA) XMU=-RMSS(4) ATRIT=RMSS(16) ATRIB=RMSS(15) ATRIL=RMSS(17) C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION IF(IMSS(11).EQ.1) THEN XMP=RMSS(29) IDG=39+KSUSY1 XMGR=PMAS(PYCOMP(IDG),1) XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI IF(IFL.EQ.5) THEN XMF=XMBOT ELSEIF(IFL.EQ.6) THEN XMF=XMTOP ELSE XMF=PMAS(IFL,1) ENDIF IF(XMI.GT.XMGR+XMF) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=IFL IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4 ENDIF ENDIF C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO C...CHARGED DECAYS: DO 140 IX=1,2 C...DI -> U CHI1-,CHI2- IF(IDU.EQ.1) THEN XMFP=PMAS(IFL+1,1) XMF =PMAS(IFL,1) C...UI -> D CHI1+,CHI2+ ELSE XMFP=PMAS(IFL-1,1) XMF =PMAS(IFL,1) ENDIF XMJ=SMW(IX) AXMJ=ABS(XMJ) IF(XMI.GE.AXMJ+XMFP) THEN XMA2=XMJ**2 XMB2=XMFP**2 IF(IDU.EQ.2) THEN IF(IFL.EQ.6) THEN XMFP=XMBOT XMF =XMTOP ELSEIF(IFL.LT.6) THEN XMF=0D0 XMFP=0D0 ENDIF CBL=VMIXC(IX,1) CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA CAR=0D0 ELSE IF(IFL.EQ.5) THEN XMF =XMBOT XMFP=XMTOP ELSEIF(IFL.LT.5) THEN XMF=0D0 XMFP=0D0 ENDIF CBL=UMIXC(IX,1) CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA CAR=0D0 ENDIF CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL CAL=CALP CBL=CBLP CAR=CARP CBR=CBRP C...F1 -> F` CHI IF(ILR.EQ.1) THEN CA=CAL CB=CBL C...F2 -> F` CHI ELSE CA=CAR CB=CBR ENDIF LKNT=LKNT+1 XL=PYLAMF(XMI2,XMA2,XMB2) C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)* & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP) IDLAM(LKNT,3)=0 IF(IDU.EQ.1) THEN IDLAM(LKNT,1)=-KFCCHI(IX) IDLAM(LKNT,2)=IFL+1 ELSE IDLAM(LKNT,1)=KFCCHI(IX) IDLAM(LKNT,2)=IFL-1 ENDIF ENDIF 140 CONTINUE C...NEUTRAL DECAYS DO 150 IX=1,4 C...DI -> D CHI10 XMF=PMAS(IFL,1) XMJ=SMZ(IX) AXMJ=ABS(XMJ) IF(XMI.GE.AXMJ+XMF) THEN XMA2=XMJ**2 XMB2=XMF**2 IF(IDU.EQ.1) THEN IF(IFL.EQ.5) THEN XMF=XMBOT ELSEIF(IFL.LT.5) THEN XMF=0D0 ENDIF CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1) CAL=XMF*ZMIXC(IX,3)/XMW/CBETA CAR=-2D0*EI*TANW*ZMIXC(IX,1) CBR=CAL ELSE IF(IFL.EQ.6) THEN XMF=XMTOP ELSEIF(IFL.LT.5) THEN XMF=0D0 ENDIF CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1) CAL=XMF*ZMIXC(IX,4)/XMW/SBETA CAR=-2D0*EI*TANW*ZMIXC(IX,1) CBR=CAL ENDIF CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL CAL=CALP CBL=CBLP CAR=CARP CBR=CBRP C...F1 -> F CHI IF(ILR.EQ.1) THEN CA=CAL CB=CBL C...F2 -> F CHI ELSE CA=CAR CB=CBR ENDIF LKNT=LKNT+1 XL=PYLAMF(XMI2,XMA2,XMB2) C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)* & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF) IDLAM(LKNT,1)=KFNCHI(IX) IDLAM(LKNT,2)=IFL IDLAM(LKNT,3)=0 ENDIF 150 CONTINUE C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS C...IG=23,25,35,36 DO 160 II=1,4 IG=IGG(II) IF(ILR.EQ.1) GOTO 160 XMB=PMAS(IG,1) XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1) IF(XMI.LT.XMSF1+XMB) GOTO 160 IF(IG.EQ.23) THEN BL=-SIGN(.5D0,EI)/CW+EI*XW/CW BR=EI*XW/CW BLR=0D0 ELSEIF(IG.EQ.25) THEN IF(IFL.EQ.5) THEN XMF=XMBOT ELSEIF(IFL.EQ.6) THEN XMF=XMTOP ELSEIF(IFL.LT.5) THEN XMF=0D0 ELSE XMF=PMAS(IFL,1) ENDIF IF(IDU.EQ.2) THEN GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+ & XMF**2/XMW*COSA/SBETA GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+ & XMF**2/XMW*COSA/SBETA ELSE GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+ & XMF**2/XMW*(-SINA)/CBETA GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+ & XMF**2/XMW*(-SINA)/CBETA ENDIF IF(IFL.EQ.5) THEN AT=ATRIB ELSEIF(IFL.EQ.6) THEN AT=ATRIT ELSEIF(IFL.EQ.15) THEN AT=ATRIL ELSE AT=0D0 ENDIF C.........need to complexify IF(IDU.EQ.2) THEN GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+ & AT*COSA) ELSE GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA- & AT*SINA) ENDIF BL=GHLL BR=GHRR BLR=-GHLR ELSEIF(IG.EQ.35) THEN IF(IFL.EQ.5) THEN XMF=XMBOT ELSEIF(IFL.EQ.6) THEN XMF=XMTOP ELSEIF(IFL.LT.5) THEN XMF=0D0 ELSE XMF=PMAS(IFL,1) ENDIF IF(IDU.EQ.2) THEN GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+ & XMF**2/XMW*SINA/SBETA GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+ & XMF**2/XMW*SINA/SBETA ELSE GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+ & XMF**2/XMW*COSA/CBETA GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+ & XMF**2/XMW*COSA/CBETA ENDIF IF(IFL.EQ.5) THEN AT=ATRIB ELSEIF(IFL.EQ.6) THEN AT=ATRIT ELSEIF(IFL.EQ.15) THEN AT=ATRIL ELSE AT=0D0 ENDIF C.........Need to complexify IF(IDU.EQ.2) THEN GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+ & AT*SINA) ELSE GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+ & AT*COSA) ENDIF BL=GHLL BR=GHRR BLR=GHLR ELSEIF(IG.EQ.36) THEN GHLL=0D0 GHRR=0D0 IF(IFL.EQ.5) THEN XMF=XMBOT ELSEIF(IFL.EQ.6) THEN XMF=XMTOP ELSEIF(IFL.LT.5) THEN XMF=0D0 ELSE XMF=PMAS(IFL,1) ENDIF IF(IFL.EQ.5) THEN AT=ATRIB ELSEIF(IFL.EQ.6) THEN AT=ATRIT ELSEIF(IFL.EQ.15) THEN AT=ATRIL ELSE AT=0D0 ENDIF C.........Need to complexify IF(IDU.EQ.2) THEN GHLR=XMF/2D0/XMW*(-XMU+AT/TANB) ELSE GHLR=XMF/2D0/XMW/(-XMU+AT*TANB) ENDIF BL=GHLL BR=GHRR BLR=GHLR ENDIF AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+ & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+ & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR XL=PYLAMF(XMI2,XMSF1**2,XMB**2) LKNT=LKNT+1 IF(IG.EQ.23) THEN XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2 ELSE XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2 ENDIF IDLAM(LKNT,3)=0 IDLAM(LKNT,1)=KFIN-KSUSY1 IDLAM(LKNT,2)=IG 160 CONTINUE C...SF -> SF' + W XMB=PMAS(24,1) IF(MOD(IFL,2).EQ.0) THEN KF1=KSUSY1+IFL-1 ELSE KF1=KSUSY1+IFL+1 ENDIF KF2=KF1+KSUSY1 XMSF1=PMAS(PYCOMP(KF1),1) XMSF2=PMAS(PYCOMP(KF2),1) IF(XMI.GT.XMB+XMSF1) THEN IF(MOD(IFL,2).EQ.0) THEN IF(ILR.EQ.1) THEN AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1) ELSE AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1) ENDIF ELSE IF(ILR.EQ.1) THEN AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1) ELSE AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1) ENDIF ENDIF XL=PYLAMF(XMI2,XMSF1**2,XMB**2) LKNT=LKNT+1 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2 IDLAM(LKNT,3)=0 IDLAM(LKNT,1)=KF1 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1)) ENDIF IF(XMI.GT.XMB+XMSF2) THEN IF(MOD(IFL,2).EQ.0) THEN IF(ILR.EQ.1) THEN AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3) ELSE AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3) ENDIF ELSE IF(ILR.EQ.1) THEN AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3) ELSE AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3) ENDIF ENDIF XL=PYLAMF(XMI2,XMSF2**2,XMB**2) LKNT=LKNT+1 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2 IDLAM(LKNT,3)=0 IDLAM(LKNT,1)=KF2 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1)) ENDIF C...SF -> SF' + HC XMB=PMAS(37,1) IF(MOD(IFL,2).EQ.0) THEN KF1=KSUSY1+IFL-1 ELSE KF1=KSUSY1+IFL+1 ENDIF KF2=KF1+KSUSY1 XMSF1=PMAS(PYCOMP(KF1),1) XMSF2=PMAS(PYCOMP(KF2),1) IF(XMI.GT.XMB+XMSF1) THEN XMF=0D0 XMFP=0D0 AT=0D0 AB=0D0 IF(MOD(IFL,2).EQ.0) THEN C...T1-> B1 HC IF(ILR.EQ.1) THEN CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1) CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2) CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2) CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1) C...T2-> B1 HC ELSE CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1) CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2) CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2) CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1) ENDIF IF(IFL.EQ.6) THEN XMF=XMTOP XMFP=XMBOT AT=ATRIT AB=ATRIB ENDIF ELSE C...B1 -> T1 HC IF(ILR.EQ.1) THEN CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1) CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2) CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2) CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1) C...B2-> T1 HC ELSE CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1) CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2) CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1) CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2) ENDIF IF(IFL.EQ.5) THEN XMF=XMTOP XMFP=XMBOT AT=ATRIT AB=ATRIB ENDIF ENDIF XL=PYLAMF(XMI2,XMSF1**2,XMB**2) LKNT=LKNT+1 C.......Need to complexify AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+ & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+ & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB) XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2 IDLAM(LKNT,3)=0 IDLAM(LKNT,1)=KF1 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1)) ENDIF IF(XMI.GT.XMB+XMSF2) THEN XMF=0D0 XMFP=0D0 AT=0D0 AB=0D0 IF(MOD(IFL,2).EQ.0) THEN C...T1-> B2 HC IF(ILR.EQ.1) THEN CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1) CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2) CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1) CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2) C...T2-> B2 HC ELSE CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3) CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4) CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4) CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3) ENDIF IF(IFL.EQ.6) THEN XMF=XMTOP XMFP=XMBOT AT=ATRIT AB=ATRIB ENDIF ELSE C...B1 -> T2 HC IF(ILR.EQ.1) THEN CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1) CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2) CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2) CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1) C...B2-> T2 HC ELSE CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3) CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4) CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4) CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3) ENDIF IF(IFL.EQ.5) THEN XMF=XMTOP XMFP=XMBOT AT=ATRIT AB=ATRIB ENDIF ENDIF XL=PYLAMF(XMI2,XMSF1**2,XMB**2) LKNT=LKNT+1 C.......Need to complexify AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+ & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+ & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB) XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2 IDLAM(LKNT,3)=0 IDLAM(LKNT,1)=KF2 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1)) ENDIF C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO IF(IFL.LE.6) THEN XMFP=0D0 XMF=0D0 IF(IFL.EQ.6) XMF=PMAS(6,1) IF(IFL.EQ.5) XMF=PMAS(5,1) XMJ=PMAS(PYCOMP(KSUSY1+21),1) AXMJ=ABS(XMJ) IF(XMI.GE.AXMJ+XMF) THEN AL=-SFMIX(IFL,3) BL=SFMIX(IFL,1) AR=-SFMIX(IFL,4) BR=SFMIX(IFL,2) C...F1 -> F CHI IF(ILR.EQ.1) THEN XCA=AL XCB=BL C...F2 -> F CHI ELSE XCA=AR XCB=BR ENDIF LKNT=LKNT+1 XMA2=XMJ**2 XMB2=XMF**2 XL=PYLAMF(XMI2,XMA2,XMB2) XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)* & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=IFL IDLAM(LKNT,3)=0 ENDIF ENDIF C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT. &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI) C...M*M = C1**2 * G**2/(16PI**2) C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3) LKNT=LKNT+1 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2) XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL) IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3 IDLAM(LKNT,1)=KSUSY1+22 IDLAM(LKNT,2)=4 IDLAM(LKNT,3)=0 ENDIF C...R-violating sfermion decays (SKANDS). CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT) IKNT=LKNT XLAM(0)=0D0 DO 170 I=1,IKNT IF(XLAM(I).LT.0D0) XLAM(I)=0D0 XLAM(0)=XLAM(0)+XLAM(I) 170 CONTINUE IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3 RETURN END C********************************************************************* C...PYGLUI C...Calculates gluino decay modes. SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) CC &SFMIX(16,4), C COMMON/PYINTS/XXM(20) COMPLEX*16 CXC COMMON/PYINTC/XXC(10),CXC(8) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/ C...Local variables COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP DOUBLE PRECISION PYLAMF,XL DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN DOUBLE PRECISION CA,CB,AL,AR,BL,BR DOUBLE PRECISION XLAM(0:400) INTEGER IDLAM(400,3) INTEGER LKNT,IX,ILR,I,IKNT,IFL DOUBLE PRECISION SR2 DOUBLE PRECISION GAM DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I EXTERNAL PYGAUS,PYXXZ6 DOUBLE PRECISION PYGAUS,PYXXZ6 DOUBLE PRECISION PREC INTEGER KFNCHI(4),KFCCHI(2) DATA PI/3.141592654D0/ DATA SR2/1.4142136D0/ DATA PREC/1D-2/ DATA KFNCHI/1000022,1000023,1000025,1000035/ DATA KFCCHI/1000024,1000037/ C...COUNT THE NUMBER OF DECAY MODES LKNT=0 IF(KFIN.NE.KSUSY1+21) RETURN KCIN=PYCOMP(KFIN) XW=PARU(102) TANW = SQRT(XW/(1D0-XW)) XMI=PMAS(KCIN,1) AXMI=ABS(XMI) XMI2=XMI**2 AEM=PYALEM(XMI2) AS =PYALPS(XMI2) C1=AEM/XW XMI3=AXMI**3 XMI=SIGN(XMI,RMSS(3)) C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON IF(IMSS(11).EQ.1) THEN XMP=RMSS(29) IDG=39+KSUSY1 XMGR=PMAS(PYCOMP(IDG),1) XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI IF(AXMI.GT.XMGR) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=21 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC ENDIF ENDIF C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK DO 110 IFL=1,6 DO 100 ILR=1,2 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1) AXMJ=ABS(XMJ) XMF=PMAS(IFL,1) IF(AXMI.GE.AXMJ+XMF) THEN C...Minus sign difference from gluino-quark-squark feynman rules AL=SFMIX(IFL,1) BL=-SFMIX(IFL,3) AR=SFMIX(IFL,2) BR=-SFMIX(IFL,4) C...F1 -> F CHI IF(ILR.EQ.1) THEN CA=AL CB=BL C...F2 -> F CHI ELSE CA=AR CB=BR ENDIF LKNT=LKNT+1 XMA2=XMJ**2 XMB2=XMF**2 XL=PYLAMF(XMI2,XMA2,XMB2) XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)* & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF) IDLAM(LKNT,1)=ILR*KSUSY1+IFL IDLAM(LKNT,2)=-IFL IDLAM(LKNT,3)=0 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=0 ENDIF 100 CONTINUE 110 CONTINUE C...3-BODY DECAYS TO GAUGINO FERMION-FERMION C...GLUINO -> NI Q QBAR DO 170 IX=1,4 XMJ=SMZ(IX) AXMJ=ABS(XMJ) IF(AXMI.GE.AXMJ) THEN DO 120 I=1,4 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I)) 120 CONTINUE OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2 ORPP=DCONJG(OLPP) XXC(1)=0D0 XXC(2)=XMJ XXC(3)=0D0 XXC(4)=XMI IA=1 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1) XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1) XXC(7)=XXC(5) XXC(8)=XXC(6) XXC(9)=1D6 XXC(10)=0D0 EI=KCHG(IA,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP CXC(1)=0D0 CXC(2)=-GLIJ CXC(3)=0D0 CXC(4)=DCONJG(GLIJ) CXC(5)=0D0 CXC(6)=GRIJ CXC(7)=0D0 CXC(8)=-DCONJG(GRIJ) S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2) IDLAM(LKNT,1)=KFNCHI(IX) IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-1 ENDIF IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IX) IDLAM(LKNT,2)=3 IDLAM(LKNT,3)=-3 ENDIF 130 CONTINUE IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN PMOLD=PMAS(PYCOMP(KSUSY1+5),1) IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN GOTO 140 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI ENDIF CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM) LKNT=LKNT+1 XLAM(LKNT)=GAM IDLAM(LKNT,1)=KFNCHI(IX) IDLAM(LKNT,2)=5 IDLAM(LKNT,3)=-5 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD ENDIF C...U-TYPE QUARKS 140 CONTINUE IA=2 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1) XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1) C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290 XXC(7)=XXC(5) XXC(8)=XXC(6) EI=KCHG(IA,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP CXC(2)=-GLIJ CXC(4)=DCONJG(GLIJ) CXC(6)=GRIJ CXC(8)=-DCONJG(GRIJ) IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2) IDLAM(LKNT,1)=KFNCHI(IX) IDLAM(LKNT,2)=2 IDLAM(LKNT,3)=-2 ENDIF IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IX) IDLAM(LKNT,2)=4 IDLAM(LKNT,3)=-4 ENDIF 150 CONTINUE C...INCLUDE THE DECAY GLUINO -> NJ + T + T~ C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR XMF=PMAS(6,1) IF(AXMI.GE.AXMJ+2D0*XMF) THEN PMOLD=PMAS(PYCOMP(KSUSY1+6),1) IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN GOTO 160 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI ENDIF CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM) LKNT=LKNT+1 XLAM(LKNT)=GAM IDLAM(LKNT,1)=KFNCHI(IX) IDLAM(LKNT,2)=6 IDLAM(LKNT,3)=-6 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD ENDIF 160 CONTINUE ENDIF 170 CONTINUE C...GLUINO -> CI Q QBAR' DO 210 IX=1,2 XMJ=SMW(IX) AXMJ=ABS(XMJ) IF(AXMI.GE.AXMJ) THEN DO 180 I=1,2 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I)) UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I)) 180 CONTINUE S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 XXC(1)=0D0 XXC(2)=XMJ XXC(3)=0D0 XXC(4)=XMI XXC(5)=PMAS(PYCOMP(KSUSY1+1),1) XXC(6)=PMAS(PYCOMP(KSUSY1+2),1) XXC(9)=1D6 XXC(10)=0D0 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32))) ORPP=DCONJG(OLPP) CXC(1)=DCMPLX(0D0,0D0) CXC(3)=DCMPLX(0D0,0D0) CXC(5)=DCMPLX(0D0,0D0) CXC(7)=DCMPLX(0D0,0D0) CXC(2)=UMIXC(IX,1)*OLPP/SR2 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2 CXC(6)=DCMPLX(0D0,0D0) CXC(8)=DCMPLX(0D0,0D0) IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ELSEIF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(6) XXC(8)=XXC(5) IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(IX) IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-2 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ENDIF IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(IX) IDLAM(LKNT,2)=3 IDLAM(LKNT,3)=-4 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ENDIF 190 CONTINUE XMF=PMAS(6,1) XMFP=PMAS(5,1) IF(AXMI.GE.AXMJ+XMF+XMFP) THEN IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP, $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1) PMOLB2=PMAS(PYCOMP(KSUSY2+5),1) PMOLT1=PMAS(PYCOMP(KSUSY1+6),1) PMOLB1=PMAS(PYCOMP(KSUSY1+5),1) IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI CALL PYTBBC(IX,100,XMI,GAM) LKNT=LKNT+1 XLAM(LKNT)=GAM IDLAM(LKNT,1)=KFCCHI(IX) IDLAM(LKNT,2)=5 IDLAM(LKNT,3)=-6 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1 ENDIF 200 CONTINUE ENDIF 210 CONTINUE C...R-parity violating (3-body) decays. CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT) IKNT=LKNT XLAM(0)=0D0 DO 220 I=1,IKNT IF(XLAM(I).LT.0D0) XLAM(I)=0D0 XLAM(0)=XLAM(0)+XLAM(I) 220 CONTINUE IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6 RETURN END C********************************************************************* C...PYTBBN C...Calculates the three-body decay of gluinos into C...neutralinos and third generation fermions. SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ C...Local variables. EXTERNAL PYSIMP,PYLAMF DOUBLE PRECISION PYSIMP,PYLAMF INTEGER LIN,NN DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100) DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24 DOUBLE PRECISION XLN1,XLN2,B1,B2 DOUBLE PRECISION E,XMGLU,GAM DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4) SAVE HRB,HLB,FLB,FRB DOUBLE PRECISION ALPHAW,ALPHAS DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4) SAVE HLT,HRT,FLT,FRT DOUBLE PRECISION AMN(4),AN(4,4),ZN(3) SAVE AMN,AN,ZN DOUBLE PRECISION AMBOT,SINC,COSC DOUBLE PRECISION AMTOP,SINA,COSA DOUBLE PRECISION SINW,COSW,TANW DOUBLE PRECISION ROT1(4,4) LOGICAL IFIRST SAVE IFIRST DATA IFIRST/.TRUE./ TANB=RMSS(5) SINB=TANB/SQRT(1D0+TANB**2) COSB=SINB/TANB XW=PARU(102) SINW=SQRT(XW) COSW=SQRT(1D0-XW) TANW=SINW/COSW AMW=PMAS(24,1) COSC=SFMIX(5,1) SINC=SFMIX(5,3) COSA=SFMIX(6,1) SINA=SFMIX(6,3) AMBOT=PYMRUN(5,XMGLU**2) AMTOP=PYMRUN(6,XMGLU**2) W2=SQRT(2D0) FAKT1=AMBOT/W2/AMW/COSB FAKT2=AMTOP/W2/AMW/SINB IF(IFIRST) THEN DO 110 II=1,4 AMN(II)=SMZ(II) DO 100 J=1,4 ROT1(II,J)=0D0 AN(II,J)=0D0 100 CONTINUE 110 CONTINUE ROT1(1,1)=COSW ROT1(1,2)=-SINW ROT1(2,1)=-ROT1(1,2) ROT1(2,2)=ROT1(1,1) ROT1(3,3)=COSB ROT1(3,4)=SINB ROT1(4,3)=-ROT1(3,4) ROT1(4,4)=ROT1(3,3) DO 140 II=1,4 DO 130 J=1,4 DO 120 JJ=1,4 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J) 120 CONTINUE 130 CONTINUE 140 CONTINUE DO 150 J=1,4 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4)) ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1)) ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0* & XW)*AN(J,2)/COSW HRT(J)=ZN(1)*COSA-ZN(3)*SINA HLT(J)=ZN(1)*COSA+ZN(2)*SINA FLT(J)=ZN(3)*COSA+ZN(1)*SINA FRT(J)=ZN(2)*COSA-ZN(1)*SINA C FLU(J)=ZN(3) C FRU(J)=ZN(2) ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4)) ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1)) ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW HRB(J)=ZN(1)*COSC-ZN(3)*SINC HLB(J)=ZN(1)*COSC+ZN(2)*SINC FLB(J)=ZN(3)*COSC+ZN(1)*SINC FRB(J)=ZN(2)*COSC-ZN(1)*SINC C FLD(J)=ZN(3) C FRD(J)=ZN(2) 150 CONTINUE C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1) C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1) C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1) C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1) IFIRST=.FALSE. ENDIF IF(NINT(3D0*E).EQ.2) THEN HL=HLT(I) HR=HRT(I) FL=FLT(I) FR=FRT(I) COSD=SFMIX(6,1) SIND=SFMIX(6,3) XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2 XM=PMAS(6,1) ELSE HL=HLB(I) HR=HRB(I) FL=FLB(I) FR=FRB(I) COSD=SFMIX(5,1) SIND=SFMIX(5,3) XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2 XM=PMAS(5,1) ENDIF COSD2=COSD*COSD SIND2=SIND*SIND COS2D=COSD2-SIND2 SIN2D=SIND*COSD*2D0 HL2=HL*HL HR2=HR*HR FL2=FL*FL FR2=FR*FR FF=FL*FR HH=HL*HR HFL=HL*FL HFR=HR*FR HRFL=HR*FL HLFR=HL*FR XM2=XM*XM XMG=XMGLU XMG2=XMG*XMG ALPHAW=PYALEM(XMG2) ALPHAS=PYALPS(XMG2) XMR=AMN(I) XMR2=XMR*XMR XMQ4=XMG*XM2*XMR XM24=(XMG2+XM2)*(XM2+XMR2) SMIN=4D0*XM2 SMAX=(XMG-ABS(XMR))**2 XMQA=XMG2+2D0*XM2+XMR2 DO 170 LIN=1,NN-1 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN) GRS=SBAR-XMQA W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR) W=DSQRT(W) XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W))) XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W))) B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W) B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W) G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D & +2D0*(FF*SIND2-HH*COSD2))*W G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D) & +4D0*HFL*XM*XMR)*XLN1 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D) & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1)) & +8D0*HFL*XMQ4*SIN2D)*B1 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D) & +4D0*HFR*XMR*XM)*XLN2 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2)) & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2) & -8D0*HFR*XMQ4*SIN2D)*B2 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2) & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2) & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2) & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))* & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2) & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1)) G(5)=(2D0*(HH*COSD2-FF*SIND2) & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1) & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR) & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2) & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2) & +COS2D*XM*(SBAR+XMG2-XMR2)) & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2)) & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2)) G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2) & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2) & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2) & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2 SUMME(LIN)=0D0 DO 160 J=0,6 SUMME(LIN)=SUMME(LIN)+G(J) 160 CONTINUE 170 CONTINUE SUMME(0)=0D0 SUMME(NN)=0D0 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN) &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3) RETURN END C********************************************************************* C...PYTBBC C...Calculates the three-body decay of gluinos into C...charginos and third generation fermions. SUBROUTINE PYTBBC(I,NN,XMGLU,GAM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ C...Local variables. EXTERNAL PYSIMP,PYLAMF DOUBLE PRECISION PYSIMP,PYLAMF INTEGER I,NN,LIN DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4) DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX DOUBLE PRECISION SUMME(0:100),A(4,8) DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2 DOUBLE PRECISION XMGLU,GAM DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2), &DDD(2),EEE(2),FFF(2) SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF DOUBLE PRECISION ALPHAW,ALPHAS DOUBLE PRECISION AMC(2) SAVE AMC DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA SAVE AMSB,AMST LOGICAL IFIRST SAVE IFIRST DATA IFIRST/.TRUE./ TANB=RMSS(5) SINB=TANB/SQRT(1D0+TANB**2) COSB=SINB/TANB XW=PARU(102) AMW=PMAS(24,1) COSC=SFMIX(5,1) SINC=SFMIX(5,3) COSA=SFMIX(6,1) SINA=SFMIX(6,3) AMBOT=PYMRUN(5,XMGLU**2) AMTOP=PYMRUN(6,XMGLU**2) W2=SQRT(2D0) AMW=PMAS(24,1) FAKT1=AMBOT/W2/AMW/COSB FAKT2=AMTOP/W2/AMW/SINB IF(IFIRST) THEN AMC(1)=SMW(1) AMC(2)=SMW(2) DO 100 JJ=1,2 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA 100 CONTINUE AMST(1)=PMAS(PYCOMP(KSUSY1+6),1) AMST(2)=PMAS(PYCOMP(KSUSY2+6),1) AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1) AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1) IFIRST=.FALSE. ENDIF ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I) ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I) VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I) VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I) COS2A=COSA**2-SINA**2 SIN2A=SINA*COSA*2D0 COS2C=COSC**2-SINC**2 SIN2C=SINC*COSC*2D0 XMG=XMGLU XMT=PMAS(6,1) XMB=PMAS(5,1) XMR=AMC(I) XMG2=XMG*XMG ALPHAW=PYALEM(XMG2) ALPHAS=PYALPS(XMG2) XMT2=XMT*XMT XMB2=XMB*XMB XMR2=XMR*XMR XMQ2=XMG2+XMT2+XMB2+XMR2 XMQ4=XMG*XMT*XMB*XMR XMQ3=XMG2*XMR2+XMT2*XMB2 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2) XMGTBR=(XMG2+XMT2)*(XMB2+XMR2) XMST(1)=AMST(1)*AMST(1) XMST(2)=AMST(1)*AMST(1) XMST(3)=AMST(2)*AMST(2) XMST(4)=AMST(2)*AMST(2) XMSB(1)=AMSB(1)*AMSB(1) XMSB(2)=AMSB(2)*AMSB(2) XMSB(3)=AMSB(1)*AMSB(1) XMSB(4)=AMSB(2)*AMSB(2) A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I) A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I)) A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I)) A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I)) A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I)) A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I)) A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I)) A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I)) A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I) A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I)) A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I)) A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I)) A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I)) A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I)) A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I)) A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I)) A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I) A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I)) A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I)) A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I)) A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I)) A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I)) A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I)) A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I)) A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I) A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I)) A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I)) A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I)) A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I)) A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I)) A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I)) A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I)) SMAX=(XMG-ABS(XMR))**2 SMIN=(XMB+XMT)**2+0.1D0 DO 120 LIN=0,NN-1 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN) AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR GRS=SBAR-XMQ2 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2) W=DSQRT(W)/2D0/SBAR ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W))) ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W))) ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W))) ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W))) SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A) & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2)) & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2) & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4) & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W)) SUMME(LIN)=SUMME(LIN)-ULR(2)*W & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A) & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2)) & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2) & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4) & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W)) SUMME(LIN)=SUMME(LIN)-VLR(1)*W & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C) & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2)) & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2) & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4) & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W)) SUMME(LIN)=SUMME(LIN)-VLR(2)*W & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C) & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2)) & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2) & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4) & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W)) SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1)) & *((AAA(I)*BBB(I)-XX1(I)*XX2(I)) & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1) & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1)) SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1)) & *((EEE(I)*FFF(I)-CCC(I)*DDD(I)) & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1) & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1)) DO 110 J=1,4 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3) & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2) & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2) & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR) & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8)) & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W))) & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3) & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2) & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2) & -A(J,6)*(XMG2+XMR2-SBAR) & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8)) & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W)))) & /(GRS+XMSB(J)+XMST(J)) 110 CONTINUE 120 CONTINUE SUMME(NN)=0D0 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN) &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3) RETURN END C********************************************************************* C...PYNJDC C...Calculates decay widths for the neutralinos (admixtures of C...Bino, W3-ino, Higgs1-ino, Higgs2-ino) C...Input: KCIN = KF code for particle C...Output: XLAM = widths C... IDLAM = KF codes for decay particles C... IKNT = number of decay channels defined C...AUTHOR: STEPHEN MRENNA C...Last change: C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma C...when CHIGAMMA .NE. 0 C...10 FEB 96: Calculate this decay for small tan(beta) SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), c &SFMIX(16,4) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) C COMMON/PYINTS/XXM(20) COMPLEX*16 CXC COMMON/PYINTC/XXC(10),CXC(8) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/ C...Local variables. COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB INTEGER KFIN DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2, &XMZ,XMZ2,AXMJ,AXMI DOUBLE PRECISION S12MIN,S12MAX DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2 DOUBLE PRECISION PYLAMF,XL DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I DOUBLE PRECISION PYX2XH,PYX2XG DOUBLE PRECISION XLAM(0:400) INTEGER IDLAM(400,3) INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID INTEGER ITH(3),KF1,KF2 INTEGER ITHC DOUBLE PRECISION DH(3),EH(3) DOUBLE PRECISION SR2 DOUBLE PRECISION CBETA,SBETA DOUBLE PRECISION GAMCON,XMT1,XMT2 DOUBLE PRECISION PYALEM,PI,PYALPS DOUBLE PRECISION RAT1,RAT2 DOUBLE PRECISION T3T,FCOL DOUBLE PRECISION ALFA,BETA,TANB DOUBLE PRECISION PYXXGA EXTERNAL PYGAUS,PYXXZ6 DOUBLE PRECISION PYGAUS,PYXXZ6 DOUBLE PRECISION PREC INTEGER KFNCHI(4),KFCCHI(2) DATA ITH/25,35,36/ DATA ITHC/37/ DATA PREC/1D-2/ DATA PI/3.141592654D0/ DATA SR2/1.4142136D0/ DATA KFNCHI/1000022,1000023,1000025,1000035/ DATA KFCCHI/1000024,1000037/ C...COUNT THE NUMBER OF DECAY MODES LKNT=0 XMW=PMAS(24,1) XMW2=XMW**2 XMZ=PMAS(23,1) XMZ2=XMZ**2 XW=1D0-XMW2/XMZ2 XW1=1D0-XW TANW = SQRT(XW/XW1) C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER IX=1 IF(KFIN.EQ.KFNCHI(2)) IX=2 IF(KFIN.EQ.KFNCHI(3)) IX=3 IF(KFIN.EQ.KFNCHI(4)) IX=4 XMI=SMZ(IX) XMI2=XMI**2 AXMI=ABS(XMI) AEM=PYALEM(XMI2) AS =PYALPS(XMI2) C1=AEM/XW XMI3=ABS(XMI**3) TANB=RMSS(5) BETA=ATAN(TANB) ALFA=RMSS(18) CBETA=COS(BETA) SBETA=TANB*CBETA CALFA=COS(ALFA) SALFA=SIN(ALFA) DO 110 I=1,4 DO 100 J=1,4 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I)) 100 CONTINUE 110 CONTINUE DO 130 I=1,2 DO 120 J=1,2 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I)) UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I)) 120 CONTINUE 130 CONTINUE C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300 C...FORCE CHI0_2 -> CHI0_1 + GAMMA IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN XMJ=SMZ(1) AXMJ=ABS(XMJ) LKNT=LKNT+1 GAMCON=AEM**3/8D0/PI/XMW2/XW XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2) IDLAM(LKNT,1)=KSUSY1+22 IDLAM(LKNT,2)=22 IDLAM(LKNT,3)=0 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT) GOTO 340 ENDIF C...GRAVITINO DECAY MODES IF(IMSS(11).EQ.1) THEN XMP=RMSS(29) IDG=39+KSUSY1 XMGR=PMAS(PYCOMP(IDG),1) SINW=SQRT(XW) COSW=SQRT(1D0-XW) XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI IF(AXMI.GT.XMGR+PMAS(22,1)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=22 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2 ENDIF IF(AXMI.GT.XMGR+XMZ) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=23 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 + $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)* & (1D0-XMZ2/XMI2)**4 ENDIF IF(AXMI.GT.XMGR+PMAS(25,1)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=25 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)* $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4 ENDIF IF(AXMI.GT.XMGR+PMAS(35,1)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=35 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)* $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4 ENDIF IF(AXMI.GT.XMGR+PMAS(36,1)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=36 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)* $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4 ENDIF IF(IX.EQ.1) GOTO 300 ENDIF DO 220 IJ=1,IX-1 XMJ=SMZ(IJ) AXMJ=ABS(XMJ) XMJ2=XMJ**2 C...CHI0_I -> CHI0_J + GAMMA IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 ) RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 ) IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR. & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=22 IDLAM(LKNT,3)=0 GAMCON=AEM**3/8D0/PI/XMW2/XW XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2) ENDIF ENDIF C...CHI0_I -> CHI0_J + Z0 IF(AXMI.GE.AXMJ+XMZ) THEN LKNT=LKNT+1 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))- & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0 ORPP=-DCONJG(OLPP) GX2=ABS(OLPP)**2+ABS(ORPP)**2 GLR=DBLE(OLPP*DCONJG(ORPP)) XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=23 IDLAM(LKNT,3)=0 ELSEIF(AXMI.GE.AXMJ) THEN XXC(1)=0D0 XXC(2)=XMJ XXC(3)=0D0 XXC(4)=XMI XXC(9)=XMZ XXC(10)=PMAS(23,2) OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))- & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0 ORPP=DCONJG(OLPP) C...CHARGED LEPTONS FID=11 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) EI=KCHG(FID,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))* & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1)) GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP CXC(2)=-GLIJ CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP CXC(4)=DCONJG(GLIJ) CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP CXC(6)=GRIJ CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP CXC(8)=-DCONJG(GRIJ) S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF IF(XXC(6).LT.AXMI ) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=FID IDLAM(LKNT,3)=-FID IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=13 IDLAM(LKNT,3)=-13 ENDIF ENDIF 140 CONTINUE IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN XXC(5)=PMAS(PYCOMP(KSUSY1+15),1) XXC(6)=PMAS(PYCOMP(KSUSY2+15),1) ELSE XXC(6)=PMAS(PYCOMP(KSUSY1+15),1) XXC(5)=PMAS(PYCOMP(KSUSY2+15),1) ENDIF IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF IF(XXC(6).LT.AXMI ) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=15 IDLAM(LKNT,3)=-15 ENDIF C...NEUTRINOS 150 CONTINUE FID=12 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) EI=KCHG(FID,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))* & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1)) GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP CXC(2)=-GLIJ CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP CXC(4)=DCONJG(GLIJ) CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP CXC(6)=GRIJ CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP CXC(8)=-DCONJG(GRIJ) S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF IF( XXC(6).LT.AXMI ) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=12 IDLAM(LKNT,3)=-12 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=14 IDLAM(LKNT,3)=-14 160 CONTINUE IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1)) & THEN XXC(5)=PMAS(PYCOMP(KSUSY1+16),1) IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF XXC(7)=XXC(5) LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) ELSE LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) ENDIF IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=16 IDLAM(LKNT,3)=-16 C...D-TYPE QUARKS 170 CONTINUE FID=1 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) EI=KCHG(FID,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))* & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1)) GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP CXC(2)=-GLIJ CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP CXC(4)=DCONJG(GLIJ) CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP CXC(6)=GRIJ CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP CXC(8)=-DCONJG(GRIJ) S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF IF( XXC(6).LT.AXMI ) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0 IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-1 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=3 IDLAM(LKNT,3)=-3 ENDIF ENDIF 180 CONTINUE IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN XXC(5)=PMAS(PYCOMP(KSUSY1+5),1) XXC(6)=PMAS(PYCOMP(KSUSY2+5),1) ELSE XXC(6)=PMAS(PYCOMP(KSUSY1+5),1) XXC(5)=PMAS(PYCOMP(KSUSY2+5),1) ENDIF IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190 IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ELSEIF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0 IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=5 IDLAM(LKNT,3)=-5 ENDIF C...U-TYPE QUARKS 190 CONTINUE FID=2 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) EI=KCHG(FID,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))* & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1)) GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP CXC(2)=-GLIJ CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP CXC(4)=DCONJG(GLIJ) CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP CXC(6)=GRIJ CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP CXC(8)=-DCONJG(GRIJ) IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200 IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ELSEIF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0 IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=2 IDLAM(LKNT,3)=-2 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=4 IDLAM(LKNT,3)=-4 ENDIF ENDIF 200 CONTINUE ENDIF C...CHI0_I -> CHI0_J + H0_K EH(1)=SIN(ALFA) EH(2)=COS(ALFA) EH(3)=-SIN(BETA) DH(1)=COS(ALFA) DH(2)=-SIN(ALFA) DH(3)=COS(BETA) QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+ & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)- & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+ & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1)) RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+ & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))- & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+ & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1))) DO 210 IH=1,3 XMH=PMAS(ITH(IH),1) XMH2=XMH**2 IF(AXMI.GE.AXMJ+XMH) THEN LKNT=LKNT+1 XL=PYLAMF(XMI2,XMJ2,XMH2) F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH)) F12K=F21K C...SIGN OF MASSES I,J XMK=XMJ IF(IH.EQ.3) XMK=-XMK GX2=ABS(F21K)**2+ABS(F12K)**2 GLR=DBLE(F21K*DCONJG(F12K)) XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=ITH(IH) IDLAM(LKNT,3)=0 ENDIF 210 CONTINUE 220 CONTINUE C...CHI0_I -> CHI+_J + W- DO 260 IJ=1,2 XMJ=SMW(IJ) AXMJ=ABS(XMJ) XMJ2=XMJ**2 IF(AXMI.GE.AXMJ+XMW) THEN LKNT=LKNT+1 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)- & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2) CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+ & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2) GX2=ABS(CXC(1))**2+ABS(CXC(3))**2 GLR=DBLE(CXC(1)*DCONJG(CXC(3))) XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=-24 IDLAM(LKNT,3)=0 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-KFCCHI(IJ) IDLAM(LKNT,2)=24 IDLAM(LKNT,3)=0 ELSEIF(AXMI.GE.AXMJ) THEN S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 RT2I = 1D0/SQRT(2D0) CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)- & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+ & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I CXC(5)=DCMPLX(0D0,0D0) CXC(7)=DCMPLX(0D0,0D0) IA=11 JA=12 EI=KCHG(IA,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 EJ=KCHG(JA,1)/3D0 T3J=SIGN(1D0,EJ+1D-6)/2D0 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)* & TANW+ZMIXC(IX,2)*T3J)*RT2I CXC(4)=-DCONJG(UMIXC(IJ,1))*( & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I CXC(6)=DCMPLX(0D0,0D0) CXC(8)=DCMPLX(0D0,0D0) XXC(1)=0D0 XXC(2)=XMJ XXC(3)=0D0 XXC(4)=XMI XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1) XXC(9)=PMAS(24,1) XXC(10)=PMAS(24,2) IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230 IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ELSEIF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(6) XXC(8)=XXC(5) IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=11 IDLAM(LKNT,3)=-12 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=13 IDLAM(LKNT,3)=-14 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ENDIF ENDIF 230 CONTINUE IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN XXC(5)=PMAS(PYCOMP(KSUSY1+15),1) XXC(6)=PMAS(PYCOMP(KSUSY1+16),1) ELSE XXC(5)=PMAS(PYCOMP(KSUSY2+15),1) XXC(6)=PMAS(PYCOMP(KSUSY1+16),1) ENDIF IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ENDIF IF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(6) XXC(8)=XXC(5) IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=15 IDLAM(LKNT,3)=-16 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ENDIF C...NOW, DO THE QUARKS 240 CONTINUE IA=1 JA=2 EI=KCHG(IA,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 EJ=KCHG(JA,1)/3D0 T3J=SIGN(1D0,EJ+1D-6)/2D0 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)* & TANW+ZMIXC(IX,2)*T3J) CXC(4)=-DCONJG(UMIXC(IJ,1))*( & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I) XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1) XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1) IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ENDIF IF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(6) XXC(8)=XXC(5) IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-2 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=3 IDLAM(LKNT,3)=-4 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ENDIF ENDIF 250 CONTINUE ENDIF 260 CONTINUE 270 CONTINUE C...CHI0_I -> CHI+_I + H- DO 280 IJ=1,2 XMJ=SMW(IJ) AXMJ=ABS(XMJ) XMJ2=XMJ**2 XMHP=PMAS(ITHC,1) IF(AXMI.GE.AXMJ+XMHP) THEN LKNT=LKNT+1 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+ & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2) ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)- & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)* & UMIXC(IJ,2)/SR2) GX2=ABS(OLPP)**2+ABS(ORPP)**2 GLR=DBLE(OLPP*DCONJG(ORPP)) XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=-ITHC IDLAM(LKNT,3)=0 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ELSE ENDIF 280 CONTINUE C...2-BODY DECAYS TO FERMION SFERMION DO 290 J=1,16 IF(J.GE.7.AND.J.LE.10) GOTO 290 KF1=KSUSY1+J KF2=KSUSY2+J XMSF1=PMAS(PYCOMP(KF1),1) XMSF2=PMAS(PYCOMP(KF2),1) XMF=PMAS(J,1) IF(J.LE.6) THEN FCOL=3D0 ELSE FCOL=1D0 ENDIF EI=KCHG(J,1)/3D0 T3T=SIGN(1D0,EI) IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0 IF(MOD(J,2).EQ.0) THEN CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T) CAL=XMF*ZMIXC(IX,4)/XMW/SBETA CAR=-2D0*EI*TANW*ZMIXC(IX,1) CBR=CAL ELSE CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T) CAL=XMF*ZMIXC(IX,3)/XMW/CBETA CAR=-2D0*EI*TANW*ZMIXC(IX,1) CBR=CAL ENDIF C...D~ D_L IF(AXMI.GE.XMF+XMSF1) THEN LKNT=LKNT+1 XMA2=XMSF1**2 XMB2=XMF**2 XL=PYLAMF(XMI2,XMA2,XMB2) CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2) CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2) XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI) IDLAM(LKNT,1)=KF1 IDLAM(LKNT,2)=-J IDLAM(LKNT,3)=0 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=0 ENDIF C...D~ D_R IF(AXMI.GE.XMF+XMSF2) THEN LKNT=LKNT+1 XMA2=XMSF2**2 XMB2=XMF**2 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4) CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4) XL=PYLAMF(XMI2,XMA2,XMB2) XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI) IDLAM(LKNT,1)=KF2 IDLAM(LKNT,2)=-J IDLAM(LKNT,3)=0 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=0 ENDIF 290 CONTINUE 300 CONTINUE C...3-BODY DECAY TO Q Q~ GLUINO XMJ=PMAS(PYCOMP(KSUSY1+21),1) IF(AXMI.GE.XMJ) THEN RT2I = 1D0/SQRT(2D0) OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I ORPP=DCONJG(OLPP) AXMJ=ABS(XMJ) XXC(1)=0D0 XXC(2)=XMJ XXC(3)=0D0 XXC(4)=XMI FID=1 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310 XXC(7)=XXC(5) XXC(8)=XXC(6) XXC(9)=1D6 XXC(10)=0D0 EI=KCHG(FID,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP CXC(1)=0D0 CXC(2)=-GLIJ CXC(3)=0D0 CXC(4)=DCONJG(GLIJ) CXC(5)=0D0 CXC(6)=GRIJ CXC(7)=0D0 CXC(8)=-DCONJG(GRIJ) S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 C...ALL QUARKS BUT T IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-1 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=3 IDLAM(LKNT,3)=-3 ENDIF ENDIF 310 CONTINUE IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN XXC(5)=PMAS(PYCOMP(KSUSY1+5),1) XXC(6)=PMAS(PYCOMP(KSUSY2+5),1) ELSE XXC(6)=PMAS(PYCOMP(KSUSY1+5),1) XXC(5)=PMAS(PYCOMP(KSUSY2+5),1) ENDIF IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320 XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=5 IDLAM(LKNT,3)=-5 ENDIF C...U-TYPE QUARKS 320 CONTINUE FID=2 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330 XXC(7)=XXC(5) XXC(8)=XXC(6) EI=KCHG(FID,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP CXC(2)=-GLIJ CXC(4)=DCONJG(GLIJ) CXC(6)=GRIJ CXC(8)=-DCONJG(GRIJ) IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=2 IDLAM(LKNT,3)=-2 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=4 IDLAM(LKNT,3)=-4 ENDIF ENDIF 330 CONTINUE ENDIF C...R-violating decay modes (SKANDS). CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT) 340 IKNT=LKNT XLAM(0)=0D0 DO 350 I=1,IKNT IF(XLAM(I).LT.0D0) XLAM(I)=0D0 XLAM(0)=XLAM(0)+XLAM(I) 350 CONTINUE IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6 RETURN END C********************************************************************* C...PYCJDC C...Calculate decay widths for the charginos (admixtures of C...charged Wino and charged Higgsino. C...Input: KCIN = KF code for particle C...Output: XLAM = widths C... IDLAM = KF codes for decay particles C... IKNT = number of decay channels defined C...AUTHOR: STEPHEN MRENNA C...Last change: C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e C...when CHIENU .NE. 0 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) CC &SFMIX(16,4), C COMMON/PYINTS/XXM(20) COMPLEX*16 CXC COMMON/PYINTC/XXC(10),CXC(8) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/ C...Local variables COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB INTEGER KFIN,KCIN DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2, &XMZ,XMZ2,AXMJ,AXMI DOUBLE PRECISION S12MIN,S12MAX DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK DOUBLE PRECISION PYLAMF,XL DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA DOUBLE PRECISION PYX2XH,PYX2XG DOUBLE PRECISION XLAM(0:400) INTEGER IDLAM(400,3) INTEGER LKNT,IX,IH,J,IJ,I,IKNT INTEGER ITH(3) INTEGER ITHC DOUBLE PRECISION ETAH(3),DH(3),EH(3) DOUBLE PRECISION SR2 DOUBLE PRECISION CBETA,SBETA,TANB DOUBLE PRECISION PYALEM,PI,PYALPS DOUBLE PRECISION FCOL INTEGER KF1,KF2,ISF INTEGER KFNCHI(4),KFCCHI(2) DOUBLE PRECISION TEMP EXTERNAL PYGAUS,PYXXZ6 DOUBLE PRECISION PYGAUS,PYXXZ6 DOUBLE PRECISION PREC DATA ITH/25,35,36/ DATA ITHC/37/ DATA ETAH/1D0,1D0,-1D0/ DATA SR2/1.4142136D0/ DATA PI/3.141592654D0/ DATA PREC/1D-2/ DATA KFNCHI/1000022,1000023,1000025,1000035/ DATA KFCCHI/1000024,1000037/ C...COUNT THE NUMBER OF DECAY MODES LKNT=0 XMW=PMAS(24,1) XMW2=XMW**2 XMZ=PMAS(23,1) XMZ2=XMZ**2 XW=1D0-XMW2/XMZ2 XW1=1D0-XW TANW = SQRT(XW/XW1) C...1 OR 2 DEPENDING ON CHARGINO TYPE IX=1 IF(KFIN.EQ.KFCCHI(2)) IX=2 KCIN=PYCOMP(KFIN) XMI=SMW(IX) XMI2=XMI**2 AXMI=ABS(XMI) AEM=PYALEM(XMI2) AS =PYALPS(XMI2) C1=AEM/XW XMI3=ABS(XMI**3) TANB=RMSS(5) BETA=ATAN(TANB) CBETA=COS(BETA) SBETA=TANB*CBETA ALFA=RMSS(18) DO 110 I=1,2 DO 100 J=1,2 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I)) UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I)) 100 CONTINUE 110 CONTINUE C...GRAVITINO DECAY MODES IF(IMSS(11).EQ.1) THEN XMP=RMSS(29) IDG=39+KSUSY1 XMGR=PMAS(PYCOMP(IDG),1) C SINW=SQRT(XW) C COSW=SQRT(1D0-XW) XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI IF(AXMI.GT.XMGR+XMW) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=24 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*( & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+ & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))* & (1D0-XMW2/XMI2)**4 ENDIF IF(AXMI.GT.XMGR+PMAS(37,1)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=37 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+ & (ABS(UMIXC(IX,2))*SBETA)**2)) & *(1D0-PMAS(37,1)**2/XMI2)**4 ENDIF ENDIF C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS IF(IX.EQ.1) GOTO 170 XMJ=SMW(1) AXMJ=ABS(XMJ) XMJ2=XMJ**2 C...CHI_2+ -> CHI_1+ + Z0 IF(AXMI.GE.AXMJ+XMZ) THEN LKNT=LKNT+1 IJ=1 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))- & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))- & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0 GX2=ABS(OLPP)**2+ABS(ORPP)**2 GLR=DBLE(OLPP*DCONJG(ORPP)) XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=23 IDLAM(LKNT,3)=0 C...CHARGED LEPTONS ELSEIF(AXMI.GE.AXMJ) THEN S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 IA=11 JA=12 EI=KCHG(IABS(IA),1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 XXC(1)=0D0 XXC(2)=XMJ XXC(3)=0D0 XXC(4)=XMI XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) XXC(6)=1D6 XXC(9)=PMAS(23,1) XXC(10)=PMAS(23,2) IJ=1 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))- & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))- & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP CXC(2)=DCMPLX(0D0,0D0) CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW) CXC(5)=-DCMPLX(EI/XW1)*ORPP CXC(6)=DCMPLX(0D0,0D0) CXC(7)=-DCMPLX(EI/XW1)*OLPP CXC(8)=DCMPLX(0D0,0D0) IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=11 IDLAM(LKNT,3)=-11 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=13 IDLAM(LKNT,3)=-13 ENDIF IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=15 IDLAM(LKNT,3)=-15 ENDIF ENDIF C...NEUTRINOS 120 CONTINUE IA=12 JA=11 EI=KCHG(IABS(IA),1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) XXC(6)=1D6 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW) CXC(5)=-DCMPLX(EI/XW1)*ORPP CXC(7)=-DCMPLX(EI/XW1)*OLPP IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=12 IDLAM(LKNT,3)=-12 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=14 IDLAM(LKNT,3)=-14 ENDIF IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN XXC(5)=PMAS(PYCOMP(KSUSY1+15),1) ELSE XXC(5)=PMAS(PYCOMP(KSUSY2+15),1) ENDIF IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF XXC(7)=XXC(5) LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=16 IDLAM(LKNT,3)=-16 ENDIF C...D-TYPE QUARKS 130 CONTINUE IA=1 JA=2 EI=KCHG(IABS(IA),1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) XXC(6)=1D6 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP CXC(2)=DCMPLX(0D0,0D0) CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW) CXC(5)=-DCMPLX(EI/XW1)*ORPP CXC(6)=DCMPLX(0D0,0D0) CXC(7)=-DCMPLX(EI/XW1)*OLPP CXC(8)=DCMPLX(0D0,0D0) IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-1 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=3 IDLAM(LKNT,3)=-3 ENDIF ENDIF IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN XXC(5)=PMAS(PYCOMP(KSUSY1+5),1) ELSE XXC(5)=PMAS(PYCOMP(KSUSY2+5),1) ENDIF IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF XXC(7)=XXC(5) LKNT=LKNT+1 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=5 IDLAM(LKNT,3)=-5 ENDIF C...U-TYPE QUARKS 140 CONTINUE IA=2 JA=1 EI=KCHG(IABS(IA),1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) XXC(6)=1D6 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP CXC(2)=DCMPLX(0D0,0D0) CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW) CXC(5)=-DCMPLX(EI/XW1)*ORPP CXC(6)=DCMPLX(0D0,0D0) CXC(7)=-DCMPLX(EI/XW1)*OLPP CXC(8)=DCMPLX(0D0,0D0) IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=2 IDLAM(LKNT,3)=-2 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=4 IDLAM(LKNT,3)=-4 ENDIF ENDIF 150 CONTINUE ENDIF C...CHI_2+ -> CHI_1+ + H0_K EH(2)=COS(ALFA) EH(1)=SIN(ALFA) EH(3)=-SBETA DH(2)=-SIN(ALFA) DH(1)=COS(ALFA) DH(3)=COS(BETA) DO 160 IH=1,3 XMH=PMAS(ITH(IH),1) XMH2=XMH**2 C...NO 3-BODY OPTION IF(AXMI.GE.AXMJ+XMH) THEN LKNT=LKNT+1 XL=PYLAMF(XMI2,XMJ2,XMH2) OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) - & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) - & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2 XMK=XMJ*ETAH(IH) GX2=ABS(OLPP)**2+ABS(ORPP)**2 GLR=DBLE(OLPP*DCONJG(ORPP)) XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=ITH(IH) IDLAM(LKNT,3)=0 ENDIF 160 CONTINUE C...CHI1 JUMPS TO HERE 170 CONTINUE C...CHI+_I -> CHI0_J + W+ DO 220 IJ=1,4 XMJ=SMZ(IJ) AXMJ=ABS(XMJ) XMJ2=XMJ**2 IF(AXMI.GE.AXMJ+XMW) THEN LKNT=LKNT+1 DO 180 I=1,4 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I)) 180 CONTINUE CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)- & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2) CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+ & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2) GX2=ABS(CXC(1))**2+ABS(CXC(3))**2 GLR=DBLE(CXC(1)*DCONJG(CXC(3))) XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=24 IDLAM(LKNT,3)=0 C...LEPTONS ELSEIF(AXMI.GE.AXMJ) THEN S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 DO 190 I=1,4 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I)) 190 CONTINUE CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)- & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+ & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2 CXC(5)=DCMPLX(0D0,0D0) CXC(7)=DCMPLX(0D0,0D0) IA=11 JA=12 EI=KCHG(IA,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 EJ=KCHG(JA,1)/3D0 T3J=SIGN(1D0,EJ+1D-6)/2D0 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)* & TANW+ZMIXC(IJ,2)*T3J)/SR2 CXC(4)=-DCONJG(UMIXC(IX,1))*( & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2 CXC(6)=DCMPLX(0D0,0D0) CXC(8)=DCMPLX(0D0,0D0) XXC(1)=0D0 XXC(2)=XMJ XXC(3)=0D0 XXC(4)=XMI XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1) XXC(9)=PMAS(24,1) XXC(10)=PMAS(24,2) CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190 IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ELSEIF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(6) XXC(8)=XXC(5) C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW, C...--> 1/(16PI)/M**3*(AEM/XW)**2 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN LKNT=LKNT+1 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=-11 IDLAM(LKNT,3)=12 C...ONLY DECAY CHI+1 -> E+ NU_E IF( IMSS(12).NE. 0 ) GOTO 260 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=-13 IDLAM(LKNT,3)=14 ENDIF ENDIF IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN LKNT=LKNT+1 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN XXC(6)=PMAS(PYCOMP(KSUSY1+15),1) ELSE XXC(6)=PMAS(PYCOMP(KSUSY2+15),1) ENDIF XXC(5)=PMAS(PYCOMP(KSUSY1+16),1) IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ELSEIF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(6) XXC(8)=XXC(5) TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=-15 IDLAM(LKNT,3)=16 ENDIF C...NOW, DO THE QUARKS 200 CONTINUE IA=1 JA=2 EI=KCHG(IA,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 EJ=KCHG(JA,1)/3D0 T3J=SIGN(1D0,EJ+1D-6)/2D0 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)* & TANW+ZMIXC(IJ,2)*T3J) CXC(4)=-DCONJG(UMIXC(IX,1))*( & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I) XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1) IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210 IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ENDIF IF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(6) XXC(8)=XXC(5) IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=-1 IDLAM(LKNT,3)=2 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=-3 IDLAM(LKNT,3)=4 ENDIF ENDIF 210 CONTINUE ENDIF 220 CONTINUE C...CHI+_I -> CHI0_J + H+ DO 230 IJ=1,4 XMJ=SMZ(IJ) AXMJ=ABS(XMJ) XMJ2=XMJ**2 XMHP=PMAS(ITHC,1) IF(AXMI.GE.AXMJ+XMHP) THEN LKNT=LKNT+1 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+ & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2) ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)- & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)* & UMIXC(IX,2)/SR2) GX2=ABS(OLPP)**2+ABS(ORPP)**2 GLR=DBLE(OLPP*DCONJG(ORPP)) XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=ITHC IDLAM(LKNT,3)=0 ELSE ENDIF 230 CONTINUE C...2-BODY DECAYS TO FERMION SFERMION DO 240 J=1,16 IF(J.GE.7.AND.J.LE.10) GOTO 240 IF(MOD(J,2).EQ.0) THEN KF1=KSUSY1+J-1 ELSE KF1=KSUSY1+J+1 ENDIF KF2=KF1+KSUSY1 XMSF1=PMAS(PYCOMP(KF1),1) XMSF2=PMAS(PYCOMP(KF2),1) XMF=PMAS(J,1) IF(J.LE.6) THEN FCOL=3D0 ELSE FCOL=1D0 ENDIF C...U~ D_L IF(MOD(J,2).EQ.0) THEN XMFP=PMAS(J-1,1) CAL=UMIXC(IX,1) CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2 CBR=0D0 ISF=J-1 ELSE XMFP=PMAS(J+1,1) CAL=VMIXC(IX,1) CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2 CBR=0D0 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2 ISF=J+1 ENDIF C...~U_L D IF(AXMI.GE.XMF+XMSF1) THEN LKNT=LKNT+1 XMA2=XMSF1**2 XMB2=XMF**2 XL=PYLAMF(XMI2,XMA2,XMB2) CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2) CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2) XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI) IDLAM(LKNT,3)=0 IF(MOD(J,2).EQ.0) THEN IDLAM(LKNT,1)=-KF1 IDLAM(LKNT,2)=J ELSE IDLAM(LKNT,1)=KF1 IDLAM(LKNT,2)=-J ENDIF ENDIF C...U~ D_R IF(AXMI.GE.XMF+XMSF2) THEN LKNT=LKNT+1 XMA2=XMSF2**2 XMB2=XMF**2 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4) CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4) XL=PYLAMF(XMI2,XMA2,XMB2) XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI) IDLAM(LKNT,3)=0 IF(MOD(J,2).EQ.0) THEN IDLAM(LKNT,1)=-KF2 IDLAM(LKNT,2)=J ELSE IDLAM(LKNT,1)=KF2 IDLAM(LKNT,2)=-J ENDIF ENDIF 240 CONTINUE C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH C...A 2-BODY -- 2-BODY CHAIN XMJ=PMAS(PYCOMP(KSUSY1+21),1) IF(AXMI.GE.XMJ) THEN AXMJ=ABS(XMJ) S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 XXC(1)=0D0 XXC(2)=XMJ XXC(3)=0D0 XXC(4)=XMI XXC(5)=PMAS(PYCOMP(KSUSY1+1),1) XXC(6)=PMAS(PYCOMP(KSUSY1+2),1) XXC(9)=1D6 XXC(10)=0D0 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32))) ORPP=DCONJG(OLPP) CXC(1)=DCMPLX(0D0,0D0) CXC(3)=DCMPLX(0D0,0D0) CXC(5)=DCMPLX(0D0,0D0) CXC(7)=DCMPLX(0D0,0D0) CXC(2)=UMIXC(IX,1)*OLPP/SR2 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2 CXC(6)=DCMPLX(0D0,0D0) CXC(8)=DCMPLX(0D0,0D0) IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ELSEIF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(6) XXC(8)=XXC(5) IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=-1 IDLAM(LKNT,3)=2 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=-3 IDLAM(LKNT,3)=4 ENDIF ENDIF 250 CONTINUE ENDIF C...R-violating decay modes (SKANDS). CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT) 260 IKNT=LKNT XLAM(0)=0D0 DO 270 I=1,IKNT XLAM(0)=XLAM(0)+XLAM(I) IF(XLAM(I).LT.0D0) THEN WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN, & (IDLAM(I,J),J=1,3) XLAM(I)=0D0 ENDIF 270 CONTINUE IF(XLAM(0).EQ.0D0) THEN XLAM(0)=1D-6 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0) WRITE(MSTU(11),*) LKNT WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT) ENDIF RETURN END C********************************************************************* C...PYXXZ6 C...Used in the calculation of inoi -> inoj + f + ~f. FUNCTION PYXXZ6(X) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) C COMMON/PYINTS/XXM(20) COMPLEX*16 CXC COMMON/PYINTC/XXC(10),CXC(8) SAVE /PYDAT1/,/PYINTC/ C...Local variables. COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT DOUBLE PRECISION PYXXZ6,X DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2 DOUBLE PRECISION SIJ DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2 DOUBLE PRECISION OL2 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL INTEGER I C...Statement functions. C...Integral from x to y of (t-a)(b-t) dt. TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B) C...Integral from x to y of (t-a)(b-t)/(t-c) dt. TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))- &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A) C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt. TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+ &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C))) C...Integral from x to y of (t-a)/(b-t) dt. UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A) C...Integral from x to y of 1/(t-a) dt. TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A))) XM12=XXC(1)**2 XM22=XXC(2)**2 XM32=XXC(3)**2 S=XXC(4)**2 S13=X S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S) S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)* &( (X-XM22-S)**2 -4D0*XM22*S ) ) S23MIN=(S23AVE-S23DEL) S23MAX=(S23AVE+S23DEL) XMSD1=XXC(5)**2 XMSD2=XXC(7)**2 XMSU1=XXC(6)**2 XMSU2=XXC(8)**2 XMV=XXC(9) XMG=XXC(10) QLLS=CXC(1) QLLU=CXC(2) QLRS=CXC(3) QLRT=CXC(4) QRLS=CXC(5) QRLT=CXC(6) QRRS=CXC(7) QRRU=CXC(8) WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2 SIJ=2D0*XXC(2)*XXC(4)*S13 IF(XMV.LE.1000D0) THEN OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS)) WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S) & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2 IF(XXC(5).LE.10000D0) THEN WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))* & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)- & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+ & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)- & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1)) & *(S13-XMV**2)/WPROP2 ELSE WFL1=0D0 ENDIF IF(XXC(6).LE.10000D0) THEN WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))* & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)- & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+ & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)- & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1)) & *(S13-XMV**2)/WPROP2 ELSE WFL2=0D0 ENDIF ELSE WW=0D0 WFL1=0D0 WFL2=0D0 ENDIF IF(XXC(5).LE.10000D0) THEN WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1) & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2) & - 2D0*DBLE(QLRT*DCONJG(QLLU))* & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2) ELSE WF1=0D0 ENDIF IF(XXC(6).LE.10000D0) THEN WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1) & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2) & - 2D0*DBLE(QRLT*DCONJG(QRRU))* & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2) ELSE WF2=0D0 ENDIF PYXXZ6=(WW+WF1+WF2+WFL1+WFL2) IF(PYXXZ6.LT.0D0) THEN WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 ' WRITE(MSTU(11),*) XXc(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) PYH2XX=0D0 RETURN END C********************************************************************* C...PYGAUS C...Integration by adaptive Gaussian quadrature. C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig. FUNCTION PYGAUS(F, A, B, EPS) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Local declarations. EXTERNAL F DOUBLE PRECISION F,W(12), X(12) DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/ DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/ DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/ DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/ DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/ DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/ DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/ DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/ DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/ DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/ DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/ DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/ C...The Gaussian quadrature algorithm. H = 0D0 IF(B .EQ. A) GOTO 140 CONST = 5D-3 / ABS(B-A) BB = A 100 CONTINUE AA = BB BB = B 110 CONTINUE C1 = 0.5D0*(BB+AA) C2 = 0.5D0*(BB-AA) S8 = 0D0 DO 120 I = 1, 4 U = C2*X(I) S8 = S8 + W(I) * (F(C1+U) + F(C1-U)) 120 CONTINUE S16 = 0D0 DO 130 I = 5, 12 U = C2*X(I) S16 = S16 + W(I) * (F(C1+U) + F(C1-U)) 130 CONTINUE S16 = C2*S16 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN H = H + S16 IF(BB .NE. B) GOTO 100 ELSE BB = C1 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110 H = 0D0 CALL PYERRM(18,'(PYGAUS:) too high accuracy required') GOTO 140 ENDIF 140 CONTINUE PYGAUS = H RETURN END C********************************************************************* C...PYGAU2 C...Integration by adaptive Gaussian quadrature. C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig. C...Carbon copy of PYGAUS, but avoids having to use it recursively. FUNCTION PYGAU2(F, A, B, EPS) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Local declarations. EXTERNAL F DOUBLE PRECISION F,W(12), X(12) DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/ DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/ DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/ DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/ DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/ DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/ DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/ DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/ DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/ DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/ DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/ DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/ C...The Gaussian quadrature algorithm. H = 0D0 IF(B .EQ. A) GOTO 140 CONST = 5D-3 / ABS(B-A) BB = A 100 CONTINUE AA = BB BB = B 110 CONTINUE C1 = 0.5D0*(BB+AA) C2 = 0.5D0*(BB-AA) S8 = 0D0 DO 120 I = 1, 4 U = C2*X(I) S8 = S8 + W(I) * (F(C1+U) + F(C1-U)) 120 CONTINUE S16 = 0D0 DO 130 I = 5, 12 U = C2*X(I) S16 = S16 + W(I) * (F(C1+U) + F(C1-U)) 130 CONTINUE S16 = C2*S16 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN H = H + S16 IF(BB .NE. B) GOTO 100 ELSE BB = C1 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110 H = 0D0 CALL PYERRM(18,'(PYGAU2:) too high accuracy required') GOTO 140 ENDIF 140 CONTINUE PYGAU2 = H RETURN END C********************************************************************* C...PYSIMP C...Simpson formula for an integral. FUNCTION PYSIMP(Y,X0,X1,N) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DOUBLE PRECISION Y,X0,X1,H,S DIMENSION Y(0:N) S=0D0 H=(X1-X0)/N DO 100 I=0,N-2,2 S=S+Y(I)+4D0*Y(I+1)+Y(I+2) 100 CONTINUE PYSIMP=S*H/3D0 RETURN END C********************************************************************* C...PYLAMF C...The standard lambda function. FUNCTION PYLAMF(X,Y,Z) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DOUBLE PRECISION PYLAMF,X,Y,Z PYLAMF=(X-(Y+Z))**2-4D0*Y*Z IF(PYLAMF.LT.0D0) PYLAMF=0D0 RETURN END C********************************************************************* C...PYTBDY C...Generates 3-body decays of gauginos. SUBROUTINE PYTBDY(IDIN) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/ C...Local variables. DOUBLE PRECISION XM(5) COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2) DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3 DOUBLE PRECISION CPHI1,SPHI1 DOUBLE PRECISION S23DEL,EPS DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3) DOUBLE PRECISION F1,F2,X0,X1,X2,X3 INTEGER INOID(4) DATA INOID/22,23,25,35/ DATA EPS/1D-6/ ID=IDIN ISKIP=1 XM(1)=P(N+1,5) XM(2)=P(N+2,5) XM(3)=P(N+3,5) XM(5)=P(ID,5) C...GENERATE S12 S12MIN=(XM(1)+XM(2))**2 S12MAX=(XM(5)-XM(3))**2 YJACO1=S12MAX-S12MIN C...Initialize some parameters XW=PARU(102) XW1=1D0-XW TANW=SQRT(XW/XW1) IZID1=0 IWID1=0 IZID2=0 IWID2=0 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(IABS(JA),1)/3D0 T3J=SIGN(1D0,EJ+1D-6)/2D0 QRLS=DCMPLX(0D0,0D0) QRLT=QRLS QRRS=QRLS QRRU=QRLS XRR2=1D6**2 XRL2=XRR2 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2 IF(MOD(IA,2).EQ.0) THEN QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)* & TANW+ZMIXC(IZID2,2)*T3I) QLRT=-DCONJG(UMIXC(IZID1,1))*( & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J) ELSE QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)* & TANW+ZMIXC(IZID2,2)*T3J) QLRT=-DCONJG(UMIXC(IZID1,1))*( & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I) ENDIF ELSEIF(IWID1*IWID2.NE.0) THEN IZID1=IWID1 IZID2=IWID2 XM1M2=SMW(IWID1)*SMW(IWID2) SQMZ=PMAS(23,1)**2 GMMZ=PMAS(23,1)*PMAS(23,2) DO 140 I=1,2 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I)) UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I)) VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I)) UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I)) 140 CONTINUE OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))- & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))- & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0 QRLS=-DCMPLX(EI/XW1)*ORPP QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP QRRS=-DCMPLX(EI/XW1)*OLPP QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP IF(MOD(IA,2).EQ.0) THEN XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW) ELSE XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW) ENDIF ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21) &THEN ISKIP=0 ELSE ISKIP=0 ENDIF IF(ISKIP.NE.0) THEN WTMAX=0D0 DO 160 KT=1,100 S12=S12MIN+YJACO1*(KT-1)/99 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2) & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12) S23DF1=(S12-XM(2)**2-XM(1)**2)**2 & -(2D0*XM(1)*XM(2))**2 S23DF2=(S12-XM(3)**2-XM(5)**2)**2 & -(2D0*XM(3)*XM(5))**2 S23DF1=S23DF1*EPS S23DF2=S23DF2*EPS S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12) S23DEL=S23DEL/EPS S23MIN=S23AVE-S23DEL S23MAX=S23AVE+S23DEL YJACO2=S23MAX-S23MIN TH=S12 DO 150 KS=1,100 S23=S23MIN+YJACO2*(KS-1)/99 SH=S23 UH=ZM12+ZM22-SH-TH WU2 = (UH-ZM12)*(UH-ZM22) WT2 = (TH-ZM12)*(TH-ZM22) WS2 = XM1M2*SH PROPZ2 = (SH-SQMZ)**2 + GMMZ**2 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2) QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2) QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2) QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2) QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2) WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+ & (ABS(QRL)**2+ABS(QLR)**2)*WT2+ & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2) IF(WT0.GT.WTMAX) WTMAX=WT0 150 CONTINUE 160 CONTINUE WTMAX=WTMAX*1.05D0 ENDIF C...FIND S12* AX=S12MIN CX=S12MAX BX=S12MIN+0.5D0*YJACO1 X0=AX X3=CX IF(ABS(CX-BX).GT.ABS(BX-AX))THEN X1=BX X2=BX+C*(CX-BX) ELSE X2=BX X1=BX-C*(BX-AX) ENDIF C...SOLVE FOR F1 AND F2 S23DF1=(X1-XM(2)**2-XM(1)**2)**2 &-(2D0*XM(1)*XM(2))**2 S23DF2=(X1-XM(3)**2-XM(5)**2)**2 &-(2D0*XM(3)*XM(5))**2 S23DF1=S23DF1*EPS S23DF2=S23DF2*EPS S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1) F1=-2D0*S23DEL/EPS S23DF1=(X2-XM(2)**2-XM(1)**2)**2 &-(2D0*XM(1)*XM(2))**2 S23DF2=(X2-XM(3)**2-XM(5)**2)**2 &-(2D0*XM(3)*XM(5))**2 S23DF1=S23DF1*EPS S23DF2=S23DF2*EPS S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2) F2=-2D0*S23DEL/EPS 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS) IF(F2.LE.F1)THEN X0=X1 X1=X2 X2=R*X1+C*X3 F1=F2 S23DF1=(X2-XM(2)**2-XM(1)**2)**2 & -(2D0*XM(1)*XM(2))**2 S23DF2=(X2-XM(3)**2-XM(5)**2)**2 & -(2D0*XM(3)*XM(5))**2 S23DF1=S23DF1*EPS S23DF2=S23DF2*EPS S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2) F2=-2D0*S23DEL/EPS ELSE X3=X2 X2=X1 X1=R*X2+C*X0 F2=F1 S23DF1=(X1-XM(2)**2-XM(1)**2)**2 & -(2D0*XM(1)*XM(2))**2 S23DF2=(X1-XM(3)**2-XM(5)**2)**2 & -(2D0*XM(3)*XM(5))**2 S23DF1=S23DF1*EPS S23DF2=S23DF2*EPS S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1) F1=-2D0*S23DEL/EPS ENDIF GOTO 170 ENDIF C...WE WANT THE MAXIMUM, NOT THE MINIMUM IF(F1.LT.F2)THEN GOLDEN=-F1 XMIN=X1 ELSE GOLDEN=-F2 XMIN=X2 ENDIF IKNT=0 180 S12=S12MIN+PYR(0)*YJACO1 IKNT=IKNT+1 C...GENERATE S23 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2) &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12) S23DF1=(S12-XM(2)**2-XM(1)**2)**2 &-(2D0*XM(1)*XM(2))**2 S23DF2=(S12-XM(3)**2-XM(5)**2)**2 &-(2D0*XM(3)*XM(5))**2 S23DF1=S23DF1*EPS S23DF2=S23DF2*EPS S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12) S23DEL=S23DEL/EPS S23MIN=S23AVE-S23DEL S23MAX=S23AVE+S23DEL YJACO2=S23MAX-S23MIN S23=S23MIN+PYR(0)*YJACO2 C...CHECK THE SAMPLING IF(IKNT.GT.100) THEN WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY ' GOTO 190 ENDIF IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180 IF(ISKIP.EQ.0) GOTO 190 SH=S23 TH=S12 UH=ZM12+ZM22-SH-TH WU2 = (UH-ZM12)*(UH-ZM22) WT2 = (TH-ZM12)*(TH-ZM22) WS2 = XM1M2*SH PROPZ2 = (SH-SQMZ)**2 + GMMZ**2 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2) QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2) QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2) QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2) QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2) c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2) c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ) c &/DCMPLX(TH-XML2) c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2) c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2) WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+ &(ABS(QRL)**2+ABS(QLR)**2)*WT2+ &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2) IF(WT.LT.PYR(0)*WTMAX) GOTO 180 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5)) D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5)) D2=XM(5)-D1-D3 P1=SQRT(D1*D1-XM(1)**2) P2=SQRT(D2*D2-XM(2)**2) P3=SQRT(D3*D3-XM(3)**2) CTHE1=2D0*PYR(0)-1D0 ANG1=2D0*PYR(0)*PARU(1) CPHI1=COS(ANG1) SPHI1=SIN(ANG1) ARG=1D0-CTHE1**2 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0 STHE1=SQRT(ARG) P(N+1,1)=P1*STHE1*CPHI1 P(N+1,2)=P1*STHE1*SPHI1 P(N+1,3)=P1*CTHE1 P(N+1,4)=D1 C...GET CPHI3 ANG3=2D0*PYR(0)*PARU(1) CPHI3=COS(ANG3) SPHI3=SIN(ANG3) CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3 ARG=1D0-CTHE3**2 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0 STHE3=SQRT(ARG) P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1 &+P3*STHE3*SPHI3*SPHI1 &+P3*CTHE3*STHE1*CPHI1 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1 &-P3*STHE3*SPHI3*CPHI1 &+P3*CTHE3*STHE1*SPHI1 P(N+3,3)=P3*STHE3*CPHI3*STHE1 &+P3*CTHE3*CTHE1 P(N+3,4)=D3 DO 200 I=1,3 P(N+2,I)=-P(N+1,I)-P(N+3,I) 200 CONTINUE P(N+2,4)=D2 RETURN END C********************************************************************* C...PYTECM C...Finds the s-hat dependent eigenvalues of the inverse propagator C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the C...phase space generation. 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 CDF Tune A C 101 AW : Rick Field's CDF Tune AW C 102 BW : Rick Field's CDF Tune BW C 103 DW : Rick Field's CDF Tune DW C 104 DWT : Rick Field's CDF Tune DW with slower UE energy scaling C 105 QW : Rick Field's CDF Tune QW (NB: needs CTEQ6.1M pdfs externally) C 106 ATLAS : Arthur Moraes' (old) ATLAS tune (ATLAS DC2 / Rome) C 107 ACR : Tune A modified with annealing CR C ====== Intermediate Models ================================================= C 200 IM 1 : Intermediate model: new UE, Q2-ordered showers, annealing CR C 201 APT : Tune A modified to use new pT-ordered final-state showers C ====== New UE, interleaved pT-ordered showers, annealing CR ================ C 300 S0 : Sandhoff-Skands Tune 0 C 301 S1 : Sandhoff-Skands Tune 1 C 302 S2 : Sandhoff-Skands Tune 2 C 303 S0A : S0 with "Tune A" UE energy scaling C 304 NOCR : New UE "best try" without colour reconnections C 305 Old : New UE, original (primitive) colour reconnections C ======= The Uppsala models ================================================= C ( NB! must be run with special modified Pythia 6.215 version ) C ( available from http://www.isv.uu.se/thep/MC/scigal/ ) C 400 GAL 0 : Generalized area-law model. Old parameters C 401 SCI 0 : Soft-Colour-Interaction model. Old parameters C 402 GAL 1 : Generalized area-law model. Tevatron MB retuned (Skands) C 403 SCI 1 : Soft-Colour-Interaction model. Tevatron MB retuned (Skands) C C More details; C C Quick Dictionary: C BE : Bose-Einstein C BR : Beam Remnants C CR : Colour Reconnections C HAD: Hadronization C ISR/FSR: Initial-State Radiation / Final-State Radiation C FSI: Final-State Interactions (=CR+BE) C MB : Minimum-bias C MI : Multiple Interactions C UE : Underlying Event C C A (100) and AW (101). Old UE model, Q2-ordered showers. C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) *** C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+ C...Key feature: extensively compared to CDF data (R.D. Field). C...* Large starting scale for ISR (PARP(67)=4) C...* AW has even more radiation due to smaller mu_R choice in alpha_s. C...* See: http://www.phys.ufl.edu/~rfield/cdf/ C C BW (102). Old UE model, Q2-ordered showers. C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) *** C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+ C...Key feature: extensively compared to CDF data (R.D. Field). C...NB: Can also be run with Pythia 6.2 or 6.312+ C...* Small starting scale for ISR (PARP(67)=1) C...* BW has more radiation due to smaller mu_R choice in alpha_s. C...* See: http://www.phys.ufl.edu/~rfield/cdf/ C C DW (103) and DWT (104). Old UE model, Q2-ordered showers. C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) *** C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+ C...Key feature: extensively compared to CDF data (R.D. Field). C...NB: Can also be run with Pythia 6.2 or 6.312+ C...* Intermediate starting scale for ISR (PARP(67)=2.5) C...* DWT has a different reference energy, the same as the "S" models C... below, leading to more UE activity at the LHC, but less at RHIC. C...* See: http://www.phys.ufl.edu/~rfield/cdf/ C C QW (105). Old UE model, Q2-ordered showers. C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) *** C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+ C...Key feature: uses CTEQ61 (external pdf library must be linked) C C ATLAS (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...APT (201). Old UE model, pT-ordered final-state showers C...Key feature: Rick Field's Tune A, but with new final-state showers C C S0 (300) and S0A (303). New UE model, pT-ordered showers. C...Key feature: large amount of multiple interactions C...* Somewhat faster than the other colour annealing scenarios. C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed C... from Tune A, leading to less UE at the LHC, but more at RHIC. C...* Small amount of radiation. C...* Large amount of low-pT MI C...* Low degree of proton lumpiness (broad matter dist.) C...* CR Type S (driven by free triplets), of medium strength. C...* See: Pythia6402 update notes or later. C C S1 (301). New UE model, pT-ordered showers. C...Key feature: large amount of radiation. C...* Large amount of low-pT perturbative ISR C...* Large amount of FSR off ISR partons C...* Small amount of low-pT multiple interactions C...* Moderate degree of proton lumpiness C...* Least aggressive CR type (S+S Type I), but with large strength C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120. C C S2 (302). New UE model, pT-ordered showers. C...Key feature: very lumpy proton + gg string cluster formation allowed C...* Small amount of radiation C...* Moderate amount of low-pT MI C...* High degree of proton lumpiness (more spiky matter distribution) C...* Most aggressive CR type (S+S Type II), but with small strength C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120. C C NOCR (304). New UE model, pT-ordered showers. C...Key feature: no colour reconnections (NB: "Best fit" only). C...* NB: (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 ? RDF's QK? C (problem: K-factor affects everything so only works as C intended for min-bias, not for UE ... probably need a C better long-term solution to handle UE as well. Anyway, C Mark uses MSTP(33) and PARP(31)-PARP(33).) C...Global statements IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) C...SCI and GAL Commonblocks COMMON /SCIPAR/MSWI(2),PARSCI(2) C...Internal parameters PARAMETER(MXTUNS=500) CHARACTER*8 CHVERS, CHDOC PARAMETER (CHVERS='1.010 ',CHDOC='Jun 2007') CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME CHARACTER*40 CHMSTJ(50), CHMSTP(51:100), CHPARP(61:100), & CHPARJ(41:100), CH40 CHARACTER*60 CH60 CHARACTER*70 CH70 DATA (CHNAMS(I),I=0,1)/'Default',' '/ DATA (CHNAMS(I),I=100,110)/ & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW', & 'ATLAS Tune','Tune ACR',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','Tune APT',9*' '/ DATA (CHNAMS(I),I=400,410)/ & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',7*' '/ DATA (CHMSTJ(I),I=11,20)/ & 5*' ','HAD treatment of small-mass systems',4*' '/ DATA (CHMSTJ(I),I=41,50)/ & 'FSR type (Q2 or pT) for old framework',9*' '/ DATA (CHMSTP(I),I=51,100)/ 5 'PDF set','PDF set internal (=1) or pdflib (=2)', 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', 9 'BR primordial kT compensation', 9 'BR primordial kT distribution', 9 'BR energy partitioning scheme',2*' ', 9 'FSI colour (re-)connection model',5*' '/ DATA (CHPARP(I),I=61,100)/ 6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor', 6 2*' ','ISR Q2max factor',3*' ', 7 'FSR Q2max factor for non-s-channel procs',5*' ', 7 'FSI colour reconnection turnoff scale', 7 'FSI colour reconnection strength', 7 'BR composite x enhancement','BR breakup suppression', 8 2*'UE IR cutoff at reference ecm', 8 2*'UE mass distribution parameter', 8 'UE gg colour correlated fraction','UE total gg fraction', 8 2*' ', 8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power', 9 'BR primordial kT width <|kT|>',' ', 9 'BR primordial kT UV cutoff',7*' '/ DATA (CHPARJ(I),I=41,90)/ 4 ' ','HAD string parameter b',8*' ',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 P. Skands & D. Wicke, hep-ph/0703081' WRITE(M11,5030) CH60 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120' WRITE(M11,5030) CH60 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129' WRITE(M11,5030) CH60 ENDIF C...Smooth ISR, low FSR MSTP(70)=2 MSTP(72)=0 C...pT0 PARP(82)=1.85D0 C...Transverse density profile. MSTP(82)=5 PARP(83)=1.6D0 C...Colour Reconnections MSTP(95)=6 PARP(78)=0.20D0 PARP(77)=0.0D0 C... Reference energy for pT0 and energy scaling pace. IF (ITUNE.EQ.303) PARP(90)=0.25D0 C...Lambda_FSR scale. PARJ(81)=0.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 P. Skands & D. Wicke, hep-ph/0703081' WRITE(M11,5030) CH60 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129' WRITE(M11,5030) CH60 ENDIF C... Smooth ISR, low FSR MSTP(70)=2 MSTP(72)=0 C... pT0 PARP(82)=2.05D0 C... Transverse density profile. MSTP(82)=5 PARP(83)=1.8D0 C... Colour Reconnections MSTP(95)=0 C... Lambda_FSR scale. PARJ(81)=0.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 CH60='See P. Skands & D. Wicke, hep-ph/0703081,' WRITE(M11,5030) CH60 CH60='R.D. Field (CDF), in hep-ph/0610012 (Tune A)' WRITE(M11,5030) CH60 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019' WRITE(M11,5030) CH60 ENDIF IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// & ' with tune. Using defaults.') GOTO 9998 ENDIF MSTP(81)=1 PARP(89)=1800D0 PARP(90)=0.25D0 MSTP(82)=4 PARP(83)=0.5D0 PARP(84)=0.4D0 MSTP(51)=7 MSTP(52)=1 PARP(71)=4D0 PARJ(81)=0.29D0 PARP(82)=2.0D0 PARP(85)=0.0D0 PARP(86)=0.66D0 PARP(62)=1D0 PARP(64)=1D0 PARP(67)=4D0 MSTP(91)=1 PARP(91)=1D0 PARP(93)=5D0 MSTP(95)=6 PARP(78)=0.25D0 C...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... APT. Tune A modified to use new pT-ordered FSR. ELSEIF(ITUNE.EQ.201) THEN IF (M13.GE.1) THEN WRITE(M11,5010) ITUNE, CHNAME CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),' WRITE(M11,5030) CH60 CH60='R.D. Field (CDF), in hep-ph/0610012 (Tune A)' WRITE(M11,5030) CH60 CH60='T. Sjostrand & M. v. Zijl, PRD36(1987)2019' WRITE(M11,5030) CH60 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129' WRITE(M11,5030) CH60 ENDIF IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// & ' with tune.') ENDIF C...Set Pythia tune A C...Multiple interactions on, old framework MSTP(81)=1 C...Fast IR cutoff energy scaling by default PARP(89)=1800D0 PARP(90)=0.25D0 C...Default CTEQ5L (internal) MSTP(51)=7 MSTP(52)=1 C...Double Gaussian matter distribution. MSTP(82)=4 PARP(83)=0.5D0 PARP(84)=0.4D0 C...FSR activity. PARP(71)=4D0 c...String drawing almost completely minimizes string length. PARP(85)=0.9D0 PARP(86)=0.95D0 C...ISR cutoff, muR scale factor, and phase space size PARP(62)=1D0 PARP(64)=1D0 PARP(67)=4D0 C...Intrinsic kT, size, and max MSTP(91)=1 PARP(91)=1D0 PARP(93)=5D0 C...Use pT-ordered FSR MSTJ(41)=12 C...Lambda_FSR scale for pT-ordering PARJ(81)=0.14D0 C...Retune pT0 PARP(82)=2.1D0 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,5070) 41, MSTJ(41), CHMSTJ(41) WRITE(M11,5050) 71, PARP(71), CHPARP(71) WRITE(M11,5060) 81, PARJ(81), CHPARJ(81) WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) WRITE(M11,5050) 82, PARP(82), CHPARP(82) WRITE(M11,5050) 89, PARP(89), CHPARP(89) WRITE(M11,5050) 90, PARP(90), CHPARP(90) WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) WRITE(M11,5050) 83, PARP(83), CHPARP(83) WRITE(M11,5050) 84, PARP(84), CHPARP(84) WRITE(M11,5050) 85, PARP(85), CHPARP(85) WRITE(M11,5050) 86, PARP(86), CHPARP(86) WRITE(M11,5040) 91, MSTP(91), CHMSTP(91) WRITE(M11,5050) 91, PARP(91), CHPARP(91) WRITE(M11,5050) 93, PARP(93), CHPARP(93) 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(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR. & KFLA(I).EQ.9900553)) THEN ISCOL(IR)=1 C...QUARKONIA--- ENDIF IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1 PMTH(1,IR)=PMA(I) IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2) PMTH(3,IR)=PMTH(2,IR)+PMQTH2 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21) PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22) ELSEIF(ISCOL(IR).EQ.1) THEN PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2) PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82) PMTH(4,IR)=PMTH(3,IR) PMTH(5,IR)=PMTH(3,IR) ELSEIF(ISCHG(IR).EQ.1) THEN PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2) PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90) PMTH(4,IR)=PMTH(3,IR) PMTH(5,IR)=PMTH(3,IR) ENDIF IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR) PM=PM+PMA(I) IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1 DO 160 J=1,4 PS(J)=PS(J)+P(IPA(I),J) 160 CONTINUE 170 CONTINUE IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2)) IF(NPA.EQ.1) PS(5)=PS(4) IF(PS(5).LE.PM+PMQT1E) RETURN C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0). KFSRCE=0 IF(IP2.LE.0) THEN ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN KFSRCE=IABS(K(K(IP1,3),2)) ELSE IPAR1=MAX(1,K(IP1,3)) IPAR2=MAX(1,K(IP2,3)) IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0) & KFSRCE=IABS(K(K(IPAR1,3),2)) ENDIF ITYPES=0 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6 C...Identify two primary showerers. ITYPE1=0 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6 ITYPE2=0 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6 C...Order of showerers. Presence of gluino. ITYPMN=MIN(ITYPE1,ITYPE2) ITYPMX=MAX(ITYPE1,ITYPE2) IORD=1 IF(ITYPE1.GT.ITYPE2) IORD=2 IGLUI=0 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1 C...Check if 3-jet matrix elements to be used. M3JC=0 ALPHA=0.5D0 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN IF(MSTJ(38).NE.0) THEN M3JC=MSTJ(38) ALPHA=PARJ(80) MSTJ(38)=0 ELSEIF(MSTJ(47).GE.6) THEN M3JC=MSTJ(47) ELSE ICLASS=1 ICOMBI=4 C...Vector/axial vector -> q + qbar; q -> q + V. IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.3)) THEN ICLASS=2 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN ICOMBI=1 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND. & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN C...gamma*/Z0: assume e+e- initial state if unknown. EI=-1D0 IF(KFSRCE.EQ.23) THEN IANNFL=K(K(IP1,3),3) IF(IANNFL.NE.0) THEN KANNFL=IABS(K(IANNFL,2)) IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0 ENDIF ENDIF AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*PARU(102) EF=KCHG(KFLA(1),1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*PARU(102) XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102))) SH=PS(5)**2 SQMZ=PMAS(23,1)**2 SQWZ=PS(5)*PMAS(23,2) SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2) VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+ & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ ICOMBI=3 ALPHA=VECT/(VECT+AXIV) ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN ICOMBI=4 ENDIF C...For chi -> chi q qbar, use V/A -> q qbar as first approximation. ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN ICLASS=2 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.1)) THEN ICLASS=3 C...Scalar/pseudoscalar -> q + qbar; q -> q + S. ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN ICLASS=4 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN ICOMBI=1 ELSEIF(KFSRCE.EQ.36) THEN ICOMBI=2 ENDIF ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.1)) THEN ICLASS=5 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S. ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.3)) THEN ICLASS=6 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.2)) THEN ICLASS=7 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN ICLASS=8 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.2)) THEN ICLASS=9 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi. ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.5)) THEN ICLASS=10 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.2)) THEN ICLASS=11 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.1)) THEN ICLASS=12 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g. ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN ICLASS=13 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.2)) THEN ICLASS=14 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.1)) THEN ICLASS=15 C...g -> ~g + ~g (eikonal approximation). ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN ICLASS=16 ENDIF M3JC=5*ICLASS+ICOMBI ENDIF ENDIF C...Find if interference with initial state partons. MIIS=0 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50) IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0) &MIIS=MSTJ(50)-3 IF(MIIS.NE.0) THEN DO 190 I=1,2 KCII(I)=0 KCA=PYCOMP(KFLA(I)) IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2)) NIIS(I)=0 IF(KCII(I).NE.0) THEN DO 180 J=1,2 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5)) IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND. & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN NIIS(I)=NIIS(I)+1 IIIS(I,NIIS(I))=ICSI ENDIF 180 CONTINUE ENDIF 190 CONTINUE IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0 ENDIF C...Boost interfering initial partons to rest frame C...and reconstruct their polar and azimuthal angles. IF(MIIS.NE.0) THEN DO 210 I=1,2 DO 200 J=1,5 K(N+I,J)=K(IPA(I),J) P(N+I,J)=P(IPA(I),J) V(N+I,J)=0D0 200 CONTINUE 210 CONTINUE DO 230 I=3,2+NIIS(1) DO 220 J=1,5 K(N+I,J)=K(IIIS(1,I-2),J) P(N+I,J)=P(IIIS(1,I-2),J) V(N+I,J)=0D0 220 CONTINUE 230 CONTINUE DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2) DO 240 J=1,5 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J) P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J) V(N+I,J)=0D0 240 CONTINUE 250 CONTINUE CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4), & -PS(2)/PS(4),-PS(3)/PS(4)) PHI=PYANGL(P(N+1,1),P(N+1,2)) CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0) THE=PYANGL(P(N+1,3),P(N+1,1)) CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0) DO 260 I=3,2+NIIS(1) THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2)) PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2)) 260 CONTINUE DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2) THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3), & SQRT(P(N+I,1)**2+P(N+I,2)**2)) PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2)) 270 CONTINUE ENDIF C...Boost 3 or more partons to their rest frame. IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4), &-PS(2)/PS(4),-PS(3)/PS(4)) C...Define imagined single initiator of shower for parton system. NS=N IF(N.GT.MSTU(4)-MSTU(32)-10) THEN CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS') IF(MSTU(21).GE.1) RETURN ENDIF 280 N=NS IF(NPA.GE.2) THEN K(N+1,1)=11 K(N+1,2)=21 K(N+1,3)=0 K(N+1,4)=0 K(N+1,5)=0 P(N+1,1)=0D0 P(N+1,2)=0D0 P(N+1,3)=0D0 P(N+1,4)=PS(5) P(N+1,5)=PS(5) V(N+1,5)=PS(5)**2 N=N+1 IREF(1)=21 ENDIF C...Loop over partons that may branch. NEP=NPA IM=NS IF(NPA.EQ.1) IM=NS-1 290 IM=IM+1 IF(N.GT.NS) THEN IF(IM.GT.N) GOTO 600 KFLM=IABS(K(IM,2)) IR=IREF(IM-NS) IF(KSH(IR).EQ.0) GOTO 290 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290 IGM=K(IM,3) ELSE IGM=-1 ENDIF IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS') IF(MSTU(21).GE.1) RETURN ENDIF C...Position of aunt (sister to branching parton). C...Origin and flavour of daughters. IAU=0 IF(IGM.GT.0) THEN IF(K(IM-1,3).EQ.IGM) IAU=IM-1 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1 ENDIF IF(IGM.GE.0) THEN K(IM,4)=N+1 DO 300 I=1,NEP K(N+I,3)=IM 300 CONTINUE ELSE K(N+1,3)=IPA(1) ENDIF IF(IGM.LE.0) THEN DO 310 I=1,NEP K(N+I,2)=K(IPA(I),2) 310 CONTINUE ELSEIF(KFLM.NE.21) THEN K(N+1,2)=K(IM,2) K(N+2,2)=K(IM,5) IREF(N+1-NS)=IREF(IM-NS) IREF(N+2-NS)=IABS(K(N+2,2)) ELSEIF(K(IM,5).EQ.21) THEN K(N+1,2)=21 K(N+2,2)=21 IREF(N+1-NS)=21 IREF(N+2-NS)=21 ELSE K(N+1,2)=K(IM,5) K(N+2,2)=-K(IM,5) IREF(N+1-NS)=IABS(K(N+1,2)) IREF(N+2-NS)=IABS(K(N+2,2)) ENDIF C...Reset flags on daughters and tries made. DO 320 IP=1,NEP K(N+IP,1)=3 K(N+IP,4)=0 K(N+IP,5)=0 KFLD(IP)=IABS(K(N+IP,2)) IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1 ITRY(IP)=0 ISL(IP)=0 ISI(IP)=0 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1 320 CONTINUE ISLM=0 C...Maximum virtuality of daughters. IF(IGM.LE.0) THEN DO 330 I=1,NPA IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4) P(N+I,5)=MIN(QMAX,PS(5)) IR=IREF(N+I-NS) IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR)) IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5) 330 CONTINUE ELSE IF(MSTJ(43).LE.2) PEM=V(IM,2) IF(MSTJ(43).GE.3) PEM=P(IM,4) P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM) P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM) IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22) ENDIF DO 340 I=1,NEP PMSD(I)=P(N+I,5) IF(ISI(I).EQ.1) THEN IR=IREF(N+I-NS) IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR) ENDIF V(N+I,5)=P(N+I,5)**2 340 CONTINUE C...Choose one of the daughters for evolution. 350 INUM=0 IF(NEP.EQ.1) INUM=1 DO 360 I=1,NEP IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I 360 CONTINUE DO 370 I=1,NEP IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN IR=IREF(N+I-NS) IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I ENDIF 370 CONTINUE IF(INUM.EQ.0) THEN RMAX=0D0 DO 380 I=1,NEP IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN RPM=P(N+I,5)/PMSD(I) IR=IREF(N+I-NS) IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN RMAX=RPM INUM=I ENDIF ENDIF 380 CONTINUE ENDIF C...Cancel choice of predetermined daughter already treated. INUM=MAX(1,INUM) INUMT=INUM IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM ENDIF C...Store information on choice of evolving daughter. IEP(1)=N+INUM DO 390 I=2,NEP IEP(I)=IEP(I-1)+1 IF(IEP(I).GT.N+NEP) IEP(I)=N+1 390 CONTINUE DO 400 I=1,NEP KFL(I)=IABS(K(IEP(I),2)) 400 CONTINUE ITRY(INUM)=ITRY(INUM)+1 IF(ITRY(INUM).GT.200) THEN CALL PYERRM(14,'(PYSHOW:) caught in infinite loop') IF(MSTU(21).GE.1) RETURN ENDIF Z=0.5D0 IR=IREF(IEP(1)-NS) IF(KSH(IR).EQ.0) GOTO 450 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450 C...Check if evolution already predetermined for daughter. IPSPD=0 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3 ENDIF IF(INUM.EQ.1.OR.INUM.EQ.2) THEN ISSET(INUM)=0 IF(IPSPD.NE.0) ISSET(INUM)=1 ENDIF C...Select side for interference with initial state partons. IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN III=IEP(1)-NS-1 ISII(III)=0 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN ISII(III)=1 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN IF(PYR(0).GT.0.5D0) ISII(III)=1 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN ISII(III)=1 IF(PYR(0).GT.0.5D0) ISII(III)=2 ENDIF ENDIF C...Calculate allowed z range. IF(NEP.EQ.1) THEN PMED=PS(4) ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN PMED=P(IM,5) ELSE IF(INUM.EQ.1) PMED=V(IM,1)*PEM IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM ENDIF IF(MOD(MSTJ(43),2).EQ.1) THEN ZC=PMTH(2,21)/PMED ZCE=PMTH(2,22)/PMED IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED ELSE ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2))) IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2 PMTMPE=PMTH(2,22) IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90) ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2))) IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2 ENDIF ZC=MIN(ZC,0.491D0) ZCE=MIN(ZCE,0.49991D0) IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND. &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN P(IEP(1),5)=PMTH(1,IR) V(IEP(1),5)=P(IEP(1),5)**2 GOTO 450 ENDIF C...Integral of Altarelli-Parisi z kernel for QCD. C...(Includes squark and gluino; with factor N_C/C_F extra for latter). IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0 C...QUARKONIA+++ C...Evolution of QQ~[3S18] state if MSTP(148)=1. ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND. & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN FBR=6D0*LOG((1D0-ZC)/ZC) C...QUARKONIA--- ELSEIF(MSTJ(49).EQ.0) THEN FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC) IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0) C...Integral of Altarelli-Parisi z kernel for scalar gluon. ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC) ELSEIF(MSTJ(49).EQ.1) THEN FBR=(1D0-2D0*ZC)/3D0 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon. ELSEIF(KFL(1).EQ.21) THEN FBR=6D0*MSTJ(45)*(0.5D0-ZC) ELSE FBR=2D0*LOG((1D0-ZC)/ZC) ENDIF C...Reset QCD probability for colourless. IF(ISCOL(IR).EQ.0) FBR=0D0 C...Integral of Altarelli-Parisi kernel for photon emission. FBRE=0D0 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN IF(KFL(1).LE.18) THEN FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE) ENDIF IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE ENDIF C...Inner veto algorithm starts. Find maximum mass for evolution. 410 PMS=V(IEP(1),5) IF(IGM.GE.0) THEN PM2=0D0 DO 420 I=2,NEP PM=P(IEP(I),5) IRI=IREF(IEP(I)-NS) IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI) PM2=PM2+PM 420 CONTINUE PMS=MIN(PMS,(P(IM,5)-PM2)**2) ENDIF C...Select mass for daughter in QCD evolution. B0=27D0/6D0 DO 430 IFF=4,MSTJ(45) IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0 430 CONTINUE C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2. PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2) C...Already predetermined choice. IF(IPSPD.NE.0) THEN PMSQCD=P(IPSPD,5)**2 ELSEIF(FBR.LT.1D-3) THEN PMSQCD=0D0 ELSEIF(MSTJ(44).LE.0) THEN PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR))) ELSEIF(MSTJ(44).EQ.1) THEN PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR)) ELSE PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR)) ENDIF C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2. IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2 V(IEP(1),5)=PMSQCD MCE=1 C...Select mass for daughter in QED evolution. IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2. PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2) IF(FBRE.LT.1D-3) THEN PMSQED=0D0 ELSE PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/ & (PARU(101)*FBRE))) ENDIF C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2. PMSQED=PMSQED+PMTH(1,IR)**2 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED= & PMTH(2,IR)**2 IF(PMSQED.GT.PMSQCD) THEN V(IEP(1),5)=PMSQED MCE=2 ENDIF ENDIF C...Check whether daughter mass below cutoff. P(IEP(1),5)=SQRT(V(IEP(1),5)) IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN P(IEP(1),5)=PMTH(1,IR) V(IEP(1),5)=P(IEP(1),5)**2 GOTO 450 ENDIF C...Already predetermined choice of z, and flavour in g -> qqbar. IF(IPSPD.NE.0) THEN IPSGD1=K(IPSPD,4) IPSGD2=K(IPSPD,5) PMSGD1=P(IPSGD1,5)**2 PMSGD2=P(IPSGD2,5)**2 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2- & 4D0*PMSGD1*PMSGD2)) Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS- & PMSGD1+PMSGD2)/ALAMPS Z=MAX(0.00001D0,MIN(0.99999D0,Z)) IF(KFL(1).NE.21) THEN K(IEP(1),5)=21 ELSE K(IEP(1),5)=IABS(K(IPSGD1,2)) ENDIF C...Select z value of branching: q -> qgamma. ELSEIF(MCE.EQ.2) THEN Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0) IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410 K(IEP(1),5)=22 C...QUARKONIA+++ C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g. ELSEIF(MSTJ(49).EQ.0.AND. & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0) C...Select always the harder 'gluon' if the switch MSTP(149)<=0. IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410 K(IEP(1),5)=21 C...QUARKONIA--- C...Select z value of branching: q -> qg, g -> gg, g -> qqbar. ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0) C...Only do z weighting when no ME correction afterwards. IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410 K(IEP(1),5)=21 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0) IF(PYR(0).GT.0.5D0) Z=1D0-Z IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410 K(IEP(1),5)=21 ELSEIF(MSTJ(49).NE.1) THEN Z=PYR(0) IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410 KFLB=1+INT(MSTJ(45)*PYR(0)) PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5) IF(PMQ.GE.1D0) GOTO 410 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5) IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ) & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410 ELSE IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410 ENDIF K(IEP(1),5)=KFLB C...Ditto for scalar gluon model. ELSEIF(KFL(1).NE.21) THEN Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC)) K(IEP(1),5)=21 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN Z=ZC+(1D0-2D0*ZC)*PYR(0) K(IEP(1),5)=21 ELSE Z=ZC+(1D0-2D0*ZC)*PYR(0) KFLB=1+INT(MSTJ(45)*PYR(0)) PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5) IF(PMQ.GE.1D0) GOTO 410 K(IEP(1),5)=KFLB ENDIF C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar). IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND. & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410 ELSE PT2APP=Z*(1D0-Z)*V(IEP(1),5) IF(MSTJ(44).GE.4) PT2APP=PT2APP* & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2 IF(PT2APP.LT.PT2MIN) GOTO 410 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410 ENDIF ENDIF C...Check if z consistent with chosen m. IF(KFL(1).EQ.21) THEN IRGD1=IABS(K(IEP(1),5)) IRGD2=IRGD1 ELSE IRGD1=IR IRGD2=IABS(K(IEP(1),5)) ENDIF IF(NEP.EQ.1) THEN PED=PS(4) ELSEIF(NEP.GE.3) THEN PED=P(IEP(1),4) ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5) ELSE IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM ENDIF IF(MOD(MSTJ(43),2).EQ.1) THEN PMQTH3=0.5D0*PARJ(82) IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83) IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90) PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5) PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5) ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2- & 4D0*PMQ1*PMQ2))) ZH=1D0+PMQ1-PMQ2 ELSE ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2)) ZH=1D0 ENDIF IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND. &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN ELSEIF(IPSPD.NE.0) THEN ELSE ZL=0.5D0*(ZH-ZD) ZU=0.5D0*(ZH+ZD) IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410 ENDIF IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL* &(1D0-ZU))) IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU)) C...Width suppression for q -> q + g. IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN IF(IGM.EQ.0) THEN EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5)) ELSE EGLU=PMED*(1D0-Z) ENDIF CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2) IF(MSTJ(40).EQ.1) THEN IF(CHI.LT.PYR(0)) GOTO 410 ELSEIF(MSTJ(40).EQ.2) THEN IF(1D0-CHI.LT.PYR(0)) GOTO 410 ENDIF ENDIF C...Three-jet matrix element correction. IF(M3JC.GE.1) THEN WME=1D0 WSHOW=1D0 C...QED matrix elements: only for massless case so far. IF(MCE.EQ.2.AND.IGM.EQ.0) THEN X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5)) X2=1D0-V(IEP(1),5)/V(NS+1,5) X3=(1D0-X1)+(1D0-X2) KI1=K(IPA(INUM),2) KI2=K(IPA(3-INUM),2) QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+ & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2) WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2) ELSEIF(MCE.EQ.2) THEN C...QCD matrix elements, including mass effects. ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN PS1ME=V(IEP(1),5) PM1ME=PMTH(1,IR) M3JCC=M3JC IF(IR.GE.31.AND.IGM.EQ.0) THEN C...QCD ME: original parton, first branching. PM2ME=PMTH(1,63-IR) ECMME=PS(5) ELSEIF(IR.GE.31) THEN C...QCD ME: original parton, subsequent branchings. PM2ME=PMTH(1,63-IR) PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5)) ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2)) ELSEIF(K(IM,2).EQ.21) THEN C...QCD ME: secondary partons, first branching. PM2ME=PM1ME ZMME=V(IM,1) IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2- & 4D0*PS1ME*PM2ME**2)) PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/ & V(IM,5) ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2)) M3JCC=66 ELSE C...QCD ME: secondary partons, subsequent branchings. PM2ME=PM1ME PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5)) ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2)) M3JCC=66 ENDIF C...Construct ME variables. R1ME=PM1ME/ECMME R2ME=PM2ME/ECMME X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME) X2=1D0+R2ME**2-PS1ME/ECMME**2 C...Call ME, with right order important for two inequivalent showerers. IF(IR.EQ.IORD+30) THEN WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA) ELSE WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA) ENDIF C...Split up total ME when two radiating partons. ISPRAD=1 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR. & (M3JCC.GE.26.AND.M3JCC.LE.29).OR. & (M3JCC.GE.36.AND.M3JCC.LE.39).OR. & (M3JCC.GE.46.AND.M3JCC.LE.49).OR. & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/ & MAX(1D-10,2D0-X1-X2) C...Evaluate shower rate to be compared with. WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)* & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2)) IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW ELSEIF(MSTJ(49).NE.1) THEN C...Toy model scalar theory matrix elements; no mass effects. ELSE X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5)) X2=1D0-V(IEP(1),5)/V(NS+1,5) X3=(1D0-X1)+(1D0-X2) WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2) WME=X3**2 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)* & PARJ(171) ENDIF IF(WME.LT.PYR(0)*WSHOW) GOTO 410 ENDIF C...Impose angular ordering by rejection of nonordered emission. IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN PEMAO=V(IM,1)*P(IM,4) IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4) IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN MAOD=0 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4 & .OR.MSTJ(42).EQ.7)) THEN MAOD=0 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3 & .OR.MSTJ(42).EQ.6)) THEN MAOD=1 PMDAO=PMTH(2,K(IEP(1),5)) THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2) ELSE MAOD=1 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5) IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID* & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2 ENDIF MAOM=1 IAOM=IM 440 IF(K(IAOM,5).EQ.22) THEN IAOM=K(IAOM,3) IF(K(IAOM,3).LE.NS) MAOM=0 IF(MAOM.EQ.1) GOTO 440 ENDIF IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5) IF(THE2ID.LT.THE2IM) GOTO 410 ENDIF ENDIF C...Impose user-defined maximum angle at first branching. IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN IF(NEP.EQ.1.AND.IM.EQ.NS) THEN THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5) IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5) IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5) IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410 ENDIF ENDIF C...Impose angular constraint in first branching from interference C...with initial state partons. IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410 ENDIF ENDIF C...End of inner veto algorithm. Check if only one leg evolved so far. 450 V(IEP(1),1)=Z ISL(1)=0 ISL(2)=0 IF(NEP.EQ.1) GOTO 490 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350 DO 460 I=1,NEP IR=IREF(N+I-NS) IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350 ENDIF 460 CONTINUE C...Check if chosen multiplet m1,m2,z1,z2 is physical. IF(NEP.GE.3) THEN PMSUM=0D0 DO 470 I=1,NEP PMSUM=PMSUM+P(N+I,5) 470 CONTINUE IF(PMSUM.GE.PS(5)) GOTO 350 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN DO 480 I1=N+1,N+2 IRDA=IREF(I1-NS) IF(KSH(IRDA).EQ.0) GOTO 480 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480 IF(IRDA.EQ.21) THEN IRGD1=IABS(K(I1,5)) IRGD2=IRGD1 ELSE IRGD1=IRDA IRGD2=IABS(K(I1,5)) ENDIF I2=2*N+3-I1 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5) ELSE IF(I1.EQ.N+1) ZM=V(IM,1) IF(I1.EQ.N+2) ZM=1D0-V(IM,1) PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2- & 4D0*V(N+1,5)*V(N+2,5)) PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/ & V(IM,5) ENDIF IF(MOD(MSTJ(43),2).EQ.1) THEN PMQTH3=0.5D0*PARJ(82) IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83) IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90) PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5) PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5) ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2- & 4D0*PMQ1*PMQ2))) ZH=1D0+PMQ1-PMQ2 ELSE ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2)) ZH=1D0 ENDIF IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND. & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN ELSE ZL=0.5D0*(ZH-ZD) ZU=0.5D0*(ZH+ZD) IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND. & ISSET(1).EQ.0) THEN ISL(1)=1 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND. & ISSET(2).EQ.0) THEN ISL(2)=1 ENDIF ENDIF IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20, & ZL*(1D0-ZU))) IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU)) 480 CONTINUE IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN ISL(3-ISLM)=0 ISLM=3-ISLM ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0) ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0) IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0 IF(ISL(1).EQ.1) ISL(2)=0 IF(ISL(1).EQ.0) ISLM=1 IF(ISL(2).EQ.0) ISLM=2 ENDIF IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350 ENDIF IRD1=IREF(N+1-NS) IRD2=IREF(N+2-NS) IF(IGM.GT.0) THEN IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE. & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN PMQ1=V(N+1,5)/V(IM,5) PMQ2=V(N+2,5)/V(IM,5) ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2- & 4D0*PMQ1*PMQ2))) ZH=1D0+PMQ1-PMQ2 ZL=0.5D0*(ZH-ZD) ZU=0.5D0*(ZH+ZD) IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350 ENDIF ENDIF C...Accepted branch. Construct four-momentum for initial partons. 490 MAZIP=0 MAZIC=0 IF(NEP.EQ.1) THEN P(N+1,1)=0D0 P(N+1,2)=0D0 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)- & P(N+1,5)))) P(N+1,4)=P(IPA(1),4) V(N+1,2)=P(N+1,4) ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5) P(N+1,1)=0D0 P(N+1,2)=0D0 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5)))) P(N+1,4)=PED1 P(N+2,1)=0D0 P(N+2,2)=0D0 P(N+2,3)=-P(N+1,3) P(N+2,4)=P(IM,5)-PED1 V(N+1,2)=P(N+1,4) V(N+2,2)=P(N+2,4) ELSEIF(NEP.GE.3) THEN C...Rescale all momenta for energy conservation. LOOP=0 PES=0D0 PQS=0D0 DO 510 I=1,NEP DO 500 J=1,4 P(N+I,J)=P(IPA(I),J) 500 CONTINUE PES=PES+P(N+I,4) PQS=PQS+P(N+I,5)**2/P(N+I,4) 510 CONTINUE 520 LOOP=LOOP+1 FAC=(PS(5)-PQS)/(PES-PQS) PES=0D0 PQS=0D0 DO 540 I=1,NEP DO 530 J=1,3 P(N+I,J)=FAC*P(N+I,J) 530 CONTINUE P(N+I,4)=SQRT(P(N+I,5)**2+P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2) V(N+I,2)=P(N+I,4) PES=PES+P(N+I,4) PQS=PQS+P(N+I,5)**2/P(N+I,4) 540 CONTINUE IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520 C...Construct transverse momentum for ordinary branching in shower. ELSE ZM=V(IM,1) LOOPPT=0 550 LOOPPT=LOOPPT+1 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5)))) PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5) IF(PZM.LE.0D0) THEN PTS=0D0 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND. & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN PTS=PMLS*ZM*(1D0-ZM)/V(IM,5) ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)- & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2 ELSE PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2 ENDIF IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN ZM=0.05D0+0.9D0*ZM GOTO 550 ELSEIF(PTS.LT.0D0) THEN GOTO 280 ENDIF PT=SQRT(MAX(0D0,PTS)) C...Global statistics. MINT(353)=MINT(353)+1 VINT(353)=VINT(353)+PT IF (MINT(353).EQ.1) VINT(358)=PT C...Find coefficient of azimuthal asymmetry due to gluon polarization. HAZIP=0D0 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21 & .AND.IAU.NE.0) THEN IF(K(IGM,3).NE.0) MAZIP=1 ZAU=V(IGM,1) IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1) IF(MAZIP.EQ.0) ZAU=0D0 IF(K(IGM,2).NE.21) THEN HAZIP=2D0*ZAU/(1D0+ZAU**2) ELSE HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2 ENDIF IF(K(N+1,2).NE.21) THEN HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM)) ELSE HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2 ENDIF ENDIF C...Find coefficient of azimuthal asymmetry due to soft gluon C...interference. HAZIC=0D0 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR. & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN IF(K(IGM,3).NE.0) MAZIC=N+1 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND. & ZM.GT.0.5D0) MAZIC=N+2 IF(K(IAU,2).EQ.22) MAZIC=0 ZS=ZM IF(MAZIC.EQ.N+2) ZS=1D0-ZM ZGM=V(IGM,1) IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1) IF(MAZIC.EQ.0) ZGM=1D0 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))* & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM)) HAZIC=MIN(0.95D0,HAZIC) ENDIF ENDIF C...Construct energies for ordinary branching in shower. 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND. & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+ & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5) ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN P(N+1,4)=PEM*V(IM,1) ELSE P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+ & SQRT(PMLS)*ZM)/V(IM,5) ENDIF C...Already predetermined choice of phi angle or not PHI=PARU(2)*PYR(0) IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN IPSPD=IP1+IM-NS-2 IF(K(IPSPD,4).GT.0) THEN IPSGD1=K(IPSPD,4) IF(IM.EQ.NS+2) THEN PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2)) ELSE PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2)) ENDIF ENDIF ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN IPSPD=IP1+IM-NS-2 IF(K(IPSPD,4).GT.0) THEN IPSGD1=K(IPSPD,4) PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2)) THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2)) CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0) CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0) PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2)) CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0) ENDIF ENDIF C...Construct momenta for ordinary branching in shower. P(N+1,1)=PT*COS(PHI) P(N+1,2)=PT*SIN(PHI) IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND. & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+ & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5) ELSEIF(PZM.GT.0D0) THEN P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+ & 2D0*PEM*P(N+1,4))/PZM ELSE P(N+1,3)=0D0 ENDIF P(N+2,1)=-P(N+1,1) P(N+2,2)=-P(N+1,2) P(N+2,3)=PZM-P(N+1,3) P(N+2,4)=PEM-P(N+1,4) IF(MSTJ(43).LE.2) THEN V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5) V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5) ENDIF ENDIF C...Rotate and boost daughters. IF(IGM.GT.0) THEN IF(MSTJ(43).LE.2) THEN BEX=P(IGM,1)/P(IGM,4) BEY=P(IGM,2)/P(IGM,4) BEZ=P(IGM,3)/P(IGM,4) GA=P(IGM,4)/P(IGM,5) GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)- & P(IM,4)) ELSE BEX=0D0 BEY=0D0 BEZ=0D0 GA=1D0 GABEP=0D0 ENDIF PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2) THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB) IF(PTIMB.GT.1D-4) THEN PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY) ELSE PHI=0D0 ENDIF DO 570 I=N+1,N+2 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+ & SIN(THE)*COS(PHI)*P(I,3) DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+ & SIN(THE)*SIN(PHI)*P(I,3) DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3) DP(4)=P(I,4) DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3) DGABP=GA*(GA*DBP/(1D0+GA)+DP(4)) P(I,1)=DP(1)+DGABP*BEX P(I,2)=DP(2)+DGABP*BEY P(I,3)=DP(3)+DGABP*BEZ P(I,4)=GA*(DP(4)+DBP) 570 CONTINUE ENDIF C...Weight with azimuthal distribution, if required. IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN DO 580 J=1,3 DPT(1,J)=P(IM,J) DPT(2,J)=P(IAU,J) DPT(3,J)=P(N+1,J) 580 CONTINUE DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3) DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3) DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2 DO 590 J=1,3 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM) DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM) 590 CONTINUE DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2) DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2) IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+ & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4)) IF(MAZIP.NE.0) THEN IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP))) & GOTO 560 ENDIF IF(MAZIC.NE.0) THEN IF(MAZIC.EQ.N+2) CAD=-CAD IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD) & .LT.PYR(0)) GOTO 560 ENDIF ENDIF ENDIF C...Azimuthal anisotropy due to interference with initial state partons. IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR. &K(N+2,2).EQ.21)) THEN III=IM-NS-1 IF(ISII(III).GE.1) THEN IAZIID=N+1 IF(K(N+1,2).NE.21) IAZIID=N+2 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND. & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2)) IF(III.EQ.2) THEIID=PARU(1)-THEIID PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2)) HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III))) CAD=COS(PHIIID-PHIIIS(III,ISII(III))) PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III))) IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD) & .LT.PYR(0)) GOTO 560 ENDIF ENDIF C...Continue loop over partons that may branch, until none left. IF(IGM.GE.0) K(IM,1)=14 N=N+NEP NEP=2 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS') IF(MSTU(21).GE.1) N=NS IF(MSTU(21).GE.1) RETURN ENDIF GOTO 290 C...Set information on imagined shower initiator. 600 IF(NPA.GE.2) THEN K(NS+1,1)=11 K(NS+1,2)=94 K(NS+1,3)=IP1 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2 K(NS+1,4)=NS+2 K(NS+1,5)=NS+1+NPA IIM=1 ELSE IIM=0 ENDIF C...Reconstruct string drawing information. DO 610 I=NS+1+IIM,N KQ=KCHG(PYCOMP(K(I,2)),2) IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN K(I,1)=1 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND. & IABS(K(I,2)).LE.18) THEN K(I,1)=1 ELSEIF(K(I,1).LE.10) THEN K(I,4)=MSTU(5)*(K(I,4)/MSTU(5)) K(I,5)=MSTU(5)*(K(I,5)/MSTU(5)) ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN ID1=MOD(K(I,4),MSTU(5)) IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND. & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2 K(ID1,4)=K(ID1,4)+MSTU(5)*I K(ID1,5)=K(ID1,5)+MSTU(5)*ID2 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1 K(ID2,5)=K(ID2,5)+MSTU(5)*I ELSE ID1=MOD(K(I,4),MSTU(5)) ID2=ID1+1 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN K(ID1,4)=K(ID1,4)+MSTU(5)*I K(ID1,5)=K(ID1,5)+MSTU(5)*I ELSE K(ID1,4)=0 K(ID1,5)=0 ENDIF K(ID2,4)=0 K(ID2,5)=0 ENDIF 610 CONTINUE C...Transformation from CM frame. IF(NPA.EQ.1) THEN THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2)) PHI=PYANGL(P(IPA(1),1),P(IPA(1),2)) MSTU(33)=1 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0) ELSEIF(NPA.EQ.2) THEN BEX=PS(1)/PS(4) BEY=PS(2)/PS(4) BEZ=PS(3)/PS(4) GA=PS(4)/PS(5) GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3)) & /(1D0+GA)-P(IPA(1),4)) THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1) & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2)) PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY) MSTU(33)=1 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ) ELSE CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4), & PS(3)/PS(4)) MSTU(33)=1 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4)) ENDIF C...Decay vertex of shower. DO 630 I=NS+1,N DO 620 J=1,5 V(I,J)=V(IP1,J) 620 CONTINUE 630 CONTINUE C...Delete trivial shower, else connect initiators. IF(N.LE.NS+NPA+IIM) THEN N=NS ELSE DO 640 IP=1,NPA K(IPA(IP),1)=14 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP K(NS+IIM+IP,3)=IPA(IP) IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1 IF(K(NS+IIM+IP,1).NE.1) THEN K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4) K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5) ENDIF 640 CONTINUE ENDIF RETURN END C********************************************************************* C...PYPTFS C...Generates pT-ordered timelike final-state parton showers. C...MODE defines how to find radiators and recoilers. C... = 0 : based on colour flow between undecayed partons. C... = 1 : for IPART <= NPARTD only consider primary partons, C... whether decayed or not; else as above. C... = 2 : based on common history, whether decayed or not. SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Parameter statement for maximum size of showers. PARAMETER (MAXNUR=1000) C...Commonblocks. COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYCTAG/NCT,MCT(4000,2) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/, &/PYINT1/ C...Local arrays. DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR), &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR), &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR), &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4) C...Statement functions. SHAT(I,J)=(P(I,4)+P(J,4))**2-(P(I,1)+P(J,1))**2- &(P(I,2)+P(J,2))**2-(P(I,3)+P(J,3))**2 C...Initial values. Check that valid system. PTGEN=0D0 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND. &MSTJ(41).NE.12) RETURN IF(NPART.LE.0) THEN CALL PYERRM(2,'(PYPTFS:) showering system too small') RETURN ENDIF PT2CMX=PTMAX**2 C...Mass thresholds and Lambda for QCD evolution. PMB=PMAS(5,1) PMC=PMAS(4,1) ALAM5=PARJ(81) ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0) ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0) PMBS=PMB**2 PMCS=PMC**2 ALAM5S=ALAM5**2 ALAM4S=ALAM4**2 ALAM3S=ALAM3**2 C...Cutoff scale for QCD evolution. Starting pT2. NFLAV=MAX(0,MIN(5,MSTJ(45))) PT0C=0.5D0*PARJ(82) PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2 C...Parameters for QED evolution. AEM2PI=PARU(101)/PARU(2) PT0EQ=0.5D0*PARJ(83) PT0EL=0.5D0*PARJ(90) C...Reset. Remove irrelevant colour tags. NEVOL=0 DO 100 J=1,4 PSUM(J)=0D0 100 CONTINUE DO 110 I=MINT(84)+1,N IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN K(I,5)=0 MCT(I,2)=0 ENDIF IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN K(I,4)=0 MCT(I,1)=0 ENDIF 110 CONTINUE NPARTS=NPART C...Begin loop to set up showering partons. Sum four-momenta. DO 210 IP=1,NPART I=IPART(IP) IF(MODE.NE.1.OR.I.GT.NPARTD) THEN IF(K(I,1).GT.10) GOTO 210 ELSEIF(K(I,3).GT.MINT(84)) THEN IF(K(I,3).GT.MINT(84)+2) GOTO 210 ELSE IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 210 ENDIF DO 120 J=1,4 PSUM(J)=PSUM(J)+P(I,J) 120 CONTINUE C...Find colour and charge, but skip diquarks. IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 210 KCOL=ISIGN(KCHG(PYCOMP(K(I,2)),2),K(I,2)) KCHA=ISIGN(KCHG(PYCOMP(K(I,2)),1),K(I,2)) C...Either colour or anticolour charge radiates; for gluon both. DO 160 JSGCOL=1,-1,-2 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN JCOL=4+(1-JSGCOL)/2 JCOLR=9-JCOL C...Basic info about radiating parton. NEVOL=NEVOL+1 IPOS(NEVOL)=I IFLG(NEVOL)=0 ISCOL(NEVOL)=JSGCOL ISCHG(NEVOL)=0 PTSCA(NEVOL)=PTPART(IP) C...Begin search for colour recoiler when MODE = 0 or 1. IF(MODE.LE.1) THEN C...Find sister with matching anticolour to the radiating parton. IROLD=I IRNEW=K(IROLD,JCOL)/MSTU(5) MOVE=1 C...The following will add MCT colour tracing for unprepped events C...If not done, trace Les Houches colour tags for this dipole C IF (MCT(I,JCOL-3).EQ.0) THEN C CALL PYCTTR(I,JCOL,INEW) C...Clean up mother/daughter 'read' tags set by PYCTTR C DO 125 IR=1,N C K(IR,4)=MOD(K(IR,4),MSTU(5)**2) C K(IR,5)=MOD(K(IR,5),MSTU(5)**2) C 125 CONTINUE C ENDIF C...Skip radiation off loose colour ends. 130 IF(IRNEW.EQ.0) THEN NEVOL=NEVOL-1 GOTO 160 C...Optionally skip radiation on dipole to beam remnant. ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN NEVOL=NEVOL-1 GOTO 160 C...For now always skip radiation on dipole to junction. ELSEIF(K(IRNEW,2).EQ.88) THEN NEVOL=NEVOL-1 GOTO 160 C...For MODE=1: if reached primary then done. ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND. & IRNEW.LE.NPARTD) THEN C...If sister stable and points back then done. ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD) & THEN IF(K(IRNEW,1).LT.10) THEN C...If sister unstable then go to her daughter. ELSE IROLD=IRNEW IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5)) MOVE=2 GOTO 130 ENDIF C...If found mother then look for aunt. ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ. & IROLD) THEN IROLD=IRNEW IRNEW=K(IROLD,JCOL)/MSTU(5) GOTO 130 C...If daughter stable then done. ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD) & THEN IF(K(IRNEW,1).LT.10) THEN C...If daughter unstable then go to granddaughter. ELSE IROLD=IRNEW IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5)) MOVE=2 GOTO 130 ENDIF C...If daughter points to another daughter then done or move up. ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ. & IROLD) THEN IF(K(IRNEW,1).LT.10) THEN ELSE IROLD=IRNEW IRNEW=K(IRNEW,JCOL)/MSTU(5) MOVE=1 GOTO 130 ENDIF ENDIF C...Begin search for colour recoiler when MODE = 2. ELSE IROLD=I IRNEW=K(IROLD,JCOL)/MSTU(5) 140 IF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN C...Step up to mother if radiating parton already branched. IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN IROLD=IRNEW IRNEW=K(IROLD,JCOL)/MSTU(5) GOTO 140 C...Pick sister by history if no anticolour available. ELSE IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN IRNEW=IROLD-1 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) & THEN IRNEW=IROLD+1 C...Last resort: pick at random among other primaries. ELSE ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0)))) IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART)) ENDIF ENDIF ENDIF C...Trace down if sister branched. 150 IF(K(IRNEW,1).GT.10) THEN IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5)) GOTO 150 ENDIF ENDIF C...Now found other end of colour dipole. IREC(NEVOL)=IRNEW ENDIF 160 CONTINUE C...Also electrical charge may radiate; so far only quarks and leptons. IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND. & IABS(K(I,2)).LE.18) THEN C...Basic info about radiating parton. NEVOL=NEVOL+1 IPOS(NEVOL)=I IFLG(NEVOL)=0 ISCOL(NEVOL)=0 ISCHG(NEVOL)=KCHA PTSCA(NEVOL)=PTPART(IP) C...Pick nearest (= smallest invariant mass) charged particle C...as recoiler when MODE = 0 or 1 (but for latter among primaries). IF(MODE.LE.1) THEN IRNEW=0 PM2MIN=VINT(2) DO 170 IP2=1,NPART+N-MINT(53) IF(IP2.EQ.IP) GOTO 170 IF(IP2.LE.NPART) THEN I2=IPART(IP2) IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN IF(K(I2,1).GT.10) GOTO 170 ELSEIF(K(I2,3).GT.MINT(84)) THEN IF(K(I2,3).GT.MINT(84)+2) GOTO 170 ELSE IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 170 ENDIF ELSE I2=MINT(53)+IP2-NPART ENDIF IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 170 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2- & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2 IF(PM2INV.LT.PM2MIN) THEN IRNEW=I2 PM2MIN=PM2INV ENDIF 170 CONTINUE IF(IRNEW.EQ.0) THEN NEVOL=NEVOL-1 GOTO 210 ENDIF C...Begin search for charge recoiler when MODE = 2. ELSE IROLD=I C...Pick sister by history; step up if parton already branched. 180 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN IROLD=K(IROLD,3) GOTO 180 ENDIF IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN IRNEW=IROLD-1 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN IRNEW=IROLD+1 C...Last resort: pick at random among other primaries. ELSE ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0)))) IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART)) ENDIF C...Trace down if sister branched. 190 IF(K(IRNEW,1).GT.10) THEN DO 200 IR=IRNEW+1,N IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN IRNEW=IR GOTO 190 ENDIF 200 CONTINUE ENDIF ENDIF IREC(NEVOL)=IRNEW ENDIF C...End loop to set up showering partons. System invariant mass. 210 CONTINUE IF(NEVOL.LE.0) RETURN PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2)) C...Check if 3-jet matrix elements to be used. M3JC=0 ALPHA=0.5D0 NMESYS=0 IF(MSTJ(47).GE.1) THEN C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0). KFSRCE=0 IPART1=K(IPART(1),3) IPART2=K(IPART(2),3) 220 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN KFSRCE=IABS(K(IPART1,2)) ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN IPART1=K(IPART1,3) GOTO 220 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN IPART2=K(IPART2,3) GOTO 220 ENDIF ITYPES=0 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6 C...Identify two primary showerers. KFLA1=IABS(K(IPART(1),2)) ITYPE1=0 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6 KFLA2=IABS(K(IPART(2),2)) ITYPE2=0 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6 C...Order of showerers. Presence of gluino. ITYPMN=MIN(ITYPE1,ITYPE2) ITYPMX=MAX(ITYPE1,ITYPE2) IORD=1 IF(ITYPE1.GT.ITYPE2) IORD=2 IGLUI=0 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1 C...Require exactly two primary showerers for ME corrections. NPRIM=0 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=IPART1 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3) IF(IANNFL.GT.0) THEN IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3) ENDIF IF(IANNFL.NE.0) THEN KANNFL=IABS(K(IANNFL,2)) IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0 ENDIF ENDIF AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*PARU(102) EF=KCHG(KFLA1,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*PARU(102) XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102))) SH=PSUM(5)**2 SQMZ=PMAS(23,1)**2 SQWZ=PSUM(5)*PMAS(23,2) SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2) VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+ & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ ICOMBI=3 ALPHA=VECT/(VECT+AXIV) ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN ICOMBI=4 ENDIF C...For chi -> chi q qbar, use V/A -> q qbar as first approximation. ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN ICLASS=2 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.1)) THEN ICLASS=3 C...Scalar/pseudoscalar -> q + qbar; q -> q + S. ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN ICLASS=4 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN ICOMBI=1 ELSEIF(KFSRCE.EQ.36) THEN ICOMBI=2 ENDIF ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.1)) THEN ICLASS=5 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S. ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.3)) THEN ICLASS=6 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.2)) THEN ICLASS=7 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN ICLASS=8 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.2)) THEN ICLASS=9 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi. ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.5)) THEN ICLASS=10 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.2)) THEN ICLASS=11 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.1)) THEN ICLASS=12 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g. ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN ICLASS=13 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.2)) THEN ICLASS=14 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.1)) THEN ICLASS=15 C...g -> ~g + ~g (eikonal approximation). ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN ICLASS=16 ENDIF M3JC=5*ICLASS+ICOMBI ENDIF C...Store pair that together define matrix element treatment. IF(M3JC.NE.0) THEN NMESYS=1 MESYS(NMESYS,0)=M3JC MESYS(NMESYS,1)=IPART(1) MESYS(NMESYS,2)=IPART(2) ENDIF C...Store qqbar or l+l- pairs for QED radiation. IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN NMESYS=NMESYS+1 MESYS(NMESYS,0)=101 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102 MESYS(NMESYS,1)=IPART(1) MESYS(NMESYS,2)=IPART(2) ENDIF C...Store other qqbar/l+l- pairs from g/gamma branchings. DO 270 I1=1,N IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 270 I1M=K(I1,3) 240 IF(I1M.GT.0.AND.K(I1M,2).EQ.K(I1,2)) THEN I1M=K(I1M,3) GOTO 240 ENDIF C...Move up this check to avoid out-of-bounds. IF(I1M.EQ.0) GOTO 270 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 270 DO 260 I2=I1+1,N IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 260 I2M=K(I2,3) 250 IF(I2M.GT.0.AND.K(I2M,2).EQ.K(I2,2)) THEN I2M=K(I2M,3) GOTO 250 ENDIF IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN NMESYS=NMESYS+1 MESYS(NMESYS,0)=66 MESYS(NMESYS,1)=I1 MESYS(NMESYS,2)=I2 NMESYS=NMESYS+1 MESYS(NMESYS,0)=102 MESYS(NMESYS,1)=I1 MESYS(NMESYS,2)=I2 ENDIF 260 CONTINUE 270 CONTINUE ENDIF C..Loopback point for counting number of emissions. NGEN=0 280 NGEN=NGEN+1 C...Begin loop to evolve all existing partons, if required. 290 IMX=0 PT2MX=0D0 DO 360 IEVOL=1,NEVOL IF(IFLG(IEVOL).EQ.0) THEN C...Basic info on radiator and recoil. I=IPOS(IEVOL) IR=IREC(IEVOL) SHT=SHAT(I,IR) PM2I=P(I,5)**2 PM2R=P(IR,5)**2 C...Invariant mass of "dipole".Starting value for pT evolution. SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2) C...Case of evolution by QCD branching. IF(ISCOL(IEVOL).NE.0) THEN C...Parton-by-parton maximum scale from initial conditions. IF(MSTP(72).EQ.0) THEN DO 300 IPRT=1,NPARTS IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2) 300 CONTINUE ENDIF C...If kinematically impossible then do not evolve. IF(PT2.LT.PT2CMN) THEN IFLG(IEVOL)=-1 GOTO 360 ENDIF C...Check if part of system for which ME corrections should be applied. IMESYS=0 DO 310 IME=1,NMESYS IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND. & MESYS(IME,0).LT.100) IMESYS=IME 310 CONTINUE C...Special flag for colour octet states. MOCT=0 IF(K(I,2).EQ.21) MOCT=1 IF(K(I,2).EQ.KSUSY1+21) MOCT=2 C...Upper estimate for matrix element weighting and colour factor. C...Note that g->gg and g->qqbar is split on two sides = "dipoles". WTPSGL=2D0 COLFAC=4D0/3D0 IF(MOCT.GE.1) COLFAC=3D0/2D0 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0 WTPSQQ=0.5D0*0.5D0*NFLAV C...Determine overestimated z range: switch at c and b masses. 320 IZRG=1 PT2MNE=PT2CMN B0=27D0/6D0 ALAMS=ALAM3S IF(PT2.GT.1.01D0*PMCS) THEN IZRG=2 PT2MNE=PMCS B0=25D0/6D0 ALAMS=ALAM4S ENDIF IF(PT2.GT.1.01D0*PMBS) THEN IZRG=3 PT2MNE=PMBS B0=23D0/6D0 ALAMS=ALAM5S ENDIF ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR)) IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR C...Find evolution coefficients for q->qg/g->gg and g->qqbar. EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0 EVCOEF=EVEMGL IF(MOCT.EQ.1) THEN EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0 EVCOEF=EVCOEF+EVEMQQ ENDIF C...Pick pT2 (in overestimated z range). 330 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF)) C...Loopback if crossed c/b mass thresholds. IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN PT2=PMBS GOTO 320 ENDIF IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN PT2=PMCS GOTO 320 ENDIF C...Finish if below lower cutoff. IF(PT2.LT.PT2CMN) THEN IFLG(IEVOL)=-1 GOTO 360 ENDIF C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar. IFLAG=1 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2 C...Pick z: dz/(1-z) or dz. IF(IFLAG.EQ.1) THEN Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0) ELSE Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT) ENDIF C...Loopback if outside allowed range for given pT2. ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR)) IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 330 PM2=PM2I+PT2/(Z*(1D0-Z)) IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 330 C...No weighting for primary partons; to be done later on. IF(IMESYS.GT.0) THEN C...Weighting of q->qg/X->Xg branching. ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 330 C...Weighting of g->gg branching. ELSEIF(IFLAG.EQ.1) THEN IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 330 C...Flavour choice and weighting of g->qqbar branching. ELSE KFQ=MIN(5,1+INT(NFLAV*PYR(0))) PMQ=PMAS(KFQ,1) ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2)) WTME=ROOTQQ*(Z**2+(1D0-Z)**2) IF(WTME.LT.PYR(0)) GOTO 330 IFLAG=10+KFQ ENDIF C...Case of evolution by QED branching. ELSEIF(ISCHG(IEVOL).NE.0) THEN C...If kinematically impossible then do not evolve. PT2EMN=PT0EQ**2 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2 IF(PT2.LT.PT2EMN) THEN IFLG(IEVOL)=-1 GOTO 360 ENDIF C...Check if part of system for which ME corrections should be applied. IMESYS=0 DO 340 IME=1,NMESYS IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND. & MESYS(IME,0).GT.100) IMESYS=IME 340 CONTINUE C...Charge. Matrix element weighting factor. CHG=ISCHG(IEVOL)/3D0 WTPSGA=2D0 C...Determine overestimated z range. Find evolution coefficient. ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR)) IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0) C...Pick pT2 (in overestimated z range). 350 PT2=PT2*PYR(0)**(1D0/EVCOEF) C...Finish if below lower cutoff. IF(PT2.LT.PT2EMN) THEN IFLG(IEVOL)=-1 GOTO 360 ENDIF C...Pick z: dz/(1-z). Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0) C...Loopback if outside allowed range for given pT2. ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR)) IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350 PM2=PM2I+PT2/(Z*(1D0-Z)) IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350 C...Weighting by branching kernel, except if ME weighting later. IF(IMESYS.EQ.0) THEN IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 350 ENDIF IFLAG=3 ENDIF C...Save acceptable branching. IFLG(IEVOL)=IFLAG IMESAV(IEVOL)=IMESYS PT2SAV(IEVOL)=PT2 ZSAV(IEVOL)=Z SHTSAV(IEVOL)=SHT ENDIF C...Check if branching has highest pT. IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN IMX=IEVOL PT2MX=PT2SAV(IEVOL) ENDIF 360 CONTINUE C...Finished if no more branchings to be done. IF(IMX.EQ.0) GOTO 480 C...Restore info on hardest branching to be processed. I=IPOS(IMX) IR=IREC(IMX) KCOL=ISCOL(IMX) KCHA=ISCHG(IMX) IMESYS=IMESAV(IMX) PT2=PT2SAV(IMX) Z=ZSAV(IMX) SHT=SHTSAV(IMX) PM2I=P(I,5)**2 PM2R=P(IR,5)**2 PM2=PM2I+PT2/(Z*(1D0-Z)) C...Special flag for colour octet states. MOCT=0 IF(K(I,2).EQ.21) MOCT=1 IF(K(I,2).EQ.KSUSY1+21) MOCT=2 C...Restore further info for g->qqbar branching. KFQ=0 IF(IFLG(IMX).GT.10) THEN KFQ=IFLG(IMX)-10 PMQ=PMAS(KFQ,1) ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2)) ENDIF C...For branching g include azimuthal asymmetries from polarization. ASYPOL=0D0 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN C...Trace grandmother via intermediate recoil copies. KFGM=0 IM=I 370 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND. & K(IM,3).GT.0) THEN IM=K(IM,3) IF(IM.GT.MINT(84)) GOTO 370 ENDIF IGM=K(IM,3) IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I) & KFGM=IABS(K(IGM,2)) C...Define approximate energy sharing by identifying aunt. IAU=IM+1 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4)) C...Coefficient from gluon production. IF(KFGM.LE.6) THEN ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2) ELSE ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2 ENDIF C...Coefficient from gluon decay. IF(KFQ.EQ.0) THEN ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2 ELSE ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z)) ENDIF ENDIF ENDIF C...Create new slots for branching products and recoil. INEW=N+1 IGNEW=N+2 IRNEW=N+3 N=N+3 C...Set status, flavour and mother of new ones. K(INEW,1)=K(I,1) K(IGNEW,1)=3 IF(KCHA.NE.0) K(IGNEW,1)=1 K(IRNEW,1)=K(IR,1) IF(KFQ.EQ.0) THEN K(INEW,2)=K(I,2) K(IGNEW,2)=21 IF(KCHA.NE.0) K(IGNEW,2)=22 ELSE K(INEW,2)=-ISIGN(KFQ,KCOL) K(IGNEW,2)=-K(INEW,2) ENDIF K(IRNEW,2)=K(IR,2) K(INEW,3)=I K(IGNEW,3)=I K(IRNEW,3)=IR C...Find rest frame and angles of branching+recoil. DO 380 J=1,5 P(INEW,J)=P(I,J) P(IGNEW,J)=0D0 P(IRNEW,J)=P(IR,J) 380 CONTINUE BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4)) BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4)) BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4)) CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ) PHI=PYANGL(P(INEW,1),P(INEW,2)) THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2)) C...Derive kinematics of branching: generics (like g->gg). DO 390 J=1,4 P(INEW,J)=0D0 P(IRNEW,J)=0D0 390 CONTINUE PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT) PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT) PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2 PTCOR=SQRT(MAX(0D0,PT2COR)) PZN=(PEM**2*Z-0.5D0*PM2)/PZM PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM C...Specific kinematics reduction for q->qg with m_q > 0. IF(MOCT.NE.1) THEN PTCOR=(1D0-PM2I/PM2)*PTCOR PZN=PZN+PM2I*PZG/PM2 PZG=(1D0-PM2I/PM2)*PZG C...Specific kinematics reduction for g->qqbar with m_q > 0. ELSEIF(KFQ.NE.0) THEN P(INEW,5)=PMQ P(IGNEW,5)=PMQ PTCOR=ROOTQQ*PTCOR PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG) PZG=PZM-PZN ENDIF C...Pick phi and construct kinematics of branching. 400 PHIROT=PARU(2)*PYR(0) P(INEW,1)=PTCOR*COS(PHIROT) P(INEW,2)=PTCOR*SIN(PHIROT) P(INEW,3)=PZN P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2) P(IGNEW,1)=-P(INEW,1) P(IGNEW,2)=-P(INEW,2) P(IGNEW,3)=PZG P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2) P(IRNEW,1)=0D0 P(IRNEW,2)=0D0 P(IRNEW,3)=-PZM P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT) C...Boost branching system to lab frame. CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ) C...Renew choice of phi angle according to polarization asymmetry. IF(ABS(ASYPOL).GT.1D-3) THEN DO 410 J=1,3 DPT(1,J)=P(I,J) DPT(2,J)=P(IAU,J) DPT(3,J)=P(INEW,J) 410 CONTINUE DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3) DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3) DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2 DO 420 J=1,3 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM) DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM) 420 CONTINUE DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2) DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2) IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+ & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4)) IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL))) & GOTO 400 ENDIF ENDIF C...Matrix element corrections for primary partons when requested. IF(IMESYS.GT.0) THEN M3JC=MESYS(IMESYS,0) C...Identify recoiling partner and set up three-body kinematics. IRP=MESYS(IMESYS,1) IF(IRP.EQ.I) IRP=MESYS(IMESYS,2) IF(IRP.EQ.IR) IRP=IRNEW DO 430 J=1,4 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J) 430 CONTINUE PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2- & PSUM(3)**2)) X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)- & PSUM(3)*P(INEW,3))/PSUM(5)**2 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)- & PSUM(3)*P(IRP,3))/PSUM(5)**2 X3=2D0-X1-X2 R1ME=P(INEW,5)/PSUM(5) R2ME=P(IRP,5)/PSUM(5) C...Matrix elements for gluon emission. IF(M3JC.LT.100) THEN C...Call ME, with right order important for two inequivalent showerers. IF(MESYS(IMESYS,IORD).EQ.I) THEN WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA) ELSE WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA) ENDIF C...Split up total ME when two radiating partons. ISPRAD=1 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29) & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49) & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/ & MAX(1D-10,2D0-X1-X2) C...Evaluate shower rate. WPS=2D0/(MAX(1D-10,2D0-X1-X2)* & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2)) IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS C...Matrix elements for photon emission: still rather primitive. ELSE C...For generic charge combination currently only massless expression. IF(M3JC.EQ.101) THEN CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2) WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3) C...For flavour neutral system assume vector source and include masses. ELSE WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10, & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2) WPS=2D0/(MAX(1D-10,2D0-X1-X2)* & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2)) ENDIF ENDIF C...Perform weighting with W_ME/W_PS. IF(WME.LT.PYR(0)*WPS) THEN N=N-3 IFLG(IMX)=0 GOTO 290 ENDIF ENDIF C...Now for sure accepted branching. Save highest pT. IF(NGEN.EQ.1) PTGEN=SQRT(PT2) C...Update status for obsolete ones. Bookkkep the moved original parton C...and new daughter (arbitrary choice for g->gg or g->qqbar). C...Do not bookkeep radiated photon, since it cannot radiate further. K(I,1)=K(I,1)+10 K(IR,1)=K(IR,1)+10 DO 440 IP=1,NPART IF(IPART(IP).EQ.I) IPART(IP)=INEW IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW 440 CONTINUE IF(KCHA.EQ.0) THEN NPART=NPART+1 IPART(NPART)=IGNEW ENDIF C...Initialize colour flow of branching. C...Use both old and new style colour tags for flexibility. K(INEW,4)=0 K(IGNEW,4)=0 K(INEW,5)=0 K(IGNEW,5)=0 JCOLP=4+(1-KCOL)/2 JCOLN=9-JCOLP MCT(INEW,1)=0 MCT(INEW,2)=0 MCT(IGNEW,1)=0 MCT(IGNEW,2)=0 MCT(IRNEW,1)=0 MCT(IRNEW,2)=0 C...Trivial colour flow for l->lgamma and q->qgamma. IF(IABS(KCHA).EQ.3) THEN K(I,4)=INEW K(I,5)=IGNEW ELSEIF(KCHA.NE.0) THEN IF(K(I,4).NE.0) THEN K(I,4)=K(I,4)+INEW K(INEW,4)=MSTU(5)*I MCT(INEW,1)=MCT(I,1) ENDIF IF(K(I,5).NE.0) THEN K(I,5)=K(I,5)+INEW K(INEW,5)=MSTU(5)*I MCT(INEW,2)=MCT(I,2) ENDIF C...Set colour flow for q->qg and g->gg. ELSEIF(KFQ.EQ.0) THEN K(I,JCOLP)=K(I,JCOLP)+IGNEW K(IGNEW,JCOLP)=MSTU(5)*I K(INEW,JCOLP)=MSTU(5)*IGNEW K(IGNEW,JCOLN)=MSTU(5)*INEW MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3) NCT=NCT+1 MCT(INEW,JCOLP-3)=NCT MCT(IGNEW,JCOLN-3)=NCT IF(MOCT.GE.1) THEN K(I,JCOLN)=K(I,JCOLN)+INEW K(INEW,JCOLN)=MSTU(5)*I MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3) ENDIF C...Set colour flow for g->qqbar. ELSE K(I,JCOLN)=K(I,JCOLN)+INEW K(INEW,JCOLN)=MSTU(5)*I K(I,JCOLP)=K(I,JCOLP)+IGNEW K(IGNEW,JCOLP)=MSTU(5)*I MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3) MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3) ENDIF C...Daughter info for colourless recoiling parton. IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN K(IR,4)=IRNEW K(IR,5)=IRNEW K(IRNEW,4)=0 K(IRNEW,5)=0 C...Colour of recoiling parton sails through unchanged. ELSE IF(K(IR,4).NE.0) THEN K(IR,4)=K(IR,4)+IRNEW K(IRNEW,4)=MSTU(5)*IR MCT(IRNEW,1)=MCT(IR,1) ENDIF IF(K(IR,5).NE.0) THEN K(IR,5)=K(IR,5)+IRNEW K(IRNEW,5)=MSTU(5)*IR MCT(IRNEW,2)=MCT(IR,2) ENDIF ENDIF C...Vertex information trivial. DO 450 J=1,5 V(INEW,J)=V(I,J) V(IGNEW,J)=V(I,J) V(IRNEW,J)=V(IR,J) 450 CONTINUE C...Update list of old radiators. DO 460 IEVOL=1,NEVOL IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN IPOS(IEVOL)=INEW IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW IREC(IEVOL)=IRNEW IFLG(IEVOL)=0 ELSEIF(IPOS(IEVOL).EQ.I) THEN IPOS(IEVOL)=INEW IFLG(IEVOL)=0 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN IPOS(IEVOL)=IRNEW IREC(IEVOL)=INEW IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL) IREC(IEVOL)=IGNEW IFLG(IEVOL)=0 ELSEIF(IPOS(IEVOL).EQ.IR) THEN IPOS(IEVOL)=IRNEW IFLG(IEVOL)=0 ENDIF C...Update links of old connected partons. IF(IREC(IEVOL).EQ.I) THEN IREC(IEVOL)=INEW IFLG(IEVOL)=0 ELSEIF(IREC(IEVOL).EQ.IR) THEN IREC(IEVOL)=IRNEW IFLG(IEVOL)=0 ENDIF 460 CONTINUE C...q->qg or g->gg: create new gluon radiators. IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN NEVOL=NEVOL+1 IPOS(NEVOL)=INEW IREC(NEVOL)=IGNEW IFLG(NEVOL)=0 ISCOL(NEVOL)=KCOL ISCHG(NEVOL)=0 PTSCA(NEVOL)=SQRT(PT2) NEVOL=NEVOL+1 IPOS(NEVOL)=IGNEW IREC(NEVOL)=INEW IFLG(NEVOL)=0 ISCOL(NEVOL)=-KCOL ISCHG(NEVOL)=0 PTSCA(NEVOL)=PTSCA(NEVOL-1) ENDIF C...Update matrix elements parton list and add new for g/gamma->qqbar. DO 470 IME=1,NMESYS IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW 470 CONTINUE IF(KFQ.NE.0) THEN NMESYS=NMESYS+1 MESYS(NMESYS,0)=66 MESYS(NMESYS,1)=INEW MESYS(NMESYS,2)=IGNEW NMESYS=NMESYS+1 MESYS(NMESYS,0)=102 MESYS(NMESYS,1)=INEW MESYS(NMESYS,2)=IGNEW ENDIF C...Global statistics. MINT(353)=MINT(353)+1 VINT(353)=VINT(353)+PTCOR IF (MINT(353).EQ.1) VINT(358)=PTCOR C...Loopback for more emissions if enough space. PT2CMX=PT2 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND. &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN GOTO 280 ELSE CALL PYERRM(11,'(PYPTFS:) no more memory left for shower') ENDIF C...Done. 480 CONTINUE RETURN END C********************************************************************* C...PYMAEL C...Auxiliary to PYSHOW and PYPTFS. C...Matrix elements for gluon (or photon) emission from C...a two-body state; to be used by the parton shower routine. C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and C...1/sigma_0 d(sigma)/d(x_1)d(x_2) = C... = (alpha-strong/2 pi) * CF * PYMAEL, C...i.e. normalization is such that one recovers the familiar C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case. C...Coupling structure: C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent) C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet) C... = 16-19 : q -> q V C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet) C... = 26-29 : q -> q S C... = 31-34 : V -> ~q ~qbar (~q = squark) C... = 36-39 : ~q -> ~q V C... = 41-44 : S -> ~q ~qbar C... = 46-49 : ~q -> ~q S C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino) C... = 56-59 : ~q -> q chi C... = 61-64 : q -> ~q chi C... = 66-69 : ~g -> q ~qbar C... = 71-74 : ~q -> q ~g C... = 76-79 : q -> ~q ~g C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g C...Note that the order of the decay products is important. C...In each set of four, the variants are ordered as: C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/... C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/.... C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2) C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2) FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...Check input values. Return zero outside allowed phase space. PYMAEL=0D0 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE. &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN ALPCOR=MAX(0D0,MIN(1D0,ALPHA)) C...Initial values and flags. ICLASS=NI/5 ICOMBI=NI-5*ICLASS ISSET1=0 ISSET2=0 ISSET4=0 C... Phase space. PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2)) C...Eikonal expression; also acts as default. IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN RLO=PS IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN ANUM=0D0 ELSEIF(ICOMBI.EQ.2) THEN ANUM=(2D0-X1-X2)**2 ELSEIF(ICOMBI.EQ.3) THEN ANUM=ALPCOR*(2D0-X1-X2)**2 ELSE ANUM=0.5D0*(2D0-X1-X2)**2 ENDIF RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/ & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))- & R1**2/(1D0+R2**2-R1**2-X2)**2- & R2**2/(1D0+R1**2-R2**2-X1)**2) ICOMBI=0 C...V -> q qbar (V = gamma*/Z0/W+-/...). ELSEIF(ICLASS.EQ.2) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2) & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2) & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2) & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/ & (-1+R1**2-R2**2+X2)**2 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2) & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2 & -X1-X2)**2+X1*(2-X1-X2)**2)/ & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2* & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2 RFO1=RFO1/2.D0 ISSET1=1 ENDIF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2) & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2) & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2) & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2 & -X1-X2)**2+X1*(2-X1-X2)**2)/ & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2) & +X2)/(-1-R1**2+R2**2+X1)**2 RFO2=RFO2/2.D0 ISSET2=1 ENDIF IF(ICOMBI.EQ.4) THEN RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/ & (-1-R1**2+R2**2+X1)**2 RFO4=RFO4 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2 & -R1**2*X2**2+X1*X2**2)/ & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/ & (-1+R1**2-R2**2+X2)**2 RFO4=RFO4/2.D0 ISSET4=1 ENDIF C...q -> q V. ELSEIF(ICLASS.EQ.3) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2 & +R1**2*R2**2-2D0*R2**4) RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2) RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2 ISSET1=1 ENDIF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2 & +R1**2*R2**2-2D0*R2**4) RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2 & +X1*X2**2)/(-2+X1+X2)**2 ISSET2=1 ENDIF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4) RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2 & +X1*X2**2)/(2-X1-X2)**2 ISSET4=1 ENDIF C...S -> q qbar (S = h0/H0/A0/H+-/...). ELSEIF(ICLASS.EQ.4) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2) RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 ISSET1=1 ENDIF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2) RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/ & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) ISSET2=1 ENDIF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1D0-R1**2-R2**2) RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/ & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 ISSET4=1 ENDIF C...q -> q S. ELSEIF(ICLASS.EQ.5) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1D0+R1**2-R2**2+2D0*R1) RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (1-R1**2+R2**2-X2)/(-2+X1+X2) & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (-1+R1**2-R2**2+X2)**2 ISSET1=1 ENDIF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1D0+R1**2-R2**2-2D0*R1) RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (1-R1**2+R2**2-X2)/(-2+X1+X2) & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (-1+R1**2-R2**2+X2)**2 ISSET2=1 ENDIF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1D0+R1**2-R2**2) RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2) & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2 ISSET4=1 ENDIF C...V -> ~q ~qbar (~q = squark). ELSEIF(ICLASS.EQ.6) THEN RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4) RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/ & (-1-R1**2+R2**2+X1)**2 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/ & (-1-R1**2+R2**2+X1) & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2) & /(-1+R1**2-R2**2+X2)**2 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/ & (-1+R1**2-R2**2+X2) & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) ISSET1=1 C...~q -> ~q V. ELSEIF(ICLASS.EQ.7) THEN RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4) RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)* & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)* & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)* & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/ & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/ & (3*(-2+X1+X2)) RFO1=3D0*RFO1/8D0 ISSET1=1 C...S -> ~q ~qbar. ELSEIF(ICLASS.EQ.8) THEN RLO1=PS RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2 & -R1**2*X2**2+X1*X2**2)/ & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2 RFO1=2D0*RFO1 ISSET1=1 C...~q -> ~q S. ELSEIF(ICLASS.EQ.9) THEN RLO1=PS RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) & -(X1+X2)/(-2+X1+X2)**2 ISSET1=1 C...chi -> q ~qbar (chi = neutralino/chargino). ELSEIF(ICLASS.EQ.10) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1D0+R1**2-R2**2+2D0*R1) RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/ & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (-1+R1**2-R2**2+X2)**2 ISSET1=1 ENDIF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1D0-2D0*R1+R1**2-R2**2) RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/ & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (-1+R1**2-R2**2+X2)**2 ISSET2=1 ENDIF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1+R1**2-R2**2) RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2 & +X2+R1**2*X2-X1*X2/2)/ & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2 ISSET4=1 ENDIF C...~q -> q chi. ELSEIF(ICLASS.EQ.11) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1D0-(R1+R2)**2) RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) ISSET1=1 ENDIF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1D0-(R1-R2)**2) RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/ & (-2+X1+X2)**2 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) ISSET2=1 ENDIF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1D0-R1**2-R2**2) RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2 & +3*R1**2*X2-R2**2*X2-X1*X2)/ & (-1+R1**2-R2**2+X2)**2 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/ & (2-X1-X2)/(-1+R1**2-R2**2+X2) ISSET4=1 ENDIF C...q -> ~q chi. ELSEIF(ICLASS.EQ.12) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1D0-R1**2+R2**2+2D0*R2) RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/ & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/ & (2-X1-X2)/(-1+R1**2-R2**2+X2) ISSET1=1 END IF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1D0-R1**2+R2**2-2D0*R2) RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/ & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/ & (2-X1-X2)/(-1+R1**2-R2**2+X2) ISSET2=1 END IF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1D0-R1**2+R2**2) RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/ & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2 & +R1**2*X2-X1*X2/2-X2**2/2)/ & (2-X1-X2)/(-1+R1**2-R2**2+X2) ISSET4=1 END IF C...~g -> q ~qbar. ELSEIF(ICLASS.EQ.13) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1D0+R1**2-R2**2+2D0*R1) RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2) & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/ & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (3*(-1+R1**2-R2**2+X2)**2) RFO1=3D0*RFO1/4D0 ISSET1=1 ENDIF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1D0+R1**2-R2**2-2D0*R1) RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2) & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2)) & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/ & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (3*(-1+R1**2-R2**2+X2)**2) RFO2=3D0*RFO2/4D0 ISSET2=1 ENDIF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1D0+R1**2-R2**2) RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/ & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (3*(-1+R1**2-R2**2+X2)**2) RFO4=3D0*RFO4/8D0 ISSET4=1 ENDIF C...~q -> q ~g. ELSEIF(ICLASS.EQ.14) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2) RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2) & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2)) & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2) & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2)) RFO1=RFO1 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) RFO1=9D0*RFO1/64D0 ISSET1=1 ENDIF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2) RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2) & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/ & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2)) RFO2=RFO2 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2)) & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) RFO2=9D0*RFO2/64D0 ISSET2=1 ENDIF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1-R1**2-R2**2) RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/ & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2) & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/ & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2)) RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/ & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2)) RFO4=9D0*RFO4/128D0 ISSET4=1 ENDIF C...q -> ~q ~g. ELSEIF(ICLASS.EQ.15) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1D0-R1**2+R2**2+2D0*R2) RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2) & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/ & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/ & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2) RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/ & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) RFO1=9D0*RFO1/32D0 ISSET1=1 END IF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1D0-R1**2+R2**2-2D0*R2) RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2) & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/ & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/ & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2)) RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/ & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/ & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) RFO2=9D0*RFO2/32D0 ISSET2=1 END IF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1D0-R1**2+R2**2) RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2) & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2 & -R2**2*X2/2-X1*X2/2)/ & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2)) & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2) RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) RFO4=9D0*RFO4/64D0 ISSET4=1 END IF C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future. ELSEIF(ICLASS.EQ.16) THEN RLO=PS IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN ANUM=0D0 ELSEIF(ICOMBI.EQ.2) THEN ANUM=(2D0-X1-X2)**2 ELSEIF(ICOMBI.EQ.3) THEN ANUM=ALPCOR*(2D0-X1-X2)**2 ELSE ANUM=0.5D0*(2D0-X1-X2)**2 ENDIF RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/ & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))- & R1**2/(1D0+R2**2-R1**2-X2)**2- & R2**2/(1D0+R1**2-R2**2-X1)**2) RFO=9D0*RFO/4D0 ICOMBI=0 ENDIF C...Find relevant LO and FO expression. IF(ICOMBI.EQ.0) THEN ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN RLO=RLO1 RFO=RFO1 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN RLO=RLO2 RFO=RFO2 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2 ELSEIF(ISSET4.EQ.1) THEN RLO=RLO4 RFO=RFO4 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN RLO=0.5D0*(RLO1+RLO2) RFO=0.5D0*(RFO1+RFO2) ELSEIF(ISSET1.EQ.1) THEN RLO=RLO1 RFO=RFO1 ELSE CALL PYERRM(16,'(PYMAEL:) not implemented ME code') RLO=1D0 RFO=0D0 ENDIF C...Output. PYMAEL=RFO/RLO RETURN END C********************************************************************* C...PYBOEI C...Modifies an event so as to approximately take into account C...Bose-Einstein effects according to a simple phenomenological C...parametrization. SUBROUTINE PYBOEI(NSAV) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/ C...Local arrays and data. DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100), &BEIW(100),BEI3W(100) DATA KFBE/211,-211,111,321,-321,130,310,221,331/ C...Statement function: squared invariant mass. SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2- &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2) C...Boost event to overall CM frame. Calculate CM energy. IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN DO 100 J=1,4 DPS(J)=0D0 100 CONTINUE DO 120 I=1,N KFA=IABS(K(I,2)) IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22) & .AND.K(I,3).GT.0) THEN KFMA=IABS(K(K(I,3),2)) IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1) ENDIF IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120 DO 110 J=1,4 DPS(J)=DPS(J)+P(I,J) 110 CONTINUE 120 CONTINUE CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4), &-DPS(3)/DPS(4)) PECM=0D0 DO 130 I=1,N IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4) 130 CONTINUE C...Check if we have separated strings C...Reserve copy of particles by species at end of record. IWP=0 IWN=0 NBE(0)=N+MSTU(3) NMAX=NBE(0) SMMIN=PECM DO 190 IBE=1,MIN(10,MSTJ(52)+1) NBE(IBE)=NBE(IBE-1) DO 180 I=NSAV+1,N IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN DO 140 IIBE=1,IBE-1 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180 140 CONTINUE ELSE IF(K(I,2).NE.KFBE(IBE)) GOTO 180 ENDIF IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS') RETURN ENDIF NBE(IBE)=NBE(IBE)+1 NMAX=NBE(IBE) K(NBE(IBE),1)=I K(NBE(IBE),2)=0 K(NBE(IBE),3)=0 K(NBE(IBE),4)=0 K(NBE(IBE),5)=0 P(NBE(IBE),1)=0.0D0 P(NBE(IBE),2)=0.0D0 P(NBE(IBE),3)=0.0D0 P(NBE(IBE),4)=0.0D0 P(NBE(IBE),5)=0.0D0 SMMIN=MIN(SMMIN,P(I,5)) C...Check if particles comes from different W's or Z's IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN IM=I 150 IF(K(IM,3).GT.0) THEN IM=K(IM,3) IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150 K(NBE(IBE),5)=IM IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM ENDIF ENDIF C...Check if particles comes from different strings. IF(PARJ(94).GT.0.0D0) THEN IM=I 160 IF(K(IM,3).GT.0) THEN IM=K(IM,3) IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160 K(NBE(IBE),5)=IM ENDIF ENDIF DO 170 J=1,3 P(NBE(IBE),J)=0D0 V(NBE(IBE),J)=0D0 170 CONTINUE P(NBE(IBE),5)=-1.0D0 180 CONTINUE 190 CONTINUE IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510 C...Calculate separation between W+ and W- or between two Z0's. C...No separation if there has been re-connections. SIGW=PARJ(93) IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN IF(K(IWP,2).EQ.23) THEN DMW=PMAS(23,1) DGW=PMAS(23,2) ELSE DMW=PMAS(24,1) DGW=PMAS(24,2) ENDIF DMP=P(IWP,5) DMN=P(IWN,5) TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2) TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2) TAUP=-TAUPD*LOG(PYR(IDUM)) TAUN=-TAUND*LOG(PYR(IDUM)) DXP=TAUP*PYP(IWP,8)/DMP DXN=TAUN*PYP(IWN,8)/DMN DX=DXP+DXN SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX) IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94)) ENDIF C...Add separation between strings. IF(PARJ(94).GT.0.0D0) THEN SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94)) IWP=-1 IWN=-1 ENDIF IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN DO 220 IBE=1,MIN(9,MSTJ(52)) DO 210 I1M=NBE(IBE-1)+1,NBE(IBE) Q2MIN=PECM**2 I1=K(I1M,1) DO 200 I2M=NBE(IBE-1)+1,NBE(IBE) IF(I2M.EQ.I1M) GOTO 200 I2=K(I2M,1) Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2- & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2- & (P(I1,5)+P(I2,5))**2 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN Q2MIN=Q2 ENDIF 200 CONTINUE P(I1M,5)=Q2MIN 210 CONTINUE 220 CONTINUE ENDIF C...Tabulate integral for subsequent momentum shift. DO 400 IBE=1,MIN(9,MSTJ(52)) IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2)) & .LE.1) GOTO 270 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5), & NBE(7)-NBE(6)).LE.1) GOTO 270 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211) IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321) IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221) IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331) QDEL=0.1D0*MIN(PMHQ,PARJ(93)) QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0) QDELW=0.1D0*MIN(PMHQ,SIGW) QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0) IF(MSTJ(51).EQ.1) THEN NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL)) NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3)) NBINW=MIN(100,NINT(9D0*SIGW/QDELW)) NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W)) BEEX=EXP(0.5D0*QDEL/PARJ(93)) BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93))) BEEXW=EXP(0.5D0*QDELW/SIGW) BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW)) BERT=EXP(-QDEL/PARJ(93)) BERT3=EXP(-QDEL3/(3.0D0*PARJ(93))) BERTW=EXP(-QDELW/SIGW) BERT3W=EXP(-QDEL3W/(3.0D0*SIGW)) ELSE NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL)) NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3)) NBINW=MIN(100,NINT(3D0*SIGW/QDELW)) NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W)) ENDIF DO 230 IBIN=1,NBIN QBIN=QDEL*(IBIN-0.5D0) BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2) IF(MSTJ(51).EQ.1) THEN BEEX=BEEX*BERT BEI(IBIN)=BEI(IBIN)*BEEX ELSE BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2) ENDIF IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1) 230 CONTINUE DO 240 IBIN=1,NBIN3 QBIN=QDEL3*(IBIN-0.5D0) BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2) IF(MSTJ(51).EQ.1) THEN BEEX3=BEEX3*BERT3 BEI3(IBIN)=BEI3(IBIN)*BEEX3 ELSE BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2) ENDIF IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1) 240 CONTINUE DO 250 IBIN=1,NBINW QBIN=QDELW*(IBIN-0.5D0) BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2) IF(MSTJ(51).EQ.1) THEN BEEXW=BEEXW*BERTW BEIW(IBIN)=BEIW(IBIN)*BEEXW ELSE BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2) ENDIF IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1) 250 CONTINUE DO 260 IBIN=1,NBIN3W QBIN=QDEL3W*(IBIN-0.5D0) BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/ & SQRT(QBIN**2+PMHQ**2) IF(MSTJ(51).EQ.1) THEN BEEX3W=BEEX3W*BERT3W BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W ELSE BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2) ENDIF IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1) 260 CONTINUE C...Loop through particle pairs and find old relative momentum. 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1 I1=K(I1M,1) DO 380 I2M=I1M+1,NBE(IBE) IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380 I2=K(I2M,1) Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+ & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2 IF(Q2OLD.LE.0.0D0) GOTO 380 QOLD=SQRT(Q2OLD) C...Calculate new relative momentum. QMOV=0.0D0 QMOV3=0.0D0 QMOVW=0.0D0 QMOV3W=0.0D0 IF(QOLD.LT.1D-3*QDEL) THEN GOTO 280 ELSEIF(QOLD.LE.QDEL) THEN QMOV=QOLD/3D0 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN RBIN=QOLD/QDEL IBIN=RBIN RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1) QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))* & SQRT(Q2OLD+PMHQ**2)/Q2OLD ELSE QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD ENDIF 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0) IF(QOLD.LT.1D-3*QDEL3) THEN GOTO 290 ELSEIF(QOLD.LE.QDEL3) THEN QMOV3=QOLD/3D0 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN RBIN3=QOLD/QDEL3 IBIN3=RBIN3 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1) QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))* & SQRT(Q2OLD+PMHQ**2)/Q2OLD ELSE QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD ENDIF 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0) RSCALE=1.0D0 IF(MSTJ(54).EQ.2) & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2) IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR. & K(I1M,5).EQ.K(I2M,5)) GOTO 320 IF(QOLD.LT.1D-3*QDELW) THEN GOTO 300 ELSEIF(QOLD.LE.QDELW) THEN QMOVW=QOLD/3D0 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN RBINW=QOLD/QDELW IBINW=RBINW RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1) QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))* & SQRT(Q2OLD+PMHQ**2)/Q2OLD ELSE QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD ENDIF 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0) IF(QOLD.LT.1D-3*QDEL3W) THEN GOTO 310 ELSEIF(QOLD.LE.QDEL3W) THEN QMOV3W=QOLD/3D0 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN RBIN3W=QOLD/QDEL3W IBIN3W=RBIN3W RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1) QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)- & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD ELSE QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD ENDIF 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0) IF(MSTJ(54).EQ.2) & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2) 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW) DO 330 J=1,3 P(I1M,J)=P(I1M,J)+P(NMAX+1,J) P(I2M,J)=P(I2M,J)+P(NMAX+2,J) 330 CONTINUE IF(MSTJ(54).GE.1) THEN CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3) DO 340 J=1,3 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE 340 CONTINUE ELSEIF(MSTJ(54).LE.-1) THEN EDEL=P(I1,4)+P(I2,4)- & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0)) A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+ & (P(I1,3)-P(I2,3))**2 WMAX=-1.0D20 MI3=0 MI4=0 S12=SDIP(I1,I2) SM1=(P(I1,5)+SMMIN)**2 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1)) IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND. & K(I3M,5).NE.K(I1M,5)) GOTO 360 I3=K(I3M,1) IF(K(I3,2).EQ.K(I1,2)) GOTO 360 S13=SDIP(I1,I3) S23=SDIP(I2,I3) SM3=(P(I3,5)+SMMIN)**2 IF(MSTJ(54).EQ.-2) THEN WI=(MIN(S12*SM3,S13*MIN(SM1,SM3), & S23*MIN(SM1,SM3))*SM1) ELSE WI=((P(I1,4)+P(I2,4)+P(I3,4))**2- & (P(I1,3)+P(I2,3)+P(I3,3))**2- & (P(I1,2)+P(I2,2)+P(I3,2))**2- & (P(I1,1)+P(I2,1)+P(I3,1))**2) ENDIF IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))) & GOTO 360 ELSE IF(WMAX*WI.GE.1.0) GOTO 360 ENDIF DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1)) IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND. & K(I4M,5).NE.K(I1M,5)) GOTO 350 I4=K(I4M,1) IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2)) & GOTO 350 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT. & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+ & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2) & GOTO 350 IF(MSTJ(54).EQ.-2) THEN S14=SDIP(I1,I4) S24=SDIP(I2,I4) S34=SDIP(I3,I4) W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24) W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23) W=MIN(W,MIN(S23,S24)*S13*S14) W=1.0D0/W ELSE C...weight=1-cos(theta)/mtot2 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2- & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2- & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2- & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2 W=1.0D0/S1234 IF(W.LE.WMAX) GOTO 350 ENDIF IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))) IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0) & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2))) IF(W.LE.WMAX) GOTO 350 MI3=I3M MI4=I4M WMAX=W 350 CONTINUE 360 CONTINUE IF(MI4.EQ.0) GOTO 380 I3=K(MI3,1) I4=K(MI4,1) EOLD=P(I3,4)+P(I4,4) ENEW=EOLD+EDEL P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+ & (P(I3,3)+P(I4,3))**2 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2) Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2) CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP) DO 370 J=1,3 V(MI3,J)=V(MI3,J)+P(NMAX+1,J) V(MI4,J)=V(MI4,J)+P(NMAX+2,J) 370 CONTINUE ENDIF 380 CONTINUE 390 CONTINUE 400 CONTINUE C...Shift momenta and recalculate energies. ESUMP=0.0D0 ESUM=0.0D0 PROD=0.0D0 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1)) I=K(IM,1) ESUMP=ESUMP+P(I,4) DO 410 J=1,3 P(I,J)=P(I,J)+P(IM,J) 410 CONTINUE P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) ESUM=ESUM+P(I,4) DO 420 J=1,3 PROD=PROD+V(IM,J)*P(I,J)/P(I,4) 420 CONTINUE 430 CONTINUE PARJ(96)=0.0D0 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN 440 ALPHA=(ESUMP-ESUM)/PROD PARJ(96)=PARJ(96)+ALPHA PROD=0.0D0 ESUM=0.0D0 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1)) I=K(IM,1) DO 450 J=1,3 P(I,J)=P(I,J)+ALPHA*V(IM,J) 450 CONTINUE P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) ESUM=ESUM+P(I,4) DO 460 J=1,3 PROD=PROD+V(IM,J)*P(I,J)/P(I,4) 460 CONTINUE 470 CONTINUE IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0) & GOTO 440 ENDIF C...Rescale all momenta for energy conservation. PES=0D0 PQS=0D0 DO 480 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480 PES=PES+P(I,4) PQS=PQS+P(I,5)**2/P(I,4) 480 CONTINUE PARJ(95)=PES-PECM FAC=(PECM-PQS)/(PES-PQS) DO 500 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500 DO 490 J=1,3 P(I,J)=FAC*P(I,J) 490 CONTINUE P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) 500 CONTINUE C...Boost back to correct reference frame. 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4)) DO 520 I=1,N IF(K(I,1).LT.0) K(I,1)=-K(I,1) 520 CONTINUE RETURN END C********************************************************************* C...PYBESQ C...Calculates the momentum shift in a system of two particles assuming C...the relative momentum squared should be shifted to Q2NEW. NI is the C...last position occupied in /PYJETS/. SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYJETS/,/PYDAT1/ C...Local arrays and data. DIMENSION DP(5) SAVE HC1 IF(MSTJ(55).EQ.0) THEN DQ2=Q2NEW-Q2OLD DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+ & (P(I1,3)-P(I2,3))**2 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2 SE=P(I1,4)+P(I2,4) DE=P(I1,4)-P(I2,4) DQ2SE=DQ2+SE**2 DA=SE*DE*DP12-DP2*DQ2SE DB=DP2*DQ2SE-DP12**2 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB) DO 100 J=1,3 PD=HA*(P(I1,J)-P(I2,J)) P(NI+1,J)=PD P(NI+2,J)=-PD 100 CONTINUE RETURN ENDIF K(NI+1,1)=1 K(NI+2,1)=1 DO 110 J=1,5 P(NI+1,J)=P(I1,J) P(NI+2,J)=P(I2,J) DP(J)=P(I1,J)+P(I2,J) 110 CONTINUE C...Boost to cms and rotate first particle to z-axis CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0, &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4)) PHI=PYANGL(P(NI+1,1),P(NI+1,2)) THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2)) S=Q2NEW+(P(I1,5)+P(I2,5))**2 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S) P(NI+1,1)=0.0D0 P(NI+1,2)=0.0D0 P(NI+1,3)=PZ P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2) P(NI+2,1)=0.0D0 P(NI+2,2)=0.0D0 P(NI+2,3)=-PZ P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2) DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S) CALL PYROBO(NI+1,NI+2,THE,PHI, &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4)) DO 120 J=1,3 P(NI+1,J)=P(NI+1,J)-P(I1,J) P(NI+2,J)=P(NI+2,J)-P(I2,J) 120 CONTINUE RETURN END C********************************************************************* C...PYMASS C...Gives the mass of a particle/parton. FUNCTION PYMASS(KF) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C...Reset variables. Compressed code. Special case for popcorn diquarks. PYMASS=0D0 KFA=IABS(KF) KC=PYCOMP(KF) IF(KC.EQ.0) THEN MSTJ(93)=0 RETURN ENDIF C...Guarantee use of constituent masses for internal checks. IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND. &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN IF(KFA.LE.5) THEN PYMASS=PARF(100+KFA) IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121)) ELSEIF(KFA.LE.10) THEN PYMASS=PMAS(KFA,1) ELSEIF(MSTJ(93).EQ.1) THEN PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10)) ELSE PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0) ENDIF C...Other masses can be read directly off table. ELSE PYMASS=PMAS(KC,1) ENDIF C...Optional mass broadening according to truncated Breit-Wigner C...(either in m or in m^2). IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)* & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2))) ELSE PM0=PYMASS PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/ & (PM0*PMAS(KC,2))) PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2))) PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+ & (PMUPP-PMLOW)*PYR(0)))) ENDIF ENDIF MSTJ(93)=0 RETURN END C********************************************************************* C...PYMRUN C...Gives the running, current-algebra mass of a d, u, s, c or b quark, C...for Higgs couplings. Everything else sent on to PYMASS. FUNCTION PYMRUN(KF,Q2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/ C...Most masses not handled here. KFA=IABS(KF) IF(KFA.EQ.0.OR.KFA.GT.6) THEN PYMRUN=PYMASS(KF) C...Current-algebra masses, but no Q2 dependence. ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN PYMRUN=PARF(90+KFA) C...Running current-algebra masses. ELSE AS=PYALPS(Q2) PYMRUN=PARF(90+KFA)* & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/ & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118))) ENDIF RETURN END C********************************************************************* C...PYNAME C...Gives the particle/parton name as a character string. SUBROUTINE PYNAME(KF,CHAU) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT4/CHAF(500,2) CHARACTER CHAF*16 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/ C...Local character variable. CHARACTER CHAU*16 C...Read out code with distinction particle/antiparticle. CHAU=' ' KC=PYCOMP(KF) IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2) RETURN END C********************************************************************* C...PYCHGE C...Gives three times the charge for a particle/parton. FUNCTION PYCHGE(KF) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT2/ C...Read out charge and change sign for antiparticle. PYCHGE=0 KC=PYCOMP(KF) IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF) RETURN END C********************************************************************* C...PYCOMP C...Compress the standard KF codes for use in mass and decay arrays; C...also checks whether a given code actually is defined. FUNCTION PYCOMP(KF) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C...Local arrays and saved data. DIMENSION KFORD(100:500),KCORD(101:500) SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST C...Whenever necessary reorder codes for faster search. IF(MSTU(20).EQ.0) THEN NFORD=100 KFORD(100)=0 DO 120 I=101,500 KFA=KCHG(I,4) IF(KFA.LE.100) GOTO 120 NFORD=NFORD+1 DO 100 I1=NFORD-1,0,-1 IF(KFA.GE.KFORD(I1)) GOTO 110 KFORD(I1+1)=KFORD(I1) KCORD(I1+1)=KCORD(I1) 100 CONTINUE 110 KFORD(I1+1)=KFA KCORD(I1+1)=I 120 CONTINUE MSTU(20)=1 KFLAST=0 KCLAST=0 ENDIF C...Fast action if same code as in latest call. IF(KF.EQ.KFLAST) THEN PYCOMP=KCLAST RETURN ENDIF C...Starting values. Remove internal diquark flags. PYCOMP=0 KFA=IABS(KF) IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000) C...Simple cases: direct translation. IF(KFA.GT.KFORD(NFORD)) THEN ELSEIF(KFA.LE.100) THEN PYCOMP=KFA C...Else binary search. ELSE IMIN=100 IMAX=NFORD+1 130 IAVG=(IMIN+IMAX)/2 IF(KFORD(IAVG).GT.KFA) THEN IMAX=IAVG IF(IMAX.GT.IMIN+1) GOTO 130 ELSEIF(KFORD(IAVG).LT.KFA) THEN IMIN=IAVG IF(IMAX.GT.IMIN+1) GOTO 130 ELSE PYCOMP=KCORD(IAVG) ENDIF ENDIF C...Check if antiparticle allowed. IF(PYCOMP.NE.0.AND.KF.LT.0) THEN IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0 ENDIF C...Save codes for possible future fast action. KFLAST=KF KCLAST=PYCOMP RETURN END C********************************************************************* C...PYERRM C...Informs user of errors in program execution. SUBROUTINE PYERRM(MERR,CHMESS) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYJETS/,/PYDAT1/ C...Local character variable. CHARACTER CHMESS*(*) C...Write first few warnings, then be silent. IF(MERR.LE.10) THEN MSTU(27)=MSTU(27)+1 MSTU(28)=MERR IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000) & MERR,MSTU(31),CHMESS C...Write first few errors, then be silent or stop program. ELSEIF(MERR.LE.20) THEN IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1 MSTU(30)=MSTU(30)+1 MSTU(24)=MERR-10 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100) & MERR-10,MSTU(31),CHMESS IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS WRITE(MSTU(11),5200) IF(MERR.NE.17) CALL PYLIST(2) CALL PYSTOP(3) ENDIF C...Stop program in case of irreparable error. ELSE WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS CALL PYSTOP(3) ENDIF C...Formats for output. 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9, &' PYEXEC calls:'/5X,A) 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9, &' PYEXEC calls:'/5X,A) 5200 FORMAT(5X,'Execution will be stopped after listing of last ', &'event!') 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9, &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!') RETURN END C********************************************************************* C...PYALEM C...Calculates the running alpha_electromagnetic. FUNCTION PYALEM(Q2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Calculate real part of photon vacuum polarization. C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions. C...For hadrons use parametrization of H. Burkhardt et al. C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131. AEMPI=PARU(101)/(3D0*PARU(1)) IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN RPIGG=0D0 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN RPIGG=0D0 ELSEIF(MSTU(101).EQ.2) THEN RPIGG=1D0-PARU(101)/PARU(103) ELSEIF(Q2.LT.0.09D0) THEN RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2) ELSEIF(Q2.LT.9D0) THEN RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+ & 0.00238D0*LOG(1D0+3.927D0*Q2) ELSEIF(Q2.LT.1D4) THEN RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+ & 0.00299D0*LOG(1D0+Q2) ELSE RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+ & 0.00293D0*LOG(1D0+Q2) ENDIF C...Calculate running alpha_em. PYALEM=PARU(101)/(1D0-RPIGG) PARU(108)=PYALEM RETURN END C********************************************************************* C...PYALPS C...Gives the value of alpha_strong. FUNCTION PYALPS(Q2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C...Coefficients for second-order threshold matching. C...From W.J. Marciano, Phys. Rev. D29 (1984) 580. DIMENSION STEPDN(6),STEPUP(6) c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0), c &(2D0*321D0/3703D0),0D0/ c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0), c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/ DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/ DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/ C...Constant alpha_strong trivial. Pick artificial Lambda. IF(MSTU(111).LE.0) THEN PYALPS=PARU(111) MSTU(118)=MSTU(112) PARU(117)=0.2D0 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/ & ((33D0-2D0*MSTU(112))*PARU(111))) PARU(118)=PARU(111) RETURN ENDIF C...Find effective Q2, number of flavours and Lambda. Q2EFF=Q2 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114)) NF=MSTU(112) ALAM2=PARU(112)**2 100 IF(NF.GT.MAX(3,MSTU(113))) THEN Q2THR=PARU(113)*PMAS(NF,1)**2 IF(Q2EFF.LT.Q2THR) THEN NF=NF-1 Q2RAT=Q2THR/ALAM2 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF)) IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF) GOTO 100 ENDIF ENDIF 110 IF(NF.LT.MIN(6,MSTU(114))) THEN Q2THR=PARU(113)*PMAS(NF+1,1)**2 IF(Q2EFF.GT.Q2THR) THEN NF=NF+1 Q2RAT=Q2THR/ALAM2 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF)) IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF) GOTO 110 ENDIF ENDIF IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2 PARU(117)=SQRT(ALAM2) C...Evaluate first or second order alpha_strong. B0=(33D0-2D0*NF)/6D0 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2)) IF(MSTU(111).EQ.1) THEN PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)) ELSE B1=(153D0-19D0*NF)/6D0 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/ & (B0**2*ALGQ))) ENDIF MSTU(118)=NF PARU(118)=PYALPS RETURN END C********************************************************************* C...PYANGL C...Reconstructs an angle from given x and y coordinates. FUNCTION PYANGL(X,Y) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ PYANGL=0D0 R=SQRT(X**2+Y**2) IF(R.LT.1D-20) RETURN IF(ABS(X)/R.LT.0.8D0) THEN PYANGL=SIGN(ACOS(X/R),Y) ELSE PYANGL=ASIN(Y/R) IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN PYANGL=PARU(1)-PYANGL ELSEIF(X.LT.0D0) THEN PYANGL=-PARU(1)-PYANGL ENDIF ENDIF RETURN END C********************************************************************* C...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!' CALL PYSTOP(8) C...Write current version number and current date+time. ELSE WRITE(VERS,'(I1)') MSTP(181) LOGO(28)(24:24)=VERS WRITE(SUBV,'(I3)') MSTP(182) LOGO(28)(26:28)=SUBV IF(MSTP(182).LT.100) LOGO(28)(26:26)='0' WRITE(DATE,'(I2)') MSTP(185) LOGO(29)(22:23)=DATE LOGO(29)(25:27)=MONTH(MSTP(184)) WRITE(YEAR,'(I4)') MSTP(183) LOGO(29)(29:32)=YEAR CALL PYTIME(IDATI) IF(IDATI(1).LE.0) THEN LOGO(31)=' ' ELSE WRITE(DATE,'(I2)') IDATI(3) LOGO(31)(8:9)=DATE LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2)))) WRITE(YEAR,'(I4)') IDATI(1) LOGO(31)(15:18)=YEAR WRITE(HOUR,'(I2)') IDATI(4) LOGO(31)(23:24)=HOUR WRITE(MINU,'(I2)') IDATI(5) LOGO(31)(26:27)=MINU IF(IDATI(5).LT.10) LOGO(31)(26:26)='0' WRITE(SECO,'(I2)') IDATI(6) LOGO(31)(29:30)=SECO IF(IDATI(6).LT.10) LOGO(31)(29:29)='0' ENDIF ENDIF C...Loop over lines in header. Define page feed and side borders. DO 100 ILIN=1,29+IREFER LINE=' ' IF(ILIN.EQ.1) THEN LINE(1:1)='1' ELSE LINE(2:3)='**' LINE(78:79)='**' ENDIF C...Separator lines and logos. IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN LINE(4:77)='***********************************************'// & '***************************' ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN LINE(6:37)=LOGO(ILIN-5) LINE(44:75)=LOGO(ILIN+14) ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN LINE(5:40)=REFER(2*ILIN-51) LINE(41:76)=REFER(2*ILIN-50) ENDIF C...Write lines to appropriate unit. WRITE(MSTU(11),'(A79)') LINE 100 CONTINUE RETURN END C********************************************************************* C...PYUPDA C...Facilitates the updating of particle and decay data C...by allowing it to be done in an external file. SUBROUTINE PYUPDA(MUPDA,LFN) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYDAT4/CHAF(500,2) CHARACTER CHAF*16 COMMON/PYINT4/MWID(500),WIDS(500,5) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/ C...Local arrays, character variables and data. CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72, &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)', &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)', &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ', &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)', &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/ C...Write header if not yet done. IF(MSTU(12).NE.12345) CALL PYLIST(0) C...Write information on file for editing. IF(MUPDA.EQ.1) THEN DO 110 KC=1,500 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2), & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4), & MWID(KC),MDCY(KC,1) DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC), & (KFDP(IDC,J),J=1,5) 100 CONTINUE 110 CONTINUE C...Read complete set of information from edited file or C...read partial set of new or updated information from edited file. ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN C...Reset counters. KCC=100 NDC=0 CHKF=' ' IF(MUPDA.EQ.2) THEN DO 120 I=1,MSTU(6) KCHG(I,4)=0 120 CONTINUE ELSE DO 130 KC=1,MSTU(6) IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1) 130 CONTINUE ENDIF C...Begin of loop: read new line; unknown whether particle or C...decay data. 140 READ(LFN,5200,END=190) CHINL C...Identify particle code and whether already defined (for MUPDA=3). IF(CHINL(2:10).NE.' ') THEN CHKF=CHINL(2:10) READ(CHKF,5300) KF IF(MUPDA.EQ.2) THEN IF(KF.LE.100) THEN KC=KF ELSE KCC=KCC+1 KC=KCC ENDIF ELSE KCREP=0 IF(KF.LE.100) THEN KCREP=KF ELSE DO 150 KCR=101,KCC IF(KCHG(KCR,4).EQ.KF) KCREP=KCR 150 CONTINUE ENDIF C...Remove duplicate old decay data. IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN IDCREP=MDCY(KCREP,2) NDCREP=MDCY(KCREP,3) DO 160 I=1,KCC IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP 160 CONTINUE DO 180 I=IDCREP,NDC-NDCREP MDME(I,1)=MDME(I+NDCREP,1) MDME(I,2)=MDME(I+NDCREP,2) BRAT(I)=BRAT(I+NDCREP) DO 170 J=1,5 KFDP(I,J)=KFDP(I+NDCREP,J) 170 CONTINUE 180 CONTINUE NDC=NDC-NDCREP KC=KCREP ELSEIF(KCREP.NE.0) THEN KC=KCREP ELSE KCC=KCC+1 KC=KCC ENDIF ENDIF C...Study line with particle data. IF(KC.GT.MSTU(6)) CALL PYERRM(27, & '(PYUPDA:) Particle arrays full by KF ='//CHKF) READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2), & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4), & MWID(KC),MDCY(KC,1) MDCY(KC,2)=0 MDCY(KC,3)=0 C...Study line with decay data. ELSE NDC=NDC+1 IF(NDC.GT.MSTU(7)) CALL PYERRM(27, & '(PYUPDA:) Decay data arrays full by KF ='//CHKF) IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC MDCY(KC,3)=MDCY(KC,3)+1 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC), & (KFDP(NDC,J),J=1,5) ENDIF C...End of loop; ensure that PYCOMP tables are updated. GOTO 140 190 CONTINUE MSTU(20)=0 C...Perform possible tests that new information is consistent. DO 220 KC=1,MSTU(6) KF=KCHG(KC,4) IF(KF.EQ.0) GOTO 220 WRITE(CHKF,5300) KF IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3), & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17, & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF) BRSUM=0D0 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 IF(MDME(IDC,2).GT.80) GOTO 210 KQ=KCHG(KC,1) PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64) MERR=0 DO 200 J=1,5 KP=KFDP(IDC,J) IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN IF(KP.EQ.81) KQ=0 ELSEIF(PYCOMP(KP).EQ.0) THEN MERR=3 ELSE KQ=KQ-PYCHGE(KP) KPC=PYCOMP(KP) PMS=PMS-PMAS(KPC,1) IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2), & PMAS(KPC,3)) ENDIF 200 CONTINUE IF(KQ.NE.0) MERR=MAX(2,MERR) IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0) & MERR=MAX(1,MERR) IF(MERR.EQ.3) CALL PYERRM(17, & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF) IF(MERR.EQ.2) CALL PYERRM(17, & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF) IF(MERR.EQ.1) CALL PYERRM(7, & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF) BRSUM=BRSUM+BRAT(IDC) 210 CONTINUE WRITE(CHTMP,5500) BRSUM IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0) & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '// & CHTMP(9:16)//' for KF ='//CHKF) 220 CONTINUE C...Write DATA statements for inclusion in program. ELSEIF(MUPDA.EQ.4) THEN C...Find out how many codes and decay channels are actually used. KCC=0 NDC=0 DO 230 I=1,MSTU(6) IF(KCHG(I,4).NE.0) THEN KCC=I NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1) ENDIF 230 CONTINUE C...Initialize writing of DATA statements for inclusion in program. DO 300 IVAR=1,22 NDIM=MSTU(6) IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7) NLIN=1 CHLIN=' ' CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/' LLIN=35 CHOLD='START' C...Loop through variables for conversion to characters. DO 280 IDIM=1,NDIM IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1) IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2) IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3) IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4) IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1) IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2) IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3) IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4) IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1) IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2) IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3) IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1) IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2) IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM) IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1) IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2) IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3) IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4) IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5) IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1) IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2) IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM) C...Replace variables beyond what is properly defined. IF(IVAR.LE.4) THEN IF(IDIM.GT.KCC) CHTMP=' 0' ELSEIF(IVAR.LE.8) THEN IF(IDIM.GT.KCC) CHTMP=' 0.0' ELSEIF(IVAR.LE.11) THEN IF(IDIM.GT.KCC) CHTMP=' 0' ELSEIF(IVAR.LE.13) THEN IF(IDIM.GT.NDC) CHTMP=' 0' ELSEIF(IVAR.LE.14) THEN IF(IDIM.GT.NDC) CHTMP=' 0.0' ELSEIF(IVAR.LE.19) THEN IF(IDIM.GT.NDC) CHTMP=' 0' ELSEIF(IVAR.LE.21) THEN IF(IDIM.GT.KCC) CHTMP=' ' ELSE IF(IDIM.GT.KCC) CHTMP=' 0' ENDIF C...Length of variable, trailing decimal zeros, quotation marks. LLOW=1 LHIG=1 DO 240 LL=1,16 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL IF(CHTMP(LL:LL).NE.' ') LHIG=LL 240 CONTINUE CHNEW=CHTMP(LLOW:LHIG)//' ' LNEW=1+LHIG-LLOW IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN LNEW=LNEW+1 250 LNEW=LNEW-1 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1 IF(LNEW.EQ.0) THEN CHNEW(1:3)='0D0' LNEW=3 ELSE CHNEW(LNEW+1:LNEW+2)='D0' LNEW=LNEW+2 ENDIF ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN DO 260 LL=LNEW,1,-1 IF(CHNEW(LL:LL).EQ.'''') THEN CHTMP=CHNEW CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11) LNEW=LNEW+1 ENDIF 260 CONTINUE LNEW=MIN(14,LNEW) CHTMP=CHNEW CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//'''' LNEW=LNEW+2 ENDIF C...Form composite character string, often including repetition counter. IF(CHNEW.NE.CHOLD) THEN NRPT=1 CHOLD=CHNEW CHCOM=CHNEW LCOM=LNEW ELSE LRPT=LNEW+1 IF(NRPT.GE.2) LRPT=LNEW+3 IF(NRPT.GE.10) LRPT=LNEW+4 IF(NRPT.GE.100) LRPT=LNEW+5 IF(NRPT.GE.1000) LRPT=LNEW+6 LLIN=LLIN-LRPT NRPT=NRPT+1 WRITE(CHTMP,5400) NRPT LRPT=1 IF(NRPT.GE.10) LRPT=2 IF(NRPT.GE.100) LRPT=3 IF(NRPT.GE.1000) LRPT=4 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW) LCOM=LRPT+1+LNEW ENDIF C...Add characters to end of line, to new line (after storing old line), C...or to new block of lines (after writing old block). IF(LLIN+LCOM.LE.70) THEN CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//',' LLIN=LLIN+LCOM+1 ELSEIF(NLIN.LE.19) THEN CHLIN(LLIN+1:72)=' ' CHBLK(NLIN)=CHLIN NLIN=NLIN+1 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//',' LLIN=6+LCOM+1 ELSE CHLIN(LLIN:72)='/'//' ' CHBLK(NLIN)=CHLIN WRITE(CHTMP,5400) IDIM-NRPT CHBLK(1)(30:33)=CHTMP(13:16) DO 270 ILIN=1,NLIN WRITE(LFN,5700) CHBLK(ILIN) 270 CONTINUE NLIN=1 CHLIN=' ' CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)// & ',I= , )/'//CHCOM(1:LCOM)//',' WRITE(CHTMP,5400) IDIM-NRPT+1 CHLIN(25:28)=CHTMP(13:16) LLIN=35+LCOM+1 ENDIF 280 CONTINUE C...Write final block of lines. CHLIN(LLIN:72)='/'//' ' CHBLK(NLIN)=CHLIN WRITE(CHTMP,5400) NDIM CHBLK(1)(30:33)=CHTMP(13:16) DO 290 ILIN=1,NLIN WRITE(LFN,5700) CHBLK(ILIN) 290 CONTINUE 300 CONTINUE ENDIF C...Formats for reading and writing particle data. 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3) 5100 FORMAT(10X,2I5,F12.6,5I10) 5200 FORMAT(A120) 5300 FORMAT(I9) 5400 FORMAT(I16) 5500 FORMAT(F16.5) 5600 FORMAT(F16.6) 5700 FORMAT(A72) RETURN END C********************************************************************* C...PYK C...Provides various integer-valued event related data. FUNCTION PYK(I,J) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Default value. For I=0 number of entries, number of stable entries C...or 3 times total charge. PYK=0 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN ELSEIF(I.EQ.0.AND.J.EQ.1) THEN PYK=N ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN DO 100 I1=1,N IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+ & PYCHGE(K(I1,2)) 100 CONTINUE ELSEIF(I.EQ.0) THEN C...For I > 0 direct readout of K matrix or charge. ELSEIF(J.LE.5) THEN PYK=K(I,J) ELSEIF(J.EQ.6) THEN PYK=PYCHGE(K(I,2)) C...Status (existing/fragmented/decayed), parton/hadron separation. ELSEIF(J.LE.8) THEN IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1 IF(J.EQ.8) PYK=PYK*K(I,2) ELSEIF(J.LE.12) THEN KFA=IABS(K(I,2)) KC=PYCOMP(KFA) KQ=0 IF(KC.NE.0) KQ=KCHG(KC,2) IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2) IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2) IF(J.EQ.11) PYK=KC IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2)) C...Heaviest flavour in hadron/diquark. ELSEIF(J.EQ.13) THEN KFA=IABS(K(I,2)) PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10) IF(KFA.LT.10) PYK=KFA IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10) PYK=PYK*ISIGN(1,K(I,2)) C...Particle history: generation, ancestor, rank. ELSEIF(J.LE.15) THEN I2=I I1=I 110 PYK=PYK+1 I2=I1 I1=K(I1,3) IF(I1.GT.0) THEN IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110 ENDIF IF(J.EQ.15) PYK=I2 ELSEIF(J.EQ.16) THEN KFA=IABS(K(I,2)) IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR. & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN I1=I 120 I2=I1 I1=K(I1,3) IF(I1.GT.0) THEN KFAM=IABS(K(I1,2)) ILP=1 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93) & ILP=0 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0 IF(ILP.EQ.1) GOTO 120 ENDIF IF(K(I1,1).EQ.12) THEN DO 130 I3=I1+1,I2 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92 & .AND.K(I3,2).NE.93) PYK=PYK+1 130 CONTINUE ELSE I3=I2 140 PYK=PYK+1 I3=I3+1 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140 ENDIF ENDIF C...Particle coming from collapsing jet system or not. ELSEIF(J.EQ.17) THEN I1=I 150 PYK=PYK+1 I3=I1 I1=K(I1,3) I0=MAX(1,I1) KC=PYCOMP(K(I0,2)) IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN IF(PYK.EQ.1) PYK=-1 IF(PYK.GT.1) PYK=0 RETURN ENDIF IF(KCHG(KC,2).EQ.0) GOTO 150 IF(K(I1,1).NE.12) PYK=0 IF(K(I1,1).NE.12) RETURN I2=I1 160 I2=I2+1 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160 K3M=K(I3-1,3) IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0 K3P=K(I3+1,3) IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0 C...Number of decay products. Colour flow. ELSEIF(J.EQ.18) THEN IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1) IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0 ELSEIF(J.LE.22) THEN IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5)) IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5)) IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5)) IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5)) ELSE ENDIF RETURN END C********************************************************************* C...PYP C...Provides various real-valued event related data. FUNCTION PYP(I,J) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local array. DIMENSION PSUM(4) C...Set default value. For I = 0 sum of momenta or charges, C...or invariant mass of system. PYP=0D0 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN ELSEIF(I.EQ.0.AND.J.LE.4) THEN DO 100 I1=1,N IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J) 100 CONTINUE ELSEIF(I.EQ.0.AND.J.EQ.5) THEN DO 120 J1=1,4 PSUM(J1)=0D0 DO 110 I1=1,N IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+ & P(I1,J1) 110 CONTINUE 120 CONTINUE PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2)) ELSEIF(I.EQ.0.AND.J.EQ.6) THEN DO 130 I1=1,N IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0 130 CONTINUE ELSEIF(I.EQ.0) THEN C...Direct readout of P matrix. ELSEIF(J.LE.5) THEN PYP=P(I,J) C...Charge, total momentum, transverse momentum, transverse mass. ELSEIF(J.LE.12) THEN IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP) C...Theta and phi angle in radians or degrees. ELSEIF(J.LE.16) THEN IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2)) IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2)) IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1) C...True rapidity, rapidity with pion mass, pseudorapidity. ELSEIF(J.LE.19) THEN PMR=0D0 IF(J.EQ.17) PMR=P(I,5) IF(J.EQ.18) PMR=PYMASS(211) PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2) PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR), & 1D20)),P(I,3)) C...Energy and momentum fractions (only to be used in CM frame). ELSEIF(J.LE.25) THEN IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21) IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21) IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21) IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21) IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21) IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21) ENDIF RETURN END C********************************************************************* C...PYSPHE C...Performs sphericity tensor analysis to give sphericity, C...aplanarity and the related event axes. SUBROUTINE PYSPHE(SPH,APL) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local arrays. DIMENSION SM(3,3),SV(3,3) C...Calculate matrix to be diagonalized. NP=0 DO 110 J1=1,3 DO 100 J2=J1,3 SM(J1,J2)=0D0 100 CONTINUE 110 CONTINUE PS=0D0 DO 140 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. & K(I,2).EQ.KSUSY1+39) GOTO 140 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) & GOTO 140 ENDIF NP=NP+1 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) PWT=1D0 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT= & MAX(1D-10,PA)**(PARU(41)-2D0) DO 130 J1=1,3 DO 120 J2=J1,3 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2) 120 CONTINUE 130 CONTINUE PS=PS+PWT*PA**2 140 CONTINUE C...Very low multiplicities (0 or 1) not considered. IF(NP.LE.1) THEN CALL PYERRM(8,'(PYSPHE:) too few particles for analysis') SPH=-1D0 APL=-1D0 RETURN ENDIF DO 160 J1=1,3 DO 150 J2=J1,3 SM(J1,J2)=SM(J1,J2)/PS 150 CONTINUE 160 CONTINUE C...Find eigenvalues to matrix (third degree equation). SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)- &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+ &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+ &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0) P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP) P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP) P(N+2,4)=1D0-P(N+1,4)-P(N+3,4) IF(P(N+2,4).LT.1D-5) THEN CALL PYERRM(8,'(PYSPHE:) all particles back-to-back') SPH=-1D0 APL=-1D0 RETURN ENDIF C...Find first and last eigenvector by solving equation system. DO 240 I=1,3,2 DO 180 J1=1,3 SV(J1,J1)=SM(J1,J1)-P(N+I,4) DO 170 J2=J1+1,3 SV(J1,J2)=SM(J1,J2) SV(J2,J1)=SM(J1,J2) 170 CONTINUE 180 CONTINUE SMAX=0D0 DO 200 J1=1,3 DO 190 J2=1,3 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190 JA=J1 JB=J2 SMAX=ABS(SV(J1,J2)) 190 CONTINUE 200 CONTINUE SMAX=0D0 DO 220 J3=JA+1,JA+2 J1=J3-3*((J3-1)/3) RL=SV(J1,JB)/SV(JA,JB) DO 210 J2=1,3 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2) IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210 JC=J1 SMAX=ABS(SV(J1,J2)) 210 CONTINUE 220 CONTINUE JB1=JB+1-3*(JB/3) JB2=JB+2-3*((JB+1)/3) P(N+I,JB1)=-SV(JC,JB2) P(N+I,JB2)=SV(JC,JB1) P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/ & SV(JA,JB) PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2) SGN=(-1D0)**INT(PYR(0)+0.5D0) DO 230 J=1,3 P(N+I,J)=SGN*P(N+I,J)/PA 230 CONTINUE 240 CONTINUE C...Middle axis orthogonal to other two. Fill other codes. SGN=(-1D0)**INT(PYR(0)+0.5D0) P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2)) P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3)) P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1)) DO 260 I=1,3 K(N+I,1)=31 K(N+I,2)=95 K(N+I,3)=I K(N+I,4)=0 K(N+I,5)=0 P(N+I,5)=0D0 DO 250 J=1,5 V(I,J)=0D0 250 CONTINUE 260 CONTINUE C...Calculate sphericity and aplanarity. Select storing option. SPH=1.5D0*(P(N+2,4)+P(N+3,4)) APL=1.5D0*P(N+3,4) MSTU(61)=N+1 MSTU(62)=NP IF(MSTU(43).LE.1) MSTU(3)=3 IF(MSTU(43).GE.2) N=N+3 RETURN END C********************************************************************* C...PYTHRU C...Performs thrust analysis to give thrust, oblateness C...and the related event axes. SUBROUTINE PYTHRU(THR,OBL) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local arrays. DIMENSION TDI(3),TPR(3) C...Take copy of particles that are to be considered in thrust analysis. NP=0 PS=0D0 DO 100 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. & K(I,2).EQ.KSUSY1+39) GOTO 100 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) & GOTO 100 ENDIF IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS') THR=-2D0 OBL=-2D0 RETURN ENDIF NP=NP+1 K(N+NP,1)=23 P(N+NP,1)=P(I,1) P(N+NP,2)=P(I,2) P(N+NP,3)=P(I,3) P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) P(N+NP,5)=1D0 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)= & P(N+NP,4)**(PARU(42)-1D0) PS=PS+P(N+NP,4)*P(N+NP,5) 100 CONTINUE C...Very low multiplicities (0 or 1) not considered. IF(NP.LE.1) THEN CALL PYERRM(8,'(PYTHRU:) too few particles for analysis') THR=-1D0 OBL=-1D0 RETURN ENDIF C...Loop over thrust and major. T axis along z direction in latter case. DO 320 ILD=1,2 IF(ILD.EQ.2) THEN K(N+NP+1,1)=31 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2)) MSTU(33)=1 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0) THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1)) CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0) ENDIF C...Find and order particles with highest p (pT for major). DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4 P(ILF,4)=0D0 110 CONTINUE DO 160 I=N+1,N+NP IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2) DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1 IF(P(I,4).LE.P(ILF,4)) GOTO 140 DO 120 J=1,5 P(ILF+1,J)=P(ILF,J) 120 CONTINUE 130 CONTINUE ILF=N+NP+3 140 DO 150 J=1,5 P(ILF+1,J)=P(I,J) 150 CONTINUE 160 CONTINUE C...Find and order initial axes with highest thrust (major). DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15 P(ILG,4)=0D0 170 CONTINUE NC=2**(MIN(MSTU(44),NP)-1) DO 250 ILC=1,NC DO 180 J=1,3 TDI(J)=0D0 180 CONTINUE DO 200 ILF=1,MIN(MSTU(44),NP) SGN=P(N+NP+ILF+3,5) IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN DO 190 J=1,4-ILD TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J) 190 CONTINUE 200 CONTINUE TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1 IF(TDS.LE.P(ILG,4)) GOTO 230 DO 210 J=1,4 P(ILG+1,J)=P(ILG,J) 210 CONTINUE 220 CONTINUE ILG=N+NP+MSTU(44)+4 230 DO 240 J=1,3 P(ILG+1,J)=TDI(J) 240 CONTINUE P(ILG+1,4)=TDS 250 CONTINUE C...Iterate direction of axis until stable maximum. P(N+NP+ILD,4)=0D0 ILG=0 260 ILG=ILG+1 THP=0D0 270 THPS=THP DO 280 J=1,3 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J) IF(THP.GT.1D-10) TDI(J)=TPR(J) TPR(J)=0D0 280 CONTINUE DO 300 I=N+1,N+NP SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3)) DO 290 J=1,4-ILD TPR(J)=TPR(J)+SGN*P(I,J) 290 CONTINUE 300 CONTINUE THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS IF(THP.GE.THPS+PARU(48)) GOTO 270 C...Save good axis. Try new initial axis until a number of tries agree. IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN IAGR=0 SGN=(-1D0)**INT(PYR(0)+0.5D0) DO 310 J=1,3 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP) 310 CONTINUE P(N+NP+ILD,4)=THP P(N+NP+ILD,5)=0D0 ENDIF IAGR=IAGR+1 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260 320 CONTINUE C...Find minor axis and value by orthogonality. SGN=(-1D0)**INT(PYR(0)+0.5D0) P(N+NP+3,1)=-SGN*P(N+NP+2,2) P(N+NP+3,2)=SGN*P(N+NP+2,1) P(N+NP+3,3)=0D0 THP=0D0 DO 330 I=N+1,N+NP THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2)) 330 CONTINUE P(N+NP+3,4)=THP/PS P(N+NP+3,5)=0D0 C...Fill axis information. Rotate back to original coordinate system. DO 350 ILD=1,3 K(N+ILD,1)=31 K(N+ILD,2)=96 K(N+ILD,3)=ILD K(N+ILD,4)=0 K(N+ILD,5)=0 DO 340 J=1,5 P(N+ILD,J)=P(N+NP+ILD,J) V(N+ILD,J)=0D0 340 CONTINUE 350 CONTINUE CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0) C...Calculate thrust and oblateness. Select storing option. THR=P(N+1,4) OBL=P(N+2,4)-P(N+3,4) MSTU(61)=N+1 MSTU(62)=NP IF(MSTU(43).LE.1) MSTU(3)=3 IF(MSTU(43).GE.2) N=N+3 RETURN END C********************************************************************* C...PYCLUS C...Subdivides the particle content of an event into jets/clusters. SUBROUTINE PYCLUS(NJET) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local arrays and saved variables. DIMENSION PS(5) SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM C...Functions: distance measure in pT, (pseudo)mass or Durham pT. R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)- &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)* &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5))) R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+ &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5))) C...If first time, reset. If reentering, skip preliminaries. IF(MSTU(48).LE.0) THEN NP=0 DO 100 J=1,5 PS(J)=0D0 100 CONTINUE PSS=0D0 PIMASS=PMAS(PYCOMP(211),1) ELSE NJET=NSAV IF(MSTU(43).GE.2) N=N-NJET DO 110 I=N+1,N+NJET P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) 110 CONTINUE IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN R2ACC=PARU(44)**2 ELSE R2ACC=PARU(45)*PS(5)**2 ENDIF NLOOP=0 GOTO 300 ENDIF C...Find which particles are to be considered in cluster search. DO 140 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. & K(I,2).EQ.KSUSY1+39) GOTO 140 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) & GOTO 140 ENDIF IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS') NJET=-1 RETURN ENDIF C...Take copy of these particles, with space left for jets later on. NP=NP+1 K(N+NP,3)=I DO 120 J=1,5 P(N+NP,J)=P(I,J) 120 CONTINUE IF(MSTU(42).EQ.0) P(N+NP,5)=0D0 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) DO 130 J=1,4 PS(J)=PS(J)+P(N+NP,J) 130 CONTINUE PSS=PSS+P(N+NP,5) 140 CONTINUE DO 160 I=N+1,N+NP K(I+NP,3)=K(I,3) DO 150 J=1,5 P(I+NP,J)=P(I,J) 150 CONTINUE 160 CONTINUE PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2)) C...Very low multiplicities not considered. IF(NP.LT.MSTU(47)) THEN CALL PYERRM(8,'(PYCLUS:) too few particles for analysis') NJET=-1 RETURN ENDIF C...Find precluster configuration. If too few jets, make harder cuts. NLOOP=0 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN R2ACC=PARU(44)**2 ELSE R2ACC=PARU(45)*PS(5)**2 ENDIF RINIT=1.25D0*PARU(43) IF(NP.LE.MSTU(47)+2) RINIT=0D0 170 RINIT=0.8D0*RINIT NPRE=0 NREM=NP DO 180 I=N+NP+1,N+2*NP K(I,4)=0 180 CONTINUE C...Sum up small momentum region. Jet if enough absolute momentum. IF(MSTU(46).LE.2) THEN DO 190 J=1,4 P(N+1,J)=0D0 190 CONTINUE DO 210 I=N+NP+1,N+2*NP IF(P(I,5).GT.2D0*RINIT) GOTO 210 NREM=NREM-1 K(I,4)=1 DO 200 J=1,4 P(N+1,J)=P(N+1,J)+P(I,J) 200 CONTINUE 210 CONTINUE P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2) IF(P(N+1,5).GT.2D0*RINIT) NPRE=1 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170 IF(NREM.EQ.0) GOTO 170 ENDIF C...Find fastest remaining particle. 220 NPRE=NPRE+1 PMAX=0D0 DO 230 I=N+NP+1,N+2*NP IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230 IMAX=I PMAX=P(I,5) 230 CONTINUE DO 240 J=1,5 P(N+NPRE,J)=P(IMAX,J) 240 CONTINUE NREM=NREM-1 K(IMAX,4)=NPRE C...Sum up precluster around it according to pT separation. IF(MSTU(46).LE.2) THEN DO 260 I=N+NP+1,N+2*NP IF(K(I,4).NE.0) GOTO 260 R2=R2T(I,IMAX) IF(R2.GT.RINIT**2) GOTO 260 NREM=NREM-1 K(I,4)=NPRE DO 250 J=1,4 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J) 250 CONTINUE 260 CONTINUE P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2) C...Sum up precluster around it according to mass or C...Durham pT separation. ELSE 270 IMIN=0 R2MIN=RINIT**2 DO 280 I=N+NP+1,N+2*NP IF(K(I,4).NE.0) GOTO 280 IF(MSTU(46).LE.4) THEN R2=R2M(I,N+NPRE) ELSE R2=R2D(I,N+NPRE) ENDIF IF(R2.GE.R2MIN) GOTO 280 IMIN=I R2MIN=R2 280 CONTINUE IF(IMIN.NE.0) THEN DO 290 J=1,4 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J) 290 CONTINUE P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2) NREM=NREM-1 K(IMIN,4)=NPRE GOTO 270 ENDIF ENDIF C...Check if more preclusters to be found. Start over if too few. IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170 IF(NREM.GT.0) GOTO 220 NJET=NPRE C...Reassign all particles to nearest jet. Sum up new jet momenta. 300 TSAV=0D0 PSJT=0D0 310 IF(MSTU(46).LE.1) THEN DO 330 I=N+1,N+NJET DO 320 J=1,4 V(I,J)=0D0 320 CONTINUE 330 CONTINUE DO 360 I=N+NP+1,N+2*NP R2MIN=PSS**2 DO 340 IJET=N+1,N+NJET IF(P(IJET,5).LT.RINIT) GOTO 340 R2=R2T(I,IJET) IF(R2.GE.R2MIN) GOTO 340 IMIN=IJET R2MIN=R2 340 CONTINUE K(I,4)=IMIN-N DO 350 J=1,4 V(IMIN,J)=V(IMIN,J)+P(I,J) 350 CONTINUE 360 CONTINUE PSJT=0D0 DO 380 I=N+1,N+NJET DO 370 J=1,4 P(I,J)=V(I,J) 370 CONTINUE P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) PSJT=PSJT+P(I,5) 380 CONTINUE ENDIF C...Find two closest jets. R2MIN=2D0*MAX(R2ACC,PS(5)**2) DO 400 ITRY1=N+1,N+NJET-1 DO 390 ITRY2=ITRY1+1,N+NJET IF(MSTU(46).LE.2) THEN R2=R2T(ITRY1,ITRY2) ELSEIF(MSTU(46).LE.4) THEN R2=R2M(ITRY1,ITRY2) ELSE R2=R2D(ITRY1,ITRY2) ENDIF IF(R2.GE.R2MIN) GOTO 390 IMIN1=ITRY1 IMIN2=ITRY2 R2MIN=R2 390 CONTINUE 400 CONTINUE C...If allowed, join two closest jets and start over. IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN IREC=MIN(IMIN1,IMIN2) IDEL=MAX(IMIN1,IMIN2) DO 410 J=1,4 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J) 410 CONTINUE P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2) DO 430 I=IDEL+1,N+NJET DO 420 J=1,5 P(I-1,J)=P(I,J) 420 CONTINUE 430 CONTINUE IF(MSTU(46).GE.2) THEN DO 440 I=N+NP+1,N+2*NP IORI=N+K(I,4) IF(IORI.EQ.IDEL) K(I,4)=IREC-N IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1 440 CONTINUE ENDIF NJET=NJET-1 GOTO 300 C...Divide up broad jet if empty cluster in list of final ones. ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN DO 450 I=N+1,N+NJET K(I,5)=0 450 CONTINUE DO 460 I=N+NP+1,N+2*NP K(N+K(I,4),5)=K(N+K(I,4),5)+1 460 CONTINUE IEMP=0 DO 470 I=N+1,N+NJET IF(K(I,5).EQ.0) IEMP=I 470 CONTINUE IF(IEMP.NE.0) THEN NLOOP=NLOOP+1 ISPL=0 R2MAX=0D0 DO 480 I=N+NP+1,N+2*NP IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480 IJET=N+K(I,4) R2=R2T(I,IJET) IF(R2.LE.R2MAX) GOTO 480 ISPL=I R2MAX=R2 480 CONTINUE IF(ISPL.NE.0) THEN IJET=N+K(ISPL,4) DO 490 J=1,4 P(IEMP,J)=P(ISPL,J) P(IJET,J)=P(IJET,J)-P(ISPL,J) 490 CONTINUE P(IEMP,5)=P(ISPL,5) P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2) IF(NLOOP.LE.2) GOTO 300 ENDIF ENDIF ENDIF C...If generalized thrust has not yet converged, continue iteration. IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48)) &THEN TSAV=PSJT/PSS GOTO 310 ENDIF C...Reorder jets according to energy. DO 510 I=N+1,N+NJET DO 500 J=1,5 V(I,J)=P(I,J) 500 CONTINUE 510 CONTINUE DO 540 INEW=N+1,N+NJET PEMAX=0D0 DO 520 ITRY=N+1,N+NJET IF(V(ITRY,4).LE.PEMAX) GOTO 520 IMAX=ITRY PEMAX=V(ITRY,4) 520 CONTINUE K(INEW,1)=31 K(INEW,2)=97 K(INEW,3)=INEW-N K(INEW,4)=0 DO 530 J=1,5 P(INEW,J)=V(IMAX,J) 530 CONTINUE V(IMAX,4)=-1D0 K(IMAX,5)=INEW 540 CONTINUE C...Clean up particle-jet assignments and jet information. DO 550 I=N+NP+1,N+2*NP IORI=K(N+K(I,4),5) K(I,4)=IORI-N IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N K(IORI,4)=K(IORI,4)+1 550 CONTINUE IEMP=0 PSJT=0D0 DO 570 I=N+1,N+NJET K(I,5)=0 PSJT=PSJT+P(I,5) P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0)) DO 560 J=1,5 V(I,J)=0D0 560 CONTINUE IF(K(I,4).EQ.0) IEMP=I 570 CONTINUE C...Select storing option. Output variables. Check for failure. MSTU(61)=N+1 MSTU(62)=NP MSTU(63)=NPRE PARU(61)=PS(5) PARU(62)=PSJT/PSS PARU(63)=SQRT(R2MIN) IF(NJET.LE.1) PARU(63)=0D0 IF(IEMP.NE.0) THEN CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested') NJET=-1 RETURN ENDIF IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET) IF(MSTU(43).GE.2) N=N+MAX(0,NJET) NSAV=NJET RETURN END C********************************************************************* C...PYCELL C...Provides a simple way of jet finding in eta-phi-ET coordinates, C...as used for calorimeters at hadron colliders. SUBROUTINE PYCELL(NJET) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Loop over all particles. Find cell that was hit by given particle. PTLRAT=1D0/SINH(PARU(51))**2 NP=0 NC=N DO 110 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. & K(I,2).EQ.KSUSY1+39) GOTO 110 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) & GOTO 110 ENDIF NP=NP+1 PT=SQRT(P(I,1)**2+P(I,2)**2) ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3)) IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0* & (ETA/PARU(51)+1D0)))) PHI=PYANGL(P(I,1),P(I,2)) IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0* & (PHI/PARU(1)+1D0)))) IETPH=MSTU(52)*IETA+IPHI C...Add to cell already hit, or book new cell. DO 100 IC=N+1,NC IF(IETPH.EQ.K(IC,3)) THEN K(IC,4)=K(IC,4)+1 P(IC,5)=P(IC,5)+PT GOTO 110 ENDIF 100 CONTINUE IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS') NJET=-2 RETURN ENDIF NC=NC+1 K(NC,3)=IETPH K(NC,4)=1 K(NC,5)=2 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51)) P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52)) P(NC,5)=PT 110 CONTINUE C...Smear true bin content by calorimeter resolution. IF(MSTU(53).GE.1) THEN DO 130 IC=N+1,NC PEI=P(IC,5) IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1)) 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)* & COS(PARU(2)*PYR(0)) IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120 P(IC,5)=PEF IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1)) 130 CONTINUE ENDIF C...Remove cells below threshold. IF(PARU(58).GT.0D0) THEN NCC=NC NC=N DO 140 IC=N+1,NCC IF(P(IC,5).GT.PARU(58)) THEN NC=NC+1 K(NC,3)=K(IC,3) K(NC,4)=K(IC,4) K(NC,5)=K(IC,5) P(NC,1)=P(IC,1) P(NC,2)=P(IC,2) P(NC,5)=P(IC,5) ENDIF 140 CONTINUE ENDIF C...Find initiator cell: the one with highest pT of not yet used ones. NJ=NC 150 ETMAX=0D0 DO 160 IC=N+1,NC IF(K(IC,5).NE.2) GOTO 160 IF(P(IC,5).LE.ETMAX) GOTO 160 ICMAX=IC ETA=P(IC,1) PHI=P(IC,2) ETMAX=P(IC,5) 160 CONTINUE IF(ETMAX.LT.PARU(52)) GOTO 220 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS') NJET=-2 RETURN ENDIF K(ICMAX,5)=1 NJ=NJ+1 K(NJ,4)=0 K(NJ,5)=1 P(NJ,1)=ETA P(NJ,2)=PHI P(NJ,3)=0D0 P(NJ,4)=0D0 P(NJ,5)=0D0 C...Sum up unused cells within required distance of initiator. DO 170 IC=N+1,NC IF(K(IC,5).EQ.0) GOTO 170 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170 DPHIA=ABS(P(IC,2)-PHI) IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170 PHIC=P(IC,2) IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI) IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170 K(IC,5)=-K(IC,5) K(NJ,4)=K(NJ,4)+K(IC,4) P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1) P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC P(NJ,5)=P(NJ,5)+P(IC,5) 170 CONTINUE C...Reject cluster below minimum ET, else accept. IF(P(NJ,5).LT.PARU(53)) THEN NJ=NJ-1 DO 180 IC=N+1,NC IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5) 180 CONTINUE ELSEIF(MSTU(54).LE.2) THEN P(NJ,3)=P(NJ,3)/P(NJ,5) P(NJ,4)=P(NJ,4)/P(NJ,5) IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2), & P(NJ,4)) DO 190 IC=N+1,NC IF(K(IC,5).LT.0) K(IC,5)=0 190 CONTINUE ELSE DO 200 J=1,4 P(NJ,J)=0D0 200 CONTINUE DO 210 IC=N+1,NC IF(K(IC,5).GE.0) GOTO 210 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2)) P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2)) P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1)) P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1)) K(IC,5)=0 210 CONTINUE ENDIF GOTO 150 C...Arrange clusters in falling ET sequence. 220 DO 250 I=1,NJ-NC ETMAX=0D0 DO 230 IJ=NC+1,NJ IF(K(IJ,5).EQ.0) GOTO 230 IF(P(IJ,5).LT.ETMAX) GOTO 230 IJMAX=IJ ETMAX=P(IJ,5) 230 CONTINUE K(IJMAX,5)=0 K(N+I,1)=31 K(N+I,2)=98 K(N+I,3)=I K(N+I,4)=K(IJMAX,4) K(N+I,5)=0 DO 240 J=1,5 P(N+I,J)=P(IJMAX,J) V(N+I,J)=0D0 240 CONTINUE 250 CONTINUE NJET=NJ-NC C...Convert to massless or massive four-vectors. IF(MSTU(54).EQ.2) THEN DO 260 I=N+1,N+NJET ETA=P(I,3) P(I,1)=P(I,5)*COS(P(I,4)) P(I,2)=P(I,5)*SIN(P(I,4)) P(I,3)=P(I,5)*SINH(ETA) P(I,4)=P(I,5)*COSH(ETA) P(I,5)=0D0 260 CONTINUE ELSEIF(MSTU(54).GE.3) THEN DO 270 I=N+1,N+NJET P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2)) 270 CONTINUE ENDIF C...Information about storage. MSTU(61)=N+1 MSTU(62)=NP MSTU(63)=NC-N IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET) IF(MSTU(43).GE.2) N=N+MAX(0,NJET) RETURN END C********************************************************************* C...PYJMAS C...Determines, approximately, the two jet masses that minimize C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler. SUBROUTINE PYJMAS(PMH,PML) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local arrays. DIMENSION SM(3,3),SAX(3),PS(3,5) C...Reset. NP=0 DO 120 J1=1,3 DO 100 J2=J1,3 SM(J1,J2)=0D0 100 CONTINUE DO 110 J2=1,4 PS(J1,J2)=0D0 110 CONTINUE 120 CONTINUE PSS=0D0 PIMASS=PMAS(PYCOMP(211),1) C...Take copy of particles that are to be considered in mass analysis. DO 170 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. & K(I,2).EQ.KSUSY1+39) GOTO 170 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) & GOTO 170 ENDIF IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS') PMH=-2D0 PML=-2D0 RETURN ENDIF NP=NP+1 DO 130 J=1,5 P(N+NP,J)=P(I,J) 130 CONTINUE IF(MSTU(42).EQ.0) P(N+NP,5)=0D0 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) C...Fill information in sphericity tensor and total momentum vector. DO 150 J1=1,3 DO 140 J2=J1,3 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2) 140 CONTINUE 150 CONTINUE PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2) DO 160 J=1,4 PS(3,J)=PS(3,J)+P(N+NP,J) 160 CONTINUE 170 CONTINUE C...Very low multiplicities (0 or 1) not considered. IF(NP.LE.1) THEN CALL PYERRM(8,'(PYJMAS:) too few particles for analysis') PMH=-1D0 PML=-1D0 RETURN ENDIF PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2- &PS(3,3)**2)) C...Find largest eigenvalue to matrix (third degree equation). DO 190 J1=1,3 DO 180 J2=J1,3 SM(J1,J2)=SM(J1,J2)/PSS 180 CONTINUE 190 CONTINUE SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)- &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+ &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+ &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0) SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP) C...Find largest eigenvector by solving equation system. DO 210 J1=1,3 SM(J1,J1)=SM(J1,J1)-SMA DO 200 J2=J1+1,3 SM(J2,J1)=SM(J1,J2) 200 CONTINUE 210 CONTINUE SMAX=0D0 DO 230 J1=1,3 DO 220 J2=1,3 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220 JA=J1 JB=J2 SMAX=ABS(SM(J1,J2)) 220 CONTINUE 230 CONTINUE SMAX=0D0 DO 250 J3=JA+1,JA+2 J1=J3-3*((J3-1)/3) RL=SM(J1,JB)/SM(JA,JB) DO 240 J2=1,3 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2) IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240 JC=J1 SMAX=ABS(SM(J1,J2)) 240 CONTINUE 250 CONTINUE JB1=JB+1-3*(JB/3) JB2=JB+2-3*((JB+1)/3) SAX(JB1)=-SM(JC,JB2) SAX(JB2)=SM(JC,JB1) SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB) C...Divide particles into two initial clusters by hemisphere. DO 270 I=N+1,N+NP PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3) IS=1 IF(PSAX.LT.0D0) IS=2 K(I,3)=IS DO 260 J=1,4 PS(IS,J)=PS(IS,J)+P(I,J) 260 CONTINUE 270 CONTINUE PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+ &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2) C...Reassign one particle at a time; find maximum decrease of m^2 sum. 280 PMD=0D0 IM=0 DO 290 J=1,4 PS(3,J)=PS(1,J)-PS(2,J) 290 CONTINUE DO 300 I=N+1,N+NP PPS=P(I,4)*PS(3,4)-P(I,1)*PS(3,1)-P(I,2)*PS(3,2)-P(I,3)*PS(3,3) IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS) IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS) IF(PMDI.LT.PMD) THEN PMD=PMDI IM=I ENDIF 300 CONTINUE C...Loop back if significant reduction in sum of m^2. IF(PMD.LT.-PARU(48)*PMS) THEN PMS=PMS+PMD IS=K(IM,3) DO 310 J=1,4 PS(IS,J)=PS(IS,J)-P(IM,J) PS(3-IS,J)=PS(3-IS,J)+P(IM,J) 310 CONTINUE K(IM,3)=3-IS GOTO 280 ENDIF C...Final masses and output. MSTU(61)=N+1 MSTU(62)=NP PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)) PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)) PMH=MAX(PS(1,5),PS(2,5)) PML=MIN(PS(1,5),PS(2,5)) RETURN END C********************************************************************* C...PYFOWO C...Calculates the first few Fox-Wolfram moments. SUBROUTINE PYFOWO(H10,H20,H30,H40) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Copy momenta for particles and calculate H0. NP=0 H0=0D0 HD=0D0 DO 110 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. & K(I,2).EQ.KSUSY1+39) GOTO 110 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) & GOTO 110 ENDIF IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS') H10=-1D0 H20=-1D0 H30=-1D0 H40=-1D0 RETURN ENDIF NP=NP+1 DO 100 J=1,3 P(N+NP,J)=P(I,J) 100 CONTINUE P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) H0=H0+P(N+NP,4) HD=HD+P(N+NP,4)**2 110 CONTINUE H0=H0**2 C...Very low multiplicities (0 or 1) not considered. IF(NP.LE.1) THEN CALL PYERRM(8,'(PYFOWO:) too few particles for analysis') H10=-1D0 H20=-1D0 H30=-1D0 H40=-1D0 RETURN ENDIF C...Calculate H1 - H4. H10=0D0 H20=0D0 H30=0D0 H40=0D0 DO 130 I1=N+1,N+NP DO 120 I2=I1+1,N+NP CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/ & (P(I1,4)*P(I2,4)) H10=H10+P(I1,4)*P(I2,4)*CTHE H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0) H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE) H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+ & 0.375D0) 120 CONTINUE 130 CONTINUE C...Calculate H1/H0 - H4/H0. Output. MSTU(61)=N+1 MSTU(62)=NP H10=(HD+2D0*H10)/H0 H20=(HD+2D0*H20)/H0 H30=(HD+2D0*H30)/H0 H40=(HD+2D0*H40)/H0 RETURN END C********************************************************************* C...PYTABU C...Evaluates various properties of an event, with statistics C...accumulated during the course of the run and C...printed at the end. SUBROUTINE PYTABU(MTABU) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/ C...Local arrays, character variables, saved variables and data. DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4), &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4), &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25), &KFDM(8),KFDC(200,0:8),NPDC(200) SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS, &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA, &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/, &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/, &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/, &NEVDC/0/,NKFDC/0/,NREDC/0/ C...Reset statistics on initial parton state. IF(MTABU.EQ.10) THEN NEVIS=0 NKFIS=0 C...Identify and order flavour content of initial state. ELSEIF(MTABU.EQ.11) THEN NEVIS=NEVIS+1 KFM1=2*IABS(MSTU(161)) IF(MSTU(161).GT.0) KFM1=KFM1-1 KFM2=2*IABS(MSTU(162)) IF(MSTU(162).GT.0) KFM2=KFM2-1 KFMN=MIN(KFM1,KFM2) KFMX=MAX(KFM1,KFM2) DO 100 I=1,NKFIS IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN IKFIS=-I GOTO 110 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND. & KFMX.LT.KFIS(I,2))) THEN IKFIS=I GOTO 110 ENDIF 100 CONTINUE IKFIS=NKFIS+1 110 IF(IKFIS.LT.0) THEN IKFIS=-IKFIS ELSE IF(NKFIS.GE.100) RETURN DO 130 I=NKFIS,IKFIS,-1 KFIS(I+1,1)=KFIS(I,1) KFIS(I+1,2)=KFIS(I,2) DO 120 J=0,10 NPIS(I+1,J)=NPIS(I,J) 120 CONTINUE 130 CONTINUE NKFIS=NKFIS+1 KFIS(IKFIS,1)=KFMN KFIS(IKFIS,2)=KFMX DO 140 J=0,10 NPIS(IKFIS,J)=0 140 CONTINUE ENDIF NPIS(IKFIS,0)=NPIS(IKFIS,0)+1 C...Count number of partons in initial state. NP=0 DO 160 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0) & THEN ELSE IM=I 150 IM=K(IM,3) IF(IM.LE.0.OR.IM.GT.N) THEN NP=NP+1 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN NP=NP+1 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10) & .NE.0) THEN ELSE GOTO 150 ENDIF ENDIF 160 CONTINUE NPCO=MAX(NP,1) IF(NP.GE.6) NPCO=6 IF(NP.GE.8) NPCO=7 IF(NP.GE.11) NPCO=8 IF(NP.GE.16) NPCO=9 IF(NP.GE.26) NPCO=10 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1 MSTU(62)=NP C...Write statistics on initial parton state. ELSEIF(MTABU.EQ.12) THEN FAC=1D0/MAX(1,NEVIS) WRITE(MSTU(11),5000) NEVIS DO 170 I=1,NKFIS KFMN=KFIS(I,1) IF(KFMN.EQ.0) KFMN=KFIS(I,2) KFM1=(KFMN+1)/2 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1 CALL PYNAME(KFM1,CHAU) CHIS(1)=CHAU(1:12) IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?' KFMX=KFIS(I,2) IF(KFIS(I,1).EQ.0) KFMX=0 KFM2=(KFMX+1)/2 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2 CALL PYNAME(KFM2,CHAU) CHIS(2)=CHAU(1:12) IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?' WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0), & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10) 170 CONTINUE C...Copy statistics on initial parton state into /PYJETS/. ELSEIF(MTABU.EQ.13) THEN FAC=1D0/MAX(1,NEVIS) DO 190 I=1,NKFIS KFMN=KFIS(I,1) IF(KFMN.EQ.0) KFMN=KFIS(I,2) KFM1=(KFMN+1)/2 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1 KFMX=KFIS(I,2) IF(KFIS(I,1).EQ.0) KFMX=0 KFM2=(KFMX+1)/2 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2 K(I,1)=32 K(I,2)=99 K(I,3)=KFM1 K(I,4)=KFM2 K(I,5)=NPIS(I,0) DO 180 J=1,5 P(I,J)=FAC*NPIS(I,J) V(I,J)=FAC*NPIS(I,J+5) 180 CONTINUE 190 CONTINUE N=NKFIS DO 200 J=1,5 K(N+1,J)=0 P(N+1,J)=0D0 V(N+1,J)=0D0 200 CONTINUE K(N+1,1)=32 K(N+1,2)=99 K(N+1,5)=NEVIS MSTU(3)=1 C...Reset statistics on number of particles/partons. ELSEIF(MTABU.EQ.20) THEN NEVFS=0 NPRFS=0 NFIFS=0 NCHFS=0 NKFFS=0 C...Identify whether particle/parton is primary or not. ELSEIF(MTABU.EQ.21) THEN NEVFS=NEVFS+1 MSTU(62)=0 DO 260 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260 MSTU(62)=MSTU(62)+1 KC=PYCOMP(K(I,2)) MPRI=0 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN MPRI=1 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN MPRI=1 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN MPRI=1 ELSEIF(KC.EQ.0) THEN ELSEIF(K(K(I,3),1).EQ.13) THEN IM=K(K(I,3),3) IF(IM.LE.0.OR.IM.GT.N) THEN MPRI=1 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN MPRI=1 ENDIF ELSEIF(KCHG(KC,2).EQ.0) THEN KCM=PYCOMP(K(K(I,3),2)) IF(KCM.NE.0) THEN IF(KCHG(KCM,2).NE.0) MPRI=1 ENDIF ENDIF IF(KC.NE.0.AND.MPRI.EQ.1) THEN IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1 ENDIF IF(K(I,1).LE.10) THEN NFIFS=NFIFS+1 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1 ENDIF C...Fill statistics on number of particles/partons in event. KFA=IABS(K(I,2)) KFS=3-ISIGN(1,K(I,2))-MPRI DO 210 IP=1,NKFFS IF(KFA.EQ.KFFS(IP)) THEN IKFFS=-IP GOTO 220 ELSEIF(KFA.LT.KFFS(IP)) THEN IKFFS=IP GOTO 220 ENDIF 210 CONTINUE IKFFS=NKFFS+1 220 IF(IKFFS.LT.0) THEN IKFFS=-IKFFS ELSE IF(NKFFS.GE.400) RETURN DO 240 IP=NKFFS,IKFFS,-1 KFFS(IP+1)=KFFS(IP) DO 230 J=1,4 NPFS(IP+1,J)=NPFS(IP,J) 230 CONTINUE 240 CONTINUE NKFFS=NKFFS+1 KFFS(IKFFS)=KFA DO 250 J=1,4 NPFS(IKFFS,J)=0 250 CONTINUE ENDIF NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1 260 CONTINUE C...Write statistics on particle/parton composition of events. ELSEIF(MTABU.EQ.22) THEN FAC=1D0/MAX(1,NEVFS) WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS DO 270 I=1,NKFFS CALL PYNAME(KFFS(I),CHAU) KC=PYCOMP(KFFS(I)) MDCYF=0 IF(KC.NE.0) MDCYF=MDCY(KC,1) WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4), & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)) 270 CONTINUE C...Copy particle/parton composition information into /PYJETS/. ELSEIF(MTABU.EQ.23) THEN FAC=1D0/MAX(1,NEVFS) DO 290 I=1,NKFFS K(I,1)=32 K(I,2)=99 K(I,3)=KFFS(I) K(I,4)=0 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4) DO 280 J=1,4 P(I,J)=FAC*NPFS(I,J) V(I,J)=0D0 280 CONTINUE P(I,5)=FAC*K(I,5) V(I,5)=0D0 290 CONTINUE N=NKFFS DO 300 J=1,5 K(N+1,J)=0 P(N+1,J)=0D0 V(N+1,J)=0D0 300 CONTINUE K(N+1,1)=32 K(N+1,2)=99 K(N+1,5)=NEVFS P(N+1,1)=FAC*NPRFS P(N+1,2)=FAC*NFIFS P(N+1,3)=FAC*NCHFS MSTU(3)=1 C...Reset factorial moments statistics. ELSEIF(MTABU.EQ.30) THEN NEVFM=0 NMUFM=0 DO 330 IM=1,3 DO 320 IB=1,10 DO 310 IP=1,4 FM1FM(IM,IB,IP)=0D0 FM2FM(IM,IB,IP)=0D0 310 CONTINUE 320 CONTINUE 330 CONTINUE C...Find particles to include, with (pion,pseudo)rapidity and azimuth. ELSEIF(MTABU.EQ.31) THEN NEVFM=NEVFM+1 NLOW=N+MSTU(3) NUPP=NLOW DO 410 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. & K(I,2).EQ.KSUSY1+39) GOTO 410 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND. & PYCHGE(K(I,2)).EQ.0) GOTO 410 ENDIF PMR=0D0 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211) IF(MSTU(42).GE.2) PMR=P(I,5) PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2) YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR), & 1D20)),P(I,3)) IF(ABS(YETA).GT.PARU(57)) GOTO 410 PHI=PYANGL(P(I,1),P(I,2)) IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57)) IYETA=MAX(0,MIN(511,IYETA)) IPHI=512D0*(PHI+PARU(1))/PARU(2) IPHI=MAX(0,MIN(511,IPHI)) IYEP=0 DO 340 IB=0,9 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2)) 340 CONTINUE C...Order particles in (pseudo)rapidity and/or azimuth. IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS') RETURN ENDIF NUPP=NUPP+1 IF(NUPP.EQ.NLOW+1) THEN K(NUPP,1)=IYETA K(NUPP,2)=IPHI K(NUPP,3)=IYEP ELSE DO 350 I1=NUPP-1,NLOW+1,-1 IF(IYETA.GE.K(I1,1)) GOTO 360 K(I1+1,1)=K(I1,1) 350 CONTINUE 360 K(I1+1,1)=IYETA DO 370 I1=NUPP-1,NLOW+1,-1 IF(IPHI.GE.K(I1,2)) GOTO 380 K(I1+1,2)=K(I1,2) 370 CONTINUE 380 K(I1+1,2)=IPHI DO 390 I1=NUPP-1,NLOW+1,-1 IF(IYEP.GE.K(I1,3)) GOTO 400 K(I1+1,3)=K(I1,3) 390 CONTINUE 400 K(I1+1,3)=IYEP ENDIF 410 CONTINUE K(NUPP+1,1)=2**10 K(NUPP+1,2)=2**10 K(NUPP+1,3)=4**10 C...Calculate sum of factorial moments in event. DO 480 IM=1,3 DO 430 IB=1,10 DO 420 IP=1,4 FEVFM(IB,IP)=0D0 420 CONTINUE 430 CONTINUE DO 450 IB=1,10 IF(IM.LE.2) IBIN=2**(10-IB) IF(IM.EQ.3) IBIN=4**(10-IB) IAGR=K(NLOW+1,IM)/IBIN NAGR=1 DO 440 I=NLOW+2,NUPP+1 ICUT=K(I,IM)/IBIN IF(ICUT.EQ.IAGR) THEN NAGR=NAGR+1 ELSE IF(NAGR.EQ.1) THEN ELSEIF(NAGR.EQ.2) THEN FEVFM(IB,1)=FEVFM(IB,1)+2D0 ELSEIF(NAGR.EQ.3) THEN FEVFM(IB,1)=FEVFM(IB,1)+6D0 FEVFM(IB,2)=FEVFM(IB,2)+6D0 ELSEIF(NAGR.EQ.4) THEN FEVFM(IB,1)=FEVFM(IB,1)+12D0 FEVFM(IB,2)=FEVFM(IB,2)+24D0 FEVFM(IB,3)=FEVFM(IB,3)+24D0 ELSE FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0) FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0) FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)* & (NAGR-3D0) FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)* & (NAGR-3D0)*(NAGR-4D0) ENDIF IAGR=ICUT NAGR=1 ENDIF 440 CONTINUE 450 CONTINUE C...Add results to total statistics. DO 470 IB=10,1,-1 DO 460 IP=1,4 IF(FEVFM(1,IP).LT.0.5D0) THEN FEVFM(IB,IP)=0D0 ELSEIF(IM.LE.2) THEN FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP) ELSE FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP) ENDIF FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP) FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2 460 CONTINUE 470 CONTINUE 480 CONTINUE NMUFM=NMUFM+(NUPP-NLOW) MSTU(62)=NUPP-NLOW C...Write accumulated statistics on factorial moments. ELSEIF(MTABU.EQ.32) THEN FAC=1D0/MAX(1,NEVFM) IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta' IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi' IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y ' DO 510 IM=1,3 WRITE(MSTU(11),5500) DO 500 IB=1,10 BYETA=2D0*PARU(57) IF(IM.NE.2) BYETA=BYETA/2**(IB-1) BPHI=PARU(2) IF(IM.NE.1) BPHI=BPHI/2**(IB-1) IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1)) IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1)) DO 490 IP=1,4 FMOMA(IP)=FAC*FM1FM(IM,IB,IP) FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)- & FMOMA(IP)**2))) 490 CONTINUE WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP), & IP=1,4) 500 CONTINUE 510 CONTINUE C...Copy statistics on factorial moments into /PYJETS/. ELSEIF(MTABU.EQ.33) THEN FAC=1D0/MAX(1,NEVFM) DO 540 IM=1,3 DO 530 IB=1,10 I=10*(IM-1)+IB K(I,1)=32 K(I,2)=99 K(I,3)=1 IF(IM.NE.2) K(I,3)=2**(IB-1) K(I,4)=1 IF(IM.NE.1) K(I,4)=2**(IB-1) K(I,5)=0 P(I,1)=2D0*PARU(57)/K(I,3) V(I,1)=PARU(2)/K(I,4) DO 520 IP=1,4 P(I,IP+1)=FAC*FM1FM(IM,IB,IP) V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)- & P(I,IP+1)**2))) 520 CONTINUE 530 CONTINUE 540 CONTINUE N=30 DO 550 J=1,5 K(N+1,J)=0 P(N+1,J)=0D0 V(N+1,J)=0D0 550 CONTINUE K(N+1,1)=32 K(N+1,2)=99 K(N+1,5)=NEVFM MSTU(3)=1 C...Reset statistics on Energy-Energy Correlation. ELSEIF(MTABU.EQ.40) THEN NEVEE=0 DO 560 J=1,25 FE1EC(J)=0D0 FE2EC(J)=0D0 FE1EC(51-J)=0D0 FE2EC(51-J)=0D0 FE1EA(J)=0D0 FE2EA(J)=0D0 560 CONTINUE C...Find particles to include, with proper assumed mass. ELSEIF(MTABU.EQ.41) THEN NEVEE=NEVEE+1 NLOW=N+MSTU(3) NUPP=NLOW ECM=0D0 DO 570 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. & K(I,2).EQ.KSUSY1+39) GOTO 570 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND. & PYCHGE(K(I,2)).EQ.0) GOTO 570 ENDIF PMR=0D0 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211) IF(MSTU(42).GE.2) PMR=P(I,5) IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS') RETURN ENDIF NUPP=NUPP+1 P(NUPP,1)=P(I,1) P(NUPP,2)=P(I,2) P(NUPP,3)=P(I,3) P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)) ECM=ECM+P(NUPP,4) 570 CONTINUE IF(NUPP.EQ.NLOW) RETURN C...Analyze Energy-Energy Correlation in event. FAC=(2D0/ECM**2)*50D0/PARU(1) DO 580 J=1,50 FEVEE(J)=0D0 580 CONTINUE DO 600 I1=NLOW+2,NUPP DO 590 I2=NLOW+1,I1-1 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/ & (P(I1,5)*P(I2,5)) THE=ACOS(MAX(-1D0,MIN(1D0,CTHE))) ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1)))) FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4) 590 CONTINUE 600 CONTINUE DO 610 J=1,25 FE1EC(J)=FE1EC(J)+FEVEE(J) FE2EC(J)=FE2EC(J)+FEVEE(J)**2 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J) FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J)) FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2 610 CONTINUE MSTU(62)=NUPP-NLOW C...Write statistics on Energy-Energy Correlation. ELSEIF(MTABU.EQ.42) THEN FAC=1D0/MAX(1,NEVEE) WRITE(MSTU(11),5700) NEVEE DO 620 J=1,25 FEEC1=FAC*FE1EC(J) FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2))) FEEC2=FAC*FE1EC(51-J) FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2))) FEECA=FAC*FE1EA(J) FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2))) WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1, & FEEC2,FEES2,FEECA,FEESA 620 CONTINUE C...Copy statistics on Energy-Energy Correlation into /PYJETS/. ELSEIF(MTABU.EQ.43) THEN FAC=1D0/MAX(1,NEVEE) DO 630 I=1,25 K(I,1)=32 K(I,2)=99 K(I,3)=0 K(I,4)=0 K(I,5)=0 P(I,1)=FAC*FE1EC(I) V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2))) P(I,2)=FAC*FE1EC(51-I) V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2))) P(I,3)=FAC*FE1EA(I) V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2))) P(I,4)=PARU(1)*(I-1)/50D0 P(I,5)=PARU(1)*I/50D0 V(I,4)=3.6D0*(I-1) V(I,5)=3.6D0*I 630 CONTINUE N=25 DO 640 J=1,5 K(N+1,J)=0 P(N+1,J)=0D0 V(N+1,J)=0D0 640 CONTINUE K(N+1,1)=32 K(N+1,2)=99 K(N+1,5)=NEVEE MSTU(3)=1 C...Reset statistics on decay channels. ELSEIF(MTABU.EQ.50) THEN NEVDC=0 NKFDC=0 NREDC=0 C...Identify and order flavour content of final state. ELSEIF(MTABU.EQ.51) THEN NEVDC=NEVDC+1 NDS=0 DO 670 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670 NDS=NDS+1 IF(NDS.GT.8) THEN NREDC=NREDC+1 RETURN ENDIF KFM=2*IABS(K(I,2)) IF(K(I,2).LT.0) KFM=KFM-1 DO 650 IDS=NDS-1,1,-1 IIN=IDS+1 IF(KFM.LT.KFDM(IDS)) GOTO 660 KFDM(IDS+1)=KFDM(IDS) 650 CONTINUE IIN=1 660 KFDM(IIN)=KFM 670 CONTINUE C...Find whether old or new final state. DO 690 IDC=1,NKFDC IF(NDS.LT.KFDC(IDC,0)) THEN IKFDC=IDC GOTO 700 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN DO 680 I=1,NDS IF(KFDM(I).LT.KFDC(IDC,I)) THEN IKFDC=IDC GOTO 700 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN GOTO 690 ENDIF 680 CONTINUE IKFDC=-IDC GOTO 700 ENDIF 690 CONTINUE IKFDC=NKFDC+1 700 IF(IKFDC.LT.0) THEN IKFDC=-IKFDC ELSEIF(NKFDC.GE.200) THEN NREDC=NREDC+1 RETURN ELSE DO 720 IDC=NKFDC,IKFDC,-1 NPDC(IDC+1)=NPDC(IDC) DO 710 I=0,8 KFDC(IDC+1,I)=KFDC(IDC,I) 710 CONTINUE 720 CONTINUE NKFDC=NKFDC+1 KFDC(IKFDC,0)=NDS DO 730 I=1,NDS KFDC(IKFDC,I)=KFDM(I) 730 CONTINUE NPDC(IKFDC)=0 ENDIF NPDC(IKFDC)=NPDC(IKFDC)+1 C...Write statistics on decay channels. ELSEIF(MTABU.EQ.52) THEN FAC=1D0/MAX(1,NEVDC) WRITE(MSTU(11),5900) NEVDC DO 750 IDC=1,NKFDC DO 740 I=1,KFDC(IDC,0) KFM=KFDC(IDC,I) KF=(KFM+1)/2 IF(2*KF.NE.KFM) KF=-KF CALL PYNAME(KF,CHAU) CHDC(I)=CHAU(1:12) IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?' 740 CONTINUE WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0)) 750 CONTINUE IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC C...Copy statistics on decay channels into /PYJETS/. ELSEIF(MTABU.EQ.53) THEN FAC=1D0/MAX(1,NEVDC) DO 780 IDC=1,NKFDC K(IDC,1)=32 K(IDC,2)=99 K(IDC,3)=0 K(IDC,4)=0 K(IDC,5)=KFDC(IDC,0) DO 760 J=1,5 P(IDC,J)=0D0 V(IDC,J)=0D0 760 CONTINUE DO 770 I=1,KFDC(IDC,0) KFM=KFDC(IDC,I) KF=(KFM+1)/2 IF(2*KF.NE.KFM) KF=-KF IF(I.LE.5) P(IDC,I)=KF IF(I.GE.6) V(IDC,I-5)=KF 770 CONTINUE V(IDC,5)=FAC*NPDC(IDC) 780 CONTINUE N=NKFDC DO 790 J=1,5 K(N+1,J)=0 P(N+1,J)=0D0 V(N+1,J)=0D0 790 CONTINUE K(N+1,1)=32 K(N+1,2)=99 K(N+1,5)=NEVDC V(N+1,5)=FAC*NREDC MSTU(3)=1 ENDIF C...Format statements for output on unit MSTU(11) (default 6). 5000 FORMAT(///20X,'Event statistics - initial state'/ &20X,'based on an analysis of ',I6,' events'// &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ', &'according to fragmenting system multiplicity'/ &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5', &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/) 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4) 5200 FORMAT(///20X,'Event statistics - final state'/ &20X,'based on an analysis of ',I7,' events'// &5X,'Mean primary multiplicity =',F10.4/ &5X,'Mean final multiplicity =',F10.4/ &5X,'Mean charged multiplicity =',F10.4// &5X,'Number of particles produced per event (directly and via ', &'decays/branchings)'/ &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles', &8X,'Total'/35X,'prim seco prim seco'/) 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6)) 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/ &20X,'based on an analysis of ',I6,' events'// &3X,'delta-',A3,' delta-phi /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...PYSTOP C...Allows users to handle STOP statemens SUBROUTINE PYSTOP(MCOD) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Write message, then stop WRITE(MSTU(11),5000) MCOD STOP C...Formats for output. 5000 FORMAT(/5X,'PYSTOP called with code: ',I4) RETURN END C********************************************************************* C...PYKCUT C...Dummy routine, which the user can replace in order to make cuts on C...the kinematics on the parton level before the matrix elements are C...evaluated and the event is generated. The cross-section estimates C...will automatically take these cuts into account, so the given C...values are for the allowed phase space region only. MCUT=0 means C...that the event has passed the cuts, MCUT=1 that it has failed. SUBROUTINE PYKCUT(MCUT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYDAT1/,/PYINT1/,/PYINT2/ C...Set default value (accepting event) for MCUT. MCUT=0 C...Read out subprocess number. ISUB=MINT(1) ISTSB=ISET(ISUB) C...Read out tau, y*, cos(theta), tau' (where defined, else =0). TAU=VINT(21) YST=VINT(22) CTH=0D0 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23) TAUP=0D0 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26) C...Calculate x_1, x_2, x_F. IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN X1=SQRT(TAU)*EXP(YST) X2=SQRT(TAU)*EXP(-YST) ELSE X1=SQRT(TAUP)*EXP(YST) X2=SQRT(TAUP)*EXP(-YST) ENDIF XF=X1-X2 C...Calculate shat, that, uhat, p_T^2. SHAT=TAU*VINT(2) SQM3=VINT(63) SQM4=VINT(64) RM3=SQM3/SHAT RM4=SQM4/SHAT BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) RPTS=4D0*VINT(71)**2/SHAT BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS)) RM34=2D0*RM3*RM4 RSQM=1D0+RM34 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L) THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH) UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH) PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2)) C...Decisions by user to be put here. C...Stop program if this routine is ever called. C...You should not copy these lines to your own routine. WRITE(MSTU(11),5000) CALL PYSTOP(6) C...Format for error printout. 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ', &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/ &1X,'Execution stopped!') RETURN END C********************************************************************* C...PYEVWT C...Dummy routine, which the user can replace in order to multiply the C...standard PYTHIA differential cross-section by a process- and C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds C...to generation of weighted events, with weight 1/WTXS, while for C...MSTP(142)=2 it corresponds to a modification of the underlying C...physics. SUBROUTINE PYEVWT(WTXS) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYDAT1/,/PYINT1/,/PYINT2/ C...Set default weight for WTXS. WTXS=1D0 C...Read out subprocess number. ISUB=MINT(1) ISTSB=ISET(ISUB) C...Read out tau, y*, cos(theta), tau' (where defined, else =0). TAU=VINT(21) YST=VINT(22) CTH=0D0 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23) TAUP=0D0 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26) C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2. X1=VINT(41) X2=VINT(42) XF=X1-X2 SHAT=VINT(44) THAT=VINT(45) UHAT=VINT(46) PT2=VINT(48) C...Modifications by user to be put here. C...Stop program if this routine is ever called. C...You should not copy these lines to your own routine. WRITE(MSTU(11),5000) CALL PYSTOP(4) C...Format for error printout. 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ', &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/ &1X,'Execution stopped!') RETURN END C********************************************************************* C...UPINIT C...Dummy routine, to be replaced by a user implementing external C...processes. Is supposed to fill the HEPRUP commonblock with info C...on incoming beams and allowed processes. C...New example: handles a standard Les Houches Events File. SUBROUTINE UPINIT C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...PYTHIA commonblock: only used to provide read unit MSTP(161). COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) SAVE /PYPARS/ C...User process initialization commonblock. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) SAVE /HEPRUP/ C...Lines to read in assumed never longer than 200 characters. PARAMETER (MAXLEN=200) CHARACTER*(MAXLEN) STRING C...Format for reading lines. CHARACTER*6 STRFMT STRFMT='(A000)' WRITE(STRFMT(3:5),'(I3)') MAXLEN C...Loop until finds line beginning with "" or "'.AND. &STRING(IBEG:IBEG+5).NE.'" or "'.AND. &STRING(IBEG:IBEG+6).NE.'