C********************************************************************* C********************************************************************* C* ** C* January 2006 ** C* ** C* The Lund Monte Carlo ** C* ** C* PYTHIA version 6.3 ** C* ** C* Torbjorn Sjostrand ** C* CERN/PH, CH-1211 Geneva, Switzerland ** C* phone +41 - 22 - 767 28 41 ** 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, Simulations 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, CERN 2006 ** 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 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 * PYTBH* auxiliaries 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 PYEXEC to administrate fragmentation and decay chain * C S PYPREP to rearrange showered partons along strings * C S PYSTRF to do string fragmentation of jet system * C S PYJURF to find boost to string junction rest frame * C S PYINDF to do independent fragmentation of one or many jets * C S PYDECY to do the decay of a particle * C S PYDCYK to select parton and hadron flavours in decays * C S PYKFDI to select parton and hadron flavours in fragm * C S PYNMES to select number of popcorn mesons * C S PYKFIN to calculate falvour prod. ratios from input params. * C S PYPTDI to select transverse momenta in fragm * C S PYZDIS to select longitudinal scaling variable in fragm * C S PYSHOW to do m-ordered timelike parton shower evolution * C S PYPTFS to do pT-ordered timelike parton shower evolution * C F PYMAEL auxiliary to PYSHOW & PYPTFS: gluon emission ME's * C S PYBOEI to include Bose-Einstein effects (crudely) * C S PYBESQ auxiliary to PYBOEI * C F PYMASS to give the mass of a particle or parton * C F PYMRUN to give the running MSbar mass of a quark * C S PYNAME to give the name of a particle or parton * C F PYCHGE to give three times the electric charge * C F PYCOMP to compress standard KF flavour code to internal KC * C S PYERRM to write error messages and abort faulty run * C F PYALEM to give the alpha_electromagnetic value * C F PYALPS to give the alpha_strong value * C F PYANGL to give the angle from known x and y components * C F PYR to provide a random number generator * C S PYRGET to save the state of the random number generator * C S PYRSET to set the state of the random number generator * C S PYROBO to rotate and/or boost an event * C S PYEDIT to remove unwanted entries from record * C S PYLIST to list event record or particle data * C S PYLOGO to write a logo * C S PYUPDA to update particle data * C F PYK to provide integer-valued event information * C F PYP to provide real-valued event information * C S PYSPHE to perform sphericity analysis * C S PYTHRU to perform thrust analysis * C S PYCLUS to perform three-dimensional cluster analysis * C S PYCELL to perform cluster analysis in (eta, phi, E_T) * C S PYJMAS to give high and low jet mass of event * C S PYFOWO to give Fox-Wolfram moments * C S PYTABU to analyze events, with tabular output * C * C S PYEEVT to administrate the generation of an e+e- event * C S PYXTEE to give the total cross-section at given CM energy * C S PYRADK to generate initial state photon radiation * C S PYXKFL to select flavour of primary qqbar pair * C S PYXJET to select (matrix element) jet multiplicity * C S PYX3JT to select kinematics of three-jet event * C S PYX4JT to select kinematics of four-jet event * C S PYXDIF to select angular orientation of event * C S PYONIA to perform generation of onium decay to gluons * C * C S PYBOOK to book a histogram * C S PYFILL to fill an entry in a histogram * C S PYFACT to multiply histogram contents by a factor * C S PYOPER to perform operations between histograms * C S PYHIST to print and reset all histograms * C S PYPLOT to print a single histogram * C S PYNULL to reset contents of a single histogram * C S PYDUMP to dump histogram contents onto a file * C * C S PYKCUT dummy routine for user kinematical cuts * C S PYEVWT dummy routine for weighting events * C S UPINIT dummy routine to initialize user processes * C S UPEVNT dummy routine to generate a user process event * C S UPVETO dummy routine to abort event at parton level * C S PDFSET dummy routine to be removed when using PDFLIB * C S STRUCTM dummy routine to be removed when using PDFLIB * C S STRUCTP dummy routine to be removed when using PDFLIB * C S SUGRA dummy routine to be removed when linking with ISAJET * C F VISAJE dummy functn. to be removed when linking with ISAJET * C S SSMSSM dummy routine to be removed when linking with ISAJET * C S FHSETFLAGS dummy routine -"- FEYNHIGGS * C S FHSETPARA dummy routine -"- FEYNHIGGS * C S FHHIGGSCORR dummy routine -"- FEYNHIGGS * C S PYTAUD dummy routine for interface to tau decay libraries * C S PYTIME dummy routine for giving date and time * C * C********************************************************************* C...PYDATA C...Default values for switches and parameters, C...and particle, decay and process data. BLOCK DATA PYDATA C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYDAT4/CHAF(500,2) CHARACTER CHAF*16 COMMON/PYDATR/MRPY(6),RRPY(100) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT6/PROC(0:500) CHARACTER PROC*28 COMMON/PYINT7/SIGT(0:6,0:6,0:5) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/, &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/, &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,/PYBINS/ 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, 0D0, 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, 326, 2006, 01, 25, 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 1D0, 1D0, 1D0, 1D0, 1D0, 1D0, 1D0, 1D0, 1D0, 1D0, 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 69*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/ END C********************************************************************* C...PYCKBD C...Check that BLOCK DATA PYDATA has been loaded. C...Should not be required, except that some compilers/linkers C...are pretty buggy in this respect. SUBROUTINE PYCKBD C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/ C...Check a few variables to see they have been sensibly initialized. IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0 &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR. &MSTP(1).GT.5) THEN C...If not, abort the run right away. WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!' WRITE(*,*) 'The program execution is stopped now!' STOP ENDIF RETURN END C********************************************************************* C...PYTEST C...A simple program (disguised as subroutine) to run at installation C...as a check that the program works as intended. SUBROUTINE PYTEST(MTEST) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/ C...Local arrays. DIMENSION PSUM(5),PINI(6),PFIN(6) C...Save defaults for values that are changed. MSTJ1=MSTJ(1) MSTJ3=MSTJ(3) MSTJ11=MSTJ(11) MSTJ42=MSTJ(42) MSTJ43=MSTJ(43) MSTJ44=MSTJ(44) PARJ17=PARJ(17) PARJ22=PARJ(22) PARJ43=PARJ(43) PARJ54=PARJ(54) MST101=MSTJ(101) MST104=MSTJ(104) MST105=MSTJ(105) MST107=MSTJ(107) MST116=MSTJ(116) C...First part: loop over simple events to be generated. IF(MTEST.GE.1) CALL PYTABU(20) NERR=0 DO 180 IEV=1,500 C...Reset parameter values. Switch on some nonstandard features. MSTJ(1)=1 MSTJ(3)=0 MSTJ(11)=1 MSTJ(42)=2 MSTJ(43)=4 MSTJ(44)=2 PARJ(17)=0.1D0 PARJ(22)=1.5D0 PARJ(43)=1D0 PARJ(54)=-0.05D0 MSTJ(101)=5 MSTJ(104)=5 MSTJ(105)=0 MSTJ(107)=1 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3 C...Ten events each for some single jets configurations. IF(IEV.LE.50) THEN ITY=(IEV+9)/10 MSTJ(3)=-1 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0) IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0) IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0) IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0) IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0) C...Ten events each for some simple jet systems; string fragmentation. ELSEIF(IEV.LE.130) THEN ITY=(IEV-41)/10 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0) IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0) IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0) IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0) IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0) IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0) IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0) IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0, & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) C...Seventy events with independent fragmentation and momentum cons. ELSEIF(IEV.LE.200) THEN ITY=1+(IEV-131)/16 MSTJ(2)=1+MOD(IEV-131,4) MSTJ(3)=1+MOD((IEV-131)/4,4) IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0) IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0) IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0, & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0, & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) C...A hundred events with random jets (check invariant mass). ELSEIF(IEV.LE.300) THEN 100 DO 110 J=1,5 PSUM(J)=0D0 110 CONTINUE NJET=2D0+6D0*PYR(0) DO 130 I=1,NJET KFL=21 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0)) IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0)) EJET=5D0+20D0*PYR(0) THETA=ACOS(2D0*PYR(0)-1D0) PHI=6.2832D0*PYR(0) IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI) IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI) IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL) DO 120 J=1,4 PSUM(J)=PSUM(J)+P(I,J) 120 CONTINUE 130 CONTINUE IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT. & (PSUM(5)+PARJ(32))**2) GOTO 100 C...Fifty e+e- continuum events with matrix elements. ELSEIF(IEV.LE.350) THEN MSTJ(101)=2 CALL PYEEVT(0,40D0) C...Fifty e+e- continuum event with varying shower options. ELSEIF(IEV.LE.400) THEN MSTJ(42)=1+MOD(IEV,2) MSTJ(43)=1+MOD(IEV/2,4) MSTJ(44)=MOD(IEV/8,3) CALL PYEEVT(0,90D0) C...Fifty e+e- continuum events with coherent shower. ELSEIF(IEV.LE.450) THEN CALL PYEEVT(0,500D0) C...Fifty Upsilon decays to ggg or gammagg with coherent shower. ELSE CALL PYONIA(5,9.46D0) ENDIF C...Generate event. Find total momentum, energy and charge. DO 140 J=1,4 PINI(J)=PYP(0,J) 140 CONTINUE PINI(6)=PYP(0,6) CALL PYEXEC DO 150 J=1,4 PFIN(J)=PYP(0,J) 150 CONTINUE PFIN(6)=PYP(0,6) C...Check conservation of energy, momentum and charge; C...usually exact, but only approximate for single jets. MERR=0 IF(IEV.LE.50) THEN IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0) & MERR=MERR+1 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3) IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1 ELSE DO 160 J=1,4 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1 160 CONTINUE IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1 ENDIF IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6), & (PFIN(J),J=1,4),PFIN(6) C...Check that all KF codes are known ones, and that partons/particles C...satisfy energy-momentum-mass relation. Store particle statistics. DO 170 I=1,N IF(K(I,1).GT.20) GOTO 170 IF(PYCOMP(K(I,2)).EQ.0) THEN WRITE(MSTU(11),5100) I MERR=MERR+1 ENDIF PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0) & THEN WRITE(MSTU(11),5200) I MERR=MERR+1 ENDIF 170 CONTINUE IF(MTEST.GE.1) CALL PYTABU(21) C...List all erroneous events and some normal ones. IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN IF(MERR.GE.1) WRITE(MSTU(11),6400) CALL PYLIST(2) ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN CALL PYLIST(1) ENDIF C...Stop execution if too many errors. IF(MERR.NE.0) NERR=NERR+1 IF(NERR.GE.10) THEN WRITE(MSTU(11),6300) CALL PYLIST(1) STOP ENDIF 180 CONTINUE C...Summarize result of run. IF(MTEST.GE.1) CALL PYTABU(22) C...Reset commonblock variables changed during run. MSTJ(1)=MSTJ1 MSTJ(3)=MSTJ3 MSTJ(11)=MSTJ11 MSTJ(42)=MSTJ42 MSTJ(43)=MSTJ43 MSTJ(44)=MSTJ44 PARJ(17)=PARJ17 PARJ(22)=PARJ22 PARJ(43)=PARJ43 PARJ(54)=PARJ54 MSTJ(101)=MST101 MSTJ(104)=MST104 MSTJ(105)=MST105 MSTJ(107)=MST107 MSTJ(116)=MST116 C...Second part: complete events of various kinds. C...Common initial values. Loop over initiating conditions. MSTP(122)=MAX(0,MIN(2,MTEST)) MDCY(PYCOMP(111),1)=0 DO 230 IPROC=1,8 C...Reset process type, kinematics cuts, and the flags used. MSEL=0 DO 190 ISUB=1,500 MSUB(ISUB)=0 190 CONTINUE CKIN(1)=2D0 CKIN(3)=0D0 MSTP(2)=1 MSTP(11)=0 MSTP(33)=0 MSTP(81)=1 MSTP(82)=1 MSTP(111)=1 MSTP(131)=0 MSTP(133)=0 PARP(131)=0.01D0 C...Prompt photon production at fixed target. IF(IPROC.EQ.1) THEN PZSUM=300D0 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212) PQSUM=2D0 MSEL=10 CKIN(3)=5D0 CALL PYINIT('FIXT','pi+','p',PZSUM) C...QCD processes at ISR energies. ELSEIF(IPROC.EQ.2) THEN PESUM=63D0 PZSUM=0D0 PQSUM=2D0 MSEL=1 CKIN(3)=5D0 CALL PYINIT('CMS','p','p',PESUM) C...W production + multiple interactions at CERN Collider. ELSEIF(IPROC.EQ.3) THEN PESUM=630D0 PZSUM=0D0 PQSUM=0D0 MSEL=12 CKIN(1)=20D0 MSTP(82)=4 MSTP(2)=2 MSTP(33)=3 CALL PYINIT('CMS','p','pbar',PESUM) C...W/Z gauge boson pairs + pileup events at the Tevatron. ELSEIF(IPROC.EQ.4) THEN PESUM=1800D0 PZSUM=0D0 PQSUM=0D0 MSUB(22)=1 MSUB(23)=1 MSUB(25)=1 CKIN(1)=200D0 MSTP(111)=0 MSTP(131)=1 MSTP(133)=2 PARP(131)=0.04D0 CALL PYINIT('CMS','p','pbar',PESUM) C...Higgs production at LHC. ELSEIF(IPROC.EQ.5) THEN PESUM=15400D0 PZSUM=0D0 PQSUM=2D0 MSUB(3)=1 MSUB(102)=1 MSUB(123)=1 MSUB(124)=1 PMAS(25,1)=300D0 CKIN(1)=200D0 MSTP(81)=0 MSTP(111)=0 CALL PYINIT('CMS','p','p',PESUM) C...Z' production at SSC. ELSEIF(IPROC.EQ.6) THEN PESUM=40000D0 PZSUM=0D0 PQSUM=2D0 MSEL=21 PMAS(32,1)=600D0 CKIN(1)=400D0 MSTP(81)=0 MSTP(111)=0 CALL PYINIT('CMS','p','p',PESUM) C...W pair production at 1 TeV e+e- collider. ELSEIF(IPROC.EQ.7) THEN PESUM=1000D0 PZSUM=0D0 PQSUM=0D0 MSUB(25)=1 MSUB(69)=1 MSTP(11)=1 CALL PYINIT('CMS','e+','e-',PESUM) C...Deep inelastic scattering at a LEP+LHC ep collider. ELSEIF(IPROC.EQ.8) THEN P(1,1)=0D0 P(1,2)=0D0 P(1,3)=8000D0 P(2,1)=0D0 P(2,2)=0D0 P(2,3)=-80D0 PESUM=8080D0 PZSUM=7920D0 PQSUM=0D0 MSUB(10)=1 CKIN(3)=50D0 MSTP(111)=0 CALL PYINIT('3MOM','p','e-',PESUM) ENDIF C...Generate 20 events of each required type. DO 220 IEV=1,20 CALL PYEVNT PESUMM=PESUM IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM C...Check conservation of energy/momentum/flavour. PINI(1)=0D0 PINI(2)=0D0 PINI(3)=PZSUM PINI(4)=PESUMM PINI(6)=PQSUM DO 200 J=1,4 PFIN(J)=PYP(0,J) 200 CONTINUE PFIN(6)=PYP(0,6) MERR=0 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3)) DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2)) DEVQ=ABS(PFIN(6)-PINI(6)) IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR. & DEVQ.GT.0.1D0) MERR=1 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6), & (PFIN(J),J=1,4),PFIN(6) C...Check that all KF codes are known ones, and that partons/particles C...satisfy energy-momentum-mass relation. DO 210 I=1,N IF(K(I,1).GT.20) GOTO 210 IF(PYCOMP(K(I,2)).EQ.0) THEN WRITE(MSTU(11),5100) I MERR=MERR+1 ENDIF PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2* & SIGN(1D0,P(I,5)) IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2) & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN WRITE(MSTU(11),5200) I MERR=MERR+1 ENDIF 210 CONTINUE C...Listing of erroneous events, and first event of each type. IF(MERR.GE.1) NERR=NERR+1 IF(NERR.GE.10) THEN WRITE(MSTU(11),6300) CALL PYLIST(1) STOP ENDIF IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN IF(MERR.GE.1) WRITE(MSTU(11),6400) CALL PYLIST(1) ENDIF 220 CONTINUE C...List statistics for each process type. IF(MTEST.GE.1) CALL PYSTAT(1) 230 CONTINUE C...Summarize result of run. IF(NERR.EQ.0) WRITE(MSTU(11),6500) IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR C...Format statements for output. 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ', &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X, &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X, &4(1X,F12.5),1X,F8.2) 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code') 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ', &'kinematics') 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ', &'wrong.'/5X,'Execution will be stopped after listing of event.') 6400 FORMAT(5X,'Faulty event follows:') 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.') 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/ &5X,'This should not have happened!') RETURN END C********************************************************************* C...PYHEPC C...Converts PYTHIA event record contents to or from C...the standard event record commonblock. SUBROUTINE PYHEPC(MCONV) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...HEPEVT commonblock. PARAMETER (NMXHEP=4000) COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) DOUBLE PRECISION PHEP,VHEP SAVE /HEPEVT/ C...Conversion from PYTHIA to standard, the easy part. IF(MCONV.EQ.1) THEN NEVHEP=0 IF(N.GT.NMXHEP) CALL PYERRM(8, & '(PYHEPC:) no more space in /HEPEVT/') NHEP=MIN(N,NMXHEP) DO 150 I=1,NHEP ISTHEP(I)=0 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1) IDHEP(I)=K(I,2) JMOHEP(1,I)=K(I,3) JMOHEP(2,I)=0 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN JDAHEP(1,I)=K(I,4) JDAHEP(2,I)=K(I,5) ELSE JDAHEP(1,I)=0 JDAHEP(2,I)=0 ENDIF DO 100 J=1,5 PHEP(J,I)=P(I,J) 100 CONTINUE DO 110 J=1,4 VHEP(J,I)=V(I,J) 110 CONTINUE C...Check if new event (from pileup). IF(I.EQ.1) THEN INEW=1 ELSE IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I ENDIF C...Fill in missing mother information. IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN IMO1=I-2 120 IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0) & THEN IMO1=IMO1-1 GOTO 120 ENDIF JMOHEP(1,I)=IMO1 JMOHEP(2,I)=IMO1+1 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN I1=K(I,3)-1 130 I1=I1+1 IF(I1.GE.I) CALL PYERRM(8, & '(PYHEPC:) translation of inconsistent event history') IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130 KC=PYCOMP(K(I1,2)) IF(I1.LT.I.AND.KC.EQ.0) GOTO 130 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130 JMOHEP(2,I)=I1 ELSEIF(K(I,2).EQ.94) THEN NJET=2 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5)) IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)= & MOD(K(I+1,4)/MSTU(5),MSTU(5)) ENDIF C...Fill in missing daughter information. IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN DO 140 I1=JDAHEP(1,I),JDAHEP(2,I) I2=MOD(K(I1,4)/MSTU(5),MSTU(5)) JDAHEP(1,I2)=I 140 CONTINUE ENDIF IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150 I1=JMOHEP(1,I) IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150 IF(JDAHEP(1,I1).EQ.0) THEN JDAHEP(1,I1)=I ELSE JDAHEP(2,I1)=I ENDIF 150 CONTINUE DO 160 I=1,NHEP IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I) 160 CONTINUE C...Conversion from standard to PYTHIA, the easy part. ELSE IF(NHEP.GT.MSTU(4)) CALL PYERRM(8, & '(PYHEPC:) no more space in /PYJETS/') N=MIN(NHEP,MSTU(4)) NKQ=0 KQSUM=0 DO 190 I=1,N K(I,1)=0 IF(ISTHEP(I).EQ.1) K(I,1)=1 IF(ISTHEP(I).EQ.2) K(I,1)=11 IF(ISTHEP(I).EQ.3) K(I,1)=21 K(I,2)=IDHEP(I) K(I,3)=JMOHEP(1,I) K(I,4)=JDAHEP(1,I) K(I,5)=JDAHEP(2,I) DO 170 J=1,5 P(I,J)=PHEP(J,I) 170 CONTINUE DO 180 J=1,4 V(I,J)=VHEP(J,I) 180 CONTINUE V(I,5)=0D0 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN I1=JDAHEP(1,I) IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))* & PHEP(5,I)/PHEP(4,I) ENDIF C...Fill in missing information on colour connection in jet systems. IF(ISTHEP(I).EQ.1) THEN KC=PYCOMP(K(I,2)) KQ=0 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) IF(KQ.NE.0) NKQ=NKQ+1 IF(KQ.NE.2) KQSUM=KQSUM+KQ IF(KQ.NE.0.AND.KQSUM.NE.0) THEN K(I,1)=2 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN IF(K(I+1,2).EQ.21) K(I,1)=2 ENDIF ENDIF 190 CONTINUE IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8, & '(PYHEPC:) input parton configuration not colour singlet') ENDIF END C********************************************************************* C...PYINIT C...Initializes the generation procedure; finds maxima of the C...differential cross-sections to be used for weighting. SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYDAT4/CHAF(500,2) CHARACTER CHAF*16 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/, &/PYINT1/,/PYINT2/,/PYINT5/ C...Local arrays and character variables. DIMENSION ALAMIN(20),NFIN(20) CHARACTER*(*) FRAME,BEAM,TARGET CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6 C...Interface to PDFLIB. COMMON/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS COMMON/W50512/QCDL4,QCDL5 SAVE /W50511/,/W50512/ DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5 CHARACTER*20 PARM(20) DATA VALUE/20*0D0/,PARM/20*' '/ C...Data:Lambda and n_f values for parton distributions.. DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0, &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/, &NFIN/20*4/ DATA CHLH/'lepton','hadron'/ C...Check that BLOCK DATA PYDATA has been loaded. CALL PYCKBD C...Reset MINT and VINT arrays. Write headers. MSTI(53)=0 DO 100 J=1,400 MINT(J)=0 VINT(J)=0D0 100 CONTINUE IF(MSTU(12).NE.12345) CALL PYLIST(0) IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) C...Reset error counters. MSTU(23)=0 MSTU(27)=0 MSTU(30)=0 C...Reset processes that should not be on. MSUB(96)=0 MSUB(97)=0 C...Call user process initialization routine. IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN MSEL=0 CALL UPINIT MSEL=0 ENDIF C...Maximum 4 generations; set maximum number of allowed flavours. MSTP(1)=MIN(4,MSTP(1)) MSTU(114)=MIN(MSTU(114),2*MSTP(1)) MSTP(58)=MIN(MSTP(58),2*MSTP(1)) C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton. DO 120 I=-20,20 VINT(180+I)=0D0 IA=IABS(I) IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN DO 110 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110 IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)= & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2) 110 CONTINUE ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN VINT(180+I)=1D0 ENDIF 120 CONTINUE C...Initialize parton distributions: PDFLIB. IF(MSTP(52).EQ.2) THEN PARM(1)='NPTYPE' VALUE(1)=1 PARM(2)='NGROUP' VALUE(2)=MSTP(51)/1000 PARM(3)='NSET' VALUE(3)=MOD(MSTP(51),1000) PARM(4)='TMAS' VALUE(4)=PMAS(6,1) CALL PDFSET(PARM,VALUE) MINT(93)=1000000+MSTP(51) ENDIF C...Choose Lambda value to use in alpha-strong. MSTU(111)=MSTP(2) IF(MSTP(3).GE.2) THEN ALAM=0.2D0 NF=4 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN ALAM=ALAMIN(MSTP(51)) NF=NFIN(MSTP(51)) ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN ALAM=QCDL5 NF=5 ELSEIF(MSTP(52).EQ.2) THEN ALAM=QCDL4 NF=4 ENDIF PARP(1)=ALAM PARP(61)=ALAM PARP(72)=ALAM PARU(112)=ALAM MSTU(112)=NF IF(MSTP(3).EQ.3) PARJ(81)=ALAM ENDIF C...Initialize the SUSY generation: couplings, masses, C...decay modes, branching ratios, and so on. CALL PYMSIN C...Initialize widths and partial widths for resonances. CALL PYINRE C...Set Z0 mass and width for e+e- routines. PARJ(123)=PMAS(23,1) PARJ(124)=PMAS(23,2) C...Identify beam and target particles and frame of process. CHFRAM=FRAME//' ' CHBEAM=BEAM//' ' CHTARG=TARGET//' ' CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN) IF(MINT(65).EQ.1) GOTO 170 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives. C...For e-gamma allow 2 alternatives. MINT(121)=1 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13 ENDIF MINT(123)=MSTP(14) IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR. &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN IF(MSTP(14).EQ.11) MINT(123)=0 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6 IF(MSTP(14).EQ.15) MINT(123)=2 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7 IF(MSTP(14).EQ.19) MINT(123)=3 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN IF(MSTP(14).EQ.21) MINT(123)=0 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4 IF(MSTP(14).EQ.24) MINT(123)=1 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9 ENDIF C...Set up kinematics of process. CALL PYINKI(0) C...Set up kinematics for photons inside leptons. IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA) C...Precalculate flavour selection weights. CALL PYKFIN C...Loop over gamma-p or gamma-gamma alternatives. CKIN3=CKIN(3) MSAV48=0 DO 160 IGA=1,MINT(121) CKIN(3)=CKIN3 MINT(122)=IGA C...Select partonic subprocesses to be included in the simulation. CALL PYINPR MINT(101)=1 MINT(102)=1 MINT(103)=MINT(11) MINT(104)=MINT(12) C...Count number of subprocesses on. MINT(48)=0 DO 130 ISUB=1,500 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND. & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN MSUB(ISUB)=0 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND. & MSUB(ISUB).EQ.1) THEN WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42)) STOP ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN WRITE(MSTU(11),5300) ISUB STOP ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN WRITE(MSTU(11),5400) ISUB STOP ELSEIF(MSUB(ISUB).EQ.1) THEN MINT(48)=MINT(48)+1 ENDIF 130 CONTINUE C...Stop or raise warning flag if no subprocesses on. IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN IF(MSTP(127).NE.1) THEN WRITE(MSTU(11),5500) STOP ELSE WRITE(MSTU(11),5700) MSTI(53)=1 ENDIF ENDIF MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94) MSAV48=MSAV48+MINT(48) C...Reset variables for cross-section calculation. DO 150 I=0,500 DO 140 J=1,3 NGEN(I,J)=0 XSEC(I,J)=0D0 140 CONTINUE 150 CONTINUE C...Find parametrized total cross-sections. CALL PYXTOT VINT(318)=VINT(317) C...Maxima of differential cross-sections. IF(MSTP(121).LE.1) CALL PYMAXI C...Initialize possibility of pileup events. IF(MINT(121).GT.1) MSTP(131)=0 IF(MSTP(131).NE.0) CALL PYPILE(1) C...Initialize multiple interactions with variable impact parameter. IF(MINT(50).EQ.1) THEN PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR. & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82)) IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN CALL PYMULT(1) CALL PYMIGN(1) ENDIF ENDIF C...Save results for gamma-p and gamma-gamma alternatives. IF(MINT(121).GT.1) CALL PYSAVE(1,IGA) 160 CONTINUE C...Initialization finished. IF(MSAV48.EQ.0) THEN IF(MSTP(127).NE.1) THEN WRITE(MSTU(11),5500) STOP ELSE WRITE(MSTU(11),5700) MSTI(53)=1 ENDIF ENDIF 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600) C...Formats for initialization information. 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ', &'routines',1X,17('*')) 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6, &'-',A6,' interactions.'/1X,'Execution stopped!') 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/ &1X,'Execution stopped!') 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/ &1X,'Execution stopped!') 5500 FORMAT(1X,'Error: no subprocess switched on.'/ &1X,'Execution stopped.') 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X, &22('*')) 5700 FORMAT(1X,'Error: no subprocess switched on.'/ &1X,'Execution will stop if you try to generate events.') RETURN END C********************************************************************* C...PYEVNT C...Administers the generation of a high-pT event via calls to C...a number of subroutines. SUBROUTINE PYEVNT C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/, &/PYINT2/,/PYINT4/,/PYINT5/ C...Local array. DIMENSION VTX(4) C...Optionally let PYEVNW do the whole job. IF(MSTP(81).GE.20) THEN CALL PYEVNW RETURN ENDIF C...Stop if no subprocesses on. IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN WRITE(MSTU(11),5100) STOP ENDIF C...Initial values for some counters. N=0 MINT(5)=MINT(5)+1 MINT(7)=0 MINT(8)=0 MINT(30)=0 MINT(83)=0 MINT(84)=MSTP(126) MSTU(24)=0 MSTU70=0 MSTJ14=MSTJ(14) C...Normally, use K(I,4:5) colour info rather than /PYCTAG/. 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(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...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.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...Parameter statement for maximum size of showers. PARAMETER (MAXNUP=500) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYCTAG/NCT,MCT(4000,2) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), & XMI(2,240),PT2MI(240),IMISEP(0:240) SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/, & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/ C...Local arrays. DIMENSION VTX(4) C...Stop if no subprocesses on. IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN WRITE(MSTU(11),5100) STOP ENDIF C...Initial values for some counters. N=0 MINT(5)=MINT(5)+1 MINT(7)=0 MINT(8)=0 MINT(30)=0 MINT(83)=0 MINT(84)=MSTP(126) MSTU(24)=0 MSTU70=0 MSTJ14=MSTJ(14) C...Normally, use K(I,4:5) colour info rather than /PYCT/. 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, & '(PYEVNT:) 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(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 PT2MXS=0.25D0*VINT(2) C...Loopback point in case of failure in evolution. LOOP=0 130 LOOP=LOOP+1 MINT(51)=0 IF(LOOP.GT.100) THEN CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or ' & //'multiple interactions.') MINT(51)=1 RETURN ENDIF C...Pre-initialization of interleaved MI/ISR/JI evolution, only done C...once per event. (E.g. compute constants and save variables to be C...restored later in case of failure.) IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2) C...Initialize interleaved MI/ISR/JI evolution. C...PT2MAX: absolute upper limit for evolution - Initialization may C... return a PT2MAX which is lower than this. C...PT2MIN: absolute lower limit for evolution - Initialization may C... return a PT2MIN which is larger than this (e.g. Lambda_QCD). PT2MAX=PT2MXS PT2MIN=0D0 CALL PYEVOL(0,PT2MAX,PT2MIN) IF (MINT(51).EQ.1) GOTO 130 C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN. C...In principle factorized, so can be stopped and restarted. C...Example: stop/start at pT=10 GeV. (Commented out for now.) C PT2MED=MAX(10D0**2,PT2MIN) C CALL PYEVOL(1,PT2MAX,PT2MED) C IF (MINT(51).EQ.1) GOTO 160 C PT2MAX=PT2MED CALL PYEVOL(1,PT2MAX,PT2MIN) IF (MINT(51).EQ.1) GOTO 130 C...Finalize interleaved MI/ISR/JI evolution. CALL PYEVOL(2,PT2MAX,PT2MIN) IF (MINT(51).EQ.1) GOTO 130 ENDIF MSTP(61)=MSTP61 MSTP(81)=MSTP81 IF(MINT(51).EQ.1) GOTO 100 C...(MINT(52) is actually obsolete in this routine. Set anyway C...to ensure PYDOCU stable.) MINT(52)=N MINT(53)=N C...Beam remnants - new scheme. 140 IF(MINT(50).EQ.1) THEN IF (ISUB.EQ.95) MINT(31)=1 C...Beam remnant flavour and colour assignments - new scheme. CALL PYMIHK IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) & GOTO 120 IF(MINT(51).EQ.1) GOTO 100 C...Primordial kT and beam remnant momentum sharing - new scheme. CALL PYMIRM IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) & GOTO 120 IF(MINT(51).EQ.1) GOTO 100 IF (ISUB.EQ.95) MINT(31)=0 ELSEIF(MINT(111).NE.12) THEN C...Hadron remnants and primordial kT - old model. C...Happens e.g. for direct photon on one side. IPU1=IMI(1,1,1) IPU2=IMI(2,1,1) CALL PYREMN(IPU1,IPU2) IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO & 110 IF(MINT(51).EQ.1) GOTO 100 C...PYREMN does not set colour tags for BRs, so needs to be done now. DO 160 I=MINT(53)+1,N DO 150 KCS=4,5 IDA=MOD(K(I,KCS),MSTU(5)) IF (IDA.NE.0) THEN MCT(I,KCS-3)=MCT(IDA,6-KCS) ELSE MCT(I,KCS-3)=0 ENDIF 150 CONTINUE 160 CONTINUE C...Instruct PYPREP to use colour tags MINT(33)=1 C...Now delete any colour processing information if set (since partons C...otherwise not FS showered!) DO 170 I=MINT(84)+1,N IF (I.LE.N) THEN K(I,4)=MOD(K(I,4),MSTU(5)**2) K(I,5)=MOD(K(I,5),MSTU(5)**2) ENDIF 170 CONTINUE ENDIF C...Showering of final state partons (optional). ALAMSV=PARJ(81) PARJ(81)=PARP(72) IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10) & THEN QMAX=VINT(55) IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55) CALL PYPTFS(1,QMAX,0D0,PTGEN) ENDIF PARJ(81)=ALAMSV C...Decay of final state resonances. MINT(32)=0 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN CALL PYRESD(0) IF(MINT(51).NE.0) GOTO 100 C...External processes: handle successive showers. ELSEIF(ISET(ISUB).EQ.11) THEN CALL PYADSH(NFIN) ENDIF IF(MINT(51).EQ.1) GOTO 100 ELSEIF(ISUB.NE.99) THEN C...Diffractive and elastic scattering. CALL PYDIFF ELSE C...DIS scattering (photon flux external). CALL PYDISG IF(MINT(51).EQ.1) GOTO 100 ENDIF C...Check that no odd resonance left undecayed. MINT(54)=N IF(MSTP(111).GE.1) THEN NFIX=N DO 180 I=MINT(84)+1,NFIX IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND. & K(I,2).NE.22) THEN KCA=PYCOMP(K(I,2)) IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN CALL PYRESD(I) IF(MINT(51).EQ.1) GOTO 100 ENDIF ENDIF 180 CONTINUE ENDIF C...Boost hadronic subsystem to overall rest frame. C..(Only relevant when photon inside lepton beam.) IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA) C...Recalculate energies from momenta and masses (if desired). IF(MSTP(113).GE.1) THEN DO 190 I=MINT(83)+1,N IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+ & P(I,2)**2+P(I,3)**2+P(I,5)**2) 190 CONTINUE NRECAL=N ENDIF C...Colour promiscuity before string formation IF (MSTP(95).EQ.2.OR.MSTP(95).EQ.3) 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) 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. IF(MSTP(162).GT.0) THEN WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP DO 190 I=1,NUP 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), & VTIMUP(I),SPINUP(I) 190 CONTINUE 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,E14.6,E12.4) 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...PYINRE C...Calculates full and effective widths of gauge bosons, stores C...masses and widths, rescales coefficients to be used for C...resonance production generation. SUBROUTINE PYINRE C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYDAT4/CHAF(500,2) CHARACTER CHAF*16 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT6/PROC(0:500) CHARACTER PROC*28 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/, &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/ C...Local arrays and data. DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400), &WDTEM(0:400,0:5),KCORD(500),PMORD(500) C...Born level couplings in MSSM Higgs doublet sector. XW=PARU(102) XWV=XW IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2 XW1=1D0-XW IF(MSTP(4).EQ.2) THEN TANBE=PARU(141) RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2 SQMZ=PMAS(23,1)**2 SQMW=PMAS(24,1)**2 SQMH=PMAS(25,1)**2 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH) SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE)) SQMHC=SQMA+SQMW IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN WRITE(MSTU(11),5000) STOP ENDIF PMAS(35,1)=SQRT(SQMHP) PMAS(36,1)=SQRT(SQMA) PMAS(37,1)=SQRT(SQMHC) ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)* & (SQMA-SQMZ))) BESU=ATAN(TANBE) PARU(142)=1D0 PARU(143)=1D0 PARU(161)=-SIN(ALSU)/COS(BESU) PARU(162)=COS(ALSU)/SIN(BESU) PARU(163)=PARU(161) PARU(164)=SIN(BESU-ALSU) PARU(165)=PARU(164) PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW PARU(171)=COS(ALSU)/COS(BESU) PARU(172)=SIN(ALSU)/SIN(BESU) PARU(173)=PARU(171) PARU(174)=COS(BESU-ALSU) PARU(175)=PARU(174) PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)* & SIN(BESU+ALSU) PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU) PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW PARU(181)=TANBE PARU(182)=1D0/TANBE PARU(183)=PARU(181) PARU(184)=0D0 PARU(185)=PARU(184) PARU(186)=COS(BESU-ALSU) PARU(187)=SIN(BESU-ALSU) PARU(188)=PARU(186) PARU(189)=PARU(187) PARU(190)=0D0 PARU(195)=COS(BESU-ALSU) ENDIF C...Reset effective widths of gauge bosons. DO 110 I=1,500 DO 100 J=1,5 WIDS(I,J)=1D0 100 CONTINUE 110 CONTINUE C...Order resonances by increasing mass (except Z0 and W+/-). NRES=0 DO 140 KC=1,500 KF=KCHG(KC,4) IF(KF.EQ.0) GOTO 140 IF(MWID(KC).EQ.0) GOTO 140 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN IF(MSTP(1).LE.3) GOTO 140 ENDIF IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN IF(IMSS(1).LE.0) GOTO 140 ENDIF NRES=NRES+1 PMRES=PMAS(KC,1) IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0 DO 120 I1=NRES-1,1,-1 IF(PMRES.GE.PMORD(I1)) GOTO 130 KCORD(I1+1)=KCORD(I1) PMORD(I1+1)=PMORD(I1) 120 CONTINUE 130 KCORD(I1+1)=KC PMORD(I1+1)=PMRES 140 CONTINUE C...Loop over possible resonances. DO 180 I=1,NRES KC=KCORD(I) KF=KCHG(KC,4) C...Check that no fourth generation channels on by mistake. IF(MSTP(1).LE.3) THEN DO 150 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 KFA1=IABS(KFDP(IDC,1)) KFA2=IABS(KFDP(IDC,2)) IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR. & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18) & MDME(IDC,1)=-1 150 CONTINUE ENDIF C...Check that no supersymmetric channels on by mistake. IF(IMSS(1).LE.0) THEN DO 160 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 KFA1S=IABS(KFDP(IDC,1))/KSUSY1 KFA2S=IABS(KFDP(IDC,2))/KSUSY1 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2) & MDME(IDC,1)=-1 160 CONTINUE ENDIF C...Find mass and evaluate width. PMR=PMAS(KC,1) IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1 IF(MWID(KC).EQ.3) MINT(63)=1 CALL PYWIDT(KF,PMR**2,WDTP,WDTE) MINT(51)=0 C...Evaluate suppression factors due to non-simulated channels. IF(KCHG(KC,3).EQ.0) THEN WDTP0I=0D0 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0) WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+ & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+ & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I WIDS(KC,3)=0D0 WIDS(KC,4)=0D0 WIDS(KC,5)=0D0 ELSE IF(MWID(KC).EQ.3) MINT(63)=1 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM) MINT(51)=0 WDTP0I=0D0 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0) WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+ & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+ & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+ & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+ & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+ & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+ & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+ & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2 ENDIF C...Set resonance widths and branching ratios; C...also on/off switch for decays. IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN PMAS(KC,2)=WDTP(0) PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2)) IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41) DO 170 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 BRAT(IDC)=0D0 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0) 170 CONTINUE ENDIF 180 CONTINUE C...Flavours of leptoquark: redefine charge and name. KFLQQ=KFDP(MDCY(42,2),1) KFLQL=KFDP(MDCY(42,2),2) KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+ &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL) LL=1 IF(IABS(KFLQL).EQ.13) LL=2 IF(IABS(KFLQL).EQ.15) LL=3 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)// &CHAF(IABS(KFLQL),1)(1:LL)//' ' CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar ' C...Special cases in treatment of gamma*/Z0: redefine process name. IF(MSTP(43).EQ.1) THEN PROC(1)='f + fbar -> gamma*' PROC(15)='f + fbar -> g + gamma*' PROC(19)='f + fbar -> gamma + gamma*' PROC(30)='f + g -> f + gamma*' PROC(35)='f + gamma -> f + gamma*' ELSEIF(MSTP(43).EQ.2) THEN PROC(1)='f + fbar -> Z0' PROC(15)='f + fbar -> g + Z0' PROC(19)='f + fbar -> gamma + Z0' PROC(30)='f + g -> f + Z0' PROC(35)='f + gamma -> f + Z0' ELSEIF(MSTP(43).EQ.3) THEN PROC(1)='f + fbar -> gamma*/Z0' PROC(15)='f + fbar -> g + gamma*/Z0' PROC(19)='f+ fbar -> gamma + gamma*/Z0' PROC(30)='f + g -> f + gamma*/Z0' PROC(35)='f + gamma -> f + gamma*/Z0' ENDIF C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name. IF(MSTP(44).EQ.1) THEN PROC(141)='f + fbar -> gamma*' ELSEIF(MSTP(44).EQ.2) THEN PROC(141)='f + fbar -> Z0' ELSEIF(MSTP(44).EQ.3) THEN PROC(141)='f + fbar -> Z''0' ELSEIF(MSTP(44).EQ.4) THEN PROC(141)='f + fbar -> gamma*/Z0' ELSEIF(MSTP(44).EQ.5) THEN PROC(141)='f + fbar -> gamma*/Z''0' ELSEIF(MSTP(44).EQ.6) THEN PROC(141)='f + fbar -> Z0/Z''0' ELSEIF(MSTP(44).EQ.7) THEN PROC(141)='f + fbar -> gamma*/Z0/Z''0' ENDIF C...Special cases in treatment of WW -> WW: redefine process name. IF(MSTP(45).EQ.1) THEN PROC(77)='W+ + W+ -> W+ + W+' ELSEIF(MSTP(45).EQ.2) THEN PROC(77)='W+ + W- -> W+ + W-' ELSEIF(MSTP(45).EQ.3) THEN PROC(77)='W+/- + W+/- -> W+/- + W+/-' ENDIF C...Format for error information. 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ', &'combination'/1X,'Execution stopped!') RETURN END C********************************************************************* C...PYINBM C...Identifies the two incoming particles and the choice of frame. SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...User process initialization commonblock. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) SAVE /HEPRUP/ C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/ C...Local arrays, character variables and data. CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26, &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16 DIMENSION LEN(3),KCDE(39),PM(2) DATA CHALP/'abcdefghijklmnopqrstuvwxyz', &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ DATA CHCDE/ 'e- ','e+ ','nu_e ', &'nu_ebar ','mu- ','mu+ ','nu_mu ', &'nu_mubar ','tau- ','tau+ ','nu_tau ', &'nu_taubar ','pi+ ','pi- ','n0 ', &'nbar0 ','p+ ','pbar- ','gamma ', &'lambda0 ','sigma- ','sigma0 ','sigma+ ', &'xi- ','xi0 ','omega- ','pi0 ', &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ', &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ', &'k+ ','k- ','ks0 ','kl0 '/ DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16, &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222, &3312,3322,3334,111,110,990,6*22,321,-321,310,130/ C...Store initial energy. Default frame. VINT(290)=WIN MINT(111)=0 C...Special user process initialization; convert to normal input. IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN MINT(111)=11 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12 CALL PYNAME(IDBMUP(1),CHNAME) CHBEAM=CHNAME(1:12) CALL PYNAME(IDBMUP(2),CHNAME) CHTARG=CHNAME(1:12) ENDIF C...Convert character variables to lowercase and find their length. CHCOM(1)=CHFRAM CHCOM(2)=CHBEAM CHCOM(3)=CHTARG DO 130 I=1,3 LEN(I)=12 DO 110 LL=12,1,-1 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1 DO 100 LA=1,26 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)= & CHALP(1)(LA:LA) 100 CONTINUE 110 CONTINUE CHIDNT(I)=CHCOM(I) C...Fix up bar, underscore and charge in particle name (if needed). DO 120 LL=1,10 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN CHTEMP=CHIDNT(I) CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' ' ENDIF 120 CONTINUE IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN CHTEMP=CHIDNT(I) CHIDNT(I)='nu_'//CHTEMP(3:7) ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN CHIDNT(I)(1:3)='n0 ' ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN CHIDNT(I)(1:5)='nbar0' ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN CHIDNT(I)(1:3)='p+ ' ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR. & CHIDNT(I)(1:2).EQ.'p-') THEN CHIDNT(I)(1:5)='pbar-' ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN CHIDNT(I)(7:7)='0' ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN CHIDNT(I)(1:7)='reggeon' ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN CHIDNT(I)(1:7)='pomeron' ENDIF 130 CONTINUE C...Identify free initialization. IF(CHCOM(1)(1:2).EQ.'no') THEN MINT(65)=1 RETURN ENDIF C...Identify incoming beam and target particles. DO 160 I=1,2 DO 140 J=1,39 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J) 140 CONTINUE PM(I)=PYMASS(MINT(10+I)) VINT(2+I)=PM(I) MINT(140+I)=0 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN CHTEMP=CHIDNT(I+1)(7:12)//' ' DO 150 J=1,12 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J) 150 CONTINUE PM(I)=PYMASS(MINT(140+I)) VINT(302+I)=PM(I) ENDIF 160 CONTINUE IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2)) IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3)) IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP C...Identify choice of frame and input energies. CHINIT=' ' C...Events defined in the CM frame. IF(CHCOM(1)(1:2).EQ.'cm') THEN MINT(111)=1 S=WIN**2 IF(MSTP(122).GE.1) THEN IF(CHCOM(2)(1:1).NE.'e') THEN LOFFS=(31-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' collider'//' ' ELSE LOFFS=(30-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' collider'//' ' ENDIF WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),5300) WIN ENDIF C...Events defined in fixed target frame. ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN MINT(111)=2 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2) IF(MSTP(122).GE.1) THEN LOFFS=(29-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' fixed target'//' ' WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),5400) WIN WRITE(MSTU(11),5500) SQRT(S) ENDIF C...Frame defined by user three-vectors. ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN MINT(111)=3 P(1,5)=PM(1) P(2,5)=PM(2) P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2) P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2) S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2- & (P(1,3)+P(2,3))**2 IF(MSTP(122).GE.1) THEN LOFFS=(22-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' user configuration'//' ' WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),5600) WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4) WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4) WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) ENDIF C...Frame defined by user four-vectors. ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN MINT(111)=4 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1) PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2) S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2- & (P(1,3)+P(2,3))**2 IF(MSTP(122).GE.1) THEN LOFFS=(22-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' user configuration'//' ' WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),5600) WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4) WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4) WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) ENDIF C...Frame defined by user five-vectors. ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN MINT(111)=5 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2- & (P(1,3)+P(2,3))**2 IF(MSTP(122).GE.1) THEN LOFFS=(22-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' user configuration'//' ' WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),5600) WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4) WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4) WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) ENDIF C...Frame defined by HEPRUP common block. ELSEIF(MINT(111).GE.11) THEN S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))- & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2 IF(MSTP(122).GE.1) THEN LOFFS=(22-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' user configuration'//' ' WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2) WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) ENDIF C...Unknown frame. Error for too low CM energy. ELSE WRITE(MSTU(11),5800) CHFRAM(1:LEN(1)) STOP ENDIF IF(S.LT.PARP(2)**2) THEN WRITE(MSTU(11),5900) SQRT(S) STOP ENDIF C...Formats for initialization and error information. 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/ &1X,'Execution stopped!') 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/ &1X,'Execution stopped!') 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I') 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy', &19X,'I'/1X,'I',76X,'I'/1X,78('=')) 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I') 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X, &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('=')) 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X, &'pz (GeV/c)',6X,'E (GeV)',9X,'I') 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I') 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/ &1X,'Execution stopped!') 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ', &'generation.'/1X,'Execution stopped!') 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X, &'GeV beam energies',13X,'I') RETURN END C********************************************************************* C...PYINKI C...Sets up kinematics, including rotations and boosts to/from CM frame. SUBROUTINE PYINKI(MODKI) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...User process initialization commonblock. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) SAVE /HEPRUP/ C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/ C...Set initial flavour state. N=2 DO 100 I=1,2 K(I,1)=1 K(I,2)=MINT(10+I) IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I) 100 CONTINUE C...Reset boost. Do kinematics for various cases. DO 110 J=6,10 VINT(J)=0D0 110 CONTINUE C...Set up kinematics for events defined in CM frame. IF(MINT(111).EQ.1) THEN WIN=VINT(290) IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290) S=WIN**2 P(1,5)=VINT(3) P(2,5)=VINT(4) IF(MINT(141).NE.0) P(1,5)=VINT(303) IF(MINT(142).NE.0) P(2,5)=VINT(304) P(1,1)=0D0 P(1,2)=0D0 P(2,1)=0D0 P(2,2)=0D0 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/ & (4D0*S)) P(2,3)=-P(1,3) P(1,4)=SQRT(P(1,3)**2+P(1,5)**2) P(2,4)=SQRT(P(2,3)**2+P(2,5)**2) C...Set up kinematics for fixed target events. ELSEIF(MINT(111).EQ.2) THEN WIN=VINT(290) IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290) P(1,5)=VINT(3) P(2,5)=VINT(4) IF(MINT(141).NE.0) P(1,5)=VINT(303) IF(MINT(142).NE.0) P(2,5)=VINT(304) P(1,1)=0D0 P(1,2)=0D0 P(2,1)=0D0 P(2,2)=0D0 P(1,3)=WIN P(1,4)=SQRT(P(1,3)**2+P(1,5)**2) P(2,3)=0D0 P(2,4)=P(2,5) S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4) VINT(10)=P(1,3)/(P(1,4)+P(2,4)) CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10)) C...Set up kinematics for events in user-defined frame. ELSEIF(MINT(111).EQ.3) THEN P(1,5)=VINT(3) P(2,5)=VINT(4) IF(MINT(141).NE.0) P(1,5)=VINT(303) IF(MINT(142).NE.0) P(2,5)=VINT(304) P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2) P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2) DO 120 J=1,3 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4)) 120 CONTINUE CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) VINT(7)=PYANGL(P(1,1),P(1,2)) CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) VINT(6)=PYANGL(P(1,3),P(1,1)) CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3)) C...Set up kinematics for events with user-defined four-vectors. ELSEIF(MINT(111).EQ.4) THEN PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1) PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2) DO 130 J=1,3 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4)) 130 CONTINUE CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) VINT(7)=PYANGL(P(1,1),P(1,2)) CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) VINT(6)=PYANGL(P(1,3),P(1,1)) CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) S=(P(1,4)+P(2,4))**2 C...Set up kinematics for events with user-defined five-vectors. ELSEIF(MINT(111).EQ.5) THEN DO 140 J=1,3 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4)) 140 CONTINUE CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) VINT(7)=PYANGL(P(1,1),P(1,2)) CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) VINT(6)=PYANGL(P(1,3),P(1,1)) CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) S=(P(1,4)+P(2,4))**2 C...Set up kinematics for events with external user processes. ELSEIF(MINT(111).GE.11) THEN P(1,5)=VINT(3) P(2,5)=VINT(4) IF(MINT(141).NE.0) P(1,5)=VINT(303) IF(MINT(142).NE.0) P(2,5)=VINT(304) P(1,1)=0D0 P(1,2)=0D0 P(2,1)=0D0 P(2,2)=0D0 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2)) P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2)) P(1,4)=EBMUP(1) P(2,4)=EBMUP(2) VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4)) CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10)) S=(P(1,4)+P(2,4))**2 ENDIF C...Return or error for too low CM energy. IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN IF(MSTP(172).LE.1) THEN CALL PYERRM(23, & '(PYINKI:) too low invariant mass in this event') ELSE MSTI(61)=1 RETURN ENDIF ENDIF C...Save information on incoming particles. VINT(1)=SQRT(S) VINT(2)=S IF(MINT(111).GE.4) THEN IF(MINT(141).EQ.0) THEN VINT(3)=P(1,5) IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2 ELSE VINT(303)=P(1,5) ENDIF IF(MINT(142).EQ.0) THEN VINT(4)=P(2,5) IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2 ELSE VINT(304)=P(2,5) ENDIF ENDIF VINT(5)=P(1,3) IF(MODKI.EQ.0) VINT(289)=S DO 150 J=1,5 V(1,J)=0D0 V(2,J)=0D0 VINT(290+J)=P(1,J) VINT(295+J)=P(2,J) 150 CONTINUE C...Store pT cut-off and related constants to be used in generation. IF(MODKI.EQ.0) VINT(285)=CKIN(3) IF(MSTP(82).LE.1) THEN PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90) ELSE PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) ENDIF VINT(149)=4D0*PTMN**2/S VINT(154)=PTMN RETURN END C********************************************************************* C...PYINPR C...Selects partonic subprocesses to be included in the simulation. SUBROUTINE PYINPR C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...User process initialization commonblock. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) SAVE /HEPRUP/ C...Commonblocks and character variables. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT6/PROC(0:500) CHARACTER PROC*28 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/, &/PYINT6/ CHARACTER CHIPR*10 C...Reset processes to be included. IF(MSEL.NE.0) THEN DO 100 I=1,500 MSUB(I)=0 100 CONTINUE ENDIF C...Set running pTmin scale. IF(MSTP(82).LE.1) THEN PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90) ELSE PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) ENDIF C...Begin by assuming incoming photon to enter subprocess. IF(MINT(11).EQ.22) MINT(15)=22 IF(MINT(12).EQ.22) MINT(16)=22 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous. IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN MSUB(10)=1 MINT(123)=MINT(122)+1 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30 C...allow mixture. C...Here also set a few parameters otherwise normally not touched. ELSEIF(MINT(121).GT.1) THEN C...Parton distributions dampened at small Q2; go to low energies, C...alpha_s <1; no minimum pT cut-off a priori. IF(MSTP(18).EQ.2) THEN MSTP(57)=3 PARP(2)=2D0 PARU(115)=1D0 CKIN(5)=0.2D0 CKIN(6)=0.2D0 ENDIF C...Define pT cut-off parameters and whether run involves low-pT. PTMVMD=PTMRUN VINT(154)=PTMVMD PTMDIR=PTMVMD IF(MSTP(18).EQ.2) PTMDIR=PARP(15) PTMANO=PTMVMD IF(MSTP(15).EQ.5) PTMANO=0.60D0+ & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2 IPTL=1 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0 IF(MSEL.EQ.2) IPTL=1 C...Set up for p/gamma * gamma; real or virtual photons. IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND. & MSTP(14).EQ.30)) THEN C...Set up for p/VMD * VMD. IF(MINT(122).EQ.1) THEN MINT(123)=2 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 C...Set up for p/VMD * direct gamma. ELSEIF(MINT(122).EQ.2) THEN MINT(123)=0 IF(MINT(121).EQ.6) MINT(123)=5 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for p/VMD * anomalous gamma. ELSEIF(MINT(122).EQ.3) THEN MINT(123)=3 IF(MINT(121).EQ.6) MINT(123)=7 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 C...Set up for DIS * p. ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR. & IABS(MINT(12)).GT.100)) THEN MINT(123)=8 IF(IPTL.EQ.1) MSUB(99)=1 C...Set up for direct * direct gamma (switch off leptons). ELSEIF(MINT(122).EQ.4) THEN MINT(123)=0 MSUB(137)=1 MSUB(138)=1 MSUB(139)=1 MSUB(140)=1 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) 110 CONTINUE IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for direct * anomalous gamma. ELSEIF(MINT(122).EQ.5) THEN MINT(123)=6 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMANO C...Set up for anomalous * anomalous gamma. ELSEIF(MINT(122).EQ.6) THEN MINT(123)=3 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 ENDIF C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom. ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN C...Set up for direct * direct gamma (switch off leptons). IF(MINT(122).EQ.1) THEN MINT(123)=0 MSUB(137)=1 MSUB(138)=1 MSUB(139)=1 MSUB(140)=1 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) 120 CONTINUE IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for direct * VMD and VMD * direct gamma. ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN MINT(123)=5 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for direct * anomalous and anomalous * direct gamma. ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN MINT(123)=6 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMANO C...Set up for VMD*VMD. ELSEIF(MINT(122).EQ.5) THEN MINT(123)=2 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 C...Set up for VMD * anomalous and anomalous * VMD gamma. ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN MINT(123)=7 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 C...Set up for anomalous * anomalous gamma. ELSEIF(MINT(122).EQ.9) THEN MINT(123)=3 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 C...Set up for DIS * VMD and VMD * DIS gamma. ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN MINT(123)=8 IF(IPTL.EQ.1) MSUB(99)=1 C...Set up for DIS * anomalous and anomalous * DIS gamma. ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN MINT(123)=9 IF(IPTL.EQ.1) MSUB(99)=1 ENDIF C...Set up for gamma* * p; virtual photons = dir, res. ELSEIF(MINT(121).EQ.2) THEN C...Set up for direct * p. IF(MINT(122).EQ.1) THEN MINT(123)=0 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for resolved * p. ELSEIF(MINT(122).EQ.2) THEN MINT(123)=1 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 ENDIF C...Set up for gamma* * gamma*; virtual photons = dir, res. ELSEIF(MINT(121).EQ.4) THEN C...Set up for direct * direct gamma (switch off leptons). IF(MINT(122).EQ.1) THEN MINT(123)=0 MSUB(137)=1 MSUB(138)=1 MSUB(139)=1 MSUB(140)=1 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) 130 CONTINUE IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for direct * resolved and resolved * direct gamma. ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN MINT(123)=5 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for resolved * resolved gamma. ELSEIF(MINT(122).EQ.4) THEN MINT(123)=2 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 ENDIF C...End of special set up for gamma-p and gamma-gamma. ENDIF CKIN(1)=2D0*CKIN(3) ENDIF C...Flavour information for individual beams. DO 140 I=1,2 MINT(40+I)=1 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2 MINT(44+I)=MINT(40+I) IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR. & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3 140 CONTINUE C...If two real gammas, whereof one direct, pick the first. C...For two virtual photons, keep requested order. IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN MINT(41)=1 MINT(45)=1 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR. & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN MINT(41)=1 MINT(45)=1 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR. & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN MINT(42)=1 MINT(46)=1 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN MINT(41)=1 MINT(45)=1 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN MINT(42)=1 MINT(46)=1 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN MINT(41)=1 MINT(45)=1 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN MINT(42)=1 MINT(46)=1 ENDIF ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN IF(MINT(11).EQ.22) THEN MINT(41)=1 MINT(45)=1 ELSE MINT(42)=1 MINT(46)=1 ENDIF ENDIF IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26, & '(PYINPR:) unallowed MSTP(14) code for single photon') ENDIF C...Flavour information on combination of incoming particles. MINT(43)=2*MINT(41)+MINT(42)-2 MINT(44)=MINT(43) IF(MINT(123).LE.0) THEN IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1 ELSEIF(MINT(123).LE.3) THEN IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN MINT(43)=4 MINT(44)=1 ENDIF MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7 MINT(50)=0 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1 MINT(107)=0 MINT(108)=0 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12) & MINT(107)=2 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13) & MINT(107)=3 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR. & MINT(122).EQ.10) MINT(108)=2 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR. & MINT(122).EQ.11) MINT(108)=3 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN IF(MINT(122).GE.3) MINT(107)=1 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1 ELSEIF(MINT(121).EQ.2) THEN IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1 ELSE IF(MINT(11).EQ.22) THEN MINT(107)=MINT(123) IF(MINT(123).GE.4) MINT(107)=0 IF(MINT(123).EQ.7) MINT(107)=2 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4 IF(MSTP(14).EQ.28) MINT(107)=2 IF(MSTP(14).EQ.29) MINT(107)=3 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4) & MINT(107)=4 ENDIF IF(MINT(12).EQ.22) THEN MINT(108)=MINT(123) IF(MINT(123).GE.4) MINT(108)=MINT(123)-3 IF(MINT(123).EQ.7) MINT(108)=3 IF(MSTP(14).EQ.26) MINT(108)=2 IF(MSTP(14).EQ.27) MINT(108)=3 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4) & MINT(108)=4 ENDIF IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR. & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN MINTTP=MINT(107) MINT(107)=MINT(108) MINT(108)=MINTTP ENDIF ENDIF IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0 C...Select default processes according to incoming beams C...(already done for gamma-p and gamma-gamma with C...MSTP(14) = 10, 20, 25 or 30). IF(MINT(121).GT.1) THEN ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN IF(MINT(43).EQ.1) THEN C...Lepton + lepton -> gamma/Z0 or W. IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND. & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN C...Unresolved photon + lepton: Compton scattering. MSUB(133)=1 MSUB(134)=1 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22 & .OR.MINT(12).EQ.22)) THEN C...DIS as pure gamma* + f -> f process. MSUB(99)=1 ELSEIF(MINT(43).LE.3) THEN C...Lepton + hadron: deep inelastic scattering. MSUB(10)=1 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND. & MINT(12).EQ.22) THEN C...Two unresolved photons: fermion pair production, C...exclude lepton pairs. DO 150 ISUB=137,140 MSUB(ISUB)=1 150 CONTINUE DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) 160 CONTINUE PTMDIR=PTMRUN IF(MSTP(18).EQ.2) PTMDIR=PARP(15) IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR CKIN(1)=MAX(CKIN(1),2D0*CKIN(3)) ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22)) & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND. & MINT(12).EQ.22)) THEN C...Unresolved photon + hadron: photon-parton scattering. DO 170 ISUB=131,136 MSUB(ISUB)=1 170 CONTINUE ELSEIF(MSEL.EQ.1) THEN C...High-pT QCD processes: MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 PTMN=PTMRUN VINT(154)=PTMN IF(CKIN(3).LT.PTMN) MSUB(95)=1 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0 ELSE C...All QCD processes: MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 MSUB(95)=1 ENDIF ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN C...Heavy quark production. MSUB(81)=1 MSUB(82)=1 MSUB(84)=1 DO 180 J=1,MIN(8,MDCY(21,3)) MDME(MDCY(21,2)+J-1,1)=0 180 CONTINUE MDME(MDCY(21,2)+MSEL-1,1)=1 MSUB(85)=1 DO 190 J=1,MIN(12,MDCY(22,3)) MDME(MDCY(22,2)+J-1,1)=0 190 CONTINUE MDME(MDCY(22,2)+MSEL-1,1)=1 ELSEIF(MSEL.EQ.10) THEN C...Prompt photon production: MSUB(14)=1 MSUB(18)=1 MSUB(29)=1 ELSEIF(MSEL.EQ.11) THEN C...Z0/gamma* production: MSUB(1)=1 ELSEIF(MSEL.EQ.12) THEN C...W+/- production: MSUB(2)=1 ELSEIF(MSEL.EQ.13) THEN C...Z0 + jet: MSUB(15)=1 MSUB(30)=1 ELSEIF(MSEL.EQ.14) THEN C...W+/- + jet: MSUB(16)=1 MSUB(31)=1 ELSEIF(MSEL.EQ.15) THEN C...Z0 & W+/- pair production: MSUB(19)=1 MSUB(20)=1 MSUB(22)=1 MSUB(23)=1 MSUB(25)=1 ELSEIF(MSEL.EQ.16) THEN C...h0 production: MSUB(3)=1 MSUB(102)=1 MSUB(103)=1 MSUB(123)=1 MSUB(124)=1 ELSEIF(MSEL.EQ.17) THEN C...h0 & Z0 or W+/- pair production: MSUB(24)=1 MSUB(26)=1 ELSEIF(MSEL.EQ.18) THEN C...h0 production; interesting processes in e+e-. MSUB(24)=1 MSUB(103)=1 MSUB(123)=1 MSUB(124)=1 ELSEIF(MSEL.EQ.19) THEN C...h0, H0 and A0 production; interesting processes in e+e-. MSUB(24)=1 MSUB(103)=1 MSUB(123)=1 MSUB(124)=1 MSUB(153)=1 MSUB(171)=1 MSUB(173)=1 MSUB(174)=1 MSUB(158)=1 MSUB(176)=1 MSUB(178)=1 MSUB(179)=1 ELSEIF(MSEL.EQ.21) THEN C...Z'0 production: MSUB(141)=1 ELSEIF(MSEL.EQ.22) THEN C...W'+/- production: MSUB(142)=1 ELSEIF(MSEL.EQ.23) THEN C...H+/- production: MSUB(143)=1 ELSEIF(MSEL.EQ.24) THEN C...R production: MSUB(144)=1 ELSEIF(MSEL.EQ.25) THEN C...LQ (leptoquark) production. MSUB(145)=1 MSUB(162)=1 MSUB(163)=1 MSUB(164)=1 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN C...Production of one heavy quark (W exchange): MSUB(83)=1 DO 200 J=1,MIN(8,MDCY(21,3)) MDME(MDCY(21,2)+J-1,1)=0 200 CONTINUE MDME(MDCY(21,2)+MSEL-31,1)=1 CMRENNA++Define SUSY alternatives. ELSEIF(MSEL.EQ.39) THEN C...Turn on all SUSY processes. IF(MINT(43).EQ.4) THEN C...Hadron-hadron processes. DO 210 I=201,301 IF(ISET(I).GE.0) MSUB(I)=1 210 CONTINUE ELSEIF(MINT(43).EQ.1) THEN C...Lepton-lepton processes: QED production of squarks. DO 220 I=201,214 MSUB(I)=1 220 CONTINUE MSUB(210)=0 MSUB(211)=0 MSUB(212)=0 DO 230 I=216,228 MSUB(I)=1 230 CONTINUE DO 240 I=261,263 MSUB(I)=1 240 CONTINUE MSUB(277)=1 MSUB(278)=1 ENDIF ELSEIF(MSEL.EQ.40) THEN C...Gluinos and squarks. IF(MINT(43).EQ.4) THEN MSUB(243)=1 MSUB(244)=1 MSUB(258)=1 MSUB(259)=1 MSUB(261)=1 MSUB(262)=1 MSUB(264)=1 MSUB(265)=1 DO 250 I=271,296 MSUB(I)=1 250 CONTINUE ELSEIF(MINT(43).EQ.1) THEN MSUB(277)=1 MSUB(278)=1 ENDIF ELSEIF(MSEL.EQ.41) THEN C...Stop production. MSUB(261)=1 MSUB(262)=1 MSUB(263)=1 IF(MINT(43).EQ.4) THEN MSUB(264)=1 MSUB(265)=1 ENDIF ELSEIF(MSEL.EQ.42) THEN C...Slepton production. DO 260 I=201,214 MSUB(I)=1 260 CONTINUE IF(MINT(43).NE.4) THEN MSUB(210)=0 MSUB(211)=0 MSUB(212)=0 ENDIF ELSEIF(MSEL.EQ.43) THEN C...Neutralino/Chargino + Gluino/Squark. IF(MINT(43).EQ.4) THEN DO 270 I=237,242 MSUB(I)=1 270 CONTINUE DO 280 I=246,254 MSUB(I)=1 280 CONTINUE MSUB(256)=1 ENDIF ELSEIF(MSEL.EQ.44) THEN C...Neutralino/Chargino pair production. IF(MINT(43).EQ.4) THEN DO 290 I=216,236 MSUB(I)=1 290 CONTINUE ELSEIF(MINT(43).EQ.1) THEN DO 300 I=216,228 MSUB(I)=1 300 CONTINUE ENDIF ELSEIF(MSEL.EQ.45) THEN C...Sbottom production. MSUB(287)=1 MSUB(288)=1 IF(MINT(43).EQ.4) THEN DO 310 I=281,296 MSUB(I)=1 310 CONTINUE ENDIF ELSEIF(MSEL.EQ.50) THEN C...Pair production of technipions and gauge bosons. DO 320 I=361,368 MSUB(I)=1 320 CONTINUE IF(MINT(43).EQ.4) THEN DO 330 I=370,377 MSUB(I)=1 330 CONTINUE ENDIF ELSEIF(MSEL.EQ.51) THEN C...QCD 2 -> 2 processes with compositeness/technicolor modifications. DO 340 I=381,386 MSUB(I)=1 340 CONTINUE ELSEIF(MSEL.EQ.61) THEN C...Charmonium production in colour octet model, with recoiling parton. DO 342 I=421,439 MSUB(I)=1 342 CONTINUE ELSEIF(MSEL.EQ.62) THEN C...Bottomonium production in colour octet model, with recoiling parton. DO 344 I=461,479 MSUB(I)=1 344 CONTINUE ELSEIF(MSEL.EQ.63) THEN C...Charmonium and bottomonium production in colour octet model. DO 346 I=421,439 MSUB(I)=1 MSUB(I+40)=1 346 CONTINUE ENDIF C...Find heaviest new quark flavour allowed in processes 81-84. KFLQM=1 DO 350 I=1,MIN(8,MDCY(21,3)) IDC=I+MDCY(21,2)-1 IF(MDME(IDC,1).LE.0) GOTO 350 KFLQM=I 350 CONTINUE IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9)) &KFLQM=MSTP(7) MINT(55)=KFLQM KFPR(81,1)=KFLQM KFPR(81,2)=KFLQM KFPR(82,1)=KFLQM KFPR(82,2)=KFLQM KFPR(83,1)=KFLQM KFPR(84,1)=KFLQM KFPR(84,2)=KFLQM C...Find heaviest new fermion flavour allowed in process 85. KFLFM=1 DO 360 I=1,MIN(12,MDCY(22,3)) IDC=I+MDCY(22,2)-1 IF(MDME(IDC,1).LE.0) GOTO 360 KFLFM=KFDP(IDC,1) 360 CONTINUE IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND. &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7) MINT(56)=KFLFM KFPR(85,1)=KFLFM KFPR(85,2)=KFLFM C...Import relevant information on external user processes. IF(MINT(111).GE.11) THEN IPYPR=0 DO 390 IUP=1,NPRUP C...Find next empty PYTHIA process number slot and enable it. 370 IPYPR=IPYPR+1 IF(IPYPR.GT.500) CALL PYERRM(26, & '(PYINPR.) no more empty slots for user processes') IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370 ISET(IPYPR)=11 C...Overwrite KFPR with references back to process number and ID. KFPR(IPYPR,1)=IUP KFPR(IPYPR,2)=LPRUP(IUP) C...Process title. WRITE(CHIPR,'(I10)') LPRUP(IUP) ICHIN=1 DO 380 ICH=1,9 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1 380 CONTINUE PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' ' C...Switch on process. MSUB(IPYPR)=1 390 CONTINUE ENDIF RETURN END C********************************************************************* C...PYXTOT C...Parametrizes total, elastic and diffractive cross-sections C...for different energies and beams. Donnachie-Landshoff for C...total and Schuler-Sjostrand for elastic and diffractive. C...Process code IPROC: C...= 1 : p + p; C...= 2 : pbar + p; C...= 3 : pi+ + p; C...= 4 : pi- + p; C...= 5 : pi0 + p; C...= 6 : phi + p; C...= 7 : J/psi + p; C...= 11 : rho + rho; C...= 12 : rho + phi; C...= 13 : rho + J/psi; C...= 14 : phi + phi; C...= 15 : phi + J/psi; C...= 16 : J/psi + J/psi; C...= 21 : gamma + p (DL); C...= 22 : gamma + p (VDM). C...= 23 : gamma + pi (DL); C...= 24 : gamma + pi (VDM); C...= 25 : gamma + gamma (DL); C...= 26 : gamma + gamma (VDM). SUBROUTINE PYXTOT C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT7/SIGT(0:6,0:6,0:5) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/ C...Local arrays. DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20), &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8), &CEFFD(10,9),SIGTMP(6,0:5) C...Common constants. DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/, &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/, &FACDD/0.0084D0/ C...Number of multiple processes to be evaluated (= 0 : undefined). DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/ C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta). DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0, &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0, &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/ DATA YPAR/ &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0, &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0, &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/ C...Beam and target hadron class: C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi. DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/ DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/ C...Characteristic class masses, slope parameters, beta = sqrt(X). DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/ DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/ DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/ C...Fitting constants used in parametrizations of diffractive results. DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/ DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/ DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/ &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0, &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0, &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0, &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0, &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0, &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0, &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0, &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0, &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0, &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/ DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/ &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0, &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0, &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0, &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0, &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0, &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0, &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0, &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0, &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0, &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0, &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0, &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0, &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0, &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0, &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/ C...Parameters. Combinations of the energy. AEM=PARU(101) PMTH=PARP(102) S=VINT(2) SRT=VINT(1) SEPS=S**EPS SETA=S**ETA SLOG=LOG(S) C...Ratio of gamma/pi (for rescaling in parton distributions). VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/ &(XPAR(5)*SEPS+YPAR(5)*SETA) VINT(317)=1D0 IF(MINT(50).NE.1) RETURN C...Order flavours of incoming particles: KF1 < KF2. IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN KF1=IABS(MINT(11)) KF2=IABS(MINT(12)) IORD=1 ELSE KF1=IABS(MINT(12)) KF2=IABS(MINT(11)) IORD=2 ENDIF ISGN12=ISIGN(1,MINT(11)*MINT(12)) C...Find process number (for lookup tables). IF(KF1.GT.1000) THEN IPROC=1 IF(ISGN12.LT.0) IPROC=2 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN IPROC=3 IF(ISGN12.LT.0) IPROC=4 IF(KF1.EQ.111) IPROC=5 ELSEIF(KF1.GT.100) THEN IPROC=11 ELSEIF(KF2.GT.1000) THEN IPROC=21 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22 ELSEIF(KF2.GT.100) THEN IPROC=23 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24 ELSE IPROC=25 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26 ENDIF C... Number of multiple processes to be stored; beam/target side. NPR=NPROC(IPROC) MINT(101)=1 MINT(102)=1 IF(NPR.EQ.3) THEN MINT(100+IORD)=4 ELSEIF(NPR.EQ.6) THEN MINT(101)=4 MINT(102)=4 ENDIF N1=0 IF(MINT(101).EQ.4) N1=4 N2=0 IF(MINT(102).EQ.4) N2=4 C...Do not do any more for user-set or undefined cross-sections. IF(MSTP(31).LE.0) RETURN IF(NPR.EQ.0) CALL PYERRM(26, &'(PYXTOT:) cross section for this process not yet implemented') C...Parameters. Combinations of the energy. AEM=PARU(101) PMTH=PARP(102) S=VINT(2) SRT=VINT(1) SEPS=S**EPS SETA=S**ETA SLOG=LOG(S) C...Loop over multiple processes (for VDM). DO 110 I=1,NPR IF(NPR.EQ.1) THEN IPR=IPROC ELSEIF(NPR.EQ.3) THEN IPR=I+4 IF(KF2.LT.1000) IPR=I+10 ELSEIF(NPR.EQ.6) THEN IPR=I+10 ENDIF C...Evaluate hadron species, mass, slope contribution and fit number. IHA=IHADA(IPR) IHB=IHADB(IPR) PMA=PMHAD(IHA) PMB=PMHAD(IHB) BHA=BHAD(IHA) BHB=BHAD(IHB) ISD=IFITSD(IPR) IDD=IFITDD(IPR) C...Skip if energy too low relative to masses. DO 100 J=0,5 SIGTMP(I,J)=0D0 100 CONTINUE IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110 C...Total cross-section. Elastic slope parameter and cross-section. SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL C...Diffractive scattering A + B -> X + B. BSD=2D0*BHB SQML=(PMA+PMTH)**2 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2) SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/ & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP) BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/ & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB) SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2) C...Diffractive scattering A + B -> A + X. BSD=2D0*BHA SQML=(PMB+PMTH)**2 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6) SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/ & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP) BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/ & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX) SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2) C...Order single diffractive correctly. IF(IORD.EQ.2) THEN SIGSAV=SIGTMP(I,2) SIGTMP(I,2)=SIGTMP(I,3) SIGTMP(I,3)=SIGSAV ENDIF C...Double diffractive scattering A + B -> X1 + X2. YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2) DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP) IF(YEFF.LE.0) SUM1=0D0 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2) SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC)))) SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC)))) SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/ & (2D0*ALP) SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC)))) SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC)))) SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/ & (2D0*ALP) BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC))) SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)* & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX) SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4) C...Non-diffractive by unitarity. SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)- & SIGTMP(I,4) 110 CONTINUE C...Put temporary results in output array: only one process. IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN DO 120 J=0,5 SIGT(0,0,J)=SIGTMP(1,J) 120 CONTINUE C...Beam multiple processes. ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN IF(MINT(107).EQ.2) THEN VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2 ELSE VINT(317)=16D0*PARP(15)**2*VINT(154)**2/ & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307))) ENDIF IF(MSTP(20).GT.0) THEN VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20) ENDIF DO 140 I=1,4 IF(MINT(107).EQ.2) THEN CONV=(AEM/PARP(160+I))*VINT(317) ELSEIF(VINT(154).GT.PARP(15)) THEN CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2* & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317) ELSE CONV=0D0 ENDIF I1=MAX(1,I-1) DO 130 J=0,5 SIGT(I,0,J)=CONV*SIGTMP(I1,J) 130 CONTINUE 140 CONTINUE DO 150 J=0,5 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J) 150 CONTINUE C...Target multiple processes. ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN IF(MINT(108).EQ.2) THEN VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2 ELSE VINT(317)=16D0*PARP(15)**2*VINT(154)**2/ & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308))) ENDIF IF(MSTP(20).GT.0) THEN VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20) ENDIF DO 170 I=1,4 IF(MINT(108).EQ.2) THEN CONV=(AEM/PARP(160+I))*VINT(317) ELSEIF(VINT(154).GT.PARP(15)) THEN CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2* & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317) ELSE CONV=0D0 ENDIF IV=MAX(1,I-1) DO 160 J=0,5 SIGT(0,I,J)=CONV*SIGTMP(IV,J) 160 CONTINUE 170 CONTINUE DO 180 J=0,5 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J) 180 CONTINUE C...Both beam and target multiple processes. ELSE IF(MINT(107).EQ.2) THEN VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2 ELSE VINT(317)=16D0*PARP(15)**2*VINT(154)**2/ & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307))) ENDIF IF(MINT(108).EQ.2) THEN VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2 ELSE VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/ & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308))) ENDIF IF(MSTP(20).GT.0) THEN VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+ & VINT(308)))**MSTP(20) ENDIF DO 210 I1=1,4 DO 200 I2=1,4 IF(MINT(107).EQ.2) THEN CONV=(AEM/PARP(160+I1))*VINT(317) ELSEIF(VINT(154).GT.PARP(15)) THEN CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2* & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317) ELSE CONV=0D0 ENDIF IF(MINT(108).EQ.2) THEN CONV=CONV*(AEM/PARP(160+I2)) ELSEIF(VINT(154).GT.PARP(15)) THEN CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2* & (1D0/PARP(15)**2-1D0/VINT(154)**2) ELSE CONV=0D0 ENDIF IF(I1.LE.2) THEN IV=MAX(1,I2-1) ELSEIF(I2.LE.2) THEN IV=MAX(1,I1-1) ELSEIF(I1.EQ.I2) THEN IV=2*I1-2 ELSE IV=5 ENDIF DO 190 J=0,5 JV=J IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV) 190 CONTINUE 200 CONTINUE 210 CONTINUE DO 230 J=0,5 DO 220 I=1,4 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J) SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J) 220 CONTINUE SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J) 230 CONTINUE ENDIF C...Scale up uniformly for Donnachie-Landshoff parametrization. IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0) DO 260 I1=0,N1 DO 250 I2=0,N2 DO 240 J=0,5 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J) 240 CONTINUE 250 CONTINUE 260 CONTINUE ENDIF RETURN END C********************************************************************* C...PYMAXI C...Finds optimal set of coefficients for kinematical variable selection C...and the maximum of the part of the differential cross-section used C...in the event weighting. SUBROUTINE PYMAXI C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...User process initialization commonblock. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) SAVE /HEPRUP/ C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT6/PROC(0:500) CHARACTER PROC*28 COMMON/PYINT7/SIGT(0:6,0:6,0:5) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/ C...Local arrays, character variables and data. CHARACTER CVAR(4)*4 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500), &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7), &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2) DATA CVAR/'tau ','tau''','y* ','cth '/ DATA SIGSSM/3*0D0/ C...Initial values and loop over subprocesses. NPOSI=0 VINT(143)=1D0 VINT(144)=1D0 XSEC(0,1)=0D0 DO 460 ISUB=1,500 MINT(1)=ISUB MINT(51)=0 C...Find maximum weight factors for photon flux. IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA) ENDIF C...Select subprocess to study: skip cases not applicable. IF(ISET(ISUB).EQ.11) THEN IF(MSUB(ISUB).NE.1) GOTO 460 C...User process intialization: cross section model dependent. IF(IABS(IDWTUP).EQ.1) THEN IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process') XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1))) ELSE IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND. & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process') IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process') XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1))) ENDIF IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)= & WTGAGA*XSEC(ISUB,1) NPOSI=NPOSI+1 GOTO 450 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN CALL PYSIGH(NCHN,SIGS) XSEC(ISUB,1)=SIGS IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)= & WTGAGA*XSEC(ISUB,1) IF(MSUB(ISUB).NE.1) GOTO 460 NPOSI=NPOSI+1 GOTO 450 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN CALL PYSIGH(NCHN,SIGS) XSEC(ISUB,1)=SIGS IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)= & WTGAGA*XSEC(ISUB,1) IF(XSEC(ISUB,1).EQ.0D0) THEN MSUB(ISUB)=0 ELSE NPOSI=NPOSI+1 ENDIF GOTO 450 ELSEIF(ISUB.EQ.96) THEN IF(MINT(50).EQ.0) GOTO 460 IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0) & GOTO 460 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR. & ISUB.EQ.53.OR.ISUB.EQ.68) THEN IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460 ELSE IF(MSUB(ISUB).NE.1) GOTO 460 ENDIF ISTSB=ISET(ISUB) IF(ISUB.EQ.96) ISTSB=2 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB MWTXS=0 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+ & MSUB(94)+MSUB(95).EQ.0) MWTXS=1 C...Find resonances (explicit or implicit in cross-section). MINT(72)=0 KFR1=0 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN KFR1=KFPR(ISUB,1) ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN KFR1=23 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172 & .OR.ISUB.EQ.177) THEN KFR1=24 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN KFR1=25 IF(MSTP(46).EQ.5) THEN KFR1=89 PMAS(89,1)=PARP(45) PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2) ENDIF ELSEIF(ISUB.EQ.194) THEN KFR1=KTECHN+113 ELSEIF(ISUB.EQ.195) THEN KFR1=KTECHN+213 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN KFR1=KTECHN+113 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN KFR1=KTECHN+213 ENDIF CKMX=CKIN(2) IF(CKMX.LE.0D0) CKMX=VINT(1) KCR1=PYCOMP(KFR1) IF(KFR1.NE.0) THEN IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR. & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0 ENDIF IF(KFR1.NE.0) THEN TAUR1=PMAS(KCR1,1)**2/VINT(2) IF(KFR1.EQ.KTECHN+113) THEN CALL PYTECM(S1,S2) TAUR1=S1/VINT(2) ENDIF GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2) MINT(72)=1 MINT(73)=KFR1 VINT(73)=TAUR1 VINT(74)=GAMR1 ENDIF KFR2=0 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368)) $ THEN KFR2=23 IF(ISUB.EQ.194) THEN KFR2=KTECHN+223 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN KFR2=KTECHN+223 ENDIF KCR2=PYCOMP(KFR2) TAUR2=PMAS(KCR2,1)**2/VINT(2) IF(KFR2.EQ.KTECHN+223) THEN CALL PYTECM(S1,S2) TAUR2=S2/VINT(2) ENDIF GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2) IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR. & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN MINT(72)=2 MINT(74)=KFR2 VINT(75)=TAUR2 VINT(76)=GAMR2 ELSEIF(KFR2.NE.0) THEN KFR1=KFR2 TAUR1=TAUR2 GAMR1=GAMR2 MINT(72)=1 MINT(73)=KFR1 VINT(73)=TAUR1 VINT(74)=GAMR1 KFR2=0 ENDIF ENDIF C...Find product masses and minimum pT of process. SQM3=0D0 SQM4=0D0 MINT(71)=0 VINT(71)=CKIN(3) VINT(80)=1D0 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN NBW=0 DO 110 I=1,2 PMMN(I)=0D0 IF(KFPR(ISUB,I).EQ.0) THEN ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT. & PARP(41)) THEN IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2 ELSE NBW=NBW+1 C...This prevents SUSY/t particles from becoming too light. KFLW=KFPR(ISUB,I) IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN KCW=PYCOMP(KFLW) PMMN(I)=PMAS(KCW,1) DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+ & PMAS(PYCOMP(KFDP(IDC,2)),1) IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+ & PMAS(PYCOMP(KFDP(IDC,3)),1) PMMN(I)=MIN(PMMN(I),PMSUM) ENDIF 100 CONTINUE ELSEIF(KFLW.EQ.6) THEN PMMN(I)=PMAS(24,1)+PMAS(5,1) ENDIF ENDIF 110 CONTINUE IF(NBW.GE.1) THEN CKIN41=CKIN(41) CKIN43=CKIN(43) CKIN(41)=MAX(PMMN(1),CKIN(41)) CKIN(43)=MAX(PMMN(2),CKIN(43)) CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4) CKIN(41)=CKIN41 CKIN(43)=CKIN43 IF(MINT(51).EQ.1) THEN WRITE(MSTU(11),5100) ISUB MSUB(ISUB)=0 GOTO 460 ENDIF SQM3=PQM3**2 SQM4=PQM4**2 ENDIF IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5)) IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90) ELSEIF(ISUB.EQ.96) THEN VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90) ENDIF ENDIF VINT(63)=SQM3 VINT(64)=SQM4 C...Prepare for additional variable choices in 2 -> 3. IF(ISTSB.EQ.5) THEN VINT(201)=0D0 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1) VINT(206)=VINT(201) IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1) VINT(204)=PMAS(23,1) IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1) IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1) IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) & VINT(204)=VINT(201) VINT(209)=VINT(204) IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206) ENDIF C...Number of points for each variable: tau, tau', y*, cos(theta-hat). NPTS(1)=2+2*MINT(72) IF(MINT(47).EQ.1) THEN IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1 ELSEIF(MINT(47).GE.5) THEN IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1 ENDIF NPTS(2)=1 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN IF(MINT(47).GE.2) NPTS(2)=2 IF(MINT(47).GE.5) NPTS(2)=3 ENDIF NPTS(3)=1 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN NPTS(3)=3 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1 ENDIF NPTS(4)=1 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4) C...Reset coefficients of cross-section weighting. DO 120 J=1,20 COEF(ISUB,J)=0D0 120 CONTINUE COEF(ISUB,1)=1D0 COEF(ISUB,8)=0.5D0 COEF(ISUB,9)=0.5D0 COEF(ISUB,13)=1D0 COEF(ISUB,18)=1D0 MCTH=0 MTAUP=0 METAUP=0 VINT(23)=0D0 VINT(26)=0D0 SIGSAM=0D0 C...Find limits and select tau, y*, cos(theta-hat) and tau' values, C...in grid of phase space points. CALL PYKLIM(1) METAU=MINT(51) NACC=0 DO 150 ITRY=1,NTRY MINT(51)=0 IF(METAU.EQ.1) GOTO 150 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4)) IF(MTAU.GT.2+2*MINT(72)) MTAU=7 RTAU=0.5D0 C...Special case when both resonances have same mass, C...as is often the case in process 194. IF(MINT(72).EQ.2) THEN IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT. & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN RTAU=0.4D0 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN RTAU=0.6D0 ENDIF ENDIF ENDIF CALL PYKMAP(1,MTAU,RTAU) IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4) METAUP=MINT(51) ENDIF IF(METAUP.EQ.1) GOTO 150 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4)) & .EQ.0) THEN MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2)) CALL PYKMAP(4,MTAUP,0.5D0) ENDIF IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN CALL PYKLIM(2) MEYST=MINT(51) ENDIF IF(MEYST.EQ.1) GOTO 150 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3)) IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5 CALL PYKMAP(2,MYST,0.5D0) CALL PYKLIM(3) MECTH=MINT(51) ENDIF IF(MECTH.EQ.1) GOTO 150 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN MCTH=1+MOD(ITRY-1,NPTS(4)) CALL PYKMAP(3,MCTH,0.5D0) ENDIF IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2) C...Store position and limits. MINT(51)=0 CALL PYKLIM(0) IF(MINT(51).EQ.1) GOTO 150 NACC=NACC+1 MVARPT(NACC,1)=MTAU MVARPT(NACC,2)=MTAUP MVARPT(NACC,3)=MYST MVARPT(NACC,4)=MCTH DO 130 J=1,30 VINTPT(NACC,J)=VINT(10+J) 130 CONTINUE C...Normal case: calculate cross-section. IF(ISTSB.NE.5) THEN CALL PYSIGH(NCHN,SIGS) IF(MWTXS.EQ.1) THEN CALL PYEVWT(WTXS) SIGS=WTXS*SIGS ENDIF C..2 -> 3: find highest value out of a number of tries. ELSE SIGS=0D0 DO 140 IKIN3=1,MSTP(129) CALL PYKMAP(5,0,0D0) IF(MINT(51).EQ.1) GOTO 140 CALL PYSIGH(NCHN,SIGTMP) IF(MWTXS.EQ.1) THEN CALL PYEVWT(WTXS) SIGTMP=WTXS*SIGTMP ENDIF IF(SIGTMP.GT.SIGS) SIGS=SIGTMP 140 CONTINUE ENDIF C...Store cross-section. SIGSPT(NACC)=SIGS IF(SIGS.GT.SIGSAM) SIGSAM=SIGS IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP, & VINT(21),VINT(22),VINT(23),VINT(26),SIGS 150 CONTINUE IF(NACC.EQ.0) THEN WRITE(MSTU(11),5100) ISUB MSUB(ISUB)=0 GOTO 460 ELSEIF(SIGSAM.EQ.0D0) THEN WRITE(MSTU(11),5300) ISUB MSUB(ISUB)=0 GOTO 460 ENDIF IF(ISUB.NE.96) NPOSI=NPOSI+1 C...Calculate integrals in tau over maximal phase space limits. TAUMIN=VINT(11) TAUMAX=VINT(31) ATAU1=LOG(TAUMAX/TAUMIN) IF(NPTS(1).GE.2) THEN ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN) ENDIF IF(NPTS(1).GE.4) THEN ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/ & GAMR1 ENDIF IF(NPTS(1).GE.6) THEN ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/ & GAMR2 ENDIF IF(NPTS(1).GT.2+2*MINT(72)) THEN ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX)) ENDIF C...Reset. Sum up cross-sections in points calculated. DO 320 IVAR=1,4 IF(NPTS(IVAR).EQ.1) GOTO 320 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320 NBIN=NPTS(IVAR) DO 170 J1=1,NBIN NAREL(J1)=0 WTREL(J1)=0D0 COEFU(J1)=0D0 DO 160 J2=1,NBIN WTMAT(J1,J2)=0D0 160 CONTINUE 170 CONTINUE DO 180 IACC=1,NACC IBIN=MVARPT(IACC,IVAR) IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72) IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4 NAREL(IBIN)=NAREL(IBIN)+1 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC) C...Sum up tau cross-section pieces in points used. IF(IVAR.EQ.1) THEN TAU=VINTPT(IACC,11) WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU IF(NBIN.GE.4) THEN WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1) WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/ & ((TAU-TAUR1)**2+GAMR1**2) ENDIF IF(NBIN.GE.6) THEN WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2) WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/ & ((TAU-TAUR2)**2+GAMR2**2) ENDIF IF(NBIN.GT.2+2*MINT(72)) THEN WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)* & TAU/MAX(2D-10,1D0-TAU) ENDIF C...Sum up tau' cross-section pieces in points used. ELSEIF(IVAR.EQ.2) THEN TAU=VINTPT(IACC,11) TAUP=VINTPT(IACC,16) TAUPMN=VINTPT(IACC,6) TAUPMX=VINTPT(IACC,26) ATAUP1=LOG(TAUPMX/TAUPMN) ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU) WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)* & (1D0-TAU/TAUP)**3/TAUP IF(NBIN.GE.3) THEN ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX)) WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)* & TAUP/MAX(2D-10,1D0-TAUP) ENDIF C...Sum up y* cross-section pieces in points used. ELSEIF(IVAR.EQ.3) THEN YST=VINTPT(IACC,12) YSTMIN=VINTPT(IACC,2) YSTMAX=VINTPT(IACC,22) AYST0=YSTMAX-YSTMIN AYST1=0.5D0*(YSTMAX-YSTMIN)**2 AYST2=AYST1 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN))) WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN) WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST) WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST) IF(MINT(45).EQ.3) THEN TAUE=VINTPT(IACC,11) IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16) YST0=-0.5D0*LOG(TAUE) AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/ & MAX(1D-10,EXP(YST0-YSTMAX)-1D0)) WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/ & MAX(1D-10,1D0-EXP(YST-YST0)) ENDIF IF(MINT(46).EQ.3) THEN TAUE=VINTPT(IACC,11) IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16) YST0=-0.5D0*LOG(TAUE) AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/ & MAX(1D-10,EXP(YST0+YSTMIN)-1D0)) WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/ & MAX(1D-10,1D0-EXP(-YST-YST0)) ENDIF C...Sum up cos(theta-hat) cross-section pieces in points used. ELSE RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2) RSQM=1D0+RM34 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2))) CTHMIN=-CTHMAX IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/ & (TAUMAX*VINT(2))) ACTH1=CTHMAX-CTHMIN ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX)) ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN)) ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN) ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX) CTH=VINTPT(IACC,13) WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/ & MAX(RM34,RSQM-CTH) WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/ & MAX(RM34,RSQM+CTH) WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/ & MAX(RM34,RSQM-CTH)**2 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/ & MAX(RM34,RSQM+CTH)**2 ENDIF 180 CONTINUE C...Check that equation system solvable. IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR) MSOLV=1 WTRELS=0D0 DO 190 IBIN=1,NBIN IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED), & IRED=1,NBIN),WTREL(IBIN) IF(NAREL(IBIN).EQ.0) MSOLV=0 WTRELS=WTRELS+WTREL(IBIN) 190 CONTINUE IF(ABS(WTRELS).LT.1D-20) MSOLV=0 C...Solve to find relative importance of cross-section pieces. IF(MSOLV.EQ.1) THEN DO 200 IBIN=1,NBIN WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS) 200 CONTINUE DO 230 IRED=1,NBIN-1 DO 220 IBIN=IRED+1,NBIN IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN MSOLV=0 GOTO 260 ENDIF RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED) WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED) DO 210 ICOE=IRED,NBIN WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE) 210 CONTINUE 220 CONTINUE 230 CONTINUE DO 250 IRED=NBIN,1,-1 DO 240 ICOE=IRED+1,NBIN WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE) 240 CONTINUE COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED) 250 CONTINUE ENDIF C...Share evenly if failure. 260 IF(MSOLV.EQ.0) THEN DO 270 IBIN=1,NBIN COEFU(IBIN)=1D0 WTRELN(IBIN)=0.1D0 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0, & WTREL(IBIN)/WTRELS) 270 CONTINUE ENDIF C...Normalize coefficients, with piece shared democratically. COEFSU=0D0 WTRELS=0D0 DO 280 IBIN=1,NBIN COEFU(IBIN)=MAX(0D0,COEFU(IBIN)) COEFSU=COEFSU+COEFU(IBIN) WTRELS=WTRELS+WTRELN(IBIN) 280 CONTINUE IF(COEFSU.GT.0D0) THEN DO 290 IBIN=1,NBIN COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0* & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS) 290 CONTINUE ELSE DO 300 IBIN=1,NBIN COEFO(IBIN)=1D0/NBIN 300 CONTINUE ENDIF IF(IVAR.EQ.1) IOFF=0 IF(IVAR.EQ.2) IOFF=17 IF(IVAR.EQ.3) IOFF=7 IF(IVAR.EQ.4) IOFF=12 DO 310 IBIN=1,NBIN ICOF=IOFF+IBIN IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1 COEF(ISUB,ICOF)=COEFO(IBIN) 310 CONTINUE IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR), & (COEFO(IBIN),IBIN=1,NBIN) 320 CONTINUE C...Find two most promising maxima among points previously determined. DO 330 J=1,4 IACCMX(J)=0 SIGSMX(J)=0D0 330 CONTINUE NMAX=0 DO 390 IACC=1,NACC DO 340 J=1,30 VINT(10+J)=VINTPT(IACC,J) 340 CONTINUE IF(ISTSB.NE.5) THEN CALL PYSIGH(NCHN,SIGS) IF(MWTXS.EQ.1) THEN CALL PYEVWT(WTXS) SIGS=WTXS*SIGS ENDIF ELSE SIGS=0D0 DO 350 IKIN3=1,MSTP(129) CALL PYKMAP(5,0,0D0) IF(MINT(51).EQ.1) GOTO 350 CALL PYSIGH(NCHN,SIGTMP) IF(MWTXS.EQ.1) THEN CALL PYEVWT(WTXS) SIGTMP=WTXS*SIGTMP ENDIF IF(SIGTMP.GT.SIGS) SIGS=SIGTMP 350 CONTINUE ENDIF IEQ=0 DO 360 IMV=1,NMAX IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV 360 CONTINUE IF(IEQ.EQ.0) THEN DO 370 IMV=NMAX,1,-1 IIN=IMV+1 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380 IACCMX(IMV+1)=IACCMX(IMV) SIGSMX(IMV+1)=SIGSMX(IMV) 370 CONTINUE IIN=1 380 IACCMX(IIN)=IACC SIGSMX(IIN)=SIGS IF(NMAX.LE.1) NMAX=NMAX+1 ENDIF 390 CONTINUE C...Read out starting position for search. IF(MSTP(122).GE.2) WRITE(MSTU(11),5700) SIGSAM=SIGSMX(1) DO 440 IMAX=1,NMAX IACC=IACCMX(IMAX) MTAU=MVARPT(IACC,1) MTAUP=MVARPT(IACC,2) MYST=MVARPT(IACC,3) MCTH=MVARPT(IACC,4) VTAU=0.5D0 VYST=0.5D0 VCTH=0.5D0 VTAUP=0.5D0 C...Starting point and step size in parameter space. DO 430 IRPT=1,2 DO 420 IVAR=1,4 IF(NPTS(IVAR).EQ.1) GOTO 420 IF(IVAR.EQ.1) VVAR=VTAU IF(IVAR.EQ.2) VVAR=VTAUP IF(IVAR.EQ.3) VVAR=VYST IF(IVAR.EQ.4) VVAR=VCTH IF(IVAR.EQ.1) MVAR=MTAU IF(IVAR.EQ.2) MVAR=MTAUP IF(IVAR.EQ.3) MVAR=MYST IF(IVAR.EQ.4) MVAR=MCTH IF(IRPT.EQ.1) VDEL=0.1D0 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0, & 0.98D0-VVAR)) IF(IRPT.EQ.1) VMAR=0.02D0 IF(IRPT.EQ.2) VMAR=0.002D0 IMOV0=1 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0 DO 410 IMOV=IMOV0,8 C...Define new point in parameter space. IF(IMOV.EQ.0) THEN INEW=2 VNEW=VVAR ELSEIF(IMOV.EQ.1) THEN INEW=3 VNEW=VVAR+VDEL ELSEIF(IMOV.EQ.2) THEN INEW=1 VNEW=VVAR-VDEL ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND. & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN VVAR=VVAR+VDEL SIGSSM(1)=SIGSSM(2) SIGSSM(2)=SIGSSM(3) INEW=3 VNEW=VVAR+VDEL ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND. & VVAR-2D0*VDEL.GT.VMAR) THEN VVAR=VVAR-VDEL SIGSSM(3)=SIGSSM(2) SIGSSM(2)=SIGSSM(1) INEW=1 VNEW=VVAR-VDEL ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN VDEL=0.5D0*VDEL VVAR=VVAR+VDEL SIGSSM(1)=SIGSSM(2) INEW=2 VNEW=VVAR ELSE VDEL=0.5D0*VDEL VVAR=VVAR-VDEL SIGSSM(3)=SIGSSM(2) INEW=2 VNEW=VVAR ENDIF C...Convert to relevant variables and find derived new limits. ILERR=0 IF(IVAR.EQ.1) THEN VTAU=VNEW CALL PYKMAP(1,MTAU,VTAU) IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN CALL PYKLIM(4) IF(MINT(51).EQ.1) ILERR=1 ENDIF ENDIF IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND. & ILERR.EQ.0) THEN IF(IVAR.EQ.2) VTAUP=VNEW CALL PYKMAP(4,MTAUP,VTAUP) ENDIF IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN CALL PYKLIM(2) IF(MINT(51).EQ.1) ILERR=1 ENDIF IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN IF(IVAR.EQ.3) VYST=VNEW CALL PYKMAP(2,MYST,VYST) CALL PYKLIM(3) IF(MINT(51).EQ.1) ILERR=1 ENDIF IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND. & ILERR.EQ.0) THEN IF(IVAR.EQ.4) VCTH=VNEW CALL PYKMAP(3,MCTH,VCTH) ENDIF IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2) C...Evaluate cross-section. Save new maximum. Final maximum. IF(ILERR.NE.0) THEN SIGS=0. ELSEIF(ISTSB.NE.5) THEN CALL PYSIGH(NCHN,SIGS) IF(MWTXS.EQ.1) THEN CALL PYEVWT(WTXS) SIGS=WTXS*SIGS ENDIF ELSE SIGS=0D0 DO 400 IKIN3=1,MSTP(129) CALL PYKMAP(5,0,0D0) IF(MINT(51).EQ.1) GOTO 400 CALL PYSIGH(NCHN,SIGTMP) IF(MWTXS.EQ.1) THEN CALL PYEVWT(WTXS) SIGTMP=WTXS*SIGTMP ENDIF IF(SIGTMP.GT.SIGS) SIGS=SIGTMP 400 CONTINUE ENDIF SIGSSM(INEW)=SIGS IF(SIGS.GT.SIGSAM) SIGSAM=SIGS IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR, & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS 410 CONTINUE 420 CONTINUE 430 CONTINUE 440 CONTINUE IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM XSEC(ISUB,1)=1.05D0*SIGSAM IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)= & WTGAGA*XSEC(ISUB,1) 450 CONTINUE IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)= & PARP(174)*XSEC(ISUB,1) IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1) 460 CONTINUE MINT(51)=0 C...Print summary table. IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN IF(MSTP(127).NE.1) THEN WRITE(MSTU(11),5900) STOP ELSE WRITE(MSTU(11),6400) MSTI(53)=1 ENDIF ENDIF IF(MSTP(122).GE.1) THEN WRITE(MSTU(11),6000) WRITE(MSTU(11),6100) DO 470 ISUB=1,500 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0) & GOTO 470 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1) 470 CONTINUE WRITE(MSTU(11),6300) ENDIF C...Format statements for maximization results. 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ', &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X, &'cth',9X,'tau''',7X,'sigma') 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ', &'phase space.'/1X,'Process switched off!') 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4) 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ', &'cross-section.'/1X,'Process switched off!') 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4) 5500 FORMAT(1X,1P,8D11.3) 5600 FORMAT(1X,'Result for ',A4,':',7F9.4) 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ', &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma') 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4) 5900 FORMAT(1X,'Error: no requested process has non-vanishing ', &'cross-section.'/1X,'Execution stopped!') 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ', &'cross-section maximum search',1X,8('*')) 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ', &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I', &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I') 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I') 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('=')) 6400 FORMAT(1X,'Error: no requested process has non-vanishing ', &'cross-section.'/ &1X,'Execution will stop if you try to generate events.') RETURN END C********************************************************************* C...PYPILE C...Initializes multiplicity distribution and selects mutliplicity C...of pileup events, i.e. several events occuring at the same C...beam crossing. SUBROUTINE PYPILE(MPILE) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT7/SIGT(0:6,0:6,0:5) SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/ C...Local arrays and saved variables. DIMENSION WTI(0:200) SAVE IMIN,IMAX,WTI,WTS C...Sum of allowed cross-sections for pileup events. IF(MPILE.EQ.1) THEN VINT(131)=SIGT(0,0,5) IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4) IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3) IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1) IF(MSTP(133).LE.0) RETURN C...Initialize multiplicity distribution at maximum. XNAVE=VINT(131)*PARP(131) IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE INAVE=MAX(1,MIN(200,NINT(XNAVE))) WTI(INAVE)=1D0 WTS=WTI(INAVE) WTN=WTI(INAVE)*INAVE C...Find shape of multiplicity distribution below maximum. IMIN=INAVE DO 100 I=INAVE-1,1,-1 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE IF(WTI(I).LT.1D-6) GOTO 110 WTS=WTS+WTI(I) WTN=WTN+WTI(I)*I IMIN=I 100 CONTINUE C...Find shape of multiplicity distribution above maximum. 110 IMAX=INAVE DO 120 I=INAVE+1,200 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1) IF(WTI(I).LT.1D-6) GOTO 130 WTS=WTS+WTI(I) WTN=WTN+WTI(I)*I IMAX=I 120 CONTINUE 130 VINT(132)=XNAVE VINT(133)=WTN/WTS IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)= & WTS/(WTS+WTI(1)/XNAVE) IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0 IF(MSTP(133).GE.2) VINT(134)=XNAVE C...Pick multiplicity of pileup events. ELSE IF(MSTP(133).LE.0) THEN MINT(81)=MAX(1,MSTP(134)) ELSE WTR=WTS*PYR(0) DO 140 I=IMIN,IMAX MINT(81)=I WTR=WTR-WTI(I) IF(WTR.LE.0D0) GOTO 150 140 CONTINUE 150 CONTINUE ENDIF ENDIF C...Format statement for error message. 5000 FORMAT(1X,'Warning: requested average number of events per bunch', &'crossing too large, ',1P,D12.4) RETURN END C********************************************************************* C...PYSAVE C...Saves and restores parameter and cross section values for the C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives. C...Also makes random choice between alternatives. SUBROUTINE PYSAVE(ISAVE,IGA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT7/SIGT(0:6,0:6,0:5) SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/ C...Local arrays and saved variables. DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20), &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5), &INTCP(15,20),RECP(15,20) SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP C...Save list of subprocesses and cross-section information. IF(ISAVE.EQ.1) THEN ICP=0 DO 120 I=1,500 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120 ICP=ICP+1 NSUBCP(IGA,ICP)=I MSUBCP(IGA,ICP)=MSUB(I) DO 100 J=1,20 COEFCP(IGA,ICP,J)=COEF(I,J) 100 CONTINUE DO 110 J=1,3 NGENCP(IGA,ICP,J)=NGEN(I,J) XSECCP(IGA,ICP,J)=XSEC(I,J) 110 CONTINUE 120 CONTINUE NCP(IGA)=ICP DO 130 J=1,3 NGENCP(IGA,0,J)=NGEN(0,J) XSECCP(IGA,0,J)=XSEC(0,J) 130 CONTINUE DO 160 I1=0,6 DO 150 I2=0,6 DO 140 J=0,5 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J) 140 CONTINUE 150 CONTINUE 160 CONTINUE C...Save various common process variables. DO 170 J=1,10 INTCP(IGA,J)=MINT(40+J) 170 CONTINUE INTCP(IGA,11)=MINT(101) INTCP(IGA,12)=MINT(102) INTCP(IGA,13)=MINT(107) INTCP(IGA,14)=MINT(108) INTCP(IGA,15)=MINT(123) RECP(IGA,1)=CKIN(3) RECP(IGA,2)=VINT(318) C...Save cross-section information only. ELSEIF(ISAVE.EQ.2) THEN DO 190 ICP=1,NCP(IGA) I=NSUBCP(IGA,ICP) DO 180 J=1,3 NGENCP(IGA,ICP,J)=NGEN(I,J) XSECCP(IGA,ICP,J)=XSEC(I,J) 180 CONTINUE 190 CONTINUE DO 200 J=1,3 NGENCP(IGA,0,J)=NGEN(0,J) XSECCP(IGA,0,J)=XSEC(0,J) 200 CONTINUE C...Choose between allowed alternatives. ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN IF(ISAVE.EQ.4) THEN XSUMCP=0D0 DO 210 IG=1,MINT(121) XSUMCP=XSUMCP+XSECCP(IG,0,1) 210 CONTINUE XSUMCP=XSUMCP*PYR(0) DO 220 IG=1,MINT(121) IGA=IG XSUMCP=XSUMCP-XSECCP(IG,0,1) IF(XSUMCP.LE.0D0) GOTO 230 220 CONTINUE 230 CONTINUE ENDIF C...Restore cross-section information. DO 240 I=1,500 MSUB(I)=0 240 CONTINUE DO 270 ICP=1,NCP(IGA) I=NSUBCP(IGA,ICP) MSUB(I)=MSUBCP(IGA,ICP) DO 250 J=1,20 COEF(I,J)=COEFCP(IGA,ICP,J) 250 CONTINUE DO 260 J=1,3 NGEN(I,J)=NGENCP(IGA,ICP,J) XSEC(I,J)=XSECCP(IGA,ICP,J) 260 CONTINUE 270 CONTINUE DO 280 J=1,3 NGEN(0,J)=NGENCP(IGA,0,J) XSEC(0,J)=XSECCP(IGA,0,J) 280 CONTINUE DO 310 I1=0,6 DO 300 I2=0,6 DO 290 J=0,5 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J) 290 CONTINUE 300 CONTINUE 310 CONTINUE C...Restore various common process variables. DO 320 J=1,10 MINT(40+J)=INTCP(IGA,J) 320 CONTINUE MINT(101)=INTCP(IGA,11) MINT(102)=INTCP(IGA,12) MINT(107)=INTCP(IGA,13) MINT(108)=INTCP(IGA,14) MINT(123)=INTCP(IGA,15) CKIN(3)=RECP(IGA,1) CKIN(1)=2D0*CKIN(3) VINT(318)=RECP(IGA,2) C...Sum up cross-section info (for PYSTAT). ELSEIF(ISAVE.EQ.5) THEN DO 330 I=1,500 MSUB(I)=0 NGEN(I,1)=0 NGEN(I,3)=0 XSEC(I,3)=0D0 330 CONTINUE NGEN(0,1)=0 NGEN(0,2)=0 NGEN(0,3)=0 XSEC(0,3)=0 DO 350 IG=1,MINT(121) DO 340 ICP=1,NCP(IG) I=NSUBCP(IG,ICP) IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1) NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3) XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3) 340 CONTINUE NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1) NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2) NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3) XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3) 350 CONTINUE ENDIF RETURN END C********************************************************************* C...PYGAGA C...For lepton beams it gives photon-hadron or photon-photon systems C...to be treated with the ordinary machinery and combines this with a C...description of the lepton -> lepton + photon branching. SUBROUTINE PYGAGA(IGAGA,WTGAGA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT5/ C...Local variables and data statement. DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3), &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3) SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN DATA EPS/1D-4/ C...Initialize generation of photons inside leptons. IF(IGAGA.EQ.1) THEN C...Save quantities on incoming lepton system. VINT(301)=VINT(1) VINT(302)=VINT(2) PMS(1)=VINT(303)**2 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3)) PMS(2)=VINT(304)**2 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4)) PMC(3)=VINT(302)-PMS(1)-PMS(2) W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2 C...Calculate range of x and Q2 values allowed in generation. DO 100 I=1,2 PMC(I)=VINT(302)+PMS(I)-PMS(3-I) IF(MINT(140+I).NE.0) THEN XMIN(I)=MAX(CKIN(59+2*I),EPS) XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/ & PMC(I),1D0-EPS) YMIN=MAX(CKIN(71+2*I),EPS) YMAX=MIN(CKIN(72+2*I),1D0-EPS) IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I), & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I)) XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I)) THEMIN=MAX(CKIN(67+2*I),0D0) THEMAX=MIN(CKIN(68+2*I),PARU(1)) IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1) Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+ & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))- & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0) Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+ & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))- & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I)) C...W limits when lepton on one side only. IF(MINT(143-I).EQ.0) THEN XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I)) IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I), & (CKIN(78)**2-PMS(3-I))/PMC(I)) ENDIF ENDIF 100 CONTINUE C...W limits when lepton on both sides. IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1), & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1)) IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2), & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2)) IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN- & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1)) XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN- & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2)) ELSE XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2))) XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1))) ENDIF ENDIF C...Q2 and W values and photon flux weight factors for initialization. ELSEIF(IGAGA.EQ.2) THEN ISUB=MINT(1) MINT(15)=0 MINT(16)=0 C...W value for photon on one or both sides, and for processes C...with gamma-gamma cross section peaked at small shat. IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1)) ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2)) ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2) IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2) ELSE VINT(2)=XMAX(1)*XMAX(2)*VINT(302) IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2) ENDIF VINT(1)=SQRT(MAX(0D0,VINT(2))) C...Upper estimate of photon flux weight factor. C...Initialization Q2 scale. Flag incoming unresolved photon. WTGAGA=1D0 DO 110 I=1,2 IF(MINT(140+I).NE.0) THEN WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))* & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I)) IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3) & THEN Q2INIT=5D0+Q2MIN(3-I) ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I) ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR. & (ISUB.EQ.139.AND.I.EQ.1)) THEN Q2INIT=VINT(2)/3D0 ELSEIF(ISUB.EQ.140) THEN Q2INIT=VINT(2)/2D0 ELSE Q2INIT=Q2MIN(I) ENDIF VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT))) IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140)) & MINT(14+I)=22 VINT(306+I)=VINT(2+I)**2 ENDIF 110 CONTINUE VINT(320)=WTGAGA C...Update pTmin and cross section information. IF(MSTP(82).LE.1) THEN PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90) ELSE PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) ENDIF VINT(149)=4D0*PTMN**2/VINT(2) VINT(154)=PTMN CALL PYXTOT VINT(318)=VINT(317) C...Generate photons inside leptons and C...calculate photon flux weight factors. ELSEIF(IGAGA.EQ.3) THEN ISUB=MINT(1) MINT(15)=0 MINT(16)=0 C...Generate phase space point and check against cuts. LOOP=0 120 LOOP=LOOP+1 DO 130 I=1,2 IF(MINT(140+I).NE.0) THEN C...Pick x and Q2 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0) Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0) C...Cuts on internal consistency in x and Q2. IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))- & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120 C...Cuts on y and theta. Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3) IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/ & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I))) THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT)))) IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I)) & GOTO 120 C...Phi angle isotropic. Reconstruct pT. PHI(I)=PARU(2)*PYR(0) PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))- & PMS(I))*SIN(THETA(I)) C...Store info on variables selected, for documentation purposes. VINT(2+I)=-SQRT(Q2(I)) VINT(304+I)=X(I) VINT(306+I)=Q2(I) VINT(308+I)=Y(I) VINT(310+I)=THETA(I) VINT(312+I)=PHI(I) ELSE VINT(304+I)=1D0 VINT(306+I)=0D0 VINT(308+I)=1D0 VINT(310+I)=0D0 VINT(312+I)=0D0 ENDIF 130 CONTINUE C...Cut on W combines info from two sides. IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)- & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0* & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)* & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2) IF(W2.LT.W2MIN) GOTO 120 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120 PMS1=-Q2(1) PMS2=-Q2(2) ELSEIF(MINT(141).NE.0) THEN W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1)) PMS1=-Q2(1) PMS2=PMS(2) ELSEIF(MINT(142).NE.0) THEN W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2)) PMS1=PMS(1) PMS2=-Q2(2) ENDIF C...Store kinematics info for photon(s) in subsystem cm frame. VINT(2)=W2 VINT(1)=SQRT(W2) VINT(291)=0D0 VINT(292)=0D0 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1) VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1) VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1) VINT(296)=0D0 VINT(297)=0D0 VINT(298)=-VINT(293) VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1) VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2) C...Assign weight for photon flux; different for transverse and C...longitudinal photons. Flag incoming unresolved photon. WTGAGA=1D0 DO 140 I=1,2 IF(MINT(140+I).NE.0) THEN WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))* & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I)) IF(MSTP(16).EQ.0) THEN XY=X(I) ELSE WTGAGA=WTGAGA*X(I)/Y(I) XY=Y(I) ENDIF IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN WTGAGA=WTGAGA*(1D0-XY) ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN WTGAGA=WTGAGA*(1D0-XY) ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN WTGAGA=WTGAGA*(1D0-XY) ELSE WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)- & PMS(I)*XY**2/Q2(I)) ENDIF IF(MINT(106+I).EQ.0) MINT(14+I)=22 ENDIF 140 CONTINUE VINT(319)=WTGAGA MINT(143)=LOOP C...Update pTmin and cross section information. IF(MSTP(82).LE.1) THEN PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90) ELSE PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) ENDIF VINT(149)=4D0*PTMN**2/VINT(2) VINT(154)=PTMN CALL PYXTOT C...Reconstruct kinematics of photons inside leptons. ELSEIF(IGAGA.EQ.4) THEN C...Make place for incoming particles and scattered leptons. MOVE=3 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4 MINT(4)=MINT(4)+MOVE DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1 IF(K(I,1).EQ.21) THEN DO 150 J=1,5 K(I+MOVE,J)=K(I,J) P(I+MOVE,J)=P(I,J) V(I+MOVE,J)=V(I,J) 150 CONTINUE IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84)) & K(I+MOVE,3)=K(I,3)+MOVE IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84)) & K(I+MOVE,4)=K(I,4)+MOVE IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84)) & K(I+MOVE,5)=K(I,5)+MOVE ENDIF 160 CONTINUE DO 170 I=MINT(84)+1,N IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84)) & K(I,3)=K(I,3)+MOVE 170 CONTINUE C...Fill in incoming particles. DO 190 I=MINT(83)+1,MINT(83)+MOVE DO 180 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 180 CONTINUE 190 CONTINUE DO 200 I=1,2 K(MINT(83)+I,1)=21 IF(MINT(140+I).NE.0) THEN K(MINT(83)+I,2)=MINT(140+I) P(MINT(83)+I,5)=VINT(302+I) ELSE K(MINT(83)+I,2)=MINT(10+I) P(MINT(83)+I,5)=VINT(2+I) ENDIF P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/ & VINT(302))*(-1D0)**(I+1) P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301) 200 CONTINUE C...New mother-daughter relations in documentation section. IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN K(MINT(83)+1,4)=MINT(83)+3 K(MINT(83)+1,5)=MINT(83)+5 K(MINT(83)+2,4)=MINT(83)+4 K(MINT(83)+2,5)=MINT(83)+6 K(MINT(83)+3,3)=MINT(83)+1 K(MINT(83)+5,3)=MINT(83)+1 K(MINT(83)+4,3)=MINT(83)+2 K(MINT(83)+6,3)=MINT(83)+2 ELSEIF(MINT(141).NE.0) THEN K(MINT(83)+1,4)=MINT(83)+3 K(MINT(83)+1,5)=MINT(83)+4 K(MINT(83)+2,4)=MINT(83)+5 K(MINT(83)+3,3)=MINT(83)+1 K(MINT(83)+4,3)=MINT(83)+1 K(MINT(83)+5,3)=MINT(83)+2 ELSEIF(MINT(142).NE.0) THEN K(MINT(83)+1,4)=MINT(83)+4 K(MINT(83)+2,4)=MINT(83)+3 K(MINT(83)+2,5)=MINT(83)+5 K(MINT(83)+3,3)=MINT(83)+2 K(MINT(83)+4,3)=MINT(83)+1 K(MINT(83)+5,3)=MINT(83)+2 ENDIF C...Fill scattered lepton(s). DO 210 I=1,2 IF(MINT(140+I).NE.0) THEN LSC=MINT(83)+MIN(I+2,MOVE) K(LSC,1)=21 K(LSC,2)=MINT(140+I) P(LSC,1)=PT(I)*COS(PHI(I)) P(LSC,2)=PT(I)*SIN(PHI(I)) P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4) P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))* & (-1D0)**(I-1) P(LSC,5)=VINT(302+I) ENDIF 210 CONTINUE C...Find incoming four-vectors to subprocess. K(N+1,1)=21 IF(MINT(141).NE.0) THEN DO 220 J=1,4 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J) 220 CONTINUE ELSE DO 230 J=1,4 P(N+1,J)=P(MINT(83)+1,J) 230 CONTINUE ENDIF K(N+2,1)=21 IF(MINT(142).NE.0) THEN DO 240 J=1,4 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J) 240 CONTINUE ELSE DO 250 J=1,4 P(N+2,J)=P(MINT(83)+2,J) 250 CONTINUE ENDIF C...Define boost and rotation between hadronic subsystem and C...collision rest frame; boost hadronic subsystem to this frame. DO 260 J=1,3 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4)) 260 CONTINUE CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) BPHI=PYANGL(P(N+1,1),P(N+1,2)) CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0) BTHETA=PYANGL(P(N+1,3),P(N+1,1)) CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2), & BETA(3)) C...Add on scattered leptons to final state. DO 280 I=1,2 IF(MINT(140+I).NE.0) THEN LSC=MINT(83)+MIN(I+2,MOVE) N=N+1 DO 270 J=1,5 K(N,J)=K(LSC,J) P(N,J)=P(LSC,J) V(N,J)=V(LSC,J) 270 CONTINUE K(N,1)=1 K(N,3)=LSC ENDIF 280 CONTINUE ENDIF RETURN END C********************************************************************* C...PYRAND C...Generates quantities characterizing the high-pT scattering at the C...parton level according to the matrix elements. Chooses incoming, C...reacting partons, their momentum fractions and one of the possible C...subprocesses. SUBROUTINE PYRAND C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...User process initialization and event commonblocks. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) INTEGER MAXNUP PARAMETER (MAXNUP=500) INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), &VTIMUP(MAXNUP),SPINUP(MAXNUP) SAVE /HEPRUP/,/HEPEUP/ C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT7/SIGT(0:6,0:6,0:5) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/ C...Local arrays. DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2) C...Parameters and data used in elastic/diffractive treatment. DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/, &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/ C...Initial values, specifically for (first) semihard interaction. MINT(10)=0 MINT(17)=0 MINT(18)=0 VINT(143)=1D0 VINT(144)=1D0 VINT(157)=0D0 VINT(158)=0D0 MFAIL=0 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1 ISUB=0 ISTSB=0 LOOP=0 100 LOOP=LOOP+1 MINT(51)=0 MINT(143)=1 VINT(97)=1D0 C...Start by assuming incoming photon is entering subprocess. IF(MINT(11).EQ.22) THEN MINT(15)=22 VINT(307)=VINT(3)**2 ENDIF IF(MINT(12).EQ.22) THEN MINT(16)=22 VINT(308)=VINT(4)**2 ENDIF MINT(103)=MINT(11) MINT(104)=MINT(12) C...Choice of process type - first event of pileup. INMULT=0 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN ELSEIF(MINT(82).EQ.1) THEN C...For gamma-p or gamma-gamma first pick between alternatives. IGA=0 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA) MINT(122)=IGA C...For real gamma + gamma with different nature, flip at random. IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND. & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN MINTSV=MINT(41) MINT(41)=MINT(42) MINT(42)=MINTSV MINTSV=MINT(45) MINT(45)=MINT(46) MINT(46)=MINTSV MINTSV=MINT(107) MINT(107)=MINT(108) MINT(108)=MINTSV IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47) ENDIF C...Pick process type, possibly by user process machinery. C...(If the latter, also event will be picked here.) IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN CALL UPEVNT CALL PYUPRE ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN CALL UPEVNT CALL PYUPRE ISUB=0 110 ISUB=ISUB+1 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND. & ISUB.LT.500) GOTO 110 ELSE RSUB=XSEC(0,1)*PYR(0) DO 120 I=1,500 IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120 ISUB=I RSUB=RSUB-XSEC(I,1) IF(RSUB.LE.0D0) GOTO 130 120 CONTINUE 130 IF(ISUB.EQ.95) ISUB=96 IF(ISUB.EQ.96) INMULT=1 IF(ISET(ISUB).EQ.11) THEN IDPRUP=KFPR(ISUB,2) CALL UPEVNT CALL PYUPRE ENDIF ENDIF C...Choice of inclusive process type - pileup events. ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN RSUB=VINT(131)*PYR(0) ISUB=96 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2)) & ISUB=91 IF(ISUB.EQ.96) INMULT=1 ENDIF C...Choice of photon energy and flux factor inside lepton. IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN CALL PYGAGA(3,WTGAGA) IF(ISUB.GE.131.AND.ISUB.LE.140) THEN CKIN(3)=MAX(VINT(285),VINT(154)) CKIN(1)=2D0*CKIN(3) ENDIF C...When necessary set direct/resolved photon by hand. ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0 ENDIF C...Restrict direct*resolved processes to pTmin >= Q, C...to avoid doublecounting with DIS. IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN IF(MINT(15).EQ.22) THEN CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3))) ELSE CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4))) ENDIF CKIN(1)=2D0*CKIN(3) ENDIF C...Set up for multiple interactions. 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) THEN IF(ISUB.GE.258) THEN RKF=4D0 ELSE RKF=5D0 ENDIF IF(MOD(ISUB,2).EQ.0) THEN KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0)) ELSE KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0)) ENDIF C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c. ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN KSU1=KSUSY1 KSU2=KSUSY1 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN KSU1=KSUSY2 KSU2=KSUSY2 ELSEIF(PYR(0).LT.0.5D0) THEN KSU1=KSUSY1 KSU2=KSUSY2 ELSE KSU1=KSUSY2 KSU2=KSUSY1 ENDIF KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0)) KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0)) C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c. ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0)) KFPR(ISUB,2)=KFPR(ISUB,1) ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0)) KFPR(ISUB,2)=KFPR(ISUB,1) C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c. ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN KSU1=KSUSY1 KSU2=KSUSY1 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN KSU1=KSUSY2 KSU2=KSUSY2 ELSEIF(PYR(0).LT.0.5D0) THEN KSU1=KSUSY1 KSU2=KSUSY2 ELSE KSU1=KSUSY2 KSU2=KSUSY1 ENDIF IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN RKF=5D0 ELSE RKF=4D0 ENDIF KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0)) ENDIF ENDIF C...Find resonances (explicit or implicit in cross-section). MINT(72)=0 KFR1=0 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN KFR1=KFPR(ISUB,1) ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR. & ISUB.EQ.171.OR.ISUB.EQ.176) THEN KFR1=23 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR. & ISUB.EQ.177) THEN KFR1=24 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN KFR1=25 IF(MSTP(46).EQ.5) THEN KFR1=89 PMAS(89,1)=PARP(45) PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2) ENDIF ELSEIF(ISUB.EQ.194) THEN KFR1=KTECHN+113 ELSEIF(ISUB.EQ.195) THEN KFR1=KTECHN+213 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN KFR1=KTECHN+113 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN KFR1=KTECHN+213 ENDIF CKMX=CKIN(2) IF(CKMX.LE.0D0) CKMX=VINT(1) KCR1=PYCOMP(KFR1) IF(KFR1.NE.0) THEN IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR. & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0 ENDIF IF(KFR1.NE.0) THEN TAUR1=PMAS(KCR1,1)**2/VINT(2) IF(KFR1.EQ.KTECHN+113) THEN CALL PYTECM(S1,S2) TAUR1=S1/VINT(2) ENDIF GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2) MINT(72)=1 MINT(73)=KFR1 VINT(73)=TAUR1 VINT(74)=GAMR1 ENDIF IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368)) $THEN KFR2=23 IF(ISUB.EQ.194) THEN KFR2=KTECHN+223 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN KFR2=KTECHN+223 ENDIF KCR2=PYCOMP(KFR2) TAUR2=PMAS(KCR2,1)**2/VINT(2) IF(KFR2.EQ.KTECHN+223) THEN CALL PYTECM(S1,S2) TAUR2=S2/VINT(2) ENDIF GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2) IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR. & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN MINT(72)=2 MINT(74)=KFR2 VINT(75)=TAUR2 VINT(76)=GAMR2 ELSEIF(KFR2.NE.0) THEN KFR1=KFR2 TAUR1=TAUR2 GAMR1=GAMR2 MINT(72)=1 MINT(73)=KFR1 VINT(73)=TAUR1 VINT(74)=GAMR1 ENDIF ENDIF C...Find product masses and minimum pT of process, C...optionally with broadening according to a truncated Breit-Wigner. VINT(63)=0D0 VINT(64)=0D0 MINT(71)=0 VINT(71)=CKIN(3) IF(MINT(82).GE.2) VINT(71)=0D0 VINT(80)=1D0 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN NBW=0 DO 160 I=1,2 PMMN(I)=0D0 IF(KFPR(ISUB,I).EQ.0) THEN ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT. & PARP(41)) THEN VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2 ELSE NBW=NBW+1 C...This prevents SUSY/t particles from becoming too light. KFLW=KFPR(ISUB,I) IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN KCW=PYCOMP(KFLW) PMMN(I)=PMAS(KCW,1) DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+ & PMAS(PYCOMP(KFDP(IDC,2)),1) IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+ & PMAS(PYCOMP(KFDP(IDC,3)),1) PMMN(I)=MIN(PMMN(I),PMSUM) ENDIF 150 CONTINUE ELSEIF(KFLW.EQ.6) THEN PMMN(I)=PMAS(24,1)+PMAS(5,1) ENDIF ENDIF 160 CONTINUE IF(NBW.GE.1) THEN CKIN41=CKIN(41) CKIN43=CKIN(43) CKIN(41)=MAX(PMMN(1),CKIN(41)) CKIN(43)=MAX(PMMN(2),CKIN(43)) CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4) CKIN(41)=CKIN41 CKIN(43)=CKIN43 IF(MINT(51).EQ.1) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(MFAIL.EQ.1) THEN MSTI(61)=1 RETURN ENDIF GOTO 100 ENDIF VINT(63)=PQM3**2 VINT(64)=PQM4**2 ENDIF IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5)) ENDIF C...Prepare for additional variable choices in 2 -> 3. IF(ISTSB.EQ.5) THEN VINT(201)=0D0 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1) VINT(206)=VINT(201) IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1) VINT(204)=PMAS(23,1) IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1) IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1) IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR. & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) & VINT(204)=VINT(201) VINT(209)=VINT(204) IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206) ENDIF C...Select incoming VDM particle (rho/omega/phi/J/psi). IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND. &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN VRN=PYR(0)*SIGT(0,0,5) IF(MINT(101).LE.1) THEN I1MN=0 I1MX=0 ELSE I1MN=1 I1MX=MINT(101) ENDIF IF(MINT(102).LE.1) THEN I2MN=0 I2MX=0 ELSE I2MN=1 I2MX=MINT(102) ENDIF DO 180 I1=I1MN,I1MX KFV1=110*I1+3 DO 170 I2=I2MN,I2MX KFV2=110*I2+3 VRN=VRN-SIGT(I1,I2,5) IF(VRN.LE.0D0) GOTO 190 170 CONTINUE 180 CONTINUE 190 IF(MINT(101).GE.2) MINT(103)=KFV1 IF(MINT(102).GE.2) MINT(104)=KFV2 ENDIF IF(ISTSB.EQ.0) THEN C...Elastic scattering or single or double diffractive scattering. C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass. MINT(103)=MINT(11) MINT(104)=MINT(12) PMM(1)=VINT(3) PMM(2)=VINT(4) IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN JJ=ISUB-90 VRN=PYR(0)*SIGT(0,0,JJ) IF(MINT(101).LE.1) THEN I1MN=0 I1MX=0 ELSE I1MN=1 I1MX=MINT(101) ENDIF IF(MINT(102).LE.1) THEN I2MN=0 I2MX=0 ELSE I2MN=1 I2MX=MINT(102) ENDIF DO 210 I1=I1MN,I1MX KFV1=110*I1+3 DO 200 I2=I2MN,I2MX KFV2=110*I2+3 VRN=VRN-SIGT(I1,I2,JJ) IF(VRN.LE.0D0) GOTO 220 200 CONTINUE 210 CONTINUE 220 IF(MINT(101).GE.2) THEN MINT(103)=KFV1 PMM(1)=PYMASS(KFV1) ENDIF IF(MINT(102).GE.2) THEN MINT(104)=KFV2 PMM(2)=PYMASS(KFV2) ENDIF ENDIF VINT(67)=PMM(1) VINT(68)=PMM(2) C...Select mass for GVMD states (rejecting previous assignment). Q0S=4D0*PARP(15)**2 Q1S=4D0*VINT(154)**2 LOOP3=0 230 LOOP3=LOOP3+1 DO 240 JT=1,2 IF(MINT(106+JT).EQ.3) THEN PS=VINT(2+JT)**2 PMM(JT)=(Q0S+PS)*(Q1S+PS)/ & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)- & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1) ENDIF 240 CONTINUE IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3)) & GOTO 230 GOTO 100 ENDIF C...Side/sides of diffractive system. MINT(17)=0 MINT(18)=0 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1 C...Find masses of particles and minimal masses of diffractive states. DO 250 JT=1,2 PDIF(JT)=PMM(JT) VINT(68+JT)=PDIF(JT) IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102) 250 CONTINUE SH=VINT(2) SQM1=PMM(1)**2 SQM2=PMM(2)**2 SQM3=PDIF(1)**2 SQM4=PDIF(2)**2 SMRES1=(PMM(1)+PMRC)**2 SMRES2=(PMM(2)+PMRC)**2 C...Find elastic slope and lower limit diffractive slope. IHA=MAX(2,IABS(MINT(103))/110) IF(IHA.GE.5) IHA=1 IHB=MAX(2,IABS(MINT(104))/110) IF(IHB.GE.5) IHB=1 IF(ISUB.EQ.91) THEN BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0 ELSEIF(ISUB.EQ.92) THEN BMN=MAX(2D0,2D0*BHAD(IHB)) ELSEIF(ISUB.EQ.93) THEN BMN=MAX(2D0,2D0*BHAD(IHA)) ELSEIF(ISUB.EQ.94) THEN BMN=2D0*ALP*4D0 ENDIF C...Determine maximum possible t range and coefficient of generation. SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)* & (SQM1*SQM4-SQM2*SQM3)/SH THL=-0.5D0*(THA+THB) THU=THC/THL THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0 C...Select diffractive mass/masses according to dm^2/m^2. LOOP3=0 260 LOOP3=LOOP3+1 DO 270 JT=1,2 IF(MINT(16+JT).EQ.0) THEN PDIF(2+JT)=PDIF(JT) ELSE PMMIN=PDIF(JT) PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT)) PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0) ENDIF 270 CONTINUE SQM3=PDIF(3)**2 SQM4=PDIF(4)**2 C..Additional mass factors, including resonance enhancement. IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN IF(LOOP3.LT.100) GOTO 260 GOTO 100 ENDIF IF(ISUB.EQ.92) THEN FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3)) IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260 ELSEIF(ISUB.EQ.93) THEN FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4)) IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260 ELSEIF(ISUB.EQ.94) THEN FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/ & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))* & (1D0+CRES*SMRES2/(SMRES2+SQM4)) IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260 ENDIF C...Select t according to exp(Bmn*t) and correct to right slope. TH=THU+LOG(1D0+THRND*PYR(0))/BMN IF(ISUB.GE.92) THEN IF(ISUB.EQ.92) THEN BADD=2D0*ALP*LOG(SH/SQM3) IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0) ELSEIF(ISUB.EQ.93) THEN BADD=2D0*ALP*LOG(SH/SQM4) IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0) ELSEIF(ISUB.EQ.94) THEN BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0) ENDIF IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260 ENDIF C...Check whether m^2 and t choices are consistent. SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH IF(THB.LE.1D-8) GOTO 260 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)* & (SQM1*SQM4-SQM2*SQM3)/SH THLM=-0.5D0*(THA+THB) THUM=THC/THLM IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260 C...Information to output. VINT(21)=1D0 VINT(22)=0D0 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB)) VINT(45)=TH VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB VINT(63)=PDIF(3)**2 VINT(64)=PDIF(4)**2 VINT(283)=PMM(1)**2/4D0 VINT(284)=PMM(2)**2/4D0 C...Note: in the following, by In is meant the integral over the C...quantity multiplying coefficient cn. C...Choose tau according to h1(tau)/tau, where C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) + C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) + C...I1/I5*c5*1/(tau+tau_R') + C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) + C...I1/I7*c7*tau/(1.-tau), and C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1. ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN CALL PYKLIM(1) IF(MINT(51).NE.0) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(MFAIL.EQ.1) THEN MSTI(61)=1 RETURN ENDIF GOTO 100 ENDIF RTAU=PYR(0) MTAU=1 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)) & MTAU=5 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+ & COEF(ISUB,5)) MTAU=6 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+ & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7 CALL PYKMAP(1,MTAU,PYR(0)) C...2 -> 3, 4 processes: C...Choose tau' according to h4(tau,tau')/tau', where C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' + C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1. IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN CALL PYKLIM(4) IF(MINT(51).NE.0) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(MFAIL.EQ.1) THEN MSTI(61)=1 RETURN ENDIF GOTO 100 ENDIF RTAUP=PYR(0) MTAUP=1 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3 CALL PYKMAP(4,MTAUP,PYR(0)) ENDIF C...Choose y* according to h2(y*), where C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) + C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) + C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min, C...and c1 + c2 + c3 + c4 + c5 = 1. CALL PYKLIM(2) IF(MINT(51).NE.0) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(MFAIL.EQ.1) THEN MSTI(61)=1 RETURN ENDIF GOTO 100 ENDIF RYST=PYR(0) MYST=1 IF(RYST.GT.COEF(ISUB,8)) MYST=2 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+ & COEF(ISUB,11)) MYST=5 CALL PYKMAP(2,MYST,PYR(0)) C...2 -> 2 processes: C...Choose cos(theta-hat) (cth) according to h3(cth), where C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) + C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2, C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products), C...and c0 + c1 + c2 + c3 + c4 = 1. CALL PYKLIM(3) IF(MINT(51).NE.0) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(MFAIL.EQ.1) THEN MSTI(61)=1 RETURN ENDIF GOTO 100 ENDIF IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN RCTH=PYR(0) MCTH=1 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+ & COEF(ISUB,16)) MCTH=5 CALL PYKMAP(3,MCTH,PYR(0)) ENDIF C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing. IF(ISTSB.EQ.5) THEN CALL PYKMAP(5,0,0D0) IF(MINT(51).NE.0) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(MFAIL.EQ.1) THEN MSTI(61)=1 RETURN ENDIF GOTO 100 ENDIF ENDIF C...DIS as f + gamma* -> f process: set dummy values. ELSEIF(ISTSB.EQ.8) THEN VINT(21)=0.9D0 VINT(22)=0D0 VINT(23)=0D0 VINT(47)=0D0 VINT(48)=0D0 C...Low-pT or multiple interactions (first semihard interaction). ELSEIF(ISTSB.EQ.9) THEN IF(MINT(35).LE.1) CALL PYMULT(3) IF(MINT(35).GE.2) CALL PYMIGN(3) ISUB=MINT(1) C...Study user-defined process: kinematics plus weight. ELSEIF(ISTSB.EQ.11) THEN IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process') MSTI(51)=0 IF(NUP.LE.0) THEN MINT(51)=2 MSTI(51)=1 IF(MINT(82).EQ.1) THEN NGEN(0,1)=NGEN(0,1)-1 NGEN(ISUB,1)=NGEN(ISUB,1)-1 ENDIF IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) RETURN ENDIF C...Extract cross section event weight. IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN SIGS=1D-9*XWGTUP ELSE SIGS=1D-9*XSECUP(KFPR(ISUB,1)) ENDIF IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN VINT(97)=SIGN(1D0,XWGTUP) ELSE VINT(97)=1D-9*XWGTUP ENDIF C...Construct 'trivial' kinematical variables needed. KFL1=IDUP(1) KFL2=IDUP(2) VINT(41)=PUP(4,1)/EBMUP(1) VINT(42)=PUP(4,2)/EBMUP(2) VINT(21)=VINT(41)*VINT(42) VINT(22)=0.5D0*LOG(VINT(41)/VINT(42)) VINT(44)=VINT(21)*VINT(2) VINT(43)=SQRT(MAX(0D0,VINT(44))) VINT(55)=SCALUP IF(SCALUP.LE.0D0) VINT(55)=VINT(43) VINT(56)=VINT(55)**2 VINT(57)=AQEDUP VINT(58)=AQCDUP C...Construct other kinematical variables needed (approximately). VINT(23)=0D0 VINT(26)=VINT(21) VINT(45)=-0.5D0*VINT(44) VINT(46)=-0.5D0*VINT(44) VINT(49)=VINT(43) VINT(50)=VINT(44) VINT(51)=VINT(55) VINT(52)=VINT(56) VINT(53)=VINT(55) VINT(54)=VINT(56) VINT(25)=0D0 VINT(48)=0D0 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26, & '(PYRAND:) unacceptable ISTUP code for incoming particles') DO 280 IUP=3,NUP IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26, & '(PYRAND:) unacceptable ISTUP code for particles') IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+ & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2) IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+ & PUP(2,IUP)**2) 280 CONTINUE VINT(47)=SQRT(VINT(48)) ENDIF C...Choose azimuthal angle. VINT(24)=0D0 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0) C...Check against user cuts on kinematics at parton level. MINT(51)=0 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0) IF(MINT(51).NE.0) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(MFAIL.EQ.1) THEN MSTI(61)=1 RETURN ENDIF GOTO 100 ENDIF IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN MCUT=0 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0) & CALL PYKCUT(MCUT) IF(MCUT.NE.0) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(MFAIL.EQ.1) THEN MSTI(61)=1 RETURN ENDIF GOTO 100 ENDIF ENDIF C...Calculate differential cross-section for different subprocesses. IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS) SIGSOR=SIGS SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316) C...Multiply cross section by lepton -> photon flux factor. IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN SIGS=WTGAGA*SIGS DO 290 ICHN=1,NCHN SIGH(ICHN)=WTGAGA*SIGH(ICHN) 290 CONTINUE SIGLPT=WTGAGA*SIGLPT ENDIF C...Multiply cross-section by user-defined weights. IF(MSTP(173).EQ.1) THEN SIGS=PARP(173)*SIGS DO 300 ICHN=1,NCHN SIGH(ICHN)=PARP(173)*SIGH(ICHN) 300 CONTINUE SIGLPT=PARP(173)*SIGLPT ENDIF WTXS=1D0 SIGSWT=SIGS VINT(99)=1D0 VINT(100)=1D0 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+ & MSUB(95).EQ.0) CALL PYEVWT(WTXS) SIGSWT=WTXS*SIGS VINT(99)=WTXS IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS ENDIF C...Calculations for Monte Carlo estimate of all cross-sections. IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN IF(MSTP(142).LE.1) THEN XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS ELSE XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT ENDIF ELSEIF(MINT(82).EQ.1) THEN XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS ENDIF IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND. &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT C...Multiple interactions: store results of cross-section calculation. IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN VINT(153)=SIGSOR IF(MINT(35).LE.1) CALL PYMULT(4) IF(MINT(35).GE.2) CALL PYMIGN(4) ENDIF C...Ratio of actual to maximum cross section. IF(ISTSB.NE.11) THEN VIOL=SIGSWT/XSEC(ISUB,1) IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174) ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1)) ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1))) ELSE VIOL=1D0 ENDIF C...Check that weight not negative. IF(MSTP(123).LE.0) THEN IF(VIOL.LT.-1D-3) THEN WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21), & VINT(22),VINT(23),VINT(26) STOP ENDIF ELSE IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN VINT(109)=VIOL WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21), & VINT(22),VINT(23),VINT(26) ENDIF ENDIF C...Weighting using estimate of maximum of differential cross-section. RATND=1D0 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN IF(VIOL.LT.PYR(0)) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0 GOTO 100 ENDIF ELSEIF(MFAIL.EQ.0) THEN RATND=SIGLPT/XSEC(95,1) VIOL=VIOL/RATND IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND. & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143) IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) ISUB=0 GOTO 100 ENDIF IF(VIOL.LT.PYR(0)) THEN GOTO 140 ENDIF ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN IF(VIOL.LT.PYR(0)) THEN MSTI(61)=1 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) RETURN ENDIF ELSE RATND=SIGLPT/XSEC(95,1) IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN MSTI(61)=1 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) RETURN ENDIF VIOL=VIOL/RATND IF(VIOL.LT.PYR(0)) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) GOTO 100 ENDIF ENDIF C...Check for possible violation of estimated maximum of differential C...cross-section used in weighting. IF(MSTP(123).LE.0) THEN IF(VIOL.GT.1D0) THEN WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21), & VINT(22),VINT(23),VINT(26) STOP ENDIF ELSEIF(MSTP(123).EQ.1) THEN IF(VIOL.GT.VINT(108)) THEN VINT(108)=VIOL IF(VIOL.GT.1.0001D0) THEN MINT(10)=1 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21), & VINT(22),VINT(23),VINT(26) ENDIF ENDIF ELSEIF(VIOL.GT.VINT(108)) THEN VINT(108)=VIOL IF(VIOL.GT.1D0) THEN MINT(10)=1 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 WRITE(MSTU(11),5800) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1)) ELSEIF(KFPR(ISUB,1).LE.99) THEN WRITE(MSTU(11),5900) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1)) ELSE 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 WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1) ELSEIF(ISUB.LE.99) THEN WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1) ELSE WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1) ENDIF ENDIF VINT(108)=1D0 ENDIF ENDIF C...Multiple interactions: choose impact parameter. 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...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(MAXNUP),PTPART(MAXNUP) 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 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 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 (MAXNUP=500) C...Commonblocks. COMMON/PYPART/NPART,NPARTD,IPART(MAXNUP),PTPART(MAXNUP) 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. PT2HD=VINT(54) CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM) IF(MINT(51).NE.0) RETURN C...Decide whether quarks in hard scattering were valence or sea 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 starting value for iteration in PT2. IF (ISUBHD.EQ.95) THEN XT2GMX=0D0 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBHD.NE.11.AND. & ISUBHD.NE.12.AND.ISUBHD.NE.13.AND.ISUBHD.NE.28.AND. & ISUBHD.NE.53.AND.ISUBHD.NE.68.AND.ISUBHD.NE.95.AND. & ISUBHD.NE.96)) THEN C...All accessible phase space allowed. Select largest of IS and MI C...boundaries for hardest interaction. XT2GMX=MAX((1D0-VINT(21))**2, & (1D0-XMI(1,1))*(1D0-XMI(2,1))) 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(ISET(ISUBHD).EQ.1) XT2MI=VINT(21) IF(ISET(ISUBHD).EQ.2) & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2) IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) XT2GMX=VINT(26) ENDIF PT2MAX=MIN(PT2MAX,0.25D0*XT2GMX*VINT(2)) 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 PT2MAX as max scale. CALL PYPTIS(-1,PT2MAX,PT2MIN,PT2DUM,IFAIL) IF(MINT(51).NE.0) RETURN RETURN C---------------------------------------------------------------------- C...MODE= 1: Evolve event from PTMAX to PTMIN. ELSEIF (MODE.EQ.1) THEN C...Skip if no phase space. 190 IF (PT2MAX.LE.PT2MIN) GOTO 330 C...Starting pT2 max scale (to be udpated successively). PT2CMX=PT2MAX C...Evolve two sides of the event to find which branches at highest pT. 200 JSMX=-1 MIMX=0 PT2MX=0D0 C...Loop over current shower initiators. IF (MSTP(61).GE.1) THEN DO 230 MI=1,MINT(31) IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230 ISUB=96 IF (MI.EQ.1) ISUB=ISUBHD MINT(1)=ISUB MINT(36)=MI C...Set up shat, initiator x values, and x remaining in BR. VINT(44)=SHAT(MI) VINT(141)=XMI(1,MI) VINT(142)=XMI(2,MI) VINT(143)=1D0 VINT(144)=1D0 DO 210 JI=1,MINT(31) IF (JI.EQ.MINT(36)) GOTO 210 VINT(143)=VINT(143)-XMI(1,JI) VINT(144)=VINT(144)-XMI(2,JI) 210 CONTINUE C...Loop over sides. C...Generate trial branchings for this interaction. The hardest C...branching so far is automatically updated if necessary in /PYISMX/. DO 220 JS=1,2 MINT(30)=JS CALL PYPTIS(0,PT2CMX,PT2MIN,PT2NEW,IFAIL) IF (MINT(51).NE.0) RETURN 220 CONTINUE 230 CONTINUE ENDIF C...Generate trial additional interaction. MINT(36)=MINT(31)+1 240 IF (MOD(MSTP(81),10).GE.1) THEN MINT(1)=96 C...Set up X remaining in BR. VINT(143)=1D0 VINT(144)=1D0 DO 250 JI=1,MINT(31) VINT(143)=VINT(143)-XMI(1,JI) VINT(144)=VINT(144)-XMI(2,JI) 250 CONTINUE C...Generate trial interaction 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL) IF (MINT(51).EQ.1) RETURN ENDIF C...And the winner is: IF (PT2MX.LT.PT2MIN) THEN GOTO 330 ELSEIF (JSMX.EQ.0) THEN C...Accept additional interaction (may still fail). CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL) IF(MINT(51).NE.0) RETURN IF (IFAIL.EQ.0) THEN SHAT(MINT(36))=VINT(44) C...Decide on flavours (valence/sea/companion). DO 270 JS=1,2 MINT(30)=JS CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL) IF(MINT(51).NE.0) RETURN 270 CONTINUE ENDIF ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN C...Reconstruct kinematics of acceptable ISR branching. C...Set up shat, initiator x values, and x remaining in BR. MINT(30)=JSMX MINT(36)=MIMX VINT(44)=SHAT(MINT(36)) VINT(141)=XMI(1,MINT(36)) VINT(142)=XMI(2,MINT(36)) VINT(143)=1D0 VINT(144)=1D0 DO 280 JI=1,MINT(31) IF (JI.EQ.MINT(36)) GOTO 280 VINT(143)=VINT(143)-XMI(1,JI) VINT(144)=VINT(144)-XMI(2,JI) 280 CONTINUE PT2NEW=PT2MX CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL) IF (MINT(51).EQ.1) RETURN ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN C...Bookeep joining. Cannot (yet) be constructed kinematically. MINT(354)=MINT(354)+1 VINT(354)=VINT(354)+SQRT(PT2MX) IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX) MJOIND(JSMX-2,MJN1MX)=MJN2MX MJOIND(JSMX-2,MJN2MX)=MJN1MX ENDIF C...Update PT2 iteration scale. PT2CMX=PT2MX C...Loop back to continue evolution. IF(N.GT.MSTU(4)-MSTU(32)-10) THEN CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS') ELSE IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200 ENDIF C---------------------------------------------------------------------- C...MODE= 2: (Re-)store user information on hardest interaction etc. ELSEIF (MODE.EQ.2) THEN C...Revert to "ordinary" meanings of some parameters. 290 DO 310 JS=1,2 MINT(12+JS)=K(IMI(JS,1,1),2) VINT(140+JS)=XMI(JS,1) IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1) VINT(142+JS)=1D0 DO 300 MI=1,MINT(31) VINT(142+JS)=VINT(142+JS)-XMI(JS,MI) 300 CONTINUE 310 CONTINUE C...Restore saved quantities for hardest interaction. MINT(1)=ISUBHD MINT(15)=M15SV MINT(16)=M16SV MINT(21)=M21SV MINT(22)=M22SV DO 320 J=11,80 VINT(J)=VINTSV(J) 320 CONTINUE ENDIF 330 RETURN END C********************************************************************* C...PYSSPA C...Generates spacelike parton showers. SUBROUTINE PYSSPA(IPU1,IPU2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT2/,/PYINT3/ C...Local arrays and data. DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2), &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25), &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4), &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2), &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2) DATA IS/2*0/ C...Read out basic information; set global Q^2 scale. IPUS1=IPU1 IPUS2=IPU2 ISUB=MINT(1) Q2MX=VINT(56) VINT2R=VINT(2)*VINT(143)*VINT(144) IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX= &MIN(VINT2R,PARP(67)*VINT(56)) FCQ2MX=1D0 C...Define which processes ME corrections have been implemented for. MECOR=0 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR. & ISUB.EQ.144) MECOR=1 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2 ENDIF C...Initialize QCD evolution and check phase space. Q2MNC=PARP(62)**2 Q2MNCS(1)=Q2MNC Q2MNCS(2)=Q2MNC IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN Q0S=PARP(15)**2 PS=VINT(3)**2 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) Q2INT=SQRT(Q0S*Q2EFF) Q2MNCS(1)=MAX(Q2MNC,Q2INT) ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN Q2MNCS(1)=MAX(Q2MNC,VINT(283)) ENDIF IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN Q0S=PARP(15)**2 PS=VINT(4)**2 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) Q2INT=SQRT(Q0S*Q2EFF) Q2MNCS(2)=MAX(Q2MNC,Q2INT) ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN Q2MNCS(2)=MAX(Q2MNC,VINT(284)) ENDIF MCEV=0 ALAMS=PARU(112) PARU(112)=PARP(61) FQ2C=1D0 TCMX=0D0 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN MCEV=1 IF(MSTP(64).EQ.1) FQ2C=PARP(63) IF(MSTP(64).EQ.2) FQ2C=PARP(64) TCMX=LOG(FQ2C*Q2MX/PARP(61)**2) IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0) & MCEV=0 ENDIF C...Initialize QED evolution and check phase space. MEEV=0 XEE=1D-10 SPME=PMAS(11,1)**2 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13) &SPME=PMAS(13,1)**2 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15) &SPME=PMAS(15,1)**2 Q2MNE=MAX(PARP(68)**2,2D0*SPME) TEMX=0D0 FWTE=10D0 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN MEEV=1 TEMX=LOG(Q2MX/SPME) IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0 ENDIF IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN MEEV=2 TEMX=TCMX FWTE=1D0 ENDIF IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN C...Loopback point in case of failure to reconstruct kinematics. NS=N LOOP=0 MNT352=MINT(352) MNT353=MINT(353) VNT352=VINT(352) VNT353=VINT(353) 100 LOOP=LOOP+1 IF(LOOP.GT.100) THEN MINT(51)=1 RETURN ENDIF N=NS MINT(352)=MNT352 MINT(353)=MNT353 VINT(352)=VNT352 VINT(353)=VNT353 C...Initial values: flavours, momenta, virtualities. DO 120 JT=1,2 MORE(JT)=1 KFBEAM(JT)=MINT(10+JT) IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22 KFLS(JT)=MINT(14+JT) KFLS(JT+2)=KFLS(JT) XS(JT)=VINT(40+JT) IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT) IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT) ZS(JT)=1D0 Q2S(JT)=FCQ2MX*Q2MX DQ2(JT)=0D0 TEVCSV(JT)=TCMX ALAM(JT)=PARP(61) THE2(JT)=1D0 TEVESV(JT)=TEMX MCESV(JT)=0 C...Calculate initial parton distribution weights. MINT(105)=MINT(102+JT) MINT(109)=MINT(106+JT) VINT(120)=VINT(2+JT) IF(XS(JT).LT.1D0-XEE) THEN IF(MINT(31).GE.2) MINT(30)=JT IF(MSTP(57).LE.1) THEN CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB) ELSE CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB) ENDIF ENDIF DO 110 KFL=-25,25 XFS(JT,KFL)=XFB(KFL) 110 CONTINUE C...Special kinematics check for c/b quarks (that g -> c cbar or C...b bbar kinematically possible). KFLCB=IABS(KFLS(JT)) IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN MINT(51)=1 RETURN ENDIF ENDIF 120 CONTINUE DSH=VINT(44) IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2) C...Find if interference with final state partons. MFIS=0 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67) IF(MFIS.NE.0) THEN DO 140 I=1,2 KCFI(I)=0 KCA=PYCOMP(IABS(KFLS(I))) IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I)) NFIS(I)=0 IF(KCFI(I).NE.0) THEN IF(I.EQ.1) IPFS=IPUS1 IF(I.EQ.2) IPFS=IPUS2 DO 130 J=1,2 ICSI=MOD(K(IPFS,3+J),MSTU(5)) IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND. & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN NFIS(I)=NFIS(I)+1 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+ & P(ICSI,2)**2)) IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I)) ENDIF 130 CONTINUE ENDIF 140 CONTINUE IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0 ENDIF C...Pick up leg with highest virtuality. JTOLD=1 150 N=N+1 JT=1 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT IF(MORE(JT).EQ.0) JT=3-JT JTOLD=JT KFLB=KFLS(JT) XB=XS(JT) DO 160 KFL=-25,25 XFB(KFL)=XFS(JT,KFL) 160 CONTINUE DSHR=2D0*SQRT(DSH) DSHZ=DSH/ZS(JT) C...Check if allowed to branch. MCEV=0 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN MCEV=1 XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0)) IF(XB.GE.1D0-2D0*XEC) MCEV=0 ENDIF MEEV=0 IF(MINT(44+JT).EQ.3) THEN MEEV=1 IF(XB.GE.1D0-2D0*XEE) MEEV=0 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC) & MEEV=0 C***Currently kill QED shower for resolved photoproduction. IF(MINT(18+JT).EQ.1) MEEV=0 C***Currently kill shower for W inside electron. IF(IABS(KFLB).EQ.24) THEN MCEV=0 MEEV=0 ENDIF ENDIF IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10) &MEEV=2 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN Q2B=0D0 GOTO 260 ENDIF C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f. Q2B=Q2S(JT) TEVCB=TEVCSV(JT) TEVEB=TEVESV(JT) IF(MSTP(62).LE.1) THEN IF(ZS(JT).GT.0.99999D0) THEN Q2B=Q2S(JT) ELSE Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)* & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+ & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT)))) ENDIF IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2) IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME) ENDIF IF(MCEV.EQ.1) THEN ALSDUM=PYALPS(FQ2C*Q2B) TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117)) ALAM(JT)=PARU(117) B0=(33D0-2D0*MSTU(118))/6D0 ENDIF IF(MEEV.EQ.2) TEVEB=TEVCB TEVCBS=TEVCB TEVEBS=TEVEB C...Select side for interference with final state partons. IF(MFIS.GE.1.AND.N.LE.NS+2) THEN IFI=N-NS ISFI(IFI)=0 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN ISFI(IFI)=1 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN IF(PYR(0).GT.0.5D0) ISFI(IFI)=1 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN ISFI(IFI)=1 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2 ENDIF ENDIF C...Calculate preweighting factor for ME-corrected processes. IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG) C...Calculate Altarelli-Parisi weights. DO 170 KFL=-25,25 WTAPC(KFL)=0D0 WTAPE(KFL)=0D0 WTSF(KFL)=0D0 170 CONTINUE C...q -> q (g or gamma emission), g -> q. IF(IABS(KFLB).LE.10) THEN WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC))) WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC)) EQ2=1D0/9D0 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/ & (XEC*(1D0-XEC))) IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN WTAPC(KFLB)=WTFF*WTAPC(KFLB) WTAPC(21)=WTGF*WTAPC(21) WTAPE(KFLB)=WTFF*WTAPE(KFLB) ENDIF C...f -> f, gamma -> f. ELSEIF(IABS(KFLB).LE.20) THEN WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE))) WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE))) WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2) IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE) IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN WTAPE(KFLB)=WTFF*WTAPE(KFLB) WTAPE(22)=WTGF*WTAPE(22) ENDIF C...f -> g, g -> g. ELSEIF(KFLB.EQ.21) THEN WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB)) DO 180 KFL=1,MSTP(58) WTAPC(KFL)=WTAPQ WTAPC(-KFL)=WTAPQ 180 CONTINUE WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC) IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN DO 190 KFL=1,MSTP(58) WTAPC(KFL)=WTFG*WTAPC(KFL) WTAPC(-KFL)=WTFG*WTAPC(-KFL) 190 CONTINUE WTAPC(21)=WTGG*WTAPC(21) ENDIF C...f -> gamma, W+, W-. ELSEIF(KFLB.EQ.22) THEN WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB WTAPE(11)=WTAPF WTAPE(-11)=WTAPF IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN WTAPE(11)=WTFG*WTAPE(11) WTAPE(-11)=WTFG*WTAPE(-11) ENDIF ELSEIF(KFLB.EQ.24) THEN WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/ & (XEE*(XB+XEE)))/XB ELSEIF(KFLB.EQ.-24) THEN WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/ & (XEE*(XB+XEE)))/XB ENDIF C...Calculate parton distribution weights and sum. NTRY=0 200 NTRY=NTRY+1 IF(NTRY.GT.500) THEN MINT(51)=1 RETURN ENDIF WTSUMC=0D0 WTSUME=0D0 XFBO=MAX(1D-10,XFB(KFLB)) DO 210 KFL=-25,25 WTSF(KFL)=XFB(KFL)/XFBO WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL) WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL) 210 CONTINUE WTSUMC=MAX(0.0001D0,WTSUMC) WTSUME=MAX(0.0001D0/FWTE,WTSUME) C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2). NTRY2=0 220 NTRY2=NTRY2+1 IF(NTRY2.GT.500) THEN MINT(51)=1 RETURN ENDIF IF(MCEV.EQ.1) THEN IF(MSTP(64).LE.0) THEN TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC) ELSEIF(MSTP(64).EQ.1) THEN TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC)) ELSE TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC))) ENDIF ENDIF IF(MEEV.EQ.1) THEN TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/ & (PARU(101)*FWTE*WTSUME*TEMX))) ELSEIF(MEEV.EQ.2) THEN TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME) ENDIF C...Translate t into Q2 scale; choose between QCD and QED evolution. 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB)) IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C C...Ensure that Q2 is above threshold for charm/bottom. KFLCB=IABS(KFLB) IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND. &MCEV.EQ.1) THEN IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN Q2CB=1.1D0*PMAS(KFLCB,1)**2 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2) FCQ2MX=MIN(2D0,1.05D0*FCQ2MX) ENDIF ENDIF IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND. &MEEV.EQ.2) THEN IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0 ENDIF MCE=0 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN IF(Q2CB.GT.Q2MNCS(JT)) MCE=1 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN IF(Q2EB.GT.Q2MNE) MCE=2 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN IF(Q2EB.GT.Q2MNCS(JT)) MCE=2 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN MCE=1 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0 ELSE MCE=2 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0 ENDIF C...Evolution possibly ended. Update t values. IF(MCE.EQ.0) THEN Q2B=0D0 GOTO 260 ELSEIF(MCE.EQ.1) THEN Q2B=Q2CB Q2REF=FQ2C*Q2B IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME) IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2) ELSE Q2B=Q2EB Q2REF=Q2B IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2) ENDIF C...Select flavour for branching parton. IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME KFLA=-25 240 KFLA=KFLA+1 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA) IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA) IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240 IF(KFLA.EQ.25) THEN Q2B=0D0 GOTO 260 ENDIF C...Choose z value and corrective weight. WTZ=0D0 C...q -> q + g or q -> q + gamma. IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN Z=1D0-((1D0-XB-XEC)/(1D0-XEC))* & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0) WTZ=0.5D0*(1D0+Z**2) C...q -> g + q. ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z) C...f -> f + gamma. ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN Z=1D0-((1D0-XB-XEE)/(1D0-XEE))* & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0) ELSE Z=XB+XB*(XEE/(1D0-XEE))* & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0) ENDIF WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB) C...f -> gamma + f. ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN Z=XB+XB*(XEE/(1D0-XEE))* & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0) WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z C...f -> W+- + f. ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN Z=XB+XB*(XEE/(1D0-XEE))* & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0) WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)* & (Q2B/(Q2B+PMAS(24,1)**2)) C...g -> q + qbar. ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC)) WTZ=1D0-2D0*Z*(1D0-Z) C...g -> g + g. ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0)) WTZ=(1D0-Z*(1D0-Z))**2 C...gamma -> f + fbar. ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE)) WTZ=1D0-2D0*Z*(1D0-Z) ENDIF IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX) C...Option with resummation of soft gluon emission as effective z shift. IF(MCE.EQ.1) THEN IF(MSTP(65).GE.1) THEN RSOFT=6D0 IF(KFLB.NE.21) RSOFT=8D0/3D0 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0)) IF(Z.LE.XB) GOTO 220 ENDIF C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight. IF(MSTP(64).GE.2) THEN IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z)) IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0 ENDIF ENDIF C...Remove kinematically impossible branchings. UHAT=Q2B-DSH*(1D0-Z)/Z IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220 C...Select phi angle of branching at random. PHIBR=PARU(2)*PYR(0) C...Matrix-element corrections for some processes. IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME) WTZ=WTZ*WTME/WTFF ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME) WTZ=WTZ*WTME/WTGF ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME) WTZ=WTZ*WTME/WTFG ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME) WTZ=WTZ*WTME/WTGG ENDIF ENDIF C...Impose angular constraint in first branching from interference C...with final state partons. IF(MCE.EQ.1) THEN IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN THE2D=(4D0*Q2B)/(DSH*(1D0-Z)) IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220 ENDIF ENDIF C...Option with angular ordering requirement. IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R) IF(THE2T.GT.THE2(JT)) GOTO 220 ENDIF ENDIF C...Weighting with new parton distributions. MINT(105)=MINT(102+JT) MINT(109)=MINT(106+JT) VINT(120)=VINT(2+JT) IF(MINT(31).GE.2) MINT(30)=JT IF(MSTP(57).LE.1) THEN CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN) ELSE CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN) ENDIF XFBN=XFN(KFLB) IF(XFBN.LT.1D-20) THEN IF(KFLA.EQ.KFLB) THEN TEVCB=TEVCBS TEVEB=TEVEBS WTAPC(KFLB)=0D0 WTAPE(KFLB)=0D0 GOTO 200 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN TEVCB=0.5D0*(TEVCBS+TEVCB) GOTO 230 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN TEVEB=0.5D0*(TEVEBS+TEVEB) GOTO 230 ELSE XFBN=1D-10 XFN(KFLB)=XFBN ENDIF ENDIF DO 250 KFL=-25,25 XFB(KFL)=XFN(KFL) 250 CONTINUE XA=XB/Z IF(MINT(31).GE.2) MINT(30)=JT IF(MSTP(57).LE.1) THEN CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA) ELSE CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA) ENDIF XFAN=XFA(KFLA) IF(XFAN.LT.1D-20) GOTO 200 WTSFA=WTSF(KFLA) IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200 C...Define two hard scatterers in their CM-frame. 260 IF(N.EQ.NS+2) THEN DQ2(JT)=Q2B DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR DO 280 JR=1,2 I=NS+JR IF(JR.EQ.1) IPO=IPUS1 IF(JR.EQ.2) IPO=IPUS2 DO 270 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 270 CONTINUE K(I,1)=14 K(I,2)=KFLS(JR+2) K(I,4)=IPO K(I,5)=IPO P(I,3)=DPLCM*(-1)**(JR+1) P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR P(I,5)=-SQRT(DQ2(JR)) K(IPO,1)=14 K(IPO,3)=I K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I 280 CONTINUE C...Find maximum allowed mass of timelike parton. ELSEIF(N.GT.NS+2) THEN JR=3-JT DQ2(3)=Q2B DPC(1)=P(IS(1),4) DPC(2)=P(IS(2),4) DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3))) DPD(1)=DSH+DQ2(JR)+DQ2(JT) DPD(2)=DSHZ+DQ2(JR)+DQ2(3) DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT)) DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3)) IKIN=0 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE. & 1D-10*DPD(1)) IKIN=1 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))* & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3))) IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/ & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3) C...Generate timelike parton shower (if required). IT=N DO 290 J=1,5 K(IT,J)=0 P(IT,J)=0D0 V(IT,J)=0D0 290 CONTINUE C...f -> f + g (gamma). IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN K(IT,2)=21 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22 C...f -> g (gamma, W+-) + f. ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN K(IT,2)=KFLB IF(KFLS(JT+2).EQ.24) THEN K(IT,2)=-12 ELSEIF(KFLS(JT+2).EQ.-24) THEN K(IT,2)=12 ENDIF C...g (gamma) -> f + fbar, g + g. ELSE K(IT,2)=-KFLS(JT+2) IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2) ENDIF K(IT,1)=3 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR. & IABS(K(IT,2)).EQ.22) K(IT,1)=1 P(IT,5)=PYMASS(K(IT,2)) IF(DMSMA.LE.P(IT,5)**2) GOTO 100 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN MSTJ48=MSTJ(48) PARJ85=PARJ(85) P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2) IF(MSTP(63).EQ.1) THEN Q2TIM=DMSMA ELSEIF(MSTP(63).EQ.2) THEN Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT)) ELSE Q2TIM=DMSMA MSTJ(48)=1 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT)) IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)* & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2) PARJ(85)=SQRT(MAX(0D0,DPT2))* & (1D0/P(IT,4)+1D0/P(IS(JT),4)) ENDIF CALL PYSHOW(IT,0,SQRT(Q2TIM)) MSTJ(48)=MSTJ48 PARJ(85)=PARJ85 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5) ENDIF C...Reconstruct kinematics of branching: timelike parton shower. DMS=P(IT,5)**2 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT)) IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+ & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/ & (4D0*DSH*DPC(3)**2) IF(DPT2.LT.0D0) GOTO 100 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/ & DSHR)/DPC(3)-DPC(3) P(IT,1)=SQRT(DPT2) P(IT,3)=DPB(1)*(-1)**(JT+1) P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS) IF(N.GE.IT+1) THEN DPB(1)=SQRT(DPB(1)**2+DPT2) DPB(2)=SQRT(DPB(1)**2+DMS) DPB(3)=P(IT+1,3) DPB(4)=SQRT(DPB(3)**2+DMS) DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)* & DPB(1)) CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ) THE=PYANGL(P(IT,3),P(IT,1)) CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0) ENDIF C...Reconstruct kinematics of branching: spacelike parton. DO 300 J=1,5 K(N+1,J)=0 P(N+1,J)=0D0 V(N+1,J)=0D0 300 CONTINUE K(N+1,1)=14 K(N+1,2)=KFLB P(N+1,1)=P(IT,1) P(N+1,3)=P(IT,3)+P(IS(JT),3) P(N+1,4)=P(IT,4)+P(IS(JT),4) P(N+1,5)=-SQRT(DQ2(3)) C...Define colour flow of branching. K(IS(JT),3)=N+1 K(IT,3)=N+1 IM1=N+1 IM2=N+1 C...f -> f + gamma (Z, W). IF(IABS(K(IT,2)).GE.22) THEN K(IT,1)=1 ID1=IS(JT) ID2=IS(JT) C...f -> gamma (Z, W) + f. ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN ID1=IT ID2=IT C...gamma -> q + qbar, g + g. ELSEIF(K(N+1,2).EQ.22) THEN ID1=IS(JT) ID2=IT IM1=ID2 IM2=ID1 C...q -> q + g. ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN ID1=IT ID2=IS(JT) C...q -> g + q. ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN ID1=IS(JT) ID2=IT C...qbar -> qbar + g. ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN ID1=IS(JT) ID2=IT C...qbar -> g + qbar. ELSEIF(K(N+1,2).LT.0) THEN ID1=IT ID2=IS(JT) C...g -> g + g; g -> q + qbar. ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN ID1=IS(JT) ID2=IT ELSE ID1=IT ID2=IS(JT) ENDIF IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2 IF(ID1.NE.ID2) THEN K(ID1,5)=K(ID1,5)+MSTU(5)*ID2 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1 ENDIF N=N+1 IF(K(IT,1).EQ.1) THEN K(IT,4)=0 K(IT,5)=0 ENDIF C...Boost to new CM-frame. DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4)) DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4)) IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ) IR=N+(JT-1)*(IS(1)-N) CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT), & 0D0,0D0,0D0) C...Global statistics. MINT(352)=MINT(352)+1 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2) IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2) ENDIF C...Update kinematics variables. IS(JT)=N DQ2(JT)=Q2B IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THE2(JT)=THE2T DSH=DSHZ C...Save quantities; loop back. Q2S(JT)=Q2B DPHI(JT)=PHIBR MCESV(JT)=MCE IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR. &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN KFLS(JT+2)=KFLS(JT) KFLS(JT)=KFLA XS(JT)=XA ZS(JT)=Z DO 310 KFL=-25,25 XFS(JT,KFL)=XFA(KFL) 310 CONTINUE TEVCSV(JT)=TEVCB TEVESV(JT)=TEVEB ELSE MORE(JT)=0 IF(JT.EQ.1) IPU1=N IF(JT.EQ.2) IPU2=N ENDIF IF(N.GT.MSTU(4)-MSTU(32)-10) THEN CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS') IF(MSTU(21).GE.1) N=NS IF(MSTU(21).GE.1) RETURN ENDIF IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150 C...Boost hard scattering partons to frame of shower initiators. DO 320 J=1,3 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4)) 320 CONTINUE K(N+2,1)=1 DO 330 J=1,5 P(N+2,J)=P(NS+1,J) 330 CONTINUE CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5)) ROBO(2)=PYANGL(P(N+2,1),P(N+2,2)) ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2)) IMIN=MINT(83)+5 IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2) CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0) CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5)) C...Store user information. Reset Lambda value. IF(MINT(31).LE.1) THEN K(IPU1,3)=MINT(83)+3 K(IPU2,3)=MINT(83)+4 ELSE K(IPU1,3)=MINT(83)+1 K(IPU2,3)=MINT(83)+2 ENDIF DO 340 JT=1,2 MINT(12+JT)=KFLS(JT) VINT(140+JT)=XS(JT) IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT) IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT) 340 CONTINUE PARU(112)=ALAMS RETURN END C********************************************************************* C...PYPTIS C...Generates pT-ordered spacelike initial-state parton showers and C...trial joinings. C...MODE=-1: Initialize ISR from scratch, starting from the hardest C... interaction initiators at PT2NOW. C...MODE= 0: Generate a trial branching on interaction MINT(36), side C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2. C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2 C... is below PT2CUT. C... (Also generate test joinings if MSTP(96)=1.) C...MODE= 1: Accept stored shower branching. Update event record etc. C...PT2NOW : Starting (max) PT2 scale for evolution. C...PT2CUT : Lower limit for evolution. C...PT2 : Result of evolution. Generated PT2 for trial emission. C...IFAIL : Status return code. IFAIL=0 when all is well. SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement for maximum size of showers. PARAMETER (MAXNUP=500) C...Commonblocks. COMMON/PYPART/NPART,NPARTD,IPART(MAXNUP),PTPART(MAXNUP) 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 PT2 > mQ^2 IF (PT2NOW.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) PT2=PT2NOW IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT C...Define for which processes ME corrections have been implemented. IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ & .142.OR.ISUB.EQ.144) MECOR=1 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2 C...Calculate preweighting factor for ME-corrected processes. IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG) ENDIF C...Basic info on daughter for which to find mother. KFLB=K(IMI(JS,MI,1),2) KFLBA=IABS(KFLB) C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for C...second companion. KSVCB=MAX(-1,IMI(JS,MI,2)) C...Treat "first" companion of a pair like an ordinary sea quark C...(except that creation diagram is not allowed) IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1 C...X (rescaled to [0,1]) XB=XMI(JS,MI)/VINT(142+JS) C...Massive quarks (use physical masses.) RMQ2=0D0 MQMASS=0 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN RMQ2=RMC2 IF (KFLBA.EQ.5) RMQ2=RMB2 C...Special threshold treatment for non-photon beams IF (KFBEAM(JS).NE.22) MQMASS=KFLBA ENDIF C...Flags for parton distribution calls. MINT(105)=MINT(102+JS) MINT(109)=MINT(106+JS) VINT(120)=VINT(2+JS) C...Calculate initial parton distribution weights. IF(XB.GE.XMXC) THEN RETURN ELSEIF(MQMASS.EQ.0) THEN CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB) ELSE C...Initialize massive quark PT2 dependent pdf underestimate. PT20=PT2 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB) C.!.Tentative treatment of massive valence quarks. XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB)) XG0=XFB(21) TPM0=LOG(PT20/RMQ2) WPDF0=TPM0*XG0/XQ0 ENDIF IF (KFLB.NE.21) THEN C...For quarks, only include respective sea, val, or cmp part. IF (KSVCB.LE.0) THEN XFB(KFLB)=XPSVC(KFLB,KSVCB) ELSE C...Find companion's companion MISEA=0 120 MISEA=MISEA+1 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120 XS=XMI(JS,MISEA) XREM=VINT(142+JS) YS=XS/(XREM+XS) C...Momentum fraction of the companion quark. C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS). YB=XB*(1D0-YS) XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87)) ENDIF ENDIF C...Determine overestimated z range: switch at c and b masses. 130 IF (PT2.GT.TMIN*RMB2) THEN IZRG=3 PT2MNE=MAX(TMIN*RMB2,PT2CUT) B0=23D0/6D0 ALAM2=ALAM5**2 ELSEIF(PT2.GT.TMIN*RMC2) THEN IZRG=2 PT2MNE=MAX(TMIN*RMC2,PT2CUT) B0=25D0/6D0 ALAM2=ALAM4**2 ELSE IZRG=1 PT2MNE=PT2CUT B0=27D0/6D0 ALAM2=ALAM3**2 ENDIF C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64)) ALAM2=ALAM2/PARP(64) C...Overestimated ZMAX: IF (MQMASS.EQ.0) THEN C...Massless ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI) & /PT2MNE)-1D0) ELSE C...Massive (limit for bremsstrahlung diagram > creation) FMQ=SQRT(RMQ2/SHTNOW(MI)) ZMAX=1D0/(1D0+FMQ) ENDIF ZMIN=XB/XMXC C...If kinematically impossible then do not evolve. IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN C...Reset Altarelli-Parisi and PDF weights. DO 140 KFL=-5,5 WTAP(KFL)=0D0 WTPDF(KFL)=0D0 140 CONTINUE WTAP(21)=0D0 WTPDF(21)=0D0 C...Zero joining weights and compute X(partner) and X(mother) values. IF (MSTP(96).NE.0) THEN NJN=0 DO 150 MJ=1,MINT(31) WTAPJ(MJ)=0D0 WTPDFJ(MJ)=0D0 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ)) Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ) & +XMI(JS,MI)) 150 CONTINUE ENDIF C...Approximate Altarelli-Parisi weights (integrated AP dz). C...q -> q, g -> q or q -> q + gamma (already set which). IF(KFLBA.LE.5) THEN C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps. IF (KSVCB.LT.0) THEN WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX)) ELSE RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN)) RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX)) WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN) ENDIF WTAP(21)=0.5D0*(ZMAX-ZMIN) WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX)) IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN WTAP(KFLB)=WTFF*WTAP(KFLB) WTAP(21)=WTGF*WTAP(21) WTAPE=WTFF*WTAPE ENDIF IF (KSVCB.GE.1) THEN C...Kill normal creation but add joining diagrams for cmp quark. WTAP(21)=0D0 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'// & " quark here. Not handled yet, giving up!") PT2=0D0 MINT(51)=1 RETURN ENDIF C...Check for possible joinings IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN C...Find companion's companion. MJ=0 160 MJ=MJ+1 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160 IF (MJOIND(JS,MJ).EQ.0) THEN Y(MI)=YB+YS Z=YB/Y(MI) WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2) IF (WTAPJ(MJ).GT.1D-6) THEN NJN=1 ELSE WTAPJ(MJ)=0D0 ENDIF ENDIF C...Add trial gluon joinings. DO 170 MJ=1,MINT(31) KFLC=K(IMI(JS,MJ,1),2) IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ)) WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2) IF (WTAPJ(MJ).GT.1D-6) THEN NJN=NJN+1 ELSE WTAPJ(MJ)=0D0 ENDIF 170 CONTINUE ENDIF ELSEIF (IMI(JS,MI,2).GE.0) THEN C...Kill creation diagram for val quarks and sea quarks with companions. WTAP(21)=0D0 ELSEIF (MQMASS.EQ.0) THEN C...Extra safety factor for massless sea quark creation. WTAP(21)=WTAP(21)*1.25D0 ENDIF C... q -> g, g -> g. ELSEIF(KFLB.EQ.21) THEN C...Here we decide later whether a quark picked up is valence or C...sea, so we maintain the extra factor sqrt(z) since we deal C...with the *sum* of sea and valence in this context. WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX)) C...new: do not allow backwards evol to pick up heavy flavour. DO 180 KFL=1,MIN(3,MSTP(58)) WTAP(KFL)=WTAPQ WTAP(-KFL)=WTAPQ 180 CONTINUE WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX))) IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN WTAPQ=WTFG*WTAPQ WTAP(21)=WTGG*WTAP(21) ENDIF C...Check for possible joinings (companions handled separately above) IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0) & THEN DO 190 MJ=1,MINT(31) IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190 KSVCC=IMI(JS,MJ,2) IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1 IF (KSVCC.GE.1) GOTO 190 KFLC=K(IMI(JS,MJ,1),2) C...Only try g -> g + g once. IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ)) IF (KFLC.EQ.21) THEN WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2) ELSE WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2) ENDIF IF (WTAPJ(MJ).GT.1D-6) THEN NJN=NJN+1 ELSE WTAPJ(MJ)=0D0 ENDIF 190 CONTINUE ENDIF ENDIF C...Initialize massive quark evolution IF (MQMASS.NE.0) THEN RML=(RMQ2+VINT(18))/ALAM2 TML=LOG(RML) TPL=LOG((PT2+VINT(18))/ALAM2) TPM=LOG((PT2+VINT(18))/RMQ2) WN=WTAP(21)*WPDF0/B0 ENDIF C...Loopback point for iteration NTRY=0 NTHRES=0 200 NTRY=NTRY+1 IF(NTRY.GT.500) THEN CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.') MINT(51)=1 RETURN ENDIF C... Calculate PDF weights and sum for evolution rate. WTSUM=0D0 XFBO=MAX(1D-10,XFB(KFLB)) DO 210 KFL=-5,5 WTPDF(KFL)=XFB(KFL)/XFBO WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL) 210 CONTINUE C...Only add gluon mother diagram for massless KFLB. IF(MQMASS.EQ.0) THEN WTPDF(21)=XFB(21)/XFBO WTSUM=WTSUM+WTAP(21)*WTPDF(21) ENDIF WTSUM=MAX(0.0001D0,WTSUM) C...Add joining diagrams where applicable. WTJOIN=0D0 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN DO 220 MJ=1,MINT(31) IF (WTAPJ(MJ).LT.1D-3) GOTO 220 WTPDFJ(MJ)=1D0/XFBO C...x and x*pdf (+ sea/val) for parton C. KFLC=K(IMI(JS,MJ,1),2) KFLCA=IABS(KFLC) KSVCC=MAX(-1,IMI(JS,MJ,2)) IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1 MINT(30)=JS MINT(36)=MJ CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ) MINT(36)=MI IF (KFLC.NE.21.AND.KSVCC.LE.0) THEN XFJ(KFLC)=XPSVC(KFLC,KSVCC) ELSEIF (KSVCC.GE.1) THEN print*, 'error! parton C is companion!' ENDIF WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC) C...x and x*pdf (+ sea/val) for parton A. KFLA=21 KSVCA=0 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN KFLA=KFLB KSVCA=KSVCB ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN KFLA=KFLC KSVCA=KSVCC ENDIF MINT(30)=JS IF (KSVCA.LE.0) THEN C...Consider C the "evolved" parton if B is gluon. Val/sea C...counting will then be done correctly in PYPDFU. IF (KFLBA.EQ.21) MINT(36)=MJ CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ) MINT(36)=MI IF (KFLA.NE.21) XFJ(KFLA)=XPSVC(KFLA,KSVCA) ELSE C...If parton A is companion, use Y(MI) and YS in call to PYFCMP. XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87)) ENDIF WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ) WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ) 220 CONTINUE ENDIF C...Pick normal pT2 (in overestimated z range). 230 PT2OLD=PT2 PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18) KFLC=21 C...Evolve q -> q gamma separately, pick it if larger pT. IF(KFLBA.LE.5) THEN PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18) IF(PT2QED.GT.PT2) THEN PT2=PT2QED KFLC=22 KFLA=KFLB ENDIF ENDIF C... Evolve massive quark creation separately. MCRQQ=0 IF (MQMASS.NE.0) THEN PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM))) & -VINT(18) C... Ensure mininimum PT2CR and force creation near threshold. IF (PT2CR.LT.TMIN*RMQ2) THEN NTHRES=NTHRES+1 IF (NTHRES.GT.50) THEN CALL PYERRM(9,'(PYPTIS:) no phase space left for '// & 'massive quark creation. Gave up trying.') MINT(51)=1 RETURN ENDIF PT2=0D0 PT2CR=TMIN*RMQ2 MCRQQ=2 ENDIF C... Select largest PT2 (brems or creation): IF (PT2CR.GT.PT2) THEN MCRQQ=MAX(MCRQQ,1) WTSUM=0D0 PT2=PT2CR KFLA=21 ELSE MCRQQ=0 KFLA=KFLB ENDIF C... Compute logarithms for this PT2 TPL=LOG((PT2+VINT(18))/ALAM2) TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18))) WTCRQQ=TPM/LOG(PT2/RMQ2) ENDIF C...Evolve joining separately MJOIN=0 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN)) & -VINT(18) IF (PT2JN.GE.PT2) THEN MJOIN=1 PT2=PT2JN ENDIF ENDIF C...Loopback if crossed c/b mass thresholds. IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN PT2=RMB2 GOTO 130 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN PT2=RMC2 GOTO 130 ENDIF C...Speed up shower. Skip if higher-PT acceptable branching C...already found somewhere else. C...Also finish if below lower cutoff. IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN C...Select parton A flavour (massive Q handled above.) IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN WTRAN=PYR(0)*WTSUM KFLA=-6 240 KFLA=KFLA+1 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA) IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240 IF(KFLA.EQ.6) KFLA=21 ELSEIF (MJOIN.EQ.1) THEN C...Tentative joining accept/reject. WTRAN=PYR(0)*WTJOIN MJ=0 250 MJ=MJ+1 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ) IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'// & ' Rejected.') GOTO 230 ENDIF C...x*pdf (+ sea/val) at new pT2 for parton B. IF (KSVCB.LE.0) THEN MINT(30)=JS CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB) IF (KFLB.NE.21) XFB(KFLB)=XPSVC(KFLB,KSVCB) ELSE C...Companion distributions do not evolve. XFB(KFLB)=XFBO ENDIF WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB) KFLC=K(IMI(JS,MJ,1),2) KFLCA=IABS(KFLC) KSVCC=MAX(-1,IMI(JS,MJ,2)) IF (KSVCB.GE.1) KSVCC=-1 C...x*pdf (+ sea/val) at new pT2 for parton C. MINT(30)=JS MINT(36)=MJ CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ) MINT(36)=MI IF (KFLC.NE.21.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC) WTVETO=WTVETO/XFJ(KFLC) C...x and x*pdf (+ sea/val) at new pT2 for parton A. KFLA=21 KSVCA=0 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN KFLA=KFLB KSVCA=KSVCB ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN KFLA=KFLC KSVCA=KSVCC ENDIF IF (KSVCA.LE.0) THEN MINT(30)=JS IF (KFLB.EQ.21) MINT(36)=MJ CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ) MINT(36)=MI IF (KFLA.NE.21) XFJ(KFLA)=XPSVC(KFLA,KSVCA) ELSE XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87)) ENDIF WTVETO=WTVETO*XFJ(KFLA) C...Monte Carlo veto. IF (WTVETO.LT.PYR(0)) GOTO 200 C...If accept, save PT2 of this joining. IF (PT2.GT.PT2MX) THEN PT2MX=PT2 JSMX=2+JS MJN1MX=MJ MJN2MX=MI WTAPJ(MJ)=0D0 NJN=0 ENDIF C...Exit and continue evolution. GOTO 380 ENDIF KFLAA=IABS(KFLA) C...Choose z value (still in overestimated range) and corrective weight. C...Unphysical z will be rejected below when Q2 has is computed. WTZ=0D0 C...Note: ME and MQ>0 give corrections to overall weights, not shapes. C...q -> q + g or q -> q + gamma (already set which). IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN IF (KSVCB.LT.0) THEN Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0) ELSE ZFAC=RMIN*(RMAX/RMIN)**PYR(0) Z=((1-ZFAC)/(1+ZFAC))**2 ENDIF WTZ=0.5D0*(1D0+Z**2) C...Massive weight correction. IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2 C...Valence quark weight correction (extra sqrt) IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z) C...q -> g + q. C...NB: MQ>0 not yet implemented. Forced absent above. ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN KFLC=KFLA Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z) C...g -> q + qbar. ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN KFLC=-KFLB Z=ZMIN+PYR(0)*(ZMAX-ZMIN) WTZ=Z**2+(1D0-Z)**2 C...Massive correction IF (MQMASS.NE.0) THEN WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2 C...Extra safety margin for light sea quark creation ELSEIF (KSVCB.LT.0) THEN WTZ=WTZ/1.25D0 ENDIF C...g -> g + g. ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN KFLC=21 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/ & (ZMAX*(1D0-ZMIN)))**PYR(0)) WTZ=(1D0-Z*(1D0-Z))**2 ENDIF C...Derive Q2 from pT2. Q2B=PT2/(1D0-Z) IF (KFLBA.GE.4) Q2B=Q2B-RMQ2 C...Loopback if outside allowed z range for given pT2. RM2C=PYMASS(KFLC)**2 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI) IF (PT2ADJ.LT.1D-6) GOTO 230 C...Loopback if nonordered in angle/rapidity. IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI)) & GOTO 230 ENDIF C...Select phi angle of branching at random. PHI=PARU(2)*PYR(0) C...Matrix-element corrections for some processes. IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME) WTZ=WTZ*WTME/WTFF ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME) WTZ=WTZ*WTME/WTGF ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME) WTZ=WTZ*WTME/WTFG ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME) WTZ=WTZ*WTME/WTGG ENDIF ENDIF C...Parton distributions at new pT2 but old x. MINT(30)=JS CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN) C...Treat val and cmp separately IF (KFLB.NE.21.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB) IF (KSVCB.GE.1) & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87)) XFBN=XFN(KFLB) IF(XFBN.LT.1D-20) THEN IF(KFLA.EQ.KFLB) THEN WTAP(KFLB)=0D0 GOTO 200 ELSE XFBN=1D-10 XFN(KFLB)=XFBN ENDIF ENDIF DO 260 KFL=-5,5 XFB(KFL)=XFN(KFL) 260 CONTINUE XFB(21)=XFN(21) C...Parton distributions at new pT2 and new x. XA=XB/Z MINT(30)=JS CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA) IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN C...q -> q + g: only consider respective sea, val, or cmp content. IF (KSVCB.LE.0) THEN XFA(KFLA)=XPSVC(KFLA,KSVCB) ELSE YA=XA*(1D0-YS) XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87)) ENDIF ENDIF XFAN=XFA(KFLA) IF(XFAN.LT.1D-20) THEN GOTO 200 ENDIF C...If weighting fails continue evolution. WTTOT=0D0 IF (MCRQQ.EQ.0) THEN WTPDFA=1D0/WTPDF(KFLA) WTTOT=WTZ*XFAN/XFBN*WTPDFA ELSEIF(MCRQQ.EQ.1) THEN WTPDFA=TPM/WPDF0 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA XBEST=TPM/TPM0*XQ0 ELSEIF(MCRQQ.EQ.2) THEN C...Force massive quark creation. WTTOT=1D0 ENDIF C...Loop back if trial emission fails. IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200 WTACC=((1D0+PT2)/(0.25D0+PT2))**2 IF(WTTOT.LT.0D0) THEN WRITE(CHWT,'(1P,E12.4)') WTTOT CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative') ELSEIF(WTTOT.GT.WTACC) THEN WRITE(CHWT,'(1P,E12.4)') WTTOT IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN C...Too high weight: write out as error, but do not update error counter. IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1 CALL PYERRM(19, & '(PYPTIS:) Weight '//CHWT//' above unity') IF (PT2.GT.PTEMAX) PTEMAX=PT2 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT ELSE CALL PYERRM(9, & '(PYPTIS:) Weight '//CHWT//' above unity') ENDIF C...Useful for debugging but commented out for distribution: C print*, 'JS, MI',JS, MI C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ C print*, 'A -> B C',KFLA, KFLB, KFLC C XFAO=XFBO/WTPDFA C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN ENDIF C...Save acceptable branching. IF(PT2.GT.PT2MX) THEN MIMX=MINT(36) JSMX=JS PT2MX=PT2 KFLAMX=KFLA KFLCMX=KFLC RM2CMX=RM2C Q2BMX=Q2B ZMX=Z PT2AMX=PT2ADJ PHIMX=PHI ENDIF C---------------------------------------------------------------------- C...MODE= 1: Accept stored shower branching. Update event record etc. ELSEIF (MODE.EQ.1) THEN MI=MIMX JS=JSMX SHAT=SHTNOW(MI) SIDE=3D0-2D0*JS C...Shift down rest of event record to make room for insertion. IT=IMISEP(MI)+1 IM=IT+1 IS=IMI(JS,MI,1) DO 280 I=N,IT,-1 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2 KT1=K(I,4)/MSTU(5)**2 KT2=K(I,5)/MSTU(5)**2 ID1=MOD(K(I,4),MSTU(5)) ID2=MOD(K(I,5),MSTU(5)) IM1=MOD(K(I,4)/MSTU(5),MSTU(5)) IM2=MOD(K(I,5)/MSTU(5),MSTU(5)) IF (ID1.GE.IT) ID1=ID1+2 IF (ID2.GE.IT) ID2=ID2+2 IF (IM1.GE.IT) IM1=IM1+2 IF (IM2.GE.IT) IM2=IM2+2 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2 DO 270 IX=1,5 K(I+2,IX)=K(I,IX) P(I+2,IX)=P(I,IX) V(I+2,IX)=V(I,IX) 270 CONTINUE MCT(I+2,1)=MCT(I,1) MCT(I+2,2)=MCT(I,2) 280 CONTINUE N=N+2 C...Also update shifted-down pointers in IMI, IMISEP, and IPART. DO 290 JI=1,MINT(31) IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2 C...Also update companion pointers to the present mother. IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM 290 CONTINUE DO 300 IFS=1,NPART IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2 300 CONTINUE C...Zero entries dedicated for new timelike and mother partons. DO 320 I=IT,IT+1 DO 310 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 310 CONTINUE MCT(I,1)=0 MCT(I,2)=0 320 CONTINUE C...Define timelike and new mother partons. History. K(IT,1)=3 K(IT,2)=KFLCMX K(IM,1)=14 K(IM,2)=KFLAMX K(IS,3)=IM K(IT,3)=IM C...Set mother origin = side. K(IM,3)=MINT(83)+JS+2 IF(MI.GE.2) K(IM,3)=MINT(83)+JS C...Define colour flow of branching. IM1=IM IM2=IM C...q -> q + gamma. IF(K(IT,2).EQ.22) THEN K(IT,1)=1 ID1=IS ID2=IS C...q -> q + g. ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN ID1=IT ID2=IS C...q -> g + q. ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN ID1=IS ID2=IT C...qbar -> qbar + g. ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN ID1=IS ID2=IT C...qbar -> g + qbar. ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN ID1=IT ID2=IS C...g -> g + g; g -> q + qbar.. ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN ID1=IS ID2=IT ELSE ID1=IT ID2=IS ENDIF IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2 IF(ID1.NE.ID2) THEN K(ID1,5)=K(ID1,5)+MSTU(5)*ID2 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1 ENDIF IF(K(IT,1).EQ.1) THEN K(IT,4)=0 K(IT,5)=0 ENDIF C...Update IMI and colour tag arrays. IMI(JS,MI,1)=IM DO 330 MC=1,2 MCT(IT,MC)=0 MCT(IM,MC)=0 330 CONTINUE DO 340 JCS=4,5 KCS=JCS C...If mother flag not yet set for spacelike parton, trace it. IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM) IF(MINT(51).NE.0) RETURN 340 CONTINUE DO 350 JCS=4,5 KCS=JCS C...If mother flag not yet set for timelike parton, trace it. IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM) IF(MINT(51).NE.0) RETURN 350 CONTINUE C...Boost recoiling parton to compensate for Q2 scale. C...(Also update recoiler in documentation lines, if necessary.) BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/ & (1D0+(1D0+Q2BMX/SHAT)**2) IR=IMI(3-JS,MI,1) CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ) IF (IR.EQ.MINT(84)+3-JS) CALL PYROBO(MINT(83)+7-JS,MINT(83) & +7-JS,0D0,0D0,0D0,0D0,BETAZ) C...Rotate back system in phi to compensate for subsequent rotation. C...(not including the just added partons.) IMIN=IMISEP(MI-1)+1 IF (MI.EQ.1) IMIN=MINT(83)+5 IMAX=IMISEP(MI)-2 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0) C...Define kinematics of new partons in old frame. IMAX=IMISEP(MI) P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX)) P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2) P(IT,1)=P(IM,1) P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX) P(IT,5)=SQRT(RM2CMX) C...Boost and rotate to new frame. BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4)) BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4)) IF(BETAX**2+BETAZ**2.GE.1D0) THEN CALL PYERRM(1,'(PYPTIS:) boost bigger than unity') MINT(51)=1 IFAIL=-1 RETURN ENDIF CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ) I1=IMI(1,MI,1) THETA=PYANGL(P(I1,3),P(I1,1)) CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0) C...Global statistics. MINT(352)=MINT(352)+1 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2) IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2) C...Add parton with relevant pT scale for timelike shower. IF (K(IT,2).NE.22) THEN NPART=NPART+1 IPART(NPART)=IT PTPART(NPART)=SQRT(PT2AMX) ENDIF C...Update saved variables. SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX PT2SAV(JSMX,MIMX)=PT2MX ZSAV(JS,MIMX)=ZMX KSA=IABS(K(IS,2)) KMA=IABS(K(IM,2)) IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN C...Gluon reconstructs to quark. C...Decide whether newly created quark is valence or sea: MINT(30)=JS CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL) IF(MINT(51).NE.0) RETURN ENDIF IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN C...Quark reconstructs to gluon. C...Now some guy may have lost his companion. Check. ICMP=IMI(JS,MI,2) IF (ICMP.GT.0) THEN CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated' & //' away. Cannot handle that yet. Giving up.') MINT(51)=1 RETURN ELSEIF(ICMP.LT.0) THEN C...A sea quark with companion still in BR was reconstructed to a gluon. C...Companion should now be removed from the beam remnant. C...(Momentum integral is automatically updated in next call to PYPDFU.) ICMP=-ICMP IFL=-K(IS,2) DO 370 JCMP=ICMP,NVC(JS,IFL)-1 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1) DO 360 JI=1,MINT(31) KMI=-IMI(JS,JI,2) JFL=-K(IMI(JS,JI,1),2) IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI & ,2)+1 360 CONTINUE 370 CONTINUE NVC(JS,IFL)=NVC(JS,IFL)-1 ENDIF C...Set gluon IMI(JS,MI,2) = 0. IMI(JS,MI,2)=0 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN C...Quark reconstructing to quark. If sea with companion still in BR C...then update associated x value. C...(Momentum integral is automatically updated in next call to PYPDFU.) IF (IMI(JS,MI,2).LT.0) THEN ICMP=-IMI(JS,MI,2) IFL=-K(IS,2) XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX) ENDIF ENDIF ENDIF C...If reached this point, normal exit. 380 IFAIL=0 RETURN END C********************************************************************* C...PYMEMX C...Generates maximum ME weight in some initial-state showers. C...Inparameter MECOR: kind of hard scattering process C...Outparameter WTFF: maximum weight for fermion -> fermion C... WTGF: maximum weight for gluon/photon -> fermion C... WTFG: maximum weight for fermion -> gluon/photon C... WTGG: maximum weight for gluon -> gluon SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/ C...Default maximum weight. WTFF=1D0 WTGF=1D0 WTFG=1D0 WTGG=1D0 C...Select maximum weight by process. IF(MECOR.EQ.1) THEN WTFF=1D0 WTGF=3D0 ELSEIF(MECOR.EQ.2) THEN WTFG=1D0 WTGG=1D0 ENDIF RETURN END C********************************************************************* C...PYMEWT C...Calculates actual ME weight in some initial-state showers. C...Inparameter MECOR: kind of hard scattering process C... IFLCB: flavour combination of branching, C... 1 for fermion -> fermion, C... 2 for gluon/photon -> fermion C... 3 for fermion -> gluon/photon, C... 4 for gluon -> gluon C... Q2: Q2 value of shower branching C... Z: Z value of branching C...In+outparameter PHIBR: azimuthal angle of branching C...Outparameter WTME: actual ME weight SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/ C...Default output. WTME=1D0 C...Define kinematics of shower branching in Mandelstam variables. SQM=VINT(44) SH=SQM/Z TH=-Q2 UH=Q2-SQM*(1D0-Z)/Z C...Matrix-element corrections for f + fbar -> s-channel vector boson. IF(MECOR.EQ.1) THEN IF(IFLCB.EQ.1) THEN WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2) ELSEIF(IFLCB.EQ.2) THEN WTME=(SH**2+UH**2+2D0*SQM*TH)/((SH-SQM)**2+SQM**2) ENDIF C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0). ELSEIF(MECOR.EQ.2) THEN IF(IFLCB.EQ.3) THEN WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2) ELSEIF(IFLCB.EQ.4) THEN WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2 ENDIF ENDIF RETURN END C********************************************************************* C...PYPTMI C...Handles the generation of additional interactions in the new C...multiple interactions framework. C...MODE=-1 : Initalize MI from scratch. C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve C... Sudakov for PT2, abort if below PT2CUT. C...MODE= 1 : Accept interaction at PT2NOW and store variables. C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW C...PT2NOW : Starting (max) PT2 scale for evolution. C...PT2CUT : Lower limit for evolution. C...PT2 : Result of evolution. Generated PT2 for trial interaction. C...IFAIL : Status return code. C... = 0: All is well. C... < 0: Phase space exhausted, generation to be terminated. C... > 0: Additional interaction vetoed, but continue evolution. SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement for maximum size of showers. PARAMETER (MAXNUP=500) C...Commonblocks. COMMON/PYPART/NPART,NPARTD,IPART(MAXNUP),PTPART(MAXNUP) 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 XT2=4D0*PT2NOW/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 (VINT(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 (MAXNUP=500) C...Commonblocks. COMMON/PYPART/NPART,NPARTD,IPART(MAXNUP),PTPART(MAXNUP) COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYCTAG/NCT,MCT(4000,2) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/ C...Local array. DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3) C...Set primary vertex. DO 100 J=1,5 V(MINT(83)+5,J)=0D0 V(MINT(83)+6,J)=0D0 V(MINT(84)+1,J)=0D0 V(MINT(84)+2,J)=0D0 100 CONTINUE C...Isolate systems of particles with the same mother. NSYS=0 IMS=-1 DO 140 I=MINT(84)+3,NFIN IM=K(I,3) IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3) IF(IM.NE.IMS) THEN NSYS=NSYS+1 IBEG(NSYS)=I IMS=IM ENDIF C...Set production vertices. IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2)) & THEN DO 110 J=1,4 V(I,J)=0D0 110 CONTINUE ELSE DO 120 J=1,4 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5) 120 CONTINUE ENDIF IF(MSTP(125).GE.1) THEN IDOC=I-MSTP(126)+4 DO 130 J=1,5 V(IDOC,J)=V(I,J) 130 CONTINUE ENDIF 140 CONTINUE C...End loop over systems. Return if no showers to be performed. IBEG(NSYS+1)=NFIN+1 IF(MSTP(71).LE.0) RETURN C...Loop through systems of particles; check that sensible size. DO 270 ISYS=1,NSYS NSIZ=IBEG(ISYS+1)-IBEG(ISYS) IF(MINT(35).LE.1) THEN IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN GOTO 270 ELSEIF(NSIZ.LE.1) THEN CALL PYERRM(2,'(PYADSH:) only one particle in system') GOTO 270 ELSEIF(NSIZ.GT.80) THEN CALL PYERRM(2,'(PYADSH:) more than 80 particles in system') GOTO 270 ENDIF ENDIF C...Save status codes and daughters of showering particles; reset them. DO 150 J=1,4 PSUM(J)=0D0 150 CONTINUE DO 170 II=1,NSIZ I=IBEG(ISYS)-1+II KSAV(II,1)=K(I,1) IF(K(I,1).GT.10) THEN K(I,1)=1 IF(KSAV(II,1).EQ.14) K(I,1)=3 ENDIF IF(KSAV(II,1).LE.10) THEN ELSEIF(K(I,1).EQ.1) THEN KSAV(II,4)=K(I,4) KSAV(II,5)=K(I,5) K(I,4)=0 K(I,5)=0 ELSE KSAV(II,4)=MOD(K(I,4),MSTU(5)) KSAV(II,5)=MOD(K(I,5),MSTU(5)) K(I,4)=K(I,4)-KSAV(II,4) K(I,5)=K(I,5)-KSAV(II,5) ENDIF DO 160 J=1,4 PSUM(J)=PSUM(J)+P(I,J) 160 CONTINUE 170 CONTINUE C...Perform shower. QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2- & PSUM(3)**2)) IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55)) NSAV=N IF(MINT(35).LE.1) THEN IF(NSIZ.EQ.2) THEN CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX) ELSE CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX) ENDIF C...For external processes, first call, also ISR partons radiate. C...Can use existing PYPART list, removing partons that radiate later. ELSEIF(ISYS.EQ.1) THEN NPARTN=0 DO 175 II=1,NPART IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN NPARTN=NPARTN+1 IPART(NPARTN)=IPART(II) PTPART(NPARTN)=PTPART(II) ENDIF 175 CONTINUE NPART=NPARTN CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN) ELSE C...For subsequent calls use the systems excluded above. NPART=NSIZ NPARTD=0 DO 180 II=1,NSIZ I=IBEG(ISYS)-1+II IPART(II)=I PTPART(II)=0.5D0*QMAX 180 CONTINUE CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN) ENDIF C...Look up showered copies of original showering particles. DO 260 II=1,NSIZ I=IBEG(ISYS)-1+II IMV=I C...Particles without daughters need not be studied. IF(KSAV(II,1).LE.10) GOTO 260 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN ELSEIF(K(I,1).EQ.11) THEN 190 IMV=MOD(K(IMV,4),MSTU(5)) IF(K(IMV,1).EQ.11) GOTO 190 ELSE KDA1=MOD(K(I,4),MSTU(5)) IF(KDA1.GT.0) THEN IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5) ENDIF KDA2=MOD(K(I,5),MSTU(5)) IF(KDA2.GT.0) THEN IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5) ENDIF DO 200 I3=I+1,N IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2)) & THEN IMV=I3 KDA1=MOD(K(I3,4),MSTU(5)) IF(KDA1.GT.0) THEN IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5) ENDIF KDA2=MOD(K(I3,5),MSTU(5)) IF(KDA2.GT.0) THEN IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5) ENDIF ENDIF 200 CONTINUE ENDIF C...Restore daughter info of original partons to showered copies. IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1) IF(KSAV(II,1).LE.10) THEN ELSEIF(K(I,1).EQ.1) THEN K(IMV,4)=KSAV(II,4) K(IMV,5)=KSAV(II,5) ELSE K(IMV,4)=K(IMV,4)+KSAV(II,4) K(IMV,5)=K(IMV,5)+KSAV(II,5) ENDIF C...Reset mother info of existing daughters to showered copies. DO 210 I3=IBEG(ISYS+1),NFIN IF(K(I3,3).EQ.I) K(I3,3)=IMV IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I) IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I) ENDIF 210 CONTINUE C...Boost all original daughters to new frame of showered copy. C...Also update their colour tags. IF(IMV.NE.I) THEN DO 220 J=1,3 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4)) 220 CONTINUE FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2) DO 230 J=1,3 BETA(J)=FAC*BETA(J) 230 CONTINUE DO 250 I3=IBEG(ISYS+1),NFIN IMO=I3 240 IMO=K(IMO,3) IF(MSTP(128).LE.0) THEN IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3))) & THEN CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3)) IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1) IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2) ENDIF ELSE IF(IMO.EQ.IMV) THEN CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3)) IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1) IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2) ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN GOTO 240 ENDIF ENDIF 250 CONTINUE ENDIF 260 CONTINUE C...End of loop over showering systems 270 CONTINUE RETURN END C********************************************************************* C...PYVETO C...Interface to UPVETO, which allows user to veto event generation C...on the parton level, after parton showers but before multiple C...interactions, beam remnants and hadronization is added. SUBROUTINE PYVETO(IVETO) C...All real arithmetic in double precision. IMPLICIT DOUBLE PRECISION(A-H, O-Z) C...Three Pythia functions return integers, so need declaring. INTEGER PYK,PYCHGE,PYCOMP C...PYTHIA commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYPARS/,/PYINT1/ C...HEPEVT commonblock. PARAMETER (NMXHEP=4000) COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) DOUBLE PRECISION PHEP,VHEP SAVE /HEPEVT/ DIMENSION IRESO(100) C...Define longitudinal boost from initiator rest frame to cm frame. GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142)) GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142)) C... Reset counters. NEVHEP=0 NHEP=0 NRESO=0 C...First pass: identify final locations of resonances C...and of their daughters before showering. DO 150 I=MINT(84)+3,N ISTORE=0 IMOTH=0 C...Skip shower CM frame documentation lines. IF(K(I,2).EQ.94) THEN C... Store a new intermediate product, when mother in documentation. ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND. & K(I,3).LE.MINT(84)) THEN ISTORE=1 NHEP=NHEP+1 II=NHEP NRESO=NRESO+1 IRESO(NRESO)=I IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6)) C... Store a new intermediate product, when mother in main section. ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND. & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN ISTORE=1 NHEP=NHEP+1 II=NHEP NRESO=NRESO+1 IRESO(NRESO)=I IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6)) C...Update a product when a new copy of it has been created. ELSE IHIST=K(I,3) IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(I-1-IHIST) IR=0 DO 100 IRI=1,NRESO IF(IHIST.EQ.IRESO(IRI)) IR=IRI 100 CONTINUE C...Flavours must match, and exclude gluon and photon emission. IF(K(IHIST,2).NE.K(I,2)) IR=0 IF(IR.GT.0.AND.I.LT.N) THEN IF(K(I+1,3).EQ.K(I,3).AND.(K(I+1,2).EQ.21.OR. & K(I+1,2).EQ.22)) IR=0 ENDIF IF(IR.GT.0) THEN ISTORE=1 II=IR IRESO(IR)=I IMOTH=JMOHEP(1,II) ENDIF ENDIF IF(ISTORE.EQ.1) THEN C...Copy parton info, boosting momenta along z axis to cm frame. ISTHEP(II)=2 IDHEP(II)=K(I,2) PHEP(1,II)=P(I,1) PHEP(2,II)=P(I,2) PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4) PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3) PHEP(5,II)=P(I,5) C...Store one mother. Rest of history and vertex info zeroed. JMOHEP(1,II)=IMOTH JMOHEP(2,II)=0 JDAHEP(1,II)=0 JDAHEP(2,II)=0 VHEP(1,II)=0D0 VHEP(2,II)=0D0 VHEP(3,II)=0D0 VHEP(4,II)=0D0 ENDIF 150 CONTINUE C...Second pass: identify current set of "final" partons. DO 200 I=MINT(84)+3,N ISTORE=0 IMOTH=0 C...Store a final parton. IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN ISTORE=1 NHEP=NHEP+1 II=NHEP C..Trace it back through shower, to check if from documented particle. IHIST=I ISAVE=IHIST 160 CONTINUE IF(IHIST.GT.MINT(84)) THEN IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST) DO 170 IRI=1,NRESO IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI 170 CONTINUE ISAVE=IHIST IHIST=K(IHIST,3) IF(IMOTH.EQ.0) GOTO 160 ENDIF ENDIF IF(ISTORE.EQ.1) THEN C...Copy parton info, boosting momenta along z axis to cm frame. ISTHEP(II)=1 IDHEP(II)=K(I,2) PHEP(1,II)=P(I,1) PHEP(2,II)=P(I,2) PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4) PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3) PHEP(5,II)=P(I,5) C...Store one mother. Rest of history and vertex info zeroed. JMOHEP(1,II)=IMOTH JMOHEP(2,II)=0 JDAHEP(1,II)=0 JDAHEP(2,II)=0 VHEP(1,II)=0D0 VHEP(2,II)=0D0 VHEP(3,II)=0D0 VHEP(4,II)=0D0 ENDIF 200 CONTINUE C...Call user-written routine to decide whether to keep events. CALL UPVETO(IVETO) RETURN END C********************************************************************* C...PYRESD C...Allows resonances to decay (including parton showers for hadronic C...channels). SUBROUTINE PYRESD(IRES) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Parameter statement for maximum size of showers. PARAMETER (MAXNUP=500) C...Commonblocks. COMMON/PYPART/NPART,NPARTD,IPART(MAXNUP),PTPART(MAXNUP) COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYCTAG/NCT,MCT(4000,2) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT4/MWID(500),WIDS(500,5) SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/, &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/ C...Local arrays and complex and character variables. DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3), &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6), &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3), &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4), &ITJUNC(3),CTM2(3) COMPLEX FGK,HA(6,6),HC(6,6) REAL TIR,UIR CHARACTER CODE*9,MASS*9 C...The F, Xi and Xj functions of Gunion and Kunszt C...(Phys. Rev. D33, 665, plus errata from the authors). FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)* &HC(I1,I4)+HA(I3,I5)*HC(I3,I4)) DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/ &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34)) DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU- &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+ &2D0*(D34/D56+D56/D34)) C...Some general constants. XW=PARU(102) XWV=XW IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2 XW1=1D0-XW SQMZ=PMAS(23,1)**2 GMMZ=PMAS(23,1)*PMAS(23,2) SQMW=PMAS(24,1)**2 GMMW=PMAS(24,1)*PMAS(24,2) SH=VINT(44) C...Boost and rotate to rest frame of incoming partons, C...to get proper amount of smearing of decay angles. IBST=0 IF(IRES.EQ.0) THEN IBST=1 ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4) BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN) PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2)) CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0) THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1)) CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0) ENDIF C...Reset original resonance configuration. DO 100 JT=1,8 IREF(1,JT)=0 100 CONTINUE C...Define initial one, two or three objects for subprocess. IHDEC=0 IF(IRES.EQ.0) THEN ISUB=MINT(1) IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN IREF(1,1)=MINT(84)+2+ISET(ISUB) IREF(1,4)=MINT(83)+6+ISET(ISUB) JTMAX=1 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN IREF(1,1)=MINT(84)+1+ISET(ISUB) IREF(1,2)=MINT(84)+2+ISET(ISUB) IREF(1,4)=MINT(83)+5+ISET(ISUB) IREF(1,5)=MINT(83)+6+ISET(ISUB) JTMAX=2 ELSEIF(ISET(ISUB).EQ.5) THEN IREF(1,1)=MINT(84)+3 IREF(1,2)=MINT(84)+4 IREF(1,3)=MINT(84)+5 IREF(1,4)=MINT(83)+7 IREF(1,5)=MINT(83)+8 IREF(1,6)=MINT(83)+9 JTMAX=3 ENDIF C...Define original resonance for odd cases. ELSE ISUB=0 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36) & IHDEC=1 IF(IHDEC.EQ.1) ISUB=3 IREF(1,1)=IRES IREF(1,4)=K(IRES,3) IRESTM=IRES IF(IREF(1,4).GT.MINT(84)) THEN 110 ITMPMO=IREF(1,4) IF(K(ITMPMO,2).EQ.94) THEN IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1) IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3) ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN IRESTM=ITMPMO IREF(1,4)=K(ITMPMO,3) GOTO 110 ENDIF ENDIF IF(IREF(1,4).GT.MINT(84)) THEN EMATCH=1D10 IREF14=IREF(1,4) DO 120 II=MINT(83)+7,MINT(83)+MINT(4) IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT. & EMATCH) THEN IREF(1,4)=II EMATCH=ABS(P(II,4)-P(IREF14,4)) ENDIF 120 CONTINUE ENDIF JTMAX=1 ENDIF C...Check if initial resonance has been moved (in resonance + jet). DO 140 JT=1,3 IF(IREF(1,JT).GT.0) THEN IF(K(IREF(1,JT),1).GT.10) THEN KFA=IABS(K(IREF(1,JT),2)) IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN KDA1=MOD(K(IREF(1,JT),4),MSTU(5)) KDA2=MOD(K(IREF(1,JT),5),MSTU(5)) IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5) ENDIF IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5) ENDIF DO 130 I=IREF(1,JT)+1,N IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR. & I.EQ.KDA2)) THEN IREF(1,JT)=I KDA1=MOD(K(IREF(1,JT),4),MSTU(5)) KDA2=MOD(K(IREF(1,JT),5),MSTU(5)) IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5) ENDIF IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5) ENDIF ENDIF 130 CONTINUE ELSE KDA=MOD(K(IREF(1,JT),4),MSTU(5)) IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA ENDIF ENDIF ENDIF 140 CONTINUE C...Set decay vertex for initial resonances DO 160 JT=1,JTMAX DO 150 I=1,4 V(IREF(1,JT),I)=0D0 150 CONTINUE 160 CONTINUE C...Loop over decay history. NP=1 IP=0 170 IP=IP+1 NINH=0 JTMAX=2 IF(IREF(IP,2).EQ.0) JTMAX=1 IF(IREF(IP,3).NE.0) JTMAX=3 IT4=0 NSAV=N C...Check for Higgs which appears as decay product of user-process. IF(ISUB.EQ.0) THEN IHDEC=0 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7) & .EQ.36) IHDEC=1 IF(IHDEC.EQ.1) ISUB=3 ENDIF C...Start treatment of one, two or three resonances in parallel. 180 N=NSAV DO 340 JT=1,JTMAX ID=IREF(IP,JT) KDCY(JT)=0 KFL1(JT)=0 KFL2(JT)=0 KFL3(JT)=0 KEQL(JT)=0 NSD(JT)=ID ITJUNC(JT)=0 C...Check whether particle can/is allowed to decay. IF(ID.EQ.0) GOTO 330 KFA=IABS(K(ID,2)) KCA=PYCOMP(KFA) IF(MWID(KCA).EQ.0) GOTO 330 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR. & KFA.EQ.18) IT4=IT4+1 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5)) K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5)) C...Choose lifetime and determine decay vertex. IF(K(ID,1).EQ.5) THEN V(ID,5)=0D0 ELSEIF(K(ID,1).NE.4) THEN V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0)) ENDIF DO 190 J=1,4 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5) 190 CONTINUE C...Determine whether decay allowed or not. MOUT=0 IF(MSTJ(22).EQ.2) THEN IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1 ELSEIF(MSTJ(22).EQ.3) THEN IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1 ELSEIF(MSTJ(22).EQ.4) THEN IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1 ENDIF IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN K(ID,1)=4 GOTO 330 ENDIF C...Info for selection of decay channel: sign, pairings. IF(KCHG(KCA,3).EQ.0) THEN IPM=2 ELSE IPM=(5-ISIGN(1,K(ID,2)))/2 ENDIF KFB=0 IF(JTMAX.EQ.2) THEN KFB=IABS(K(IREF(IP,3-JT),2)) ELSEIF(JTMAX.EQ.3) THEN JT2=JT+1-3*(JT/3) KFB=IABS(K(IREF(IP,JT2),2)) IF(KFB.NE.KFA) THEN JT2=JT+2-3*((JT+1)/3) KFB=IABS(K(IREF(IP,JT2),2)) ENDIF ENDIF C...Select decay channel. IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR. & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE) WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4) IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5) IF(WDTE0S.LE.0D0) GOTO 330 RKFL=WDTE0S*PYR(0) IDL=0 200 IDL=IDL+1 IDC=IDL+MDCY(KCA,2)-1 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4)) IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5) IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200 C...Read out flavours and colour charges of decay channel chosen. KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2)) IF(KCQM(JT).EQ.-2) KCQM(JT)=2 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2)) KFC1A=PYCOMP(IABS(KFL1(JT))) IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT)) KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT)) IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2)) KFC2A=PYCOMP(IABS(KFL2(JT))) IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT)) KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT)) IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2)) KCQ3(JT)=0 IF(KFL3(JT).NE.0) THEN KFC3A=PYCOMP(IABS(KFL3(JT))) IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT)) KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT)) IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2 ENDIF C...Set/save further info on channel. KDCY(JT)=1 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1) NSD(JT)=N HGZ(JT,1)=VINT(111) HGZ(JT,2)=VINT(112) HGZ(JT,3)=VINT(114) JTZ=JT C...Select masses; to begin with assume resonances narrow. DO 220 I=1,3 P(N+I,5)=0D0 PMMN(I)=0D0 IF(I.EQ.1) THEN KFLW=IABS(KFL1(JT)) KCW=KFC1A ELSEIF(I.EQ.2) THEN KFLW=IABS(KFL2(JT)) KCW=KFC2A ELSEIF(I.EQ.3) THEN IF(KFL3(JT).EQ.0) GOTO 220 KFLW=IABS(KFL3(JT)) KCW=KFC3A ENDIF P(N+I,5)=PMAS(KCW,1) CMRENNA++ C...This prevents SUSY/t particles from becoming too light. IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN PMMN(I)=PMAS(KCW,1) DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+ & PMAS(PYCOMP(KFDP(IDC,2)),1) IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+ & PMAS(PYCOMP(KFDP(IDC,3)),1) PMMN(I)=MIN(PMMN(I),PMSUM) ENDIF 210 CONTINUE CMRENNA-- ELSEIF(KFLW.EQ.6) THEN PMMN(I)=PMAS(24,1)+PMAS(5,1) ENDIF 220 CONTINUE C...Check which two out of three are widest. IWID1=1 IWID2=2 PWID1=PMAS(KFC1A,2) PWID2=PMAS(KFC2A,2) KFLW1=IABS(KFL1(JT)) KFLW2=IABS(KFL2(JT)) IF(KFL3(JT).NE.0) THEN PWID3=PMAS(KFC3A,2) IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN IWID1=3 PWID1=PWID3 KFLW1=IABS(KFL3(JT)) ELSEIF(PWID3.GT.PWID2) THEN IWID2=3 PWID2=PWID3 KFLW2=IABS(KFL3(JT)) ENDIF ENDIF C...If all narrow then only check that masses consistent. IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND. & PWID2.LT.PARP(41))) THEN CMRENNA++ C....Handle near degeneracy cases. IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0 ENDIF ENDIF CMRENNA-- IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN CALL PYERRM(13,'(PYRESD:) daughter masses too large') MINT(51)=1 GOTO 720 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN CALL PYERRM(3,'(PYRESD:) daughter masses too large') MINT(51)=1 GOTO 720 ENDIF C...For three wide resonances select narrower of three C...according to BW decoupled from rest. ELSE PMTOT=P(ID,5) IF(KFL3(JT).NE.0) THEN IWID3=6-IWID1-IWID2 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))- & KFLW1-KFLW2 LOOP=0 230 LOOP=LOOP+1 P(N+IWID3,5)=PYMASS(KFLW3) IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230 PMTOT=PMTOT-P(N+IWID3,5) ENDIF C...Select other two correlated within remaining phase space. IF(IP.EQ.1) THEN CKIN45=CKIN(45) CKIN47=CKIN(47) CKIN(45)=MAX(PMMN(IWID1),CKIN(45)) CKIN(47)=MAX(PMMN(IWID2),CKIN(47)) CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5), & P(N+IWID2,5)) CKIN(45)=CKIN45 CKIN(47)=CKIN47 ELSE CKIN(49)=PMMN(IWID1) CKIN(50)=PMMN(IWID2) CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5), & P(N+IWID2,5)) CKIN(49)=0D0 CKIN(50)=0D0 ENDIF IF(MINT(51).EQ.1) GOTO 720 ENDIF C...Begin fill decay products, with colour flow for coloured objects. MSTU10=MSTU(10) MSTU(10)=1 MSTU(19)=1 CMRENNA++ C...1) Three-body decays of SUSY particles (plus special case top). IF(KFL3(JT).NE.0) THEN DO 250 I=N+1,N+3 DO 240 J=1,5 K(I,J)=0 V(I,J)=0D0 240 CONTINUE MCT(I,1)=0 MCT(I,2)=0 250 CONTINUE K(N+1,1)=1 K(N+1,2)=KFL1(JT) K(N+2,1)=1 K(N+2,2)=KFL2(JT) K(N+3,1)=1 K(N+3,2)=KFL3(JT) IDIN=ID CALL PYTBDY(IDIN) C...Set colour flow for t -> W + b + Z. IF(KFA.EQ.6) THEN K(N+2,1)=3 ISID=4 IF(KCQM(JT).EQ.-1) ISID=5 IDAU=N+2 K(ID,ISID)=K(ID,ISID)+IDAU K(IDAU,ISID)=MSTU(5)*ID C...Set colour flow in three-body decays - programmed as special cases. ELSEIF(KFC2A.LE.6) THEN K(N+2,1)=3 K(N+3,1)=3 ISID=4 IF(KFL2(JT).LT.0) ISID=5 K(N+2,ISID)=MSTU(5)*(N+3) K(N+3,9-ISID)=MSTU(5)*(N+2) 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 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 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)) 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. 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)) DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP)) SO=0D0 ENDIF SP=0D0 SOP=0D0 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 CQ2=PARP(84)**2 OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+ & 2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)* & EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+ & PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2) ELSE OV=EXP(-B**POWIP)/PARU(2) SO=SO+PARU(2)*B*DELTAB*OV ENDIF PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV)) SP=SP+PARU(2)*B*DELTAB*PACC SOP=SOP+PARU(2)*B*DELTAB*OV*PACC 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. VINT(145)=SIGSUM VINT(146)=SOP/SO VINT(147)=SOP/SP C...Initialize iteration in xT2 for hardest interaction. ELSEIF(MMUL.EQ.2) THEN 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=VINT(146)*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 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) IF(MSTP(82).LE.0) THEN XT2=0D0 ELSEIF(MSTP(82).EQ.1) THEN XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) ELSEIF(MSTP(82).EQ.2) 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) 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) 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. ELSEIF(MMUL.EQ.5) THEN ISUB=MINT(1) 150 IF(MSTP(82).EQ.3) THEN VINT(148)=PYR(0)/(PARU(2)*VINT(147)) ELSEIF(MSTP(82).EQ.4) THEN RTYPE=PYR(0) CQ2=PARP(84)**2 IF(RTYPE.LT.(1D0-PARP(83))**2) THEN B2=-LOG(PYR(0)) ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0)) ELSE B2=-CQ2*LOG(PYR(0)) ENDIF VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)* & (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+ & PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147)) 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)*VINT(147)) 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)*VINT(147)) ENDIF C...Multiple interactions (variable impact parameter) : reject with C...probability exp(-overlap*cross-section above pT/normalization). 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,VINT(146)*VINT(148)* & SIGABV/MAX(1D-10,SIGT(0,0,5)))) 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) 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. 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=VINT(146)*VINT(148)*XSEC(ISUB,1)/ & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149)) ENDIF VINT(63)=0D0 VINT(64)=0D0 VINT(143)=1D0-VINT(141) VINT(144)=1D0-VINT(142) C...Iterate downwards in xT2. 220 IF(MSTP(82).LE.1) THEN XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) IF(XT2.LT.VINT(149)) GOTO 270 ELSE IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))* & LOG(PYR(0)))-VINT(149) IF(XT2.LE.0D0) GOTO 270 XT2=MAX(0.01D0*VINT(149),XT2) ENDIF VINT(25)=XT2 C...Choose tau and y*. Calculate cos(theta-hat). IF(PYR(0).LE.COEF(ISUB,1)) THEN TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) ELSE TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) ENDIF VINT(21)=TAU CALL PYKLIM(2) RYST=PYR(0) MYST=1 IF(RYST.GT.COEF(ISUB,8)) MYST=2 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 CALL PYKMAP(2,MYST,PYR(0)) VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) C...Check that x not used up. Accept or reject kinematical variables. X1M=SQRT(TAU)*EXP(VINT(22)) X2M=SQRT(TAU)*EXP(-VINT(22)) IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220 VINT(71)=0.5D0*VINT(1)*SQRT(XT2) CALL PYSIGH(NCHN,SIGS) IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320) IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220 C...Reset K, P and V vectors. Select some variables. DO 240 I=N+1,N+2 DO 230 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 230 CONTINUE 240 CONTINUE RFLAV=PYR(0) PT=0.5D0*VINT(1)*SQRT(XT2) PHI=PARU(2)*PYR(0) CTH=VINT(23) C...Add first parton to event record. K(N+1,1)=3 K(N+1,2)=21 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)= & 1+INT((2D0+PARJ(2))*PYR(0)) P(N+1,1)=PT*COS(PHI) P(N+1,2)=PT*SIN(PHI) P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH)) P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH)) P(N+1,5)=0D0 C...Add second parton to event record. K(N+2,1)=3 K(N+2,2)=21 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2) P(N+2,1)=-P(N+1,1) P(N+2,2)=-P(N+1,2) P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH)) P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH)) P(N+2,5)=0D0 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN C....Choose relevant string pieces to place gluons on. DO 260 I=N+1,N+2 DMIN=1D8 DO 250 ISTR=1,NSTR I1=KSTR(ISTR,1) I2=KSTR(ISTR,2) DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)- & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)- & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)- & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3)) IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN DMIN=DIST IST1=I1 IST2=I2 ISTM=ISTR ENDIF 250 CONTINUE C....Colour flow adjustments, new string pieces. IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+ & MOD(K(IST1,4),MSTU(5)) IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)= & MSTU(5)*(K(IST1,5)/MSTU(5))+I K(I,5)=MSTU(5)*IST1 K(I,4)=MSTU(5)*IST2 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+ & MOD(K(IST2,5),MSTU(5)) IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)= & MSTU(5)*(K(IST2,4)/MSTU(5))+I KSTR(ISTM,2)=I KSTR(NSTR+1,1)=I KSTR(NSTR+1,2)=IST2 NSTR=NSTR+1 260 CONTINUE C...String drawing and colour flow for gluon loop. ELSEIF(K(N+1,2).EQ.21) THEN K(N+1,4)=MSTU(5)*(N+2) K(N+1,5)=MSTU(5)*(N+2) K(N+2,4)=MSTU(5)*(N+1) K(N+2,5)=MSTU(5)*(N+1) KSTR(NSTR+1,1)=N+1 KSTR(NSTR+1,2)=N+2 KSTR(NSTR+2,1)=N+2 KSTR(NSTR+2,2)=N+1 NSTR=NSTR+2 C...String drawing and colour flow for qqbar pair. ELSE K(N+1,4)=MSTU(5)*(N+2) K(N+2,5)=MSTU(5)*(N+1) KSTR(NSTR+1,1)=N+1 KSTR(NSTR+1,2)=N+2 NSTR=NSTR+1 ENDIF C...Global statistics. MINT(351)=MINT(351)+1 VINT(351)=VINT(351)+PT IF (MINT(351).EQ.1) VINT(356)=PT C...Update remaining energy; iterate. N=N+2 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS') MINT(51)=1 RETURN ENDIF MINT(31)=MINT(31)+1 VINT(151)=VINT(151)+VINT(41) VINT(152)=VINT(152)+VINT(42) VINT(143)=VINT(143)-VINT(41) VINT(144)=VINT(144)-VINT(42) IF(MINT(31).LT.240) GOTO 220 270 CONTINUE MINT(1)=ISUBSV DO 280 J=11,80 VINT(J)=VINTSV(J) 280 CONTINUE ENDIF C...Format statements for printout. 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter', &'actions for MSTP(82) =',I2,' ******') 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P, &D9.2,' mb: rejected') 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P, &D9.2,' mb: accepted') RETURN END C********************************************************************* C...PYREMN C...Adds on target remnants (one or two from each side) and C...includes primordial kT for hadron beams. SUBROUTINE PYREMN(IPU1,IPU2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ C...Local arrays. DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5), &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4) C...Find event type and remaining energy. ISUB=MINT(1) NS=N IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN VINT(143)=1D0-VINT(141) VINT(144)=1D0-VINT(142) ENDIF C...Define initial partons. NTRY=0 100 NTRY=NTRY+1 DO 130 JT=1,2 I=MINT(83)+JT+2 IF(JT.EQ.1) IPU=IPU1 IF(JT.EQ.2) IPU=IPU2 K(I,1)=21 K(I,2)=K(IPU,2) K(I,3)=I-2 PMS(JT)=0D0 VINT(156+JT)=0D0 VINT(158+JT)=0D0 IF(MINT(47).EQ.1) THEN DO 110 J=1,5 P(I,J)=P(I-2,J) 110 CONTINUE ELSEIF(ISUB.EQ.95) THEN K(I,2)=21 ELSE P(I,5)=P(IPU,5) C...No primordial kT, or chosen according to truncated Gaussian or C...exponential, or (for photon) predetermined or power law. 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN IF(MSTP(91).LE.0) THEN PT=0D0 ELSEIF(MSTP(91).EQ.1) THEN PT=PARP(91)*SQRT(-LOG(PYR(0))) ELSE RPT1=PYR(0) RPT2=PYR(0) PT=-PARP(92)*LOG(RPT1*RPT2) ENDIF IF(PT.GT.PARP(93)) GOTO 120 ELSEIF(MINT(106+JT).EQ.3) THEN PTA=SQRT(VINT(282+JT)) PTB=0D0 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN PTB=PARP(99)*SQRT(-LOG(PYR(0))) ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN RPT1=PYR(0) RPT2=PYR(0) PTB=-PARP(99)*LOG(RPT1*RPT2) ENDIF IF(PTB.GT.PARP(100)) GOTO 120 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0))) PT=PT*0.8D0**MINT(57) IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10) ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN IF(MSTP(93).LE.0) THEN PT=0D0 ELSEIF(MSTP(93).EQ.1) THEN PT=PARP(99)*SQRT(-LOG(PYR(0))) ELSEIF(MSTP(93).EQ.2) THEN RPT1=PYR(0) RPT2=PYR(0) PT=-PARP(99)*LOG(RPT1*RPT2) ELSEIF(MSTP(93).EQ.3) THEN HA=PARP(99)**2 HB=PARP(100)**2 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA)) ELSE HA=PARP(99)**2 HB=PARP(100)**2 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2) PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA)) ENDIF IF(PT.GT.PARP(100)) GOTO 120 ELSE PT=0D0 ENDIF VINT(156+JT)=PT PHI=PARU(2)*PYR(0) P(I,1)=PT*COS(PHI) P(I,2)=PT*SIN(PHI) PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2 ENDIF 130 CONTINUE IF(MINT(47).EQ.1) RETURN C...Kinematics construction for initial partons. I1=MINT(83)+3 I2=MINT(83)+4 IF(ISUB.EQ.95) THEN SHS=0D0 SHR=0D0 ELSE SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+ & (P(I1,2)+P(I2,2))**2 SHR=SQRT(MAX(0D0,SHS)) IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR) P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1))) P(I2,4)=SHR-P(I1,4) P(I2,3)=-P(I1,3) C...Transform partons to overall CM-frame. ROBO(3)=(P(I1,1)+P(I2,1))/SHR ROBO(4)=(P(I1,2)+P(I2,2))/SHR CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0) ROBO(2)=PYANGL(P(I1,1),P(I1,2)) CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0) ROBO(1)=PYANGL(P(I1,3),P(I1,1)) CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0) CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0) CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0) ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142)) CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5)) ENDIF C...Optionally fix up x and Q2 definitions for leptoproduction. IDISXQ=0 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND. &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1 IF(IDISXQ.EQ.1) THEN C...Find where incoming and outgoing leptons/partons are sitting. LESD=1 IF(MINT(42).EQ.1) LESD=2 LPIN=MINT(83)+3-LESD LEIN=MINT(84)+LESD LQIN=MINT(84)+3-LESD LEOUT=MINT(84)+2+LESD LQOUT=MINT(84)+5-LESD IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3) IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3) LSCMS=0 DO 140 I=MINT(84)+5,N IF(K(I,2).EQ.94) THEN LSCMS=I LEOUT=I+LESD LQOUT=I+3-LESD ENDIF 140 CONTINUE LQBG=IPU1 IF(LESD.EQ.1) LQBG=IPU2 C...Calculate actual and wanted momentum transfer. XNOM=VINT(43-LESD) Q2NOM=-VINT(45) HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)- & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))* & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4)) HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK))) FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2)) P(N+1,1)=FAC*P(LEOUT,1) P(N+1,2)=FAC*P(LEOUT,2) P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)- & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1) P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+ & P(N+1,3)**2) DO 150 J=1,4 QOLD(J)=P(LEIN,J)-P(LEOUT,J) QNEW(J)=P(LEIN,J)-P(N+1,J) 150 CONTINUE C...Boost outgoing electron and daughters. IF(LSCMS.EQ.0) THEN DO 160 J=1,4 P(LEOUT,J)=P(N+1,J) 160 CONTINUE ELSE DO 170 J=1,3 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4)) 170 CONTINUE PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2) DO 180 J=1,3 DBE(J)=PINV*P(N+2,J) 180 CONTINUE DO 200 I=LSCMS+1,N IORIG=I 190 IORIG=K(IORIG,3) IF(IORIG.GT.LEOUT) GOTO 190 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT) & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3)) 200 CONTINUE ENDIF C...Copy shower initiator and all outgoing partons. NCOP=N+1 K(NCOP,3)=LQBG DO 210 J=1,5 P(NCOP,J)=P(LQBG,J) 210 CONTINUE DO 240 I=MINT(84)+1,N ICOP=0 IF(K(I,1).GT.10) GOTO 240 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN ICOP=I ELSE IORIG=I 220 IORIG=K(IORIG,3) IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN ICOP=IORIG ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN GOTO 220 ENDIF ENDIF IF(ICOP.NE.0) THEN NCOP=NCOP+1 K(NCOP,3)=I DO 230 J=1,5 P(NCOP,J)=P(I,J) 230 CONTINUE ENDIF 240 CONTINUE C...Calculate relative rescaling factors. SLC=3-2*LESD PLCSUM=0D0 DO 250 I=N+2,NCOP PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3)) 250 CONTINUE DO 260 I=N+2,NCOP V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM 260 CONTINUE C...Transfer extra three-momentum of current. DO 280 I=N+2,NCOP DO 270 J=1,3 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J)) 270 CONTINUE P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) 280 CONTINUE C...Iterate change of initiator momentum to get energy right. ITER=0 290 ITER=ITER+1 PEEX=-P(N+1,4)-QNEW(4) PEMV=-P(N+1,3)/P(N+1,4) DO 300 I=N+2,NCOP PEEX=PEEX+P(I,4) PEMV=PEMV+V(I,1)*P(I,3)/P(I,4) 300 CONTINUE IF(ABS(PEMV).LT.1D-10) THEN MINT(51)=1 MINT(57)=MINT(57)+1 RETURN ENDIF PZCH=-PEEX/PEMV P(N+1,3)=P(N+1,3)+PZCH P(N+1,4)=SQRT(P(N+1,5)**2+P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2) DO 310 I=N+2,NCOP P(I,3)=P(I,3)+V(I,1)*PZCH P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) 310 CONTINUE IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290 C...Modify momenta in event record. HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/ & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2) IF(ABS(HBE).GE.1D0) THEN MINT(51)=1 MINT(57)=MINT(57)+1 RETURN ENDIF I=MINT(83)+5-LESD CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE) DO 330 I=N+1,NCOP ICOP=K(I,3) DO 320 J=1,4 P(ICOP,J)=P(I,J) 320 CONTINUE 330 CONTINUE ENDIF C...Check minimum invariant mass of remnant system(s). PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152)) PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152)) PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2) PMIN(0)=SQRT(PMS(0)) DO 340 JT=1,2 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT) PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1) PMIN(JT)=0D0 IF(MINT(44+JT).EQ.1) GOTO 340 MINT(105)=MINT(102+JT) MINT(109)=MINT(106+JT) CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT)) IF(MINT(51).NE.0) THEN MINT(57)=MINT(57)+1 RETURN ENDIF IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT)) IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT)) IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111) PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+ & P(MINT(83)+JT+2,2)**2) 340 CONTINUE IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND. &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT. &PSYS(2,4))) THEN MINT(51)=1 MINT(57)=MINT(57)+1 RETURN ENDIF C...Loop over two remnants; skip if none there. I=NS DO 410 JT=1,2 ISN(JT)=0 IF(MINT(44+JT).EQ.1) GOTO 410 IF(JT.EQ.1) IPU=IPU1 IF(JT.EQ.2) IPU=IPU2 C...Store first remnant parton. I=I+1 IS(JT)=I ISN(JT)=1 DO 350 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 350 CONTINUE K(I,1)=1 K(I,2)=KFLSP(JT) K(I,3)=MINT(83)+JT P(I,5)=PYMASS(K(I,2)) C...First parton colour connections and kinematics. KCOL=KCHG(PYCOMP(KFLSP(JT)),2) IF(KCOL.EQ.2) THEN K(I,1)=3 K(I,4)=MSTU(5)*IPU+IPU K(I,5)=MSTU(5)*IPU+IPU K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I ELSEIF(KCOL.NE.0) THEN K(I,1)=3 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2 K(I,KFLS+3)=IPU K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I ENDIF IF(KFLCH(JT).EQ.0) THEN P(I,1)=-P(MINT(83)+JT+2,1) P(I,2)=-P(MINT(83)+JT+2,2) PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1) P(I,3)=PSYS(JT,3) P(I,4)=PSYS(JT,4) C...When extra remnant parton or hadron: store extra remnant. ELSE I=I+1 ISN(JT)=2 DO 360 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 360 CONTINUE K(I,1)=1 K(I,2)=KFLCH(JT) K(I,3)=MINT(83)+JT P(I,5)=PYMASS(K(I,2)) C...Find parton colour connections of extra remnant. KCOL=KCHG(PYCOMP(KFLCH(JT)),2) IF(KCOL.EQ.2) THEN K(I,1)=3 K(I,4)=MSTU(5)*IPU+IPU K(I,5)=MSTU(5)*IPU+IPU K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I ELSEIF(KCOL.NE.0) THEN K(I,1)=3 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2 K(I,KFLS+3)=IPU K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I ENDIF C...Relative transverse momentum when two remnants. LOOP=0 370 LOOP=LOOP+1 CALL PYPTDI(1,P(I-1,1),P(I-1,2)) IF(IABS(MINT(10+JT)).LT.20) THEN P(I-1,1)=0D0 P(I-1,2)=0D0 ELSE P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1) P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2) ENDIF PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1) P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2) PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2 C...Meson or baryon; photon as meson. For splitup below. IMB=1 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2 C***Relative distribution for electron into two electrons. Temporary! IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT)) & THEN CHI(JT)=PYR(0) C...Relative distribution of electron energy into electron plus parton. ELSEIF(IABS(MINT(10+JT)).LT.20) THEN XHRD=VINT(140+JT) XE=VINT(154+JT) CHI(JT)=(XE-XHRD)/(1D0-XHRD) C...Relative distribution of energy for particle into two jets. ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN CHIK=PARP(92+2*IMB) IF(MSTP(92).LE.1) THEN IF(IMB.EQ.1) CHI(JT)=PYR(0) IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0)) ELSEIF(MSTP(92).EQ.2) THEN CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK)) ELSEIF(MSTP(92).EQ.3) THEN CUT=2D0*0.3D0/VINT(1) 380 CHI(JT)=PYR(0)**2 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0* & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380 ELSEIF(MSTP(92).EQ.4) THEN CUT=2D0*0.3D0/VINT(1) CUTR=(1D0+SQRT(1D0+CUT**2))/CUT 390 CHIR=CUT*CUTR**PYR(0) CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR) IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390 ELSE CUT=2D0*0.3D0/VINT(1) CUTA=CUT**(1D0-PARP(98)) CUTB=(1D0+CUT)**(1D0-PARP(98)) 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98))) IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))** & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400 ENDIF C...Relative distribution of energy for particle into jet plus particle. ELSE IF(MSTP(94).LE.1) THEN IF(IMB.EQ.1) CHI(JT)=PYR(0) IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0)) IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT) ELSEIF(MSTP(94).EQ.2) THEN CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB))) IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT) ELSEIF(MSTP(94).EQ.3) THEN CALL PYZDIS(1,0,PMS(JT+4),ZZ) CHI(JT)=ZZ ELSE CALL PYZDIS(1000,0,PMS(JT+4),ZZ) CHI(JT)=ZZ ENDIF ENDIF C...Construct total transverse mass; reject if too large. CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT))) PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT)) IF(PMS(JT).GT.PSYS(JT,4)**2) THEN IF(LOOP.LT.100) THEN GOTO 370 ELSE MINT(51)=1 MINT(57)=MINT(57)+1 RETURN ENDIF ENDIF PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1) VINT(158+JT)=CHI(JT) C...Subdivide longitudinal momentum according to value selected above. PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3))) P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1) P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1) P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4) P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3) ENDIF 410 CONTINUE N=I C...Check if longitudinal boosts needed - if so pick two systems. PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+ &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3)) IF(PDEV.LE.1D-6*VINT(1)) RETURN IF(ISN(1).EQ.0) THEN IR=0 IL=2 ELSEIF(ISN(2).EQ.0) THEN IR=1 IL=0 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN IR=1 IL=2 ELSEIF(VINT(143).GT.0.2D0) THEN IR=1 IL=0 ELSEIF(VINT(144).GT.0.2D0) THEN IR=0 IL=2 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN IR=1 IL=0 ELSE IR=0 IL=2 ENDIF IG=3-IR-IL C...E+-pL wanted for system to be modified. IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN PPB=VINT(1) PNB=VINT(1) ELSE PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3)) PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3)) ENDIF C...To keep x and Q2 in leptoproduction: do not count scattered lepton. IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN PPB=PPB-(PSYS(0,4)+PSYS(0,3)) PNB=PNB-(PSYS(0,4)-PSYS(0,3)) DO 420 J=1,4 PSYS(0,J)=0D0 420 CONTINUE DO 450 I=MINT(84)+1,NS IF(K(I,1).GT.10) GOTO 450 INCL=0 IORIG=I 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1 IORIG=K(IORIG,3) IF(IORIG.GT.LPIN) GOTO 430 IF(INCL.EQ.0) GOTO 450 DO 440 J=1,4 PSYS(0,J)=PSYS(0,J)+P(I,J) 440 CONTINUE 450 CONTINUE PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2) PPB=PPB+(PSYS(0,4)+PSYS(0,3)) PNB=PNB+(PSYS(0,4)-PSYS(0,3)) ENDIF C...Construct longitudinal boosts. DPMTB=PPB*PNB DPMTR=PMS(IR) DPMTL=PMS(IL) DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL)) IF(DSQLAM.LE.1D-6*DPMTB) THEN MINT(51)=1 MINT(57)=MINT(57)+1 RETURN ENDIF DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4)) DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/ &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB) DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/ &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB) DBER=(DRKR**2-1D0)/(DRKR**2+1D0) DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0) C...Perform longitudinal boosts. IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN P(IS(1),3)=0D0 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2) ELSEIF(IR.EQ.1) THEN CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER) ELSEIF(IDISXQ.EQ.1) THEN DO 470 I=I1,NS INCL=0 IORIG=I 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1 IORIG=K(IORIG,3) IF(IORIG.GT.LPIN) GOTO 460 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER) 470 CONTINUE ELSE CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER) ENDIF IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN P(IS(2),3)=0D0 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2) ELSEIF(IL.EQ.2) THEN CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL) ELSEIF(IDISXQ.EQ.1) THEN DO 490 I=I1,NS INCL=0 IORIG=I 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1 IORIG=K(IORIG,3) IF(IORIG.GT.LPIN) GOTO 480 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL) 490 CONTINUE ELSE CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL) ENDIF C...Final check that energy-momentum conservation worked. PESUM=0D0 PZSUM=0D0 DO 500 I=MINT(84)+1,N IF(K(I,1).GT.10) GOTO 500 PESUM=PESUM+P(I,4) PZSUM=PZSUM+P(I,3) 500 CONTINUE PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM) IF(PDEV.GT.1D-4*VINT(1)) THEN MINT(51)=1 MINT(57)=MINT(57)+1 RETURN ENDIF C...Calculate rotation and boost from overall CM frame to C...hadronic CM frame in leptoproduction. MINT(91)=0 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN MINT(91)=1 LESD=1 IF(MINT(42).EQ.1) LESD=2 LPIN=MINT(83)+3-LESD C...Sum upp momenta of everything not lepton or photon to define boost. DO 510 J=1,4 PSUM(J)=0D0 510 CONTINUE DO 530 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530 IF(K(I,2).EQ.22) GOTO 530 DO 520 J=1,4 PSUM(J)=PSUM(J)+P(I,J) 520 CONTINUE 530 CONTINUE VINT(223)=-PSUM(1)/PSUM(4) VINT(224)=-PSUM(2)/PSUM(4) VINT(225)=-PSUM(3)/PSUM(4) C...Boost incoming hadron to hadronic CM frame to determine rotations. K(N+1,1)=1 DO 540 J=1,5 P(N+1,J)=P(LPIN,J) V(N+1,J)=V(LPIN,J) 540 CONTINUE CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225)) VINT(222)=-PYANGL(P(N+1,1),P(N+1,2)) CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0) IF(LESD.EQ.2) THEN VINT(221)=-PYANGL(P(N+1,3),P(N+1,1)) ELSE VINT(221)=PYANGL(-P(N+1,3),P(N+1,1)) ENDIF ENDIF RETURN END C********************************************************************* C...PYMIGN C...Initializes treatment of new multiple interactions scenario, C...selects kinematics of hardest interaction if low-pT physics C...included in run, and generates all non-hardest interactions. SUBROUTINE PYMIGN(MMUL) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP EXTERNAL PYALPS DOUBLE PRECISION PYALPS C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT7/SIGT(0:6,0:6,0:5) COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), & XMI(2,240),PT2MI(240),IMISEP(0:240) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/, &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/ C...Local arrays and saved variables. DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80), &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5) SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM 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)) 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. 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)) DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP)) SO=0D0 ENDIF SP=0D0 SOP=0D0 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 CQ2=PARP(84)**2 OV=((1D0-PARP(83))**2*EXP(-MIN(50D0,B**2))+ & 2D0*PARP(83)*(1D0-PARP(83))*2D0/(1D0+CQ2)* & EXP(-MIN(50D0,B**2*2D0/(1D0+CQ2)))+ & PARP(83)**2/CQ2*EXP(-MIN(50D0,B**2/CQ2)))/PARU(2) ELSE OV=EXP(-B**POWIP)/PARU(2) SO=SO+PARU(2)*B*DELTAB*OV ENDIF PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV)) SP=SP+PARU(2)*B*DELTAB*PACC SOP=SOP+PARU(2)*B*DELTAB*OV*PACC 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. VINT(145)=SIGSUM VINT(146)=SOP/SO VINT(147)=SOP/SP C...Initialize iteration in xT2 for hardest interaction. ELSEIF(MMUL.EQ.2) THEN 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=VINT(146)*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 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) IF(MSTP(82).LE.0) THEN XT2=0D0 ELSEIF(MSTP(82).EQ.1) THEN XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) ELSEIF(MSTP(82).EQ.2) 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) 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) 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. ELSEIF(MMUL.EQ.5) THEN ISUB=MINT(1) 150 IF(MSTP(82).EQ.3) THEN VINT(148)=PYR(0)/(PARU(2)*VINT(147)) ELSEIF(MSTP(82).EQ.4) THEN RTYPE=PYR(0) CQ2=PARP(84)**2 IF(RTYPE.LT.(1D0-PARP(83))**2) THEN B2=-LOG(PYR(0)) ELSEIF(RTYPE.LT.1D0-PARP(83)**2) THEN B2=-0.5D0*(1D0+CQ2)*LOG(PYR(0)) ELSE B2=-CQ2*LOG(PYR(0)) ENDIF VINT(148)=((1D0-PARP(83))**2*EXP(-MIN(50D0,B2))+2D0*PARP(83)* & (1D0-PARP(83))*2D0/(1D0+CQ2)*EXP(-MIN(50D0,B2*2D0/(1D0+CQ2)))+ & PARP(83)**2/CQ2*EXP(-MIN(50D0,B2/CQ2)))/(PARU(2)*VINT(147)) 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)*VINT(147)) 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)*VINT(147)) ENDIF C...Multiple interactions (variable impact parameter) : reject with C...probability exp(-overlap*cross-section above pT/normalization). 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,VINT(146)*VINT(148)* & SIGABV/MAX(1D-10,SIGT(0,0,5)))) 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) 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=VINT(146)*VINT(148)*XSEC(ISUB,1)/ & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149)) ENDIF VINT(63)=0D0 VINT(64)=0D0 C...Iterate downwards in xT2. 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN XT2=0D0 GOTO 440 ELSEIF(MSTP(82).LE.1) THEN XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) IF(XT2.LT.VINT(149)) GOTO 440 ELSE IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))* & LOG(PYR(0)))-VINT(149) IF(XT2.LE.0D0) GOTO 440 XT2=MAX(0.01D0*VINT(149),XT2) ENDIF VINT(25)=XT2 C...Choose tau and y*. Calculate cos(theta-hat). IF(PYR(0).LE.COEF(ISUB,1)) THEN TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) ELSE TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) ENDIF VINT(21)=TAU C...New: require shat > 1. IF(TAU*VINT(2).LT.1D0) GOTO 240 CALL PYKLIM(2) RYST=PYR(0) MYST=1 IF(RYST.GT.COEF(ISUB,8)) MYST=2 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 CALL PYKMAP(2,MYST,PYR(0)) VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) C...Check that x not used up. Accept or reject kinematical variables. X1M=SQRT(TAU)*EXP(VINT(22)) X2M=SQRT(TAU)*EXP(-VINT(22)) IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240 VINT(71)=0.5D0*VINT(1)*SQRT(XT2) CALL PYSIGH(NCHN,SIGS) IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320) IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320) C...Reset K, P and V vectors. DO 260 I=N+1,N+4 DO 250 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 250 CONTINUE 260 CONTINUE PT=0.5D0*VINT(1)*SQRT(XT2) C...Choose flavour of reacting partons (and subprocess). RSIGS=SIGS*PYR(0) DO 270 ICHN=1,NCHN KFL1=ISIG(ICHN,1) KFL2=ISIG(ICHN,2) ICONMI=ISIG(ICHN,3) RSIGS=RSIGS-SIGH(ICHN) IF(RSIGS.LE.0D0) GOTO 280 270 CONTINUE C...Reassign to appropriate process codes. 280 ISUBMI=ICONMI/10 ICONMI=MOD(ICONMI,10) C...Choose new quark flavour for annihilation graphs IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN SH=TAU*VINT(2) CALL PYWIDT(21,SH,WDTP,WDTE) 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0) DO 300 I=1,MDCY(21,3) KFLF=KFDP(I+MDCY(21,2)-1,1) RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4)) IF(RKFL.LE.0D0) GOTO 310 300 CONTINUE 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN IF(KFLF.GE.4) GOTO 290 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN KFLF=4 ICONMI=ICONMI-2 ELSEIF(ISUBMI.EQ.53) THEN KFLF=5 ICONMI=ICONMI-4 ENDIF ENDIF C...Final state flavours and colour flow: default values JS=1 KFL3=KFL1 KFL4=KFL2 KCC=20 KCS=ISIGN(1,KFL1) IF(ISUBMI.EQ.11) THEN C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2 KCC=ICONMI IF(KFL1*KFL2.LT.0) KCC=KCC+2 ELSEIF(ISUBMI.EQ.12) THEN C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2 KFL3=ISIGN(KFLF,KFL1) KFL4=-KFL3 KCC=4 ELSEIF(ISUBMI.EQ.13) THEN C...f + fbar -> g + g; th arbitrary KFL3=21 KFL4=21 KCC=ICONMI+4 ELSEIF(ISUBMI.EQ.28) THEN C...f + g -> f + g; th = (p(f)-p(f))**2 IF(KFL1.EQ.21) JS=2 KCC=ICONMI+6 IF(KFL1.EQ.21) KCC=KCC+2 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1) IF(KFL2.NE.21) KCS=ISIGN(1,KFL2) ELSEIF(ISUBMI.EQ.53) THEN C...g + g -> f + fbar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) KFL3=ISIGN(KFLF,KCS) KFL4=-KFL3 KCC=ICONMI+10 ELSEIF(ISUBMI.EQ.68) THEN C...g + g -> g + g; th arbitrary KCC=ICONMI+12 KCS=(-1)**INT(1.5D0+PYR(0)) ENDIF C...Store flavours of scattering. MINT(13)=KFL1 MINT(14)=KFL2 MINT(15)=KFL1 MINT(16)=KFL2 MINT(21)=KFL3 MINT(22)=KFL4 C...Set flavours and mothers of scattering partons. K(N+1,1)=14 K(N+2,1)=14 K(N+3,1)=3 K(N+4,1)=3 K(N+1,2)=KFL1 K(N+2,2)=KFL2 K(N+3,2)=KFL3 K(N+4,2)=KFL4 K(N+1,3)=MINT(83)+1 K(N+2,3)=MINT(83)+2 K(N+3,3)=N+1 K(N+4,3)=N+2 C...Store colour connection indices. DO 320 J=1,2 JC=J IF(KCS.EQ.-1) JC=3-J IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC) IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC) IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC)) IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC)) 320 CONTINUE C...Store incoming and outgoing partons in their CM-frame. SHR=SQRT(TAU)*VINT(1) P(N+1,3)=0.5D0*SHR P(N+1,4)=0.5D0*SHR P(N+2,3)=-0.5D0*SHR P(N+2,4)=0.5D0*SHR P(N+3,5)=PYMASS(K(N+3,2)) P(N+4,5)=PYMASS(K(N+4,2)) IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR) P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2)) P(N+4,4)=SHR-P(N+3,4) P(N+4,3)=-P(N+3,3) C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4) PHI=PARU(2)*PYR(0) CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0) C...Set up default values before showers. MINT(31)=MINT(31)+1 IPU1=N+1 IPU2=N+2 IPU3=N+3 IPU4=N+4 VINT(141)=VINT(41) VINT(142)=VINT(42) N=N+4 C...Showering of initial state partons (optional). C...Note: no showering of final state partons here; it comes later. IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN MINT(51)=0 ALAMSV=PARJ(81) PARJ(81)=PARP(72) NSAV=N DO 340 I=1,4 DO 330 J=1,5 KSAV(I,J)=K(N-4+I,J) PSAV(I,J)=P(N-4+I,J) 330 CONTINUE 340 CONTINUE CALL PYSSPA(IPU1,IPU2) PARJ(81)=ALAMSV C...If shower failed then restore to situation before shower. IF(MINT(51).GE.1) THEN N=NSAV DO 360 I=1,4 DO 350 J=1,5 K(N-4+I,J)=KSAV(I,J) P(N-4+I,J)=PSAV(I,J) 350 CONTINUE 360 CONTINUE IPU1=N-3 IPU2=N-2 VINT(141)=VINT(41) VINT(142)=VINT(42) ENDIF ENDIF C...Keep track of loose colour ends and information on scattering. 370 IMI(1,MINT(31),1)=IPU1 IMI(2,MINT(31),1)=IPU2 IMI(1,MINT(31),2)=0 IMI(2,MINT(31),2)=0 XMI(1,MINT(31))=VINT(141) XMI(2,MINT(31))=VINT(142) PT2MI(MINT(31))=VINT(54) IMISEP(MINT(31))=N C...Decide whether quarks in last scattering were valence, companion or C...sea. DO 430 JS=1,2 KFBEAM=MINT(10+JS) KFSBM=ISIGN(1,MINT(10+JS)) IFL=K(IMI(JS,MINT(31),1),2) IMI(JS,MINT(31),2)=0 IF (IABS(IFL).GT.6) GOTO 430 C...Get PDFs at X and Q2 of the parton shower initiator for the C...last scattering. At this point VINT(143:144) do not yet C...include the scattered x values VINT(141:142). X=VINT(140+JS)/VINT(142+JS) IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN Q2=PARP(62)**2 ELSE Q2=VINT(54) ENDIF C...Note: XPSVC = x*pdf. MINT(30)=JS CALL PYPDFU(KFBEAM,X,Q2,XPQ) SEA=XPSVC(IFL,-1) VAL=XPSVC(IFL,0) CMP=0D0 DO 380 IVC=1,NVC(JS,IFL) CMP=CMP+XPSVC(IFL,IVC) 380 CONTINUE C...Decide (Extra factor x cancels in the dvision). RVCS=PYR(0)*(SEA+VAL+CMP) IVNOW=1 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN C...Safety check that valence present; pi0/gamma/K0S/K0L special cases. IVNOW=0 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1 IF(KFIVAL(JS,1).EQ.0) THEN IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND. & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1 ELSE DO 400 I1=1,NMI(JS) IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0) & IVNOW=IVNOW-1 400 CONTINUE ENDIF IF(IVNOW.EQ.0) GOTO 390 C...Mark valence. IMI(JS,MINT(31),2)=0 C...Sets valence content of gamma, pi0, K0S, K0L if not done. IF(KFIVAL(JS,1).EQ.0) THEN IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN KFIVAL(JS,1)=IFL KFIVAL(JS,2)=-IFL ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN KFIVAL(JS,1)=IFL IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL) IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL) ENDIF ENDIF ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN C...If sea, add opposite sign companion parton. Store X and I. NVC(JS,-IFL)=NVC(JS,-IFL)+1 XASSOC(JS,-IFL,NVC(JS,-IFL))=X C...Set pointer to companion IMI(JS,MINT(31),2)=-NVC(JS,-IFL) ELSE C...If companion, decide which one. CMPSUM=VAL+SEA ISEL=0 410 ISEL=ISEL+1 CMPSUM=CMPSUM+XPSVC(IFL,ISEL) IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410 C...Find original sea (anti-)quark: IASSOC=0 DO 420 I1=1,NMI(JS) IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420 IF (-IMI(JS,I1,2).EQ.ISEL) THEN IMI(JS,MINT(31),2)=IMI(JS,I1,1) IMI(JS,I1,2)=IMI(JS,MINT(31),1) ENDIF 420 CONTINUE C...Change X to what associated companion had, so that the correct C...amount of momentum can be subtracted from the companion sum below. X=XASSOC(JS,IFL,ISEL) C...Mark companion read. XASSOC(JS,IFL,ISEL)=0D0 ENDIF 430 CONTINUE C...Global statistics. MINT(351)=MINT(351)+1 VINT(351)=VINT(351)+PT IF (MINT(351).EQ.1) VINT(356)=PT C...Update remaining energy and other counters. IF(N.GT.MSTU(4)-MSTU(32)-10) THEN CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS') MINT(51)=1 RETURN ENDIF NMI(1)=NMI(1)+1 NMI(2)=NMI(2)+1 VINT(151)=VINT(151)+VINT(41) VINT(152)=VINT(152)+VINT(42) VINT(143)=VINT(143)-VINT(141) VINT(144)=VINT(144)-VINT(142) C...Iterate, with more interactions allowed. IF(MINT(31).LT.240) GOTO 240 440 CONTINUE C...Restore saved quantities for hardest interaction. MINT(1)=ISUBSV MINT(13)=M13SV MINT(14)=M14SV MINT(15)=M15SV MINT(16)=M16SV MINT(21)=M21SV MINT(22)=M22SV DO 450 J=11,80 VINT(J)=VINTSV(J) 450 CONTINUE VINT(141)=V141SV VINT(142)=V142SV ENDIF C...Format statements for printout. 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter', &'actions for MSTP(82) =',I2,' ******') 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P, &D9.2,' mb: rejected') 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P, &D9.2,' mb: accepted') RETURN END C********************************************************************* C...PYMIHK C...Finds left-behind remnant flavour content and hooks up C...the colour flow between the hard scattering and remnants SUBROUTINE PYMIHK C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...The event record COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) C...Parameters COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) C...The common block of dangling ends COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), & XMI(2,240),PT2MI(240),IMISEP(0:240) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/ C...Local variables PARAMETER (NERSIZ=4000) COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2) & ,MACCPT COMMON /PYCTAG/NCT,MCT(NERSIZ,2) SAVE /PYCBLS/,/PYCTAG/ DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2) & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240) DATA NERRPR/0/ SAVE NERRPR FOUR(I,J)=P(I,4)*P(J,4)-P(I,3)*P(J,3)-P(I,2)*P(J,2)-P(I,1)*P(J,1) C...Set up error checkers IBOOST=0 C...Initialize colour arrays: MCO (Original) and MCT (New) DO 110 I=MINT(84)+1,NERSIZ DO 100 JC=1,2 MCT(I,JC)=0 MCO(I,JC)=0 100 CONTINUE C...Also zero colour tracing information, if existed. IF (I.LE.N) THEN K(I,4)=MOD(K(I,4),MSTU(5)**2) K(I,5)=MOD(K(I,5),MSTU(5)**2) ENDIF 110 CONTINUE C...Initialize colour tag collapse arrays: C...JCCO (Original) and JCCN (New). DO 130 MG=MINT(84)+1,NERSIZ DO 120 JC=1,2 JCCO(MG,JC)=0 JCCN(MG,JC)=0 120 CONTINUE 130 CONTINUE C...Zero gluon insertion array DO 150 IM=1,1000 DO 140 J=1,3 INSR(IM,J)=0 140 CONTINUE 150 CONTINUE C...Compute hard scattering system rapidities IF (MSTP(89).EQ.1) THEN DO 160 IM=1,240 IF (IM.LE.MINT(31)) THEN YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM)) ELSE C...Set (unsigned) rapidity = 100 for beam remnant systems. YMI(IM)=100D0 ENDIF 160 CONTINUE ENDIF C...Treat each side separately DO 290 JS=1,2 C...Initialize side. NG(JS)=0 JV=0 KFS=ISIGN(1,MINT(10+JS)) C...Set valence content of pi0, gamma, K0S, K0L if not yet done. IF(KFIVAL(JS,1).EQ.0) THEN IF(MINT(10+JS).EQ.111) THEN KFIVAL(JS,1)=INT(1.5D0+PYR(0)) KFIVAL(JS,2)=-KFIVAL(JS,1) ELSEIF(MINT(10+JS).EQ.22) THEN PYRKF=PYR(0) KFIVAL(JS,1)=1 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4 KFIVAL(JS,2)=-KFIVAL(JS,1) ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN IF(PYR(0).GT.0.5D0) THEN KFIVAL(JS,1)=1 KFIVAL(JS,2)=-3 ELSE KFIVAL(JS,1)=3 KFIVAL(JS,2)=-1 ENDIF ENDIF ENDIF C...Initialize beam remnant sea and valence content flavour by flavour. NVSUM(JS)=0 NBRTOT(JS)=0 DO 210 JFA=1,6 C...Count up original number of JFA valence quarks and antiquarks. NVALQ=0 NVALQB=0 NSEA=0 DO 170 J=1,3 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1 170 CONTINUE NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB C...Subtract kicked out valence and determine sea from flavour cons. DO 180 IM=1,NMI(JS) IFL = K(IMI(JS,IM,1),2) IFA = IABS(IFL) IFS = ISIGN(1,IFL) IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN C...Subtract K.O. valence quark from remainder. NVALQ=NVALQ-1 JV=NVSUM(JS)-NVALQ-NVALQB IV(JS,JV)=IMI(JS,IM,1) ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN C...Subtract K.O. valence antiquark from remainder. NVALQB=NVALQB-1 JV=NVSUM(JS)-NVALQ-NVALQB IV(JS,JV)=IMI(JS,IM,1) ELSEIF (IFA.EQ.JFA) THEN C...Outside sea without companion: add opposite sea flavour inside. IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS ENDIF 180 CONTINUE C...Check if space left in PYJETS for additional BR flavours NFLSUM=IABS(NSEA)+NVALQ+NVALQB NBRTOT(JS)=NBRTOT(JS)+NFLSUM IF (N+NFLSUM+1.GT.MSTU(4)) THEN CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS') MINT(51)=1 RETURN ENDIF C...Add required val+sea content to beam remnant. IF (NFLSUM.GT.0) THEN DO 200 IA=1,NFLSUM C...Insert beam remnant quark as p.t. symbolic parton in ER. N=N+1 DO 190 IX=1,5 K(N,IX)=0 P(N,IX)=0D0 V(N,IX)=0D0 190 CONTINUE K(N,1)=3 K(N,2)=ISIGN(JFA,NSEA) IF (IA.LE.NVALQ) K(N,2)=JFA IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA K(N,3)=MINT(83)+JS C...Also update NMI, IMI, and IV arrays. NMI(JS)=NMI(JS)+1 IMI(JS,NMI(JS),1)=N IMI(JS,NMI(JS),2)=-1 IF (IA.LE.NVALQ+NVALQB) THEN IMI(JS,NMI(JS),2)=0 JV=JV+1 IV(JS,JV)=IMI(JS,NMI(JS),1) ENDIF 200 CONTINUE ENDIF 210 CONTINUE IM=0 220 IM=IM+1 IF (IM.LE.NMI(JS)) THEN IF (K(IMI(JS,IM,1),2).EQ.21) THEN NG(JS)=NG(JS)+1 C...Add fictitious parent gluons for companion pairs. ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN C...Randomly assign companions to sea quarks which have none. IF (IMI(JS,IM,2).LT.0) THEN IMC=PYR(0)*NMI(JS) 230 IMC=MOD(IMC,NMI(JS))+1 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230 IF (IMI(JS,IMC,2).GE.0) GOTO 230 IMI(JS, IM,2) = IMI(JS,IMC,1) IMI(JS,IMC,2) = IMI(JS, IM,1) ENDIF C...Add fictitious parent gluon N=N+1 DO 240 IX=1,5 K(N,IX)=0 P(N,IX)=0D0 V(N,IX)=0D0 240 CONTINUE K(N,1)=14 K(N,2)=21 K(N,3)=MINT(83)+JS C...Set gluon (anti-)colour daughter pointers K(N,4)=IMI(JS, IM,1) K(N,5)=IMI(JS, IM,2) C...Set quark (anti-)colour parent pointers K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N C...Add gluon to IMI NMI(JS)=NMI(JS)+1 IMI(JS,NMI(JS),1)=N IMI(JS,NMI(JS),2)=0 ENDIF GOTO 220 ENDIF C...If incoming (anti-)baryon, insert inside (anti-)junction. C...Set up initial v-v-j-v configuration. Otherwise set up C...mesonic v-vbar configuration IF (IABS(MINT(10+JS)).GT.1000) THEN C...Determine junction type (1: B=1 2: B=-1) ITJUNC(JS) = (3-KFS)/2 C...Insert junction. N=N+1 DO 250 IX=1,5 K(N,IX)=0 P(N,IX)=0D0 V(N,IX)=0D0 250 CONTINUE C...Set special junction codes: K(N,1)=42 K(N,2)=88 C...Set parent to side. K(N,3)=MINT(83)+JS K(N,4)=ITJUNC(JS)*MSTU(5) K(N,5)=0 C...Connect valence quarks to junction. MOUT(JS)=0 MANTI=ITJUNC(JS)-1 C...Set (anti)colour mother = junction. DO 260 JV=1,3 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5)) & +MSTU(5)*N C...Keep track of partons adjacent to junction: JST(JS,JV)=IV(JS,JV) 260 CONTINUE ELSE C...Mesons: set up initial q-qbar topology ITJUNC(JS)=0 IF (K(IV(JS,1),2).GT.0) THEN IQ=IV(JS,1) IQBAR=IV(JS,2) ELSE IQ=IV(JS,2) IQBAR=IV(JS,1) ENDIF IV(JS,3)=0 JST(JS,1)=IQ JST(JS,2)=IQBAR JST(JS,3)=0 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ C...Special for mesons. Insert gluon if BR empty. IF (NBRTOT(JS).EQ.0) THEN N=N+1 DO 270 IX=1,5 K(N,IX)=0 P(N,IX)=0D0 V(N,IX)=0D0 270 CONTINUE K(N,1)=3 K(N,2)=21 K(N,3)=MINT(83)+JS K(N,4)=0 K(N,5)=0 NBRTOT(JS)=1 NG(JS)=NG(JS)+1 C...Add gluon to IMI NMI(JS)=NMI(JS)+1 IMI(JS,NMI(JS),1)=N IMI(JS,NMI(JS),2)=0 ENDIF MOUT(JS)=0 ENDIF C...Count up number of valence quarks outside BR. DO 280 JV=1,3 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0) & MOUT(JS)=MOUT(JS)+1 280 CONTINUE 290 CONTINUE C...Now both sides have been prepared in an initial vvjv (baryonic) or C...v(g)vbar (mesonic) configuration. C...Create colour line tags starting from initiators. NCT=0 DO 320 IM=1,MINT(31) C...Consider each side in turn. DO 310 JS=1,2 I1=IMI(JS,IM,1) I2=IMI(3-JS,IM,1) DO 300 JCS=4,5 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2))) & GOTO 300 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300 KCS=JCS CALL PYCTTR(I1,KCS,I2) IF(MINT(51).NE.0) RETURN 300 CONTINUE 310 CONTINUE 320 CONTINUE DO 340 JS=1,2 C...Create colour tags for beam remnant partons. DO 330 IM=MINT(31)+1,NMI(JS) IP=IMI(JS,IM,1) IF (K(IP,2).NE.21) THEN JC=(3-ISIGN(1,K(IP,2)))/2 IF (MCT(IP,JC).EQ.0) THEN NCT=NCT+1 MCT(IP,JC)=NCT ENDIF ELSE C...Gluons ICD=K(IP,4) IAD=K(IP,5) IF (ICD.NE.0) THEN C...Fictituous gluons just inherit from their quark daughters. ICC=MCT(ICD,1) IAC=MCT(IAD,2) ELSE C...Real beam remnant gluons get their own colours ICC=NCT+1 IAC=NCT+2 NCT=NCT+2 ENDIF MCT(IP,1)=ICC MCT(IP,2)=IAC ENDIF 330 CONTINUE 340 CONTINUE C...Create colour tags for colour lines which are detached from the C...initial state. DO 360 MQGST=1,2 DO 350 I=MINT(84)+1,N C...Look for coloured string endpoint, or (later) leftover gluon. IF (K(I,1).NE.3) GOTO 350 KC=PYCOMP(K(I,2)) IF(KC.EQ.0) GOTO 350 KQ=KCHG(KC,2) IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350 C...Pick up loose string end with no previous tag. KCS=4 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5 IF(MCT(I,KCS-3).NE.0) GOTO 350 CALL PYCTTR(I,KCS,I) IF(MINT(51).NE.0) RETURN 350 CONTINUE 360 CONTINUE C...Store original colour tags DO 370 I=MINT(84)+1,N MCO(I,1)=MCT(I,1) MCO(I,2)=MCT(I,2) 370 CONTINUE C...Iteratively add gluons to already existing string pieces, enforcing C...various possible orderings, and rejecting insertions that would give C...rise to singlet gluons. C... normalization. RM0=1.5D0 MRETRY=0 PARP80=PARP(80) C...Set up simplified kinematics. C...Boost hard interaction systems. IBOOST=IBOOST+1 DO 380 IM=1,MINT(31) BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM)) CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA) 380 CONTINUE C...Assign preliminary beam remnant momenta. DO 390 I=MINT(53)+1,N JS=K(I,3) P(I,1)=0D0 P(I,2)=0D0 IF (K(I,2).NE.88) THEN P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31)) P(I,3)=P(I,4) IF (JS.EQ.2) P(I,3)=-P(I,3) ELSE C...Junctions are wildcards for the present. P(I,4)=0D0 P(I,3)=0D0 ENDIF 390 CONTINUE C...Reset colour processing information. 400 DO 410 I=MINT(84)+1,N K(I,4)=MOD(K(I,4),MSTU(5)**2) K(I,5)=MOD(K(I,5),MSTU(5)**2) 410 CONTINUE NCC=0 DO 430 JS=1,2 C...If meson, without gluon in BR, collapse q-qbar colour tags: IF (ITJUNC(JS).EQ.0) THEN JC1=MCT(JST(JS,1),1) JC2=MCT(JST(JS,2),2) NCC=NCC+1 JCCO(NCC,1)=MAX(JC1,JC2) JCCO(NCC,2)=MIN(JC1,JC2) C...Collapse colour tags in event record DO 420 I=MINT(84)+1,N IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2) IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2) 420 CONTINUE ENDIF 430 CONTINUE 440 JS=1 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2 IF (NG(JS).GT.0) THEN NOPT=0 RLOPT=1D9 C...Start at random gluon (optimizes speed for random attachments) NMGL=0 IMGL=PYR(0)*NMI(JS)+1 450 IMGL=MOD(IMGL,NMI(JS))+1 NMGL=NMGL+1 C...Only loop through NMI once (with upper limit to save time) IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN IGL = IMI(JS,IMGL,1) C...If not gluon or if already connected, try next. IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450 C...Now loop through all possible insertions of this gluon. NMP1=0 IMP1=PYR(0)*NMI(JS)+1 460 IMP1=MOD(IMP1,NMI(JS))+1 NMP1=NMP1+1 IF (IMP1.EQ.IMGL) GOTO 460 C...Only loop through NMI once (with upper limit to save time). IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN IP1 = IMI(JS,IMP1,1) C...Try both colour mother and colour anti-mother. C...Randomly select which one to try first. NANTI=0 MANTI=PYR(0)*2 470 MANTI=MOD(MANTI+1,2) NANTI=NANTI+1 IF (NANTI.LE.2) THEN IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5)) C...Reject if no appropriate mother (or if mother is fictitious C...parent gluon.) IF (IP2.LE.0) GOTO 470 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470 C...Also reject if this link has already been tried. IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470 C...Set flag to indicate that this link has now been tried for this C...gluon. IP2 may be junction, which has several mothers. K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2 IF (K(IP2,2).NE.88) THEN K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2 ENDIF C...JCG1: Original colour tag of gluon on IP1 side C...JCG2: Original colour tag of gluon on IP2 side C...JCP1: Original colour tag of IP1 on gluon side C...JCP2: Original colour tag of IP2 on gluon side. JCG1=MCO(IGL,2-MANTI) JCG2=MCO(IGL,1+MANTI) JCP1=MCO(IP1,1+MANTI) JCP2=MCO(IP2,2-MANTI) CALL PYMIHG(JCP1,JCG1,JCP2,JCG2) C...Reject gluon attachments that give rise to singlet gluons. IF (MACCPT.EQ.0) GOTO 470 C...Update colours JCG1=MCT(IGL,2-MANTI) JCG2=MCT(IGL,1+MANTI) JCP1=MCT(IP1,1+MANTI) JCP2=MCT(IP2,2-MANTI) C...Select whether to accept this insertion IF (MSTP(89).EQ.0) THEN C...Random insertions: no measure. RL=1D0 C...For random ordering, we want to suppress beam remnant breakups C...already at this point. IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53) & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN NMP1=0 NMGL=0 GOTO 470 ENDIF ELSEIF (MSTP(89).EQ.1) THEN C...Rapidity ordering: C...YGL = Rapidity of gluon. YGL=YMI(IMGL) C...If fictitious gluon IF (YGL.EQ.100D0) THEN YGL=(3-2*JS)*100D0 IDA1=MOD(K(IGL,4),MSTU(5)) IDA2=MOD(K(IGL,5),MSTU(5)) DO 480 IMT=1,NMI(JS) C...Select (arbitrarily) the most central daughter. IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2) & THEN IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT) ENDIF 480 CONTINUE ENDIF C...YP1 = Rapidity IP1 YP1=YMI(IMP1) C...If fictitious gluon IF (YP1.EQ.100D0) THEN YP1=(3-2*JS)*YP1 IDA1=MOD(K(IP1,4),MSTU(5)) IDA2=MOD(K(IP1,5),MSTU(5)) DO 490 IMT=1,NMI(JS) C...Select (arbitrarily) the most central daughter. IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2) & THEN IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT) ENDIF 490 CONTINUE ENDIF C...YP2 = Rapidity of mother system IF (K(IP2,2).NE.88) THEN DO 500 IMT=1,NMI(JS) IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT) 500 CONTINUE C...If fictitious gluon IF (YP2.EQ.100D0) THEN YP2=(3-2*JS)*YP2 IDA1=MOD(K(IP2,4),MSTU(5)) IDA2=MOD(K(IP2,5),MSTU(5)) DO 510 IMT=1,NMI(JS) C...Select (arbitrarily) the most central daughter. IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2 & ) THEN IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT) ENDIF 510 CONTINUE ENDIF C...Assign (arbitrarily) 100D0 to junction also ELSE YP2=(3-2*JS)*100D0 ENDIF RL=ABS(YGL-YP1)+ABS(YGL-YP2) ELSEIF (MSTP(89).EQ.2) THEN C...Lambda ordering: C...Compute lambda measure for this insertion. RL=1D0 DO 520 IST=1,6 ISTR(IST)=0 520 CONTINUE C...If IP2 is junction, not caught below. IF (JCP2.EQ.0) THEN ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5)) C...Anti-junction is colour endpoint et vv., always on JCG2. ISTR(5-ITJU)=IP2 ENDIF DO 530 I=MINT(84)+1,N IF (K(I,1).LT.10) THEN C...The new string pieces IF (MCT(I,1).EQ.JCG1) ISTR(1)=I IF (MCT(I,2).EQ.JCG1) ISTR(2)=I IF (MCT(I,1).EQ.JCG2) ISTR(3)=I IF (MCT(I,2).EQ.JCG2) ISTR(4)=I ENDIF 530 CONTINUE C...Also identify junctions as string endpoints. DO 540 I=MINT(84)+1,N ICMO=MOD(K(I,4)/MSTU(5),MSTU(5)) IAMO=MOD(K(I,5)/MSTU(5),MSTU(5)) C...Find partons adjacent to junctions. IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2) & .EQ.0) ISTR(2) = ICMO IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1) & .EQ.0) ISTR(1) = IAMO IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4) & .EQ.0) ISTR(4) = ICMO IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3) & .EQ.0) ISTR(3) = IAMO 540 CONTINUE C...The old string piece ISTR(5)=ISTR(1+2*MANTI) ISTR(6)=ISTR(4-2*MANTI) RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3) & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6))) RL=LOG(RL) ENDIF C...Allow some breadth to speed things up. IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN NOPT=NOPT+1 ELSEIF (RL.GT.RLOPT) THEN GOTO 470 ELSE NOPT=1 RLOPT=RL ENDIF C...INSR(NOPT,1)=Gluon colour mother C...INSR(NOPT,2)=Gluon C...INSR(NOPT,3)=Gluon anticolour mother IF (NOPT.GT.1000) GOTO 470 INSR(NOPT,1+2*MANTI)=IP2 INSR(NOPT,2)=IGL INSR(NOPT,3-2*MANTI)=IP1 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470 ENDIF IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460 ENDIF C...Reset link test information. DO 550 I=MINT(84)+1,N K(I,4)=MOD(K(I,4),MSTU(5)**2) K(I,5)=MOD(K(I,5),MSTU(5)**2) 550 CONTINUE IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450 ENDIF C...Now we have a list of best gluon insertions, none of which cause C...singlets to arise. If list is empty, try again a few times. Note: C...this should never happen if we have a meson with a gluon inserted C...in the beam remnant, since that breaks up the colour line. IF (NOPT.EQ.0) THEN C...Abandon BR-g-BR suppression for retries. This is not serious, it C...just means we happened to start with trying a bad sequence. PARP80=1D0 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN MRETRY=MRETRY+1 DO 590 JS=1,2 IF (ITJUNC(JS).NE.0) THEN JST(JS,1)=IV(JS,1) JST(JS,2)=IV(JS,2) JST(JS,3)=IV(JS,3) C...Reset valence quark parent pointers DO 560 I=MINT(53)+1,N IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I 560 CONTINUE MANTI=ITJUNC(JS)-1 C...Set (anti)colour mother = junction. DO 570 JV=1,3 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5)) & +MSTU(5)*IJU 570 CONTINUE ELSE C...Same for mesons. JST unchanged, so needn't be restored. IQ=JST(JS,1) IQBAR=JST(JS,2) K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ ENDIF C...Also reset gluon parent pointers. NG(JS)=0 DO 580 IM=1,NMI(JS) I=IMI(JS,IM,1) IF (K(I,2).EQ.21) THEN K(I,4)=MOD(K(I,4),MSTU(5)) K(I,5)=MOD(K(I,5),MSTU(5)) NG(JS)=NG(JS)+1 ENDIF 580 CONTINUE 590 CONTINUE C...Reset colour tags DO 600 I=MINT(84)+1,N MCT(I,1)=MCO(I,1) MCT(I,2)=MCO(I,2) 600 CONTINUE GOTO 400 ELSE IF(NERRPR.LT.5) THEN NERRPR=NERRPR+1 CALL PYLIST(4) CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!') WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS) ENDIF C...Kill event and start another. MINT(51)=1 RETURN ENDIF ELSE C...Select between insertions, suppressing insertions wholly in the BR. IIN=PYR(0)*NOPT+1 610 IIN=MOD(IIN,NOPT)+1 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53) & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610 ENDIF C...Now we know which gluon to insert where. Colour tags in JCCO and C...colour connection information should be updated, NG(JS) should be C...counted down, and a new loop performed if there are still gluons C...left on any side. ICM=INSR(IIN,1) IACM=INSR(IIN,3) IGL=INSR(IIN,2) C...JCG : Original gluon colour tag C...JCAG: Original gluon anticolour tag. C...JCM : Original anticolour tag of gluon colour mother C...JACM: Original colour tag of gluon anticolour mother JCG=MCO(IGL,1) JCM=MCO(ICM,2) JACG=MCO(IGL,2) JACM=MCO(IACM,1) CALL PYMIHG(JACM,JACG,JCM,JCG) IF (MACCPT.EQ.0) THEN IF(NERRPR.LT.5) THEN NERRPR=NERRPR+1 CALL PYLIST(4) CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!') WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM ENDIF C...Kill event and start another. MINT(51)=1 RETURN ELSE C...If everything went fine, store new JCCN in JCCO. NCC=NCC+1 DO 620 ICC=1,NCC JCCO(ICC,1)=JCCN(ICC,1) JCCO(ICC,2)=JCCN(ICC,2) 620 CONTINUE ENDIF C...One gluon attached is counted as equivalent to one end outside. MOUT(JS)=1 C...Set IGL colour mother = ICM. K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM C...Set ICM anticolour mother = IGL colour. IF (K(ICM,2).NE.88) THEN K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL ELSE C...If ICM is junction, just update JST array for now. DO 630 MSJ=1,3 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL 630 CONTINUE ENDIF C...Set IGL anticolour mother = IACM. K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM C...Set IACM anticolour mother = IGL anticolour. IF (K(IACM,2).NE.88) THEN K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL ELSE C...If IACM is junction, just update JST array for now. DO 640 MSJ=1,3 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL 640 CONTINUE ENDIF C...Count down # unconnected gluons. NG(JS)=NG(JS)-1 ENDIF IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440 DO 840 JS=1,2 C...Collapse fictitious gluons. DO 670 IGL=MINT(53)+1,N IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND. & K(IGL,1).EQ.14) THEN ICM=K(IGL,4)/MSTU(5) IAM=K(IGL,5)/MSTU(5) ICD=MOD(K(IGL,4),MSTU(5)) IAD=MOD(K(IGL,5),MSTU(5)) C...Set gluon daughters pointing to gluon mothers K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM C...Set gluon mothers pointing to gluon daughters. IF (K(ICM,2).NE.88) THEN K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD ELSE C...Special case: mother=junction. Just update JST array for now. DO 650 MSJ=1,3 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD 650 CONTINUE ENDIF IF (K(IAM,2).NE.88) THEN K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD ELSE DO 660 MSJ=1,3 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD 660 CONTINUE ENDIF ENDIF 670 CONTINUE C...Erase collapsed gluons from NMI and IMI (but keep them in ER) IM=NMI(JS)+1 680 IM=IM-1 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680 IF (IM.GT.MINT(31)) THEN NMI(JS)=NMI(JS)-1 DO 690 IMR=IM,NMI(JS) IMI(JS,IMR,1)=IMI(JS,IMR+1,1) IMI(JS,IMR,2)=IMI(JS,IMR+1,2) 690 CONTINUE GOTO 680 ENDIF C...Finally, connect junction. IF (ITJUNC(JS).NE.0) THEN DO 700 I=MINT(53)+1,N IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I 700 CONTINUE C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR. NBRJQ =0 NBRVQ =0 DO 720 MSJ=1,3 IDQ(MSJ)=0 C...Find jq with no glue inbetween inside beam remnant. IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5) & THEN NBRJQ=NBRJQ+1 C...Set IDQ = -I if q non-valence and = +I if q valence. IDQ(NBRJQ)=-JST(JS,MSJ) DO 710 JV=1,3 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN IDQ(NBRJQ)=JST(JS,MSJ) NBRVQ=NBRVQ+1 ENDIF 710 CONTINUE ENDIF I12=MOD(MSJ+1,2) I45=5 IF (MSJ.EQ.3) I45=4 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ) 720 CONTINUE C...Check if diquark can be formed. IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88) & .GE.1)) THEN C...If there is less than 2 valence quarks connected to junction C...and MSTP(88)>1, use random non-valence quarks to fill up. IF (NBRVQ.LE.1) THEN NDIQ=NBRVQ 730 JFLIP=NBRJQ*PYR(0)+1 IF (IDQ(JFLIP).LT.0) THEN IDQ(JFLIP)=-IDQ(JFLIP) NDIQ=NDIQ+1 ENDIF IF (NDIQ.LE.1) GOTO 730 ENDIF C...Place selected quarks first in IDQ, ordered in flavour. DO 740 JDQ=1,3 IF (IDQ(JDQ).LE.0) THEN ITEMP1 = IDQ(JDQ) IDQ(JDQ)= IDQ(3) IDQ(3) = -ITEMP1 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN ITEMP1 = IDQ(1) IDQ(1) = IDQ(2) IDQ(2) = ITEMP1 ENDIF ENDIF 740 CONTINUE C...Choose diquark spin. IF (NBRVQ.EQ.2) THEN C...If the selected quarks are both valence, we may use SU(6) rules C...to figure out which spin the diquark has, by a subdivision of the C...original beam hadron into the selected diquark system plus a kicked C...out quark, IKO. JKO=6 DO 760 JDQ=1,2 DO 750 JV=1,3 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV 750 CONTINUE 760 CONTINUE IKO=IV(JS,JKO) CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ) ELSE C...If one or more of the selected quarks are not valence, we cannot use C...SU(6) subdivisions of the original beam hadron. Instead, with the C...flavours of the diquark already selected, we assume for now C...50:50 spin-1:spin-0 (where spin-0 possible). KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2) IS=3 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND. & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1 KFDQ=KFDQ+ISIGN(IS,KFDQ) ENDIF C...Collapse diquark-j-quark system to baryon, if allowed and possible. C...Note: third quark can per definition not also be valence, C...therefore we can only do this if we are allowed to use sea quarks. 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN NTRY=0 780 NTRY=NTRY+1 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR) IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN GOTO 780 ELSEIF(NTRY.GT.100) THEN C...If no baryon can be found, give up and form diquark. IDQ(3)=0 GOTO 770 ELSE C...Replace junction by baryon. K(IJU,1)=1 K(IJU,2)=KFBAR K(IJU,3)=MINT(83)+JS K(IJU,4)=0 K(IJU,5)=0 P(IJU,5)=PYMASS(KFBAR) DO 790 MSJ=1,3 C...Prepare removal of participating quarks from ER. K(JST(JS,MSJ),1)=-1 790 CONTINUE ENDIF ELSE C...If collapse to baryon not possible or not allowed, replace junction C...by diquark. This way, collapsed gluons that were pointing at the C...junction will now point (correctly) at diquark. MANTI=ITJUNC(JS)-1 K(IJU,1)=3 K(IJU,2)=KFDQ K(IJU,3)=MINT(83)+JS K(IJU,4)=0 K(IJU,5)=0 DO 800 MSJ=1,3 IP=JST(JS,MSJ) IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN K(IJU,4+MANTI)=0 K(IJU,5-MANTI)=IP*MSTU(5) K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+ & MSTU(5)*IJU MCT(IJU,2-MANTI)=MCT(IP,1+MANTI) ELSE C...Prepare removal of participating quarks from ER. K(IP,1)=-1 ENDIF 800 CONTINUE ENDIF C...Update so ER pointers to collapsed quarks C...now go to collapsed object. DO 820 I=MINT(84)+1,N IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND & .K(I,1).GT.0) THEN DO 810 ISID=4,5 IMO=K(I,ISID)/MSTU(5) IDA=MOD(K(I,ISID),MSTU(5)) IF (IMO.GT.0) THEN IF (K(IMO,1).EQ.-1) IMO=IJU ENDIF IF (IDA.GT.0) THEN IF (K(IDA,1).EQ.-1) IDA=IJU ENDIF K(I,ISID)=IDA+MSTU(5)*IMO 810 CONTINUE ENDIF 820 CONTINUE ENDIF ENDIF C...Finally, if beam remnant is empty, insert a gluon in beam remnant. C...(this only happens for baryons, where we want to force the gluon C...to sit next to the junction. Mesons handled above.) IF (NBRTOT(JS).EQ.0) THEN N=N+1 DO 830 IX=1,5 K(N,IX)=0 P(N,IX)=0D0 V(N,IX)=0D0 830 CONTINUE IGL=N K(IGL,1)=3 K(IGL,2)=21 K(IGL,3)=MINT(83)+JS IF (ITJUNC(JS).NE.0) THEN C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons) JLEG=PYR(0)*NVSUM(JS)+1 I1=JST(JS,JLEG) JST(JS,JLEG)=IGL JCT=MCT(I1,ITJUNC(JS)) MCT(IGL,3-ITJUNC(JS))=JCT NCT=NCT+1 MCT(IGL,ITJUNC(JS))=NCT MANTI=ITJUNC(JS)-1 ELSE C...Meson. Should not happen. CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant') IF(NERRPR.LT.5) THEN WRITE(MSTU(11),*) 'This should not have been possible!' CALL PYLIST(4) NERRPR=NERRPR+1 ENDIF MINT(51)=1 RETURN ENDIF I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5)) K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2 IF (K(I2,2).NE.88) THEN K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL ELSE IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL ELSE K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL ENDIF ENDIF ENDIF 840 CONTINUE C...Remove collapsed quarks and junctions from ER and update IMI. CALL PYEDIT(11) C...Also update beam remnant part of IMI. NMI(1)=MINT(31) NMI(2)=MINT(31) DO 850 I=MINT(53)+1,N IF (K(I,1).LE.0) GOTO 850 C...Restore BR quark/diquark/baryon pointers in IMI. IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN JS=K(I,3)-MINT(83) NMI(JS)=NMI(JS)+1 IMI(JS,NMI(JS),1)=I IMI(JS,NMI(JS),2)=0 ENDIF 850 CONTINUE C...Restore companion information from collapsed gluons. DO 870 I=MINT(53)+1,N IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN JS=K(I,3)-MINT(83) JCD=MOD(K(I,4),MSTU(5)) JAD=MOD(K(I,5),MSTU(5)) DO 860 IM=1,NMI(JS) IF (IMI(JS,IM,1).EQ.JCD) IMC=IM IF (IMI(JS,IM,1).EQ.JAD) IMA=IM 860 CONTINUE IMI(JS,IMC,2)=IMI(JS,IMA,1) IMI(JS,IMA,2)=IMI(JS,IMC,1) ENDIF 870 CONTINUE C...Renumber colour lines (since some have disappeared) JCT=0 JCD=0 880 JCT=JCT+1 MFOUND=0 I=MINT(84) 890 I=I+1 IF (I.EQ.N+1) THEN IF (MFOUND.EQ.0) JCD=JCD+1 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN MCT(I,1)=JCT-JCD MFOUND=1 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN MCT(I,2)=JCT-JCD MFOUND=1 ENDIF IF (I.LE.N) GOTO 890 IF (JCT.LT.NCT) GOTO 880 NCT=JCT-JCD C...Reset hard interaction subsystems to their CM frames. IF (IBOOST.EQ.1) THEN DO 900 IM=1,MINT(31) BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM)) CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA) 900 CONTINUE C...Zero beam remnant longitudinal momenta and energies DO 910 I=MINT(53)+1,N P(I,3)=0D0 P(I,4)=0D0 910 CONTINUE ELSE CALL PYERRM(9 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.') C...Kill event and start another. MINT(51)=1 RETURN ENDIF 9999 RETURN END C********************************************************************* C...PYCTTR C...Adapted from PYPREP. C...Assigns LHA1 colour tags to coloured partons based on C...K(I,4) and K(I,5) colour connection record. C...KCS negative signifies that a previous tracing should be continued. C...(in case the tag to be continued is empty, the routine exits) C...Starts at I and ends at I or IEND. C...Special considerations for systems with junctions. SUBROUTINE PYCTTR(I,KCS,IEND) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYINT1/MINT(400),VINT(400) C...The common block of colour tags. COMMON/PYCTAG/NCT,MCT(4000,2) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/ DATA NERRPR/0/ SAVE NERRPR C...Skip if KCS not existing for this parton KQ=KCHG(PYCOMP(K(I,2)),2) IF (KQ.EQ.0) GOTO 120 IF (IABS(KQ).EQ.1.AND.(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2))) GOTO 120 IF (KCS.GT.0) THEN NCT=NCT+1 C...Set colour tag of first parton. MCT(I,KCS-3)=NCT NCS=NCT ELSE KCS=-KCS NCS=MCT(I,KCS-3) IF (NCS.EQ.0) GOTO 120 ENDIF IA=I NSTP=0 100 NSTP=NSTP+1 IF(NSTP.GT.4*N) THEN CALL PYERRM(14,'(PYCTTR:) caught in infinite loop') RETURN ENDIF C...Finished if reached final-state triplet. IF(K(IA,1).EQ.3) THEN IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120 ENDIF C...Also finished if reached junction. IF(K(IA,1).EQ.42) THEN GOTO 120 ENDIF C...GOTO next parton in colour space. 110 IB=IA C...If IB's KCS daughter not traced and exists, goto KCS daughter. IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5)) & .NE.0) THEN IA=MOD(K(IB,KCS),MSTU(5)) K(IB,KCS)=K(IB,KCS)+MSTU(5)**2 MREV=0 ELSE C...If KCS mother traced or KCS mother nonexistent, switch colour. IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5), & MSTU(5)).EQ.0) THEN KCS=9-KCS NCT=NCT+1 NCS=NCT C...Assign new colour tag on other side of old parton. MCT(IB,KCS-3)=NCT ENDIF C...Goto (new) KCS mother, set mother traced tag IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5)) K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2 MREV=1 ENDIF IF(IA.LE.0.OR.IA.GT.N) THEN CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed') IF(NERRPR.LT.5) THEN write(*,*) 'began at ',I write(*,*) 'ended going from', IB, ' to', IA CALL PYLIST(4) NERRPR=NERRPR+1 ENDIF MINT(51)=1 RETURN ENDIF IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5), & MSTU(5)).EQ.IB) THEN IF(MREV.EQ.1) KCS=9-KCS IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS C...Set KSC mother traced tag for IA K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2 ELSE IF(MREV.EQ.0) KCS=9-KCS IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS C...Set KCS daughter traced tag for IA K(IA,KCS)=K(IA,KCS)+MSTU(5)**2 ENDIF C...Assign new colour tag MCT(IA,KCS-3)=NCS IF(IA.NE.I.AND.IA.NE.IEND) GOTO 100 120 RETURN END ********************************************************************* C...PYMIHG C...Collapse JCP1 and connecting tags to JCG1. C...Collapse JCP2 and connecting tags to JCG2. SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...The event record COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) C...Parameters COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYINT1/ C...Local variables COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT COMMON /PYCTAG/NCT,MCT(4000,2) SAVE /PYCBLS/,/PYCTAG/ C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags C...in temporary tag collapse array JCCN. Only break up one connection. MACCPT=1 MCLPS=0 DO 100 ICC=1,NCC JCCN(ICC,1)=JCCO(ICC,1) JCCN(ICC,2)=JCCO(ICC,2) C...If there was a mother, it was previously connected to JCP1. C...Should be changed to JCP2. IF (MCLPS.EQ.0) THEN IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1 & ,JCP2)) THEN JCCN(ICC,1)=MAX(JCG2,JCP2) JCCN(ICC,2)=MIN(JCG2,JCP2) MCLPS=1 ENDIF ENDIF 100 CONTINUE C...Also collapse colours on JCP1 side of JCG1 IF (JCP1.NE.0) THEN JCCN(NCC+1,1)=MAX(JCP1,JCG1) JCCN(NCC+1,2)=MIN(JCP1,JCG1) ELSE JCCN(NCC+1,1)=MAX(JCP2,JCG2) JCCN(NCC+1,2)=MIN(JCP2,JCG2) ENDIF C...Initialize event record colour tag array MCT array to MCO. DO 110 I=MINT(84)+1,N MCT(I,1)=MCO(I,1) MCT(I,2)=MCO(I,2) 110 CONTINUE C...Collapse tags: C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1 C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2 C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1 C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2 DO 160 IS=1,4 C...Skip if junction. IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160 C...Define starting point in tag space. C...JCA = previous tag C...JCO = present tag C...JCN = new tag IF (MOD(IS,2).EQ.1) THEN JCO=JCP1 JCN=JCG1 JCALL=JCG1 ELSEIF (MOD(IS,2).EQ.0) THEN JCO=JCP2 JCN=JCG2 JCALL=JCG2 ENDIF ITRACE=0 120 ITRACE=ITRACE+1 IF (ITRACE.GT.1000) THEN C...NB: Proper error message should be defined here. CALL PYERRM(14 & ,'(PYMIHG:) Inf loop when collapsing colours.') MINT(57)=MINT(57)+1 MINT(51)=1 RETURN ENDIF C...Collapse all JCN tags to JCALL DO 130 I=MINT(84)+1,N IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL 130 CONTINUE C...IS = 1,2: first step forward. IS = 3,4: first step backward. IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN JCA=JCN JCN=JCO ELSE JCA=JCO JCO=JCN ENDIF C...If possible, step from JCO to new tag JCN not equal to JCA. DO 140 ICC=1,NCC+1 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN= & JCCN(ICC,2) IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN= & JCCN(ICC,1) 140 CONTINUE C...Iterate if new colour was arrived at, but don't go in circles. IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120 C...Change all JCN tags in MCO to JCALL in MCT. DO 150 I=MINT(84)+1,N IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL C...If gluon and colour tag = anticolour tag (and not = 0) try again. IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1) & .NE.0) MACCPT=0 150 CONTINUE 160 CONTINUE DO 200 JCL=NCT,1,-1 JCA=0 JCN=JCL 170 JCO=JCN DO 180 ICC=1,NCC+1 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN & =JCCN(ICC,2) IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN & =JCCN(ICC,1) 180 CONTINUE C...Overpaint all JCN with JCL IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN DO 190 I=MINT(84)+1,N IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL C...If gluon and colour tag = anticolour tag (and not = 0) try again. IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1) & .NE.0) MACCPT=0 190 CONTINUE JCA=JCO GOTO 170 ENDIF 200 CONTINUE RETURN END C********************************************************************* C...PYMIRM C...Picks primordial kT and shares longitudinal momentum among C...beam remnants. SUBROUTINE PYMIRM C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...The event record COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) C...Parameters COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) C...The common block of colour tags. COMMON/PYCTAG/NCT,MCT(4000,2) C...The common block of dangling ends COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), & XMI(2,240),PT2MI(240),IMISEP(0:240) SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/ C...Local variables DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2) C...W(I,J)| J=0 | 1 | 2 | C... I=0 | Wrem**2 | W+ | W- | C... 1 | W1**2 | W1+ | W1- | C... 2 | W2**2 | W2+ | W2- | C...4-product FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) C...Tentative parametrization of as a function of Q. SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q)) C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q)) C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q)) GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93)) C...Lambda kinematic function. FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A) C...Beginning and end of beam remnant partons NOUT=MINT(53) ISUB=MINT(1) C...Loopback point if kinematic choices gives impossible configuration. NTRY=0 100 NTRY=NTRY+1 C...Assign kT values on each side separately. DO 180 JS=1,2 C...First zero all kT on this side. Skip if no kT to generate. DO 110 IM=1,NMI(JS) P(IMI(JS,IM,1),1)=0D0 P(IMI(JS,IM,1),2)=0D0 110 CONTINUE IF(MSTP(91).LE.0) GOTO 180 C...Now assign kT to each (non-collapsed) parton in IMI. DO 170 IM=1,NMI(JS) I=IMI(JS,IM,1) C...Select kT according to truncated gaussian or 1/kt6 tails. C...For first interaction, either use rms width = PARP(91) or fitted. IF (IM.EQ.1) THEN SIGMA=PARP(91) IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN Q=SQRT(PT2MI(IM)) SIGMA=SIGPT(Q) ENDIF ELSE C...For subsequent interactions and BR partons use fragmentation width. SIGMA=PARJ(21) ENDIF PHI=PARU(2)*PYR(0) PT=0D0 IF(NTRY.LE.100) THEN 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN PT=GETPT(Q,SIGMA) PTX=PT*COS(PHI) PTY=PT*SIN(PHI) ELSEIF (MSTP(91).EQ.2) THEN CALL PYERRM(11,'(PYMIRM:) Sorry, MSTP(91)=2 not '// & 'available, using MSTP(91)=1.') CALL PYGIVE('MSTP(91)=1') GOTO 111 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN C...Use distribution with kt**6 tails, rms width = PARP(91). EPS=SQRT(3D0/2D0)*SIGMA C...Generate PTX and PTY separately, each propto 1/KT**6 DO 119 IXY=1,2 C...Decide which interval to try 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6) IF (PYR(0).LT.P12) THEN C...Use flat approx with accept/reject up to EPS. PT=PYR(0)*EPS WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3 IF (PYR(0).GT.WT) GOTO 112 ELSE C...Above EPS, use 1/kt**6 approx with accept/reject. PT=EPS/(PYR(0)**(1D0/5D0)) WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3 IF (PYR(0).GT.WT) GOTO 112 ENDIF MSIGN=1 IF (PYR(0).GT.0.5D0) MSIGN=-1 IF (IXY.EQ.1) PTX=MSIGN*PT IF (IXY.EQ.2) PTY=MSIGN*PT 119 CONTINUE ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0)) PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0)) ENDIF C...Adjust final PT. Impose upper cutoff, or zero for soft evts. PT=SQRT(PTX**2+PTY**2) WT=1D0 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT) IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0 PTX=PTX*WT PTY=PTY*WT PT=SQRT(PTX**2+PTY**2) ENDIF P(I,1)=P(I,1)+PTX P(I,2)=P(I,2)+PTY C...Compensation kicks, with varying degree of local anticorrelations. MCORR=MSTP(90) IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN PTCX=-PTX/(NMI(JS)-1) PTCY=-PTY/(NMI(JS)-1) IF(ISUB.EQ.95) THEN PTCX=-PTX/(NMI(JS)-2) PTCY=-PTY/(NMI(JS)-2) ENDIF DO 120 IMC=1,NMI(JS) IF (IMC.EQ.IM) GOTO 120 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY 120 CONTINUE ELSEIF (MCORR.GE.1) THEN DO 140 MSID=4,5 NNXT(MSID-3)=0 C...Count up # of neighbours on either side IMO=I 130 IMO=K(IMO,MSID)/MSTU(5) IF (IMO.EQ.0) GOTO 140 NNXT(MSID-3)=NNXT(MSID-3)+1 C...Stop at quarks and junctions IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130 140 CONTINUE C...How should compensation be shared when unequal numbers on the C...two sides? 50/50 regardless? N1:N2? Assume latter for now. NSUM=NNXT(1)+NNXT(2) T1=0 DO 160 MSID=4,5 C...Total momentum to be compensated on this side IF (NNXT(MSID-3).EQ.0) GOTO 160 PTCX=-(NNXT(MSID-3)*PTX)/NSUM PTCY=-(NNXT(MSID-3)*PTY)/NSUM C...RS: compensation supression factor as we go out from parton I. C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff, C...since (for now) MSTP(90) provides enough variability. RS=0.5D0 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3))) IMO=I 150 IDA=IMO IMO=K(IMO,MSID)/MSTU(5) IF (IMO.EQ.0) GOTO 160 FAC=FAC*RS IF (K(IMO,2).NE.88) THEN P(IMO,1)=P(IMO,1)+FAC*PTCX P(IMO,2)=P(IMO,2)+FAC*PTCY IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150 C...If we reach junction, divide out the kT that would have been C...assigned to the junction on each of its other legs. ELSE L1=MOD(K(IMO,4),MSTU(5)) L2=K(IMO,5)/MSTU(5) L3=MOD(K(IMO,5),MSTU(5)) P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY ENDIF 160 CONTINUE ENDIF 170 CONTINUE C...End assignment of kT values to initiators and remnants. 180 CONTINUE C...Check kinematics constraints for non-BR partons. DO 190 IM=1,MINT(31) SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2) PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2) PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2) PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1) & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2) IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN IF(NTRY.GE.100) THEN C...Kill this event and start another. CALL PYERRM(11, & '(PYMIRM:) No consistent (x,kT) sets found') MINT(51)=1 RETURN ENDIF GOTO 100 ENDIF 190 CONTINUE C...Calculate W+ and W- available for combined remnant system. W(0,1)=VINT(1) W(0,2)=VINT(1) DO 200 IM=1,MINT(31) PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST) W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST) 200 CONTINUE C...Also store Wrem**2 = W+ * W- W(0,0)=W(0,1)*W(0,2) IF (W(0,0).LT.0D0.AND.NTRY.LE.100) THEN IF(NTRY.GE.100) THEN C...Kill this event and start another. CALL PYERRM(11, & '(PYMIRM:) Negative beam remnant mass squared unavoidable') MINT(51)=1 RETURN ENDIF GOTO 100 ENDIF C...Assign unscaled x values to partons/hadrons in each of the C...beam remnants and calculate unscaled W+ and W- from them. NTRYX=0 210 NTRYX=NTRYX+1 DO 280 JS=1,2 W(JS,1)=0D0 W(JS,2)=0D0 DO 270 IM=MINT(31)+1,NMI(JS) I=IMI(JS,IM,1) KF=K(I,2) KFA=IABS(KF) ICOMP=IMI(JS,IM,2) C...Skip collapsed gluons and junctions. Reset. IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270 IF (KFA.EQ.88) GOTO 270 X=0D0 IVALQ(1)=0 IVALQ(2)=0 ICOMQ(1)=0 ICOMQ(2)=0 C...If gluon then only beam remnant, so takes all. IF(KFA.EQ.21) THEN X=1D0 C...If valence quark then use parametrized valence distribution. ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN IVALQ(1)=KF C...If companion quark then derive from companion x. ELSEIF(KFA.LE.6) THEN ICOMQ(1)=ICOMP C...If valence diquark then use two parametrized valence distributions. ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND. & ICOMP.EQ.0) THEN IVALQ(1)=ISIGN(KFA/1000,KF) IVALQ(2)=ISIGN(MOD(KFA/100,10),KF) C...If valence+sea diquark then combine valence + companion choices. ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND. & ICOMP.LT.MSTU(5)) THEN IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN IVALQ(1)=ISIGN(MOD(KFA/100,10),KF) ELSE IVALQ(1)=ISIGN(KFA/1000,KF) ENDIF ICOMQ(1)=ICOMP C...Extra code: workaround for diquark made out of two sea C...quarks, but where not (yet) ICOMP > MSTU(5). DO 220 IM1=1,MINT(31) IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN ICOMQ(2)=IMI(JS,IM1,1) IVALQ(1)=0 ENDIF 220 CONTINUE C...If sea diquark then sum of two derived from companion x. ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN ICOMQ(1)=MOD(ICOMP,MSTU(5)) ICOMQ(2)=ICOMP/MSTU(5) C...If meson or baryon then use fragmentation function. C...Somewhat arbitrary split into old and new flavour, but OK normally. ELSE KFL3=MOD(KFA/10,10) IF(MOD(KFA/1000,10).EQ.0) THEN KFL1=MOD(KFA/100,10) ELSE KFL1=MOD(KFA,10000)-10*KFL3-1 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND. & MOD(KFA,10).EQ.2) KFL1=KFL1+2 ENDIF PR=P(I,5)**2+P(I,1)**2+P(I,2)**2 CALL PYZDIS(KFL1,KFL3,PR,X) ENDIF DO 260 IQ=1,2 C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x), C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson. C...In other baryons combine u and d from proton appropriately. IF(IVALQ(IQ).NE.0) THEN NVAL=0 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1 C...Meson. IF(KFIVAL(JS,3).EQ.0) THEN MDU=0 C...Baryon with three identical quarks: mix u and d forms. ELSEIF(NVAL.EQ.3) THEN MDU=INT(PYR(0)+5D0/3D0) C...Baryon, one of two identical quarks: u form. ELSEIF(NVAL.EQ.2) THEN MDU=2 C...Baryon with two identical quarks, but not the one picked: d form. ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ. & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN MDU=1 C...Baryon with three nonidentical quarks: mix u and d forms. ELSE MDU=INT(PYR(0)+5D0/3D0) ENDIF XPOW=0.8D0 IF(MDU.EQ.1) XPOW=3.5D0 IF(MDU.EQ.2) XPOW=2D0 230 XX=PYR(0)**2 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230 X=X+XX ENDIF C...Calculation of x of companion quark. IF(ICOMQ(IQ).NE.0) THEN XCOMP=1D-4 DO 240 IM1=1,MINT(31) IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1) 240 CONTINUE NPOW=MAX(0,MIN(4,MSTP(87))) 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0) CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW* & (XCOMP**2+XX**2)/(XCOMP+XX)**2 IF(CORR.LT.PYR(0)) GOTO 250 X=X+XX ENDIF 260 CONTINUE C...Optionally enchance x of composite systems (e.g. diquarks) IF (KFA.GT.100) X=PARP(79)*X C...Store x. Also calculate light cone energies of each system. XMI(JS,IM)=X W(JS,JS)=W(JS,JS)+X W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X 270 CONTINUE W(JS,JS)=W(JS,JS)*W(0,JS) W(JS,3-JS)=W(JS,3-JS)/W(0,JS) W(JS,0)=W(JS,1)*W(JS,2) 280 CONTINUE C...Check W1 W2 < Wrem (can be done before rescaling, since W C...insensitive to global rescalings of the BR x values). IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100) & THEN GOTO 210 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN GOTO 100 ELSEIF (NTRYX.GT.100) THEN CALL PYERRM(11,'(PYMIRM:) No consistent (x,kT) sets found') MINT(57)=MINT(57)+1 MINT(51)=1 RETURN ENDIF C...Compute x rescaling factors COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0))) R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2)) R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1)) IF (R1.LT.0.OR.R2.LT.0) THEN CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !') MINT(57)=MINT(57)+1 MINT(51)=1 ENDIF C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent). W(1,1)=W(1,1)*R1 W(1,2)=W(1,2)/R1 W(2,1)=W(2,1)/R2 W(2,2)=W(2,2)*R2 C...Rescale BR x values. DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2)) XMI(1,IM)=XMI(1,IM)*R1 XMI(2,IM)=XMI(2,IM)*R2 290 CONTINUE C...Now we have a consistent set of x and kT values. C...First set up the initiators and their daughters correctly. DO 300 IM=1,MINT(31) I1=IMI(1,IM,1) I2=IMI(2,IM,1) ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+ & (P(I1,2)+P(I2,2))**2 PT12=P(I1,1)**2+P(I1,2)**2 PT22=P(I2,1)**2+P(I2,2)**2 C...p_z P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST)) P(I2,3)=-P(I1,3) C...Energies (masses should be zero at this stage) P(I1,4)=SQRT(PT12+P(I1,3)**2) P(I2,4)=SQRT(PT22+P(I2,3)**2) C...Transverse 12 system initiator velocity: VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST) VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST) C...Boost to overall initiator system rest frame CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0) CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0) C...Compute phi,theta coordinates of I1 and rotate z axis. PHI=PYANGL(P(I1,1),P(I1,2)) THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2)) CALL PYROBO(I1,I1,0D0,-PHI,0D0,0D0,0D0) CALL PYROBO(I2,I2,0D0,-PHI,0D0,0D0,0D0) CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0) CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0) C...Now boost initiators + daughters back to LAB system C...(also update documentation lines for MI = 1.) VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM)) IMIN=IMISEP(IM-1)+1 IF (IM.EQ.1) IMIN=MINT(83)+5 IMAX=IMISEP(IM) CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0) CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3)) 300 CONTINUE C...For the beam remnant partons/hadrons, we only need to set pz and E. DO 320 JS=1,2 DO 310 IM=MINT(31)+1,NMI(JS) I=IMI(JS,IM,1) C...Skip collapsed gluons and junctions. IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310 IF (KFA.EQ.88) GOTO 310 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS))) P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS))) IF (JS.EQ.2) P(I,3)=-P(I,3) 310 CONTINUE 320 CONTINUE C...Documentation lines DO 340 JS=1,2 IN=MINT(83)+JS+2 IO=IMI(JS,1,1) K(IN,1)=21 K(IN,2)=K(IO,2) K(IN,3)=MINT(83)+JS K(IN,4)=0 K(IN,5)=0 DO 330 J=1,5 P(IN,J)=P(IO,J) V(IN,J)=V(IO,J) 330 CONTINUE MCT(IN,1)=MCT(IO,1) MCT(IN,2)=MCT(IO,2) 340 CONTINUE C...Final state colour reconnections. IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380 C...Number of colour tags for which a recoupling will be tried. NTOT=NCT C...Number of recouplings to try MINT(34)=0 NRECP=0 NITER=0 350 NRECP=MINT(34) NITER=NITER+1 IITER=0 360 IITER=IITER+1 IF (IITER.LE.PARP(78)*NTOT) THEN C...Select two colour tags at random C...NB: jj strings do not have colour tags assigned to them, C...thus they are as yet not affected by anything done here. JCT=PYR(0)*NCT+1 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1 IJ1=0 IJ2=0 IK1=0 IK2=0 C...Find final state partons with this (anti)colour DO 370 I=MINT(84)+1,N IF (K(I,1).EQ.3) THEN IF (MCT(I,1).EQ.JCT) IJ1=I IF (MCT(I,2).EQ.JCT) IJ2=I IF (MCT(I,1).EQ.KCT) IK1=I IF (MCT(I,2).EQ.KCT) IK2=I ENDIF 370 CONTINUE C...Only consider recouplings not involving junctions for now. IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2) RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2) IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN MCT(IJ2,2)=KCT MCT(IK2,2)=JCT C...Count up number of reconnections MINT(34)=MINT(34)+1 ENDIF IF (MINT(34).LE.1000) THEN GOTO 360 ELSE CALL PYERRM(4,'(PYMIRM:) caught in infinite loop') GOTO 380 ENDIF ENDIF IF (NRECP.LT.MINT(34)) GOTO 350 C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS). 380 MINT(33)=1 RETURN END C********************************************************************* C...PYFSCR C...Performs colour annealing. 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...Local variables 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) IF (MSTP(95).LE.1.OR.MSTP(95).GE.6) RETURN C...Only works with colour tags. IF (MINT(33).EQ.0) GOTO 9999 C...For MSTP(95)=2 or 4, only apply to hadron-hadron IF (MSTP(95).EQ.2.OR.MSTP(05).EQ.4) 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 100 I=MAX(1,IP),N MCN(I,1)=0 MCN(I,2)=0 100 CONTINUE C...Loop over event record, starting from IP C...(Ignore junctions for now.) NLOOP=0 150 NLOOP=NLOOP+1 MCIMAX=0 MCJMAX=0 RLMAX=0D0 ILMAX=0 JLMAX=0 DO 500 I=MAX(1,IP),N IF (K(I,1).NE.3) GOTO 500 C...Check colour charge MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2)) IF (MCI.EQ.0) GOTO 500 C... Find optimal partner JLOPT=0 MCJOPT=0 MBROPT=0 MGGOPT=0 RLOPT=1D19 C...Loop over I colour/anticolour, check whether already connected 180 DO 400 ICL=1,2 IF (MCN(I,ICL).NE.0) GOTO 400 IF (ICL.EQ.1.AND.MCI.EQ.-1) GOTO 400 IF (ICL.EQ.2.AND.MCI.EQ.1) GOTO 400 C...Check whether this is a dangling colour tag (ie to junction!) IFOUND=0 DO 190 J=MAX(1,IP),N IF (K(J,1).EQ.3.AND.MCT(J,3-ICL).EQ.MCT(I,ICL)) IFOUND=1 190 CONTINUE IF (IFOUND.EQ.0) GOTO 400 DO 300 J=MAX(1,IP),N IF (K(J,1).NE.3.OR.I.EQ.J) GOTO 300 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 300 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) & 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 195 J2=MAX(1,IP),N IF (K(J2,1).EQ.3.AND.MCT(J2,3-JCL).EQ.MCT(J,JCL)) & IFOUND=1 195 CONTINUE IF (IFOUND.EQ.0) GOTO 200 C...Save connection with smallest lambda measure 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 300 CONTINUE 400 CONTINUE IF (JLOPT.NE.0) THEN C...Prioritize glue-glue over glue-quark over quark-quark C IF (MCIMAX.NE.2.AND.MCJMAX.NE.2) THEN C IF (MCI.EQ.2.OR.MCJOPT.EQ.2) RLOPT=MAX(1.1D0*RLMAX,RLOPT) C ELSEIF (MCIMAX.NE.2.OR.MCJMAX.NE.2) THEN C IF(MCI.EQ.2.AND.MCJOPT.EQ.2) RLOPT=MAX(1.1D0*RLMAX,RLOPT) C ELSEIF (MCIMAX.EQ.2.AND.MCJMAX.EQ.2) THEN C IF (MCI.NE.2.OR.MCJOPT.NE.2) RLOPT=0D0 C ENDIF 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 500 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 150 ELSE PRINT*, 'infinite loop!' STOP ENDIF ELSE C...Save and exit. First check for leftover gluon DO 600 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 600 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 480 KCT=NCT+1,LCT DO 470 IT=MAX(1,IP),N IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 470 IF (MCN(IT,1).EQ.KCT) IC=IT IF (MCN(IT,2).EQ.KCT) IA=IT 470 CONTINUE RL=FOUR(IC,I)*FOUR(IA,I) IF (RL.LT.RLMAX) THEN RLMAX=RL ICMAX=IC IAMAX=IA ENDIF 480 CONTINUE LCT=LCT+1 MCN(I,1)=MCN(ICMAX,1) MCN(I,2)=LCT MCN(ICMAX,1)=LCT ENDIF 600 CONTINUE DO 800 I=MAX(1,IP),N C...Do not erase parton shower colour history IF (K(I,1).NE.3) GOTO 800 C...Check colour charge MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2)) IF (MCI.EQ.0) GOTO 800 IF (MCN(I,1).NE.0) MCT(I,1)=MCN(I,1) IF (MCN(I,2).NE.0) MCT(I,2)=MCN(I,2) 800 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(31)=VINT(141) PARI(32)=VINT(142) PARI(33)=VINT(41) PARI(34)=VINT(42) PARI(35)=PARI(33)-PARI(34) PARI(36)=VINT(21) PARI(37)=VINT(22) PARI(38)=VINT(26) PARI(39)=VINT(157) PARI(40)=VINT(158) PARI(41)=VINT(23) PARI(42)=2D0*VINT(47)/VINT(1) ENDIF C...Store information on scattered partons in PARI. IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN DO 140 IS=7,8 I=MINT(IS) PARI(36+IS)=P(I,3)/VINT(1) PARI(38+IS)=P(I,4)/VINT(1) PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2) PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/ & SQRT(PR),1D20)),P(I,3)) PR=MAX(1D-20,P(I,1)**2+P(I,2)**2) PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/ & SQRT(PR),1D20)),P(I,3)) PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2) PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2)) PARI(48+IS)=PYANGL(P(I,1),P(I,2)) 140 CONTINUE ENDIF C...Store sum up transverse and longitudinal momenta. PARI(65)=2D0*PARI(17) IF(ISUB.LE.90.OR.ISUB.GE.95) THEN DO 150 I=MSTP(126)+1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150 PT=SQRT(P(I,1)**2+P(I,2)**2) PARI(69)=PARI(69)+PT IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT 150 CONTINUE PARI(67)=PARI(68) PARI(71)=VINT(151) PARI(72)=VINT(152) PARI(73)=VINT(151) PARI(74)=VINT(152) ELSE PARI(66)=PARI(65) PARI(69)=PARI(65) ENDIF C...Store various other pieces of information into PARI. PARI(61)=VINT(148) PARI(75)=VINT(155) PARI(76)=VINT(156) PARI(77)=VINT(159) PARI(78)=VINT(160) PARI(81)=VINT(138) C...Store information on lepton -> lepton + gamma in PYGAGA. MSTI(71)=MINT(141) MSTI(72)=MINT(142) PARI(101)=VINT(301) PARI(102)=VINT(302) DO 160 I=103,114 PARI(I)=VINT(I+202) 160 CONTINUE C...Set information for PYTABU. IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN MSTU(161)=MINT(21) MSTU(162)=0 ELSEIF(ISET(ISUB).EQ.5) THEN MSTU(161)=MINT(23) MSTU(162)=0 ELSE MSTU(161)=MINT(21) MSTU(162)=MINT(22) ENDIF RETURN END C********************************************************************* C...PYFRAM C...Performs transformations between different coordinate frames. SUBROUTINE PYFRAM(IFRAME) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYDAT1/,/PYPARS/,/PYINT1/ C...Check that transformation can and should be done. IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND. &MINT(91).EQ.1)) THEN IF(IFRAME.EQ.MINT(6)) RETURN ELSE WRITE(MSTU(11),5000) IFRAME,MINT(6) RETURN ENDIF IF(MINT(6).EQ.1) THEN C...Transform from fixed target or user specified frame to C...overall CM frame. CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) ELSEIF(MINT(6).EQ.3) THEN C...Transform from hadronic CM frame in DIS to overall CM frame. CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224), & -VINT(225)) ENDIF IF(IFRAME.EQ.1) THEN C...Transform from overall CM frame to fixed target or user specified C...frame. CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10)) ELSEIF(IFRAME.EQ.3) THEN C...Transform from overall CM frame to hadronic CM frame in DIS. CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225)) CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0) CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0) ENDIF C...Set information about new frame. MINT(6)=IFRAME MSTI(6)=IFRAME 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X, &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =', &1X,I5) RETURN END C********************************************************************* C...PYWIDT C...Calculates full and partial widths of resonances. SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/ C...Local arrays and saved variables. COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2), &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5) SAVE MOFSV,WIDWSV,WID2SV DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/ C...Compressed code and sign; mass. KFLA=IABS(KFLR) KFLS=ISIGN(1,KFLR) KC=PYCOMP(KFLA) SHR=SQRT(SH) PMR=PMAS(KC,1) C...Reset width information. DO 110 I=0,MDCY(KC,3) WDTP(I)=0D0 DO 100 J=0,5 WDTE(I,J)=0D0 100 CONTINUE 110 CONTINUE C...Allow for fudge factor to rescale resonance width. FUDGE=1D0 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR. &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN IF(MSTP(110).EQ.KFLA) THEN FUDGE=PARP(110) ELSEIF(MSTP(110).EQ.-1) THEN IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110) ELSEIF(MSTP(110).EQ.-2) THEN FUDGE=PARP(110) ENDIF ENDIF C...Not to be treated as a resonance: return. IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND. &KFLA.NE.22) THEN WDTP(0)=1D0 WDTE(0,0)=1D0 MINT(61)=0 MINT(62)=0 MINT(63)=0 RETURN C...Treatment as a resonance based on tabulated branching ratios. ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN C...Loop over possible decay channels; skip irrelevant ones. DO 120 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 120 C...Read out decay products and nominal masses. KFD1=KFDP(IDC,1) KFC1=PYCOMP(KFD1) IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1 PM1=PMAS(KFC1,1) KFD2=KFDP(IDC,2) KFC2=PYCOMP(KFD2) IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2 PM2=PMAS(KFC2,1) KFD3=KFDP(IDC,3) PM3=0D0 IF(KFD3.NE.0) THEN KFC3=PYCOMP(KFD3) IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3 PM3=PMAS(KFC3,1) ENDIF C...Naive partial width and alternative threshold factors. WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR) IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND. & PM1+PM2+PM3.GE.SHR) THEN WDTP(I)=0D0 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2- & 4D0*PM1**2*PM2**2))/SH ELSEIF(MDME(IDC,2).EQ.52) THEN PMA=MAX(PM1,PM2,PM3) PMC=MIN(PM1,PM2,PM3) PMB=PM1+PM2+PM3-PMA-PMC PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC) PMAN=PMA**2/SH PMBN=PMB**2/SH PMCN=PMC**2/SH PMBCN=PMBC**2/SH WDTP(I)=WDTP(I)*SQRT(MAX(0D0, & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)* & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))* & ((SHR-PMA)**2-(PMB+PMC)**2)* & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/ & ((1D0-PMBCN)*PMBCN*SH) ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN WDTP(I)=WDTP(I)*SQRT( & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/ & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)) ELSEIF(MDME(IDC,2).EQ.53) THEN PMA=MAX(PM1,PM2,PM3) PMC=MIN(PM1,PM2,PM3) PMB=PM1+PM2+PM3-PMA-PMC PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC) PMAN=PMA**2/SH PMBN=PMB**2/SH PMCN=PMC**2/SH PMBCN=PMBC**2/SH FACACT=SQRT(MAX(0D0, & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)* & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))* & ((SHR-PMA)**2-(PMB+PMC)**2)* & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/ & ((1D0-PMBCN)*PMBCN*SH) PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC) PMAN=PMA**2/PMR**2 PMBN=PMB**2/PMR**2 PMCN=PMC**2/PMR**2 PMBCN=PMBC**2/PMR**2 FACNOM=SQRT(MAX(0D0, & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)* & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))* & ((PMR-PMA)**2-(PMB+PMC)**2)* & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/ & ((1D0-PMBCN)*PMBCN*PMR**2) WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) C...Calculate secondary width (at most two identical/opposite). WID2=1D0 IF(MDME(IDC,1).GT.0) THEN IF(KFD2.EQ.KFD1) THEN IF(KCHG(KFC1,3).EQ.0) THEN WID2=WIDS(KFC1,1) ELSEIF(KFD1.GT.0) THEN WID2=WIDS(KFC1,4) ELSE WID2=WIDS(KFC1,5) ENDIF IF(KFD3.GT.0) THEN WID2=WID2*WIDS(KFC3,2) ELSEIF(KFD3.LT.0) THEN WID2=WID2*WIDS(KFC3,3) ENDIF ELSEIF(KFD2.EQ.-KFD1) THEN WID2=WIDS(KFC1,1) IF(KFD3.GT.0) THEN WID2=WID2*WIDS(KFC3,2) ELSEIF(KFD3.LT.0) THEN WID2=WID2*WIDS(KFC3,3) ENDIF ELSEIF(KFD3.EQ.KFD1) THEN IF(KCHG(KFC1,3).EQ.0) THEN WID2=WIDS(KFC1,1) ELSEIF(KFD1.GT.0) THEN WID2=WIDS(KFC1,4) ELSE WID2=WIDS(KFC1,5) ENDIF IF(KFD2.GT.0) THEN WID2=WID2*WIDS(KFC2,2) ELSEIF(KFD2.LT.0) THEN WID2=WID2*WIDS(KFC2,3) ENDIF ELSEIF(KFD3.EQ.-KFD1) THEN WID2=WIDS(KFC1,1) IF(KFD2.GT.0) THEN WID2=WID2*WIDS(KFC2,2) ELSEIF(KFD2.LT.0) THEN WID2=WID2*WIDS(KFC2,3) ENDIF ELSEIF(KFD3.EQ.KFD2) THEN IF(KCHG(KFC2,3).EQ.0) THEN WID2=WIDS(KFC2,1) ELSEIF(KFD2.GT.0) THEN WID2=WIDS(KFC2,4) ELSE WID2=WIDS(KFC2,5) ENDIF IF(KFD1.GT.0) THEN WID2=WID2*WIDS(KFC1,2) ELSEIF(KFD1.LT.0) THEN WID2=WID2*WIDS(KFC1,3) ENDIF ELSEIF(KFD3.EQ.-KFD2) THEN WID2=WIDS(KFC2,1) IF(KFD1.GT.0) THEN WID2=WID2*WIDS(KFC1,2) ELSEIF(KFD1.LT.0) THEN WID2=WID2*WIDS(KFC1,3) ENDIF ELSE IF(KFD1.GT.0) THEN WID2=WIDS(KFC1,2) ELSE WID2=WIDS(KFC1,3) ENDIF IF(KFD2.GT.0) THEN WID2=WID2*WIDS(KFC2,2) ELSE WID2=WID2*WIDS(KFC2,3) ENDIF IF(KFD3.GT.0) THEN WID2=WID2*WIDS(KFC3,2) ELSEIF(KFD3.LT.0) THEN WID2=WID2*WIDS(KFC3,3) ENDIF ENDIF C...Store effective widths according to case. WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 120 CONTINUE C...Return. MINT(61)=0 MINT(62)=0 MINT(63)=0 RETURN ENDIF C...Here begins detailed dynamical calculation of resonance widths. C...Shared treatment of Higgs states. KFHIGG=25 IHIGG=1 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN KFHIGG=KFLA IHIGG=KFLA-33 ENDIF C...Common electroweak and strong constants. XW=PARU(102) XWV=XW IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2 XW1=1D0-XW AEM=PYALEM(SH) IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1) AS=PYALPS(SH) RADC=1D0+AS/PARU(1) IF(KFLA.EQ.6) THEN C...t quark. FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR RADCT=1D0-2.5D0*AS/PARU(1) DO 140 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 140 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140 WID2=1D0 IF(I.GE.4.AND.I.LE.7) THEN C...t -> W + q; including approximate QCD correction factor. WDTP(I)=FAC*VCKM(3,I-3)*RADCT* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) IF(KFLR.GT.0) THEN WID2=WIDS(24,2) IF(I.EQ.7) WID2=WID2*WIDS(7,2) ELSE WID2=WIDS(24,3) IF(I.EQ.7) WID2=WID2*WIDS(7,3) ENDIF ELSEIF(I.EQ.9) THEN C...t -> H + b. RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+ & 4D0*SQRT(RM2R*RM2)) WID2=WIDS(37,2) IF(KFLR.LT.0) WID2=WIDS(37,3) CMRENNA++ ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4. BETA=ATAN(RMSS(5)) SINB=SIN(BETA) TANW=SQRT(PARU(102)/(1D0-PARU(102))) ET=KCHG(6,1)/3D0 T3L=SIGN(0.5D0,ET) KFC1=PYCOMP(KFDP(IDC,1)) KFC2=PYCOMP(KFDP(IDC,2)) PMNCHI=PMAS(KFC1,1) PMSTOP=PMAS(KFC2,1) IF(SHR.GT.PMNCHI+PMSTOP) THEN IZ=I-9 DO 130 IK=1,4 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK)) 130 CONTINUE AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB) AR=-ET*ZMIXC(IZ,1)*TANW BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR BR=AL FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)* & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR) WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM* & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+ & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH IF(KFLR.GT.0) THEN WID2=WIDS(KFC1,2)*WIDS(KFC2,2) ELSE WID2=WIDS(KFC1,2)*WIDS(KFC2,3) ENDIF ENDIF ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN C...t -> ~g + ~t KFC1=PYCOMP(KFDP(IDC,1)) KFC2=PYCOMP(KFDP(IDC,2)) PMNCHI=PMAS(KFC1,1) PMSTOP=PMAS(KFC2,1) IF(SHR.GT.PMNCHI+PMSTOP) THEN RL=SFMIX(6,1) RR=-SFMIX(6,2) PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)* & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR) WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)* & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH IF(KFLR.GT.0) THEN WID2=WIDS(KFC1,2)*WIDS(KFC2,2) ELSE WID2=WIDS(KFC1,2)*WIDS(KFC2,3) ENDIF ENDIF ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN C...t -> ~gravitino + ~t XMP2=RMSS(29)**2 KFC1=PYCOMP(KFDP(IDC,1)) XMGR2=PMAS(KFC1,1)**2 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4 KFC2=PYCOMP(KFDP(IDC,2)) WID2=WIDS(KFC2,2) IF(KFLR.LT.0) WID2=WIDS(KFC2,3) CMRENNA-- ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 140 CONTINUE ELSEIF(KFLA.EQ.7) THEN C...b' quark. FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR DO 150 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 150 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150 WID2=1D0 IF(I.GE.4.AND.I.LE.7) THEN C...b' -> W + q. WDTP(I)=FAC*VCKM(I-3,4)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) IF(KFLR.GT.0) THEN WID2=WIDS(24,3) IF(I.EQ.6) WID2=WID2*WIDS(6,2) IF(I.EQ.7) WID2=WID2*WIDS(8,2) ELSE WID2=WIDS(24,2) IF(I.EQ.6) WID2=WID2*WIDS(6,3) IF(I.EQ.7) WID2=WID2*WIDS(8,3) ENDIF WID2=WIDS(24,3) IF(KFLR.LT.0) WID2=WIDS(24,2) ELSEIF(I.EQ.9.OR.I.EQ.10) THEN C...b' -> H + q. WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2) IF(KFLR.GT.0) THEN WID2=WIDS(37,3) IF(I.EQ.10) WID2=WID2*WIDS(6,2) ELSE WID2=WIDS(37,2) IF(I.EQ.10) WID2=WID2*WIDS(6,3) ENDIF ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 150 CONTINUE ELSEIF(KFLA.EQ.8) THEN C...t' quark. FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR DO 160 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 160 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160 WID2=1D0 IF(I.GE.4.AND.I.LE.7) THEN C...t' -> W + q. WDTP(I)=FAC*VCKM(4,I-3)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) IF(KFLR.GT.0) THEN WID2=WIDS(24,2) IF(I.EQ.7) WID2=WID2*WIDS(7,2) ELSE WID2=WIDS(24,3) IF(I.EQ.7) WID2=WID2*WIDS(7,3) ENDIF ELSEIF(I.EQ.9.OR.I.EQ.10) THEN C...t' -> H + q. WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2) IF(KFLR.GT.0) THEN WID2=WIDS(37,2) IF(I.EQ.10) WID2=WID2*WIDS(7,2) ELSE WID2=WIDS(37,3) IF(I.EQ.10) WID2=WID2*WIDS(7,3) ENDIF ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 160 CONTINUE ELSEIF(KFLA.EQ.17) THEN C...tau' lepton. FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR DO 170 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 170 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170 WID2=1D0 IF(I.EQ.3) THEN C...tau' -> W + nu'_tau. WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) IF(KFLR.GT.0) THEN WID2=WIDS(24,3) WID2=WID2*WIDS(18,2) ELSE WID2=WIDS(24,2) WID2=WID2*WIDS(18,3) ENDIF ELSEIF(I.EQ.5) THEN C...tau' -> H + nu'_tau. WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2) IF(KFLR.GT.0) THEN WID2=WIDS(37,3) WID2=WID2*WIDS(18,2) ELSE WID2=WIDS(37,2) WID2=WID2*WIDS(18,3) ENDIF ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 170 CONTINUE ELSEIF(KFLA.EQ.18) THEN C...nu'_tau neutrino. FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR DO 180 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 180 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180 WID2=1D0 IF(I.EQ.2) THEN C...nu'_tau -> W + tau'. WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) IF(KFLR.GT.0) THEN WID2=WIDS(24,2) WID2=WID2*WIDS(17,2) ELSE WID2=WIDS(24,3) WID2=WID2*WIDS(17,3) ENDIF ELSEIF(I.EQ.3) THEN C...nu'_tau -> H + tau'. WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2) IF(KFLR.GT.0) THEN WID2=WIDS(37,2) WID2=WID2*WIDS(17,2) ELSE WID2=WIDS(37,3) WID2=WID2*WIDS(17,3) ENDIF ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 180 CONTINUE ELSEIF(KFLA.EQ.21) THEN C...QCD: C***Note that widths are not given in dimensional quantities here. DO 190 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 190 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190 WID2=1D0 IF(I.LE.8) THEN C...QCD -> q + qbar WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1)) IF(I.EQ.6) WID2=WIDS(6,1) IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 190 CONTINUE ELSEIF(KFLA.EQ.22) THEN C...QED photon. C***Note that widths are not given in dimensional quantities here. DO 200 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 200 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200 WID2=1D0 IF(I.LE.8) THEN C...QED -> q + qbar. EF=KCHG(I,1)/3D0 FCOF=3D0*RADC IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0) WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1)) IF(I.EQ.6) WID2=WIDS(6,1) IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) ELSEIF(I.LE.12) THEN C...QED -> l+ + l-. EF=KCHG(9+2*(I-8),1)/3D0 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1)) IF(I.EQ.12) WID2=WIDS(17,1) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 200 CONTINUE ELSEIF(KFLA.EQ.23) THEN C...Z0: ICASE=1 XWC=1D0/(16D0*XW*XW1) FAC=(AEM*XWC/3D0)*SHR 210 CONTINUE IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN VINT(111)=0D0 VINT(112)=0D0 VINT(114)=0D0 ENDIF IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN KFI=IABS(MINT(15)) IF(KFI.GT.20) KFI=IABS(MINT(16)) EI=KCHG(KFI,1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV SQMZ=PMAS(23,1)**2 HZ=SHR*WDTP(0) IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0 IF(MSTP(43).EQ.3) VINT(112)= & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2) IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)= & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2) ENDIF DO 220 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 220 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220 WID2=1D0 IF(I.LE.8) THEN C...Z0 -> q + qbar EF=KCHG(I,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV FCOF=3D0*RADC IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0) IF(I.EQ.6) WID2=WIDS(6,1) IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) ELSEIF(I.LE.16) THEN C...Z0 -> l+ + l-, nu + nubar EF=KCHG(I+2,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV FCOF=1D0 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1) ENDIF BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) IF(ICASE.EQ.1) THEN WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))* & BE34 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)* & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+ & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34 ENDIF IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I) IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR. & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+ & WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)= & VINT(111)+FGGF*WID2 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)= & VINT(114)+FZZF*WID2 ENDIF ENDIF 220 CONTINUE IF(MINT(61).GE.1) ICASE=3-ICASE IF(ICASE.EQ.2) GOTO 210 ELSEIF(KFLA.EQ.24) THEN C...W+/-: FAC=(AEM/(24D0*XW))*SHR DO 230 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 230 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230 WID2=1D0 IF(I.LE.16) THEN C...W+/- -> q + qbar' FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1) IF(KFLR.GT.0) THEN IF(MOD(I,4).EQ.3) WID2=WIDS(6,2) IF(MOD(I,4).EQ.0) WID2=WIDS(8,2) IF(I.GE.13) WID2=WID2*WIDS(7,3) ELSE IF(MOD(I,4).EQ.3) WID2=WIDS(6,3) IF(MOD(I,4).EQ.0) WID2=WIDS(8,3) IF(I.GE.13) WID2=WID2*WIDS(7,2) ENDIF ELSEIF(I.LE.20) THEN C...W+/- -> l+/- + nu FCOF=1D0 IF(KFLR.GT.0) THEN IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2) ELSE IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3) ENDIF ENDIF WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 230 CONTINUE ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN C...h0 (or H0, or A0): SHFS=SH FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR DO 270 I=1,MDCY(KFHIGG,3) IDC=I+MDCY(KFHIGG,2)-1 IF(MDME(IDC,1).LT.0) GOTO 270 KFC1=PYCOMP(KFDP(IDC,1)) KFC2=PYCOMP(KFDP(IDC,2)) RM1=PMAS(KFC1,1)**2/SH RM2=PMAS(KFC2,1)**2/SH IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0) & GOTO 270 WID2=1D0 IF(I.LE.8) THEN C...h0 -> q + qbar WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)* & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC C...A0 behaves like beta, ho and H0 like beta**3. IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1) IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2 IF(IHIGG.NE.3) THEN WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/ & PARU(151+10*IHIGG))**2 ENDIF ENDIF ENDIF IF(I.EQ.6) WID2=WIDS(6,1) IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) ELSEIF(I.LE.12) THEN C...h0 -> l+ + l- WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS) C...A0 behaves like beta, ho and H0 like beta**3. IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1) IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)* & PARU(153+10*IHIGG)**2 IF(I.EQ.12) WID2=WIDS(17,1) ELSEIF(I.EQ.13) THEN C...h0 -> g + g; quark loop contribution only ETARE=0D0 ETAIM=0D0 DO 240 J=1,2*MSTP(1) EPS=(2D0*PMAS(J,1))**2/SH C...Loop integral; function of eps=4m^2/shat; different for A0. IF(EPS.LE.1D0) THEN IF(EPS.GT.1D-4) THEN ROOT=SQRT(1D0-EPS) RLN=LOG((1D0+ROOT)/(1D0-ROOT)) ELSE RLN=LOG(4D0/EPS-2D0) ENDIF PHIRE=-0.25D0*(RLN**2-PARU(1)**2) PHIIM=0.5D0*PARU(1)*RLN ELSE PHIRE=(ASIN(1D0/SQRT(EPS)))**2 PHIIM=0D0 ENDIF IF(IHIGG.LE.2) THEN ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE) ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM ELSE ETAREJ=-0.5D0*EPS*PHIRE ETAIMJ=-0.5D0*EPS*PHIIM ENDIF C...Couplings (=1 for standard model Higgs). IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN IF(MOD(J,2).EQ.1) THEN ETAREJ=ETAREJ*PARU(151+10*IHIGG) ETAIMJ=ETAIMJ*PARU(151+10*IHIGG) ELSE ETAREJ=ETAREJ*PARU(152+10*IHIGG) ETAIMJ=ETAIMJ*PARU(152+10*IHIGG) ENDIF ENDIF ETARE=ETARE+ETAREJ ETAIM=ETAIM+ETAIMJ 240 CONTINUE ETA2=ETARE**2+ETAIM**2 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2 ELSEIF(I.EQ.14) THEN C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions ETARE=0D0 ETAIM=0D0 JMAX=3*MSTP(1)+1 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1 DO 250 J=1,JMAX IF(J.LE.2*MSTP(1)) THEN EJ=KCHG(J,1)/3D0 EPS=(2D0*PMAS(J,1))**2/SH ELSEIF(J.LE.3*MSTP(1)) THEN JL=2*(J-2*MSTP(1))-1 EJ=KCHG(10+JL,1)/3D0 EPS=(2D0*PMAS(10+JL,1))**2/SH ELSEIF(J.EQ.3*MSTP(1)+1) THEN EPS=(2D0*PMAS(24,1))**2/SH ELSE EPS=(2D0*PMAS(37,1))**2/SH ENDIF C...Loop integral; function of eps=4m^2/shat. IF(EPS.LE.1D0) THEN IF(EPS.GT.1D-4) THEN ROOT=SQRT(1D0-EPS) RLN=LOG((1D0+ROOT)/(1D0-ROOT)) ELSE RLN=LOG(4D0/EPS-2D0) ENDIF PHIRE=-0.25D0*(RLN**2-PARU(1)**2) PHIIM=0.5D0*PARU(1)*RLN ELSE PHIRE=(ASIN(1D0/SQRT(EPS)))**2 PHIIM=0D0 ENDIF IF(J.LE.3*MSTP(1)) THEN C...Fermion loops: loop integral different for A0; charges. IF(IHIGG.LE.2) THEN PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE) PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM ELSE PHIPRE=-0.5D0*EPS*PHIRE PHIPIM=-0.5D0*EPS*PHIIM ENDIF IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN EJC=3D0*EJ**2 EJH=PARU(151+10*IHIGG) ELSEIF(J.LE.2*MSTP(1)) THEN EJC=3D0*EJ**2 EJH=PARU(152+10*IHIGG) ELSE EJC=EJ**2 EJH=PARU(153+10*IHIGG) ENDIF IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0 ETAREJ=EJC*EJH*PHIPRE ETAIMJ=EJC*EJH*PHIPIM ELSEIF(J.EQ.3*MSTP(1)+1) THEN C...W loops: loop integral and charges. ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE) ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN ETAREJ=ETAREJ*PARU(155+10*IHIGG) ETAIMJ=ETAIMJ*PARU(155+10*IHIGG) ENDIF ELSE C...Charged H loops: loop integral and charges. FACHHH=(PMAS(24,1)/PMAS(37,1))**2* & PARU(158+10*IHIGG+2*(IHIGG/3)) ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH ETAIMJ=-EPS**2*PHIIM*FACHHH ENDIF ETARE=ETARE+ETAREJ ETAIM=ETAIM+ETAIMJ 250 CONTINUE ETA2=ETARE**2+ETAIM**2 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2 ELSEIF(I.EQ.15) THEN C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions ETARE=0D0 ETAIM=0D0 JMAX=3*MSTP(1)+1 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1 DO 260 J=1,JMAX IF(J.LE.2*MSTP(1)) THEN EJ=KCHG(J,1)/3D0 AJ=SIGN(1D0,EJ+0.1D0) VJ=AJ-4D0*EJ*XWV EPS=(2D0*PMAS(J,1))**2/SH EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2 ELSEIF(J.LE.3*MSTP(1)) THEN JL=2*(J-2*MSTP(1))-1 EJ=KCHG(10+JL,1)/3D0 AJ=SIGN(1D0,EJ+0.1D0) VJ=AJ-4D0*EJ*XWV EPS=(2D0*PMAS(10+JL,1))**2/SH EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2 ELSE EPS=(2D0*PMAS(24,1))**2/SH EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2 ENDIF C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2. IF(EPS.LE.1D0) THEN ROOT=SQRT(1D0-EPS) IF(EPS.GT.1D-4) THEN RLN=LOG((1D0+ROOT)/(1D0-ROOT)) ELSE RLN=LOG(4D0/EPS-2D0) ENDIF PHIRE=-0.25D0*(RLN**2-PARU(1)**2) PHIIM=0.5D0*PARU(1)*RLN PSIRE=0.5D0*ROOT*RLN PSIIM=-0.5D0*ROOT*PARU(1) ELSE PHIRE=(ASIN(1D0/SQRT(EPS)))**2 PHIIM=0D0 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS)) PSIIM=0D0 ENDIF IF(EPSP.LE.1D0) THEN ROOT=SQRT(1D0-EPSP) IF(EPSP.GT.1D-4) THEN RLN=LOG((1D0+ROOT)/(1D0-ROOT)) ELSE RLN=LOG(4D0/EPSP-2D0) ENDIF PHIREP=-0.25D0*(RLN**2-PARU(1)**2) PHIIMP=0.5D0*PARU(1)*RLN PSIREP=0.5D0*ROOT*RLN PSIIMP=-0.5D0*ROOT*PARU(1) ELSE PHIREP=(ASIN(1D0/SQRT(EPSP)))**2 PHIIMP=0D0 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP)) PSIIMP=0D0 ENDIF FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)* & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP)) FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)* & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP)) F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP) F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP) IF(J.LE.3*MSTP(1)) THEN C...Fermion loops: loop integral different for A0; charges. IF(IHIGG.EQ.3) FXYRE=0D0 IF(IHIGG.EQ.3) FXYIM=0D0 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN EJC=-3D0*EJ*VJ EJH=PARU(151+10*IHIGG) ELSEIF(J.LE.2*MSTP(1)) THEN EJC=-3D0*EJ*VJ EJH=PARU(152+10*IHIGG) ELSE EJC=-EJ*VJ EJH=PARU(153+10*IHIGG) ENDIF IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE) ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM) ELSEIF(J.EQ.3*MSTP(1)+1) THEN C...W loops: loop integral and charges. HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS) ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE) ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM) IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN ETAREJ=ETAREJ*PARU(155+10*IHIGG) ETAIMJ=ETAIMJ*PARU(155+10*IHIGG) ENDIF ELSE C...Charged H loops: loop integral and charges. FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)* & PARU(158+10*IHIGG+2*(IHIGG/3)) ETAREJ=FACHHH*FXYRE ETAIMJ=FACHHH*FXYIM ENDIF ETARE=ETARE+ETAREJ ETAIM=ETAIM+ETAIMJ 260 CONTINUE ETA2=(ETARE**2+ETAIM**2)/(XW*XW1) WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2 WID2=WIDS(23,2) ELSEIF(I.LE.17) THEN C...h0 -> Z0 + Z0, W+ + W- PM1=PMAS(IABS(KFDP(IDC,1)),1) PG1=PMAS(IABS(KFDP(IDC,1)),2) IF(MINT(62).GE.1) THEN IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND. & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND. & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN MOFSV(IHIGG,I-15)=0 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0, & 1D0-4D0*RM1)) WID2=1D0 ELSE MOFSV(IHIGG,I-15)=1 RMAS=SQRT(MAX(0D0,SH)) CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW, & WID2) WIDWSV(IHIGG,I-15)=WIDW WID2SV(IHIGG,I-15)=WID2 ENDIF ELSE IF(MOFSV(IHIGG,I-15).EQ.0) THEN WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0, & 1D0-4D0*RM1)) WID2=1D0 ELSE WIDW=WIDWSV(IHIGG,I-15) WID2=WID2SV(IHIGG,I-15) ENDIF ENDIF WDTP(I)=FAC*WIDW/(2D0*(18-I)) IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)* & PARU(138+I+10*IHIGG)**2 WID2=WID2*WIDS(7+I,1) ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN C...H0 -> Z0 + h0, A0-> Z0 + h0 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0, & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 IF(IHIGG.EQ.2) THEN WDTP(I)=WDTP(I)*PARU(179)**2 ELSEIF(IHIGG.EQ.3) THEN WDTP(I)=WDTP(I)*PARU(186)**2 ENDIF WID2=WIDS(23,2)*WIDS(25,2) ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN C...H0 -> h0 + h0, A0-> h0 + h0 WDTP(I)=FAC*0.25D0* & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1)) IF(IHIGG.EQ.2) THEN WDTP(I)=WDTP(I)*PARU(176)**2 ELSEIF(IHIGG.EQ.3) THEN WDTP(I)=WDTP(I)*PARU(169)**2 ENDIF WID2=WIDS(25,1) ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+ WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0, & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 & *PARU(195+IHIGG)**2 IF(I.EQ.20) THEN WID2=WIDS(24,2)*WIDS(37,3) ELSEIF(I.EQ.21) THEN WID2=WIDS(24,3)*WIDS(37,2) ENDIF ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN C...H0 -> Z0 + A0. WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0, & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*0.0D0 WID2=WIDS(36,2)*WIDS(23,2) ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN C...H0 -> h0 + A0. WDTP(I)=FAC*0.5D0*PARU(180)**2* & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1)) WID2=WIDS(25,2)*WIDS(36,2) ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN C...H0 -> A0 + A0 WDTP(I)=FAC*0.25D0*PARU(177)**2* & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1)) WID2=WIDS(36,1) CMRENNA++ ELSE C...Add in SUSY decays (two-body) by rescaling by phase space factor. RM10=RM1*SH/PMR**2 RM20=RM2*SH/PMR**2 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20) WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2) IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN WFAC=0D0 ELSE WFAC=WFAC/WFAC0 ENDIF WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC) CMRENNA-- IF(KFC2.EQ.KFC1) THEN WID2=WIDS(KFC1,1) ELSE KSGN1=2 IF(KFDP(IDC,1).LT.0) KSGN1=3 KSGN2=2 IF(KFDP(IDC,2).LT.0) KSGN2=3 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2) ENDIF ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 270 CONTINUE ELSEIF(KFLA.EQ.32) THEN C...Z'0: ICASE=1 XWC=1D0/(16D0*XW*XW1) FAC=(AEM*XWC/3D0)*SHR VINT(117)=0D0 280 CONTINUE IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN VINT(111)=0D0 VINT(112)=0D0 VINT(113)=0D0 VINT(114)=0D0 VINT(115)=0D0 VINT(116)=0D0 ENDIF IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN KFAI=IABS(MINT(15)) EI=KCHG(KFAI,1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV KFAIC=1 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN VPI=PARU(119+2*KFAIC) API=PARU(120+2*KFAIC) ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN VPI=PARJ(178+2*KFAIC) API=PARJ(179+2*KFAIC) ELSE VPI=PARJ(186+2*KFAIC) API=PARJ(187+2*KFAIC) ENDIF SQMZ=PMAS(23,1)**2 HZ=SHR*VINT(117) SQMZP=PMAS(32,1)**2 HZP=SHR*WDTP(0) IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR. & MSTP(44).EQ.7) VINT(111)=1D0 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)= & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2) IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)= & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2) IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR. & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2) IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)= & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/ & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2)) IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR. & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2) ENDIF DO 290 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 290 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290 WID2=1D0 IF(I.LE.16) THEN IF(I.LE.8) THEN C...Z'0 -> q + qbar EF=KCHG(I,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV IF(I.LE.2) THEN VPF=PARU(123-2*MOD(I,2)) APF=PARU(124-2*MOD(I,2)) ELSEIF(I.LE.4) THEN VPF=PARJ(182-2*MOD(I,2)) APF=PARJ(183-2*MOD(I,2)) ELSE VPF=PARJ(190-2*MOD(I,2)) APF=PARJ(191-2*MOD(I,2)) ENDIF FCOF=3D0*RADC IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF* & PYHFTH(SH,SH*RM1,1D0) IF(I.EQ.6) WID2=WIDS(6,1) IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) ELSEIF(I.LE.16) THEN C...Z'0 -> l+ + l-, nu + nubar EF=KCHG(I+2,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV IF(I.LE.10) THEN VPF=PARU(127-2*MOD(I,2)) APF=PARU(128-2*MOD(I,2)) ELSEIF(I.LE.12) THEN VPF=PARJ(186-2*MOD(I,2)) APF=PARJ(187-2*MOD(I,2)) ELSE VPF=PARJ(194-2*MOD(I,2)) APF=PARJ(195-2*MOD(I,2)) ENDIF FCOF=1D0 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1) ENDIF BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) IF(ICASE.EQ.1) THEN WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+ & APF**2*(1D0-4D0*RM1))*BE34 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)* & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)* & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)* & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)* & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)* & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34 ELSEIF(MINT(61).EQ.2) THEN FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))* & BE34 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))* & BE34 ENDIF ELSEIF(I.EQ.17) THEN C...Z'0 -> W+ + W- WDTPZP=PARU(129)**2*XW1**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2) IF(ICASE.EQ.1) THEN WDTPZ=0D0 WDTP(I)=FAC*WDTPZP ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP ELSEIF(MINT(61).EQ.2) THEN FGGF=0D0 FGZF=0D0 FGZPF=0D0 FZZF=0D0 FZZPF=0D0 FZPZPF=WDTPZP ENDIF WID2=WIDS(24,1) ELSEIF(I.EQ.18) THEN C...Z'0 -> H+ + H- CZC=2D0*(1D0-2D0*XW) BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1)) IF(ICASE.EQ.1) THEN WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI* & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2* & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)* & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2* & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C ELSEIF(MINT(61).EQ.2) THEN FGGF=0.25D0*BE34C FGZF=0.25D0*PARU(142)*CZC*BE34C FGZPF=0.25D0*PARU(143)*CZC*BE34C FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C ENDIF WID2=WIDS(37,1) ELSEIF(I.EQ.19) THEN C...Z'0 -> Z0 + gamma. ELSEIF(I.EQ.20) THEN C...Z'0 -> Z0 + h0 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)* & (3D0*RM1+0.25D0*FLAM**2)*FLAM IF(ICASE.EQ.1) THEN WDTPZ=0D0 WDTP(I)=FAC*WDTPZP ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP ELSEIF(MINT(61).EQ.2) THEN FGGF=0D0 FGZF=0D0 FGZPF=0D0 FZZF=0D0 FZZPF=0D0 FZPZPF=WDTPZP ENDIF WID2=WIDS(23,2)*WIDS(25,2) ELSEIF(I.EQ.21.OR.I.EQ.22) THEN C...Z' -> h0 + A0 or H0 + A0. BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 IF(I.EQ.21) THEN CZAH=PARU(186) CZPAH=PARU(188) ELSE CZAH=PARU(187) CZPAH=PARU(189) ENDIF IF(ICASE.EQ.1) THEN WDTPZ=CZAH**2*BE34C WDTP(I)=FAC*CZPAH**2*BE34C ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH* & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)* & VINT(116))*BE34C ELSEIF(MINT(61).EQ.2) THEN FGGF=0D0 FGZF=0D0 FGZPF=0D0 FZZF=CZAH**2*BE34C FZZPF=CZAH*CZPAH*BE34C FZPZPF=CZPAH**2*BE34C ENDIF IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2) IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2) ENDIF IF(ICASE.EQ.1) THEN VINT(117)=VINT(117)+FAC*WDTPZ WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) ENDIF IF(MDME(IDC,1).GT.0) THEN IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR. & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+ & WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR. & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+ & FGZF*WID2 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+ & FGZPF*WID2 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR. & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+ & FZZPF*WID2 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR. & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2 ENDIF ENDIF 290 CONTINUE IF(MINT(61).GE.1) ICASE=3-ICASE IF(ICASE.EQ.2) GOTO 280 ELSEIF(KFLA.EQ.34) THEN C...W'+/-: FAC=(AEM/(24D0*XW))*SHR DO 300 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 300 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300 WID2=1D0 IF(I.LE.20) THEN IF(I.LE.16) THEN C...W'+/- -> q + qbar' FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)* & VCKM((I-1)/4+1,MOD(I-1,4)+1) IF(KFLR.GT.0) THEN IF(MOD(I,4).EQ.3) WID2=WIDS(6,2) IF(MOD(I,4).EQ.0) WID2=WIDS(8,2) IF(I.GE.13) WID2=WID2*WIDS(7,3) ELSE IF(MOD(I,4).EQ.3) WID2=WIDS(6,3) IF(MOD(I,4).EQ.0) WID2=WIDS(8,3) IF(I.GE.13) WID2=WID2*WIDS(7,2) ENDIF ELSEIF(I.LE.20) THEN C...W'+/- -> l+/- + nu FCOF=PARU(133)**2+PARU(134)**2 IF(KFLR.GT.0) THEN IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2) ELSE IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3) ENDIF ENDIF WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) ELSEIF(I.EQ.21) THEN C...W'+/- -> W+/- + Z0 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2) IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2) IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2) ELSEIF(I.EQ.23) THEN C...W'+/- -> W+/- + h0 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2) IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 300 CONTINUE ELSEIF(KFLA.EQ.37) THEN C...H+/-: C IF(MSTP(49).EQ.0) THEN SHFS=SH C ELSE C SHFS=PMAS(37,1)**2 C ENDIF FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR DO 310 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 310 KFC1=PYCOMP(KFDP(IDC,1)) KFC2=PYCOMP(KFDP(IDC,2)) RM1=PMAS(KFC1,1)**2/SH RM2=PMAS(KFC2,1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310 WID2=1D0 IF(I.LE.4) THEN C...H+/- -> q + qbar' RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+ & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS) IF(KFLR.GT.0) THEN IF(I.EQ.3) WID2=WIDS(6,2) IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2) ELSE IF(I.EQ.3) WID2=WIDS(6,3) IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3) ENDIF ELSEIF(I.LE.8) THEN C...H+/- -> l+/- + nu WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)* & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0, & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS) IF(KFLR.GT.0) THEN IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2) ELSE IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3) ENDIF ELSEIF(I.EQ.9) THEN C...H+/- -> W+/- + h0. WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0, & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2) IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2) CMRENNA++ ELSE C...Add in SUSY decays (two-body) by rescaling by phase space factor. RM10=RM1*SH/PMR**2 RM20=RM2*SH/PMR**2 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20) WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2) IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN WFAC=0D0 ELSE WFAC=WFAC/WFAC0 ENDIF WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC) CMRENNA-- KSGN1=2 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3 KSGN2=2 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 310 CONTINUE ELSEIF(KFLA.EQ.41) THEN C...R: FAC=(AEM/(12D0*XW))*SHR DO 320 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 320 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320 WID2=1D0 IF(I.LE.6) THEN C...R -> q + qbar' FCOF=3D0*RADC ELSEIF(I.LE.9) THEN C...R -> l+ + l'- FCOF=1D0 ENDIF WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) IF(KFLR.GT.0) THEN IF(I.EQ.4) WID2=WIDS(6,3) IF(I.EQ.5) WID2=WIDS(7,3) IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3) IF(I.EQ.9) WID2=WIDS(17,3) ELSE IF(I.EQ.4) WID2=WIDS(6,2) IF(I.EQ.5) WID2=WIDS(7,2) IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2) IF(I.EQ.9) WID2=WIDS(17,2) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 320 CONTINUE ELSEIF(KFLA.EQ.42) THEN C...LQ (leptoquark). FAC=(AEM/4D0)*PARU(151)*SHR DO 330 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 330 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=1D0 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR) IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2) IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3) ILQL=KFDP(IDC,2)*ISIGN(1,KFLR) IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2) IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3) WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 330 CONTINUE ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN C...Techni-pi0 and techni-pi0': FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR DO 340 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 340 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1) PM2=PMAS(PYCOMP(KFDP(IDC,2)),1) RM1=PM1**2/SH RM2=PM2**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340 WID2=1D0 C...pi_tc -> g + g IF(I.EQ.8) THEN FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2 & /(8D0*PARU(1))*SH*SHR IF(KFLA.EQ.KTECHN+111) THEN FACP=FACP*RTCM(9) ELSE FACP=FACP*RTCM(10) ENDIF WDTP(I)=FACP ELSE C...pi_tc -> f + fbar. FCOF=1D0 IKA=IABS(KFDP(IDC,1)) IF(IKA.LT.10) FCOF=3D0*RADC HM1=PM1 HM2=PM2 IF(IKA.GE.4.AND.IKA.LE.6) THEN FCOF=FCOF*RTCM(1+IKA)**2 HM1=PYMRUN(KFDP(IDC,1),SH) HM2=PYMRUN(KFDP(IDC,2),SH) ELSEIF(IKA.EQ.15) THEN FCOF=FCOF*RTCM(8)**2 ENDIF WDTP(I)=FAC*FCOF*(HM1+HM2)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 340 CONTINUE ELSEIF(KFLA.EQ.KTECHN+211) THEN C...pi+_tc FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR DO 350 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 350 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1) PM2=PMAS(PYCOMP(KFDP(IDC,2)),1) PM3=0D0 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1) RM1=PM1**2/SH RM2=PM2**2/SH RM3=PM3**2/SH IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350 WID2=1D0 C...pi_tc -> f + f'. FCOF=1D0 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC C...pi_tc+ -> W b b~ IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN FCOF=3D0*RADC XMT2=PMAS(6,1)**2/SH FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2 KFC3=PYCOMP(KFDP(IDC,3)) CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3) CHECK = SQRT(RM1) T0 = (1D0-CHECK**2)* & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)- & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2) T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2) & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3) T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1) WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0)) & +T3*LOG(CHECK)) IF(KFLR.GT.0) THEN WID2=WIDS(24,2) ELSE WID2=WIDS(24,3) ENDIF ELSE FCOF=1D0 IKA=IABS(KFDP(IDC,1)) IF(IKA.LT.10) FCOF=3D0*RADC HM1=PM1 HM2=PM2 IF(I.GE.1.AND.I.LE.5) THEN IF(I.LE.2) THEN FCOF=FCOF*RTCM(5)**2 ELSEIF(I.LE.4) THEN FCOF=FCOF*RTCM(6)**2 ELSEIF(I.EQ.5) THEN FCOF=FCOF*RTCM(7)**2 ENDIF HM1=PYMRUN(KFDP(IDC,1),SH) HM2=PYMRUN(KFDP(IDC,2),SH) ELSEIF(I.EQ.8) THEN FCOF=FCOF*RTCM(8)**2 ENDIF WDTP(I)=FAC*FCOF*(HM1+HM2)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 350 CONTINUE ELSEIF(KFLA.EQ.KTECHN+331) THEN C...Techni-eta. FAC=(SH/PARP(46)**2)*SHR DO 360 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 360 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360 WID2=1D0 IF(I.LE.2) THEN WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1)) IF(I.EQ.2) WID2=WIDS(6,1) ELSE WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 360 CONTINUE ELSEIF(KFLA.EQ.KTECHN+113) THEN C...Techni-rho0: ALPRHT=2.91D0*(3D0/ITCM(1)) FAC=(ALPRHT/12D0)*SHR FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR SQMZ=PMAS(23,1)**2 SQMW=PMAS(24,1)**2 SHP=SH CALL PYWIDX(23,SHP,WDTPP,WDTEP) GMMZ=SHR*WDTPP(0) XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW)) BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) DO 370 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 370 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370 WID2=1D0 IF(I.EQ.1) THEN C...rho_tc0 -> W+ + W-. WDTP(I)=FAC*RTCM(3)**4* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=WIDS(24,1) ELSEIF(I.EQ.2) THEN C...rho_tc0 -> W+ + pi_tc-. WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)* & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3) ELSEIF(I.EQ.3) THEN C...rho_tc0 -> pi_tc+ + W-. WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)* & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3) ELSEIF(I.EQ.4) THEN C...rho_tc0 -> pi_tc+ + pi_tc-. WDTP(I)=FAC*(1D0-RTCM(3)**2)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=WIDS(PYCOMP(KTECHN+211),1) ELSEIF(I.EQ.5) THEN C...rho_tc0 -> gamma + pi_tc0 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2* & SHR**3 WID2=WIDS(PYCOMP(KTECHN+111),2) ELSEIF(I.EQ.6) THEN C...rho_tc0 -> gamma + pi_tc0' WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3 WID2=WIDS(PYCOMP(KTECHN+221),2) ELSEIF(I.EQ.7) THEN C...rho_tc0 -> Z0 + pi_tc0 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2* & XW/XW1*SHR**3 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2) ELSEIF(I.EQ.8) THEN C...rho_tc0 -> Z0 + pi_tc0' WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/ & XW/XW1*SHR**3 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2) ELSE C...rho_tc0 -> f + fbar. WID2=1D0 IF(I.LE.16) THEN IA=I-8 FCOF=3D0*RADC IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1) ELSE IA=I-6 FCOF=1D0 IF(IA.GE.17) WID2=WIDS(IA,1) ENDIF EI=KCHG(IA,1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV VALI=0.5D0*(VI+AI) VARI=0.5D0*(VI-AI) WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)* & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+ & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*( & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2)) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 370 CONTINUE ELSEIF(KFLA.EQ.KTECHN+213) THEN C...Techni-rho+/-: ALPRHT=2.91D0*(3D0/ITCM(1)) FAC=(ALPRHT/12D0)*SHR SQMZ=PMAS(23,1)**2 SQMW=PMAS(24,1)**2 SHP=SH CALL PYWIDX(24,SHP,WDTPP,WDTEP) GMMW=SHR*WDTPP(0) FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR* & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2) DO 380 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 380 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380 WID2=1D0 IF(I.EQ.1) THEN C...rho_tc+ -> W+ + Z0. WDTP(I)=FAC*RTCM(3)**4* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 IF(KFLR.GT.0) THEN WID2=WIDS(24,2)*WIDS(23,2) ELSE WID2=WIDS(24,3)*WIDS(23,2) ENDIF ELSEIF(I.EQ.2) THEN C...rho_tc+ -> W+ + pi_tc0. WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)* & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3 IF(KFLR.GT.0) THEN WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2) ELSE WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2) ENDIF ELSEIF(I.EQ.3) THEN C...rho_tc+ -> pi_tc+ + Z0. WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)* & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+ & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2* & SHR**3*XW/XW1 IF(KFLR.GT.0) THEN WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2) ELSE WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2) ENDIF ELSEIF(I.EQ.4) THEN C...rho_tc+ -> pi_tc+ + pi_tc0. WDTP(I)=FAC*(1D0-RTCM(3)**2)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 IF(KFLR.GT.0) THEN WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2) ELSE WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2) ENDIF ELSEIF(I.EQ.5) THEN C...rho_tc+ -> pi_tc+ + gamma WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2* & SHR**3 IF(KFLR.GT.0) THEN WID2=WIDS(PYCOMP(KTECHN+211),2) ELSE WID2=WIDS(PYCOMP(KTECHN+211),3) ENDIF ELSEIF(I.EQ.6) THEN C...rho_tc+ -> W+ + pi_tc0' WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3 IF(KFLR.GT.0) THEN WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2) ELSE WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2) ENDIF ELSE C...rho_tc+ -> f + fbar'. IA=I-6 WID2=1D0 IF(IA.LE.16) THEN FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1) IF(KFLR.GT.0) THEN IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2) IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2) IF(IA.GE.13) WID2=WID2*WIDS(7,3) ELSE IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3) IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3) IF(IA.GE.13) WID2=WID2*WIDS(7,2) ENDIF ELSE FCOF=1D0 IF(KFLR.GT.0) THEN IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2) ELSE IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3) ENDIF ENDIF WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 380 CONTINUE ELSEIF(KFLA.EQ.KTECHN+223) THEN C...Techni-omega: ALPRHT=2.91D0*(3D0/ITCM(1)) FAC=(ALPRHT/12D0)*SHR FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2 SQMZ=PMAS(23,1)**2 SHP=SH CALL PYWIDX(23,SHP,WDTPP,WDTEP) GMMZ=SHR*WDTPP(0) BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) DO 390 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 390 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390 WID2=1D0 IF(I.EQ.1) THEN C...omega_tc0 -> gamma + pi_tc0. WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3 WID2=WIDS(PYCOMP(KTECHN+111),2) ELSEIF(I.EQ.2) THEN C...omega_tc0 -> Z0 + pi_tc0 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/ & XW/XW1*SHR**3 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2) ELSEIF(I.EQ.3) THEN C...omega_tc0 -> gamma + pi_tc0' WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2* & SHR**3 WID2=WIDS(PYCOMP(KTECHN+221),2) ELSEIF(I.EQ.4) THEN C...omega_tc0 -> Z0 + pi_tc0' WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2* & XW/XW1*SHR**3 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2) ELSEIF(I.EQ.5) THEN C...omega_tc0 -> W+ + pi_tc- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+ & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3) ELSEIF(I.EQ.6) THEN C...omega_tc0 -> pi_tc+ + W- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+ & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2) ELSEIF(I.EQ.7) THEN C...omega_tc0 -> W+ + W-. WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=WIDS(24,1) ELSEIF(I.EQ.8) THEN C...omega_tc0 -> pi_tc+ + pi_tc-. WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=WIDS(PYCOMP(KTECHN+211),1) ELSE C...omega_tc0 -> f + fbar. WID2=1D0 IF(I.LE.14) THEN IA=I-8 FCOF=3D0*RADC IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1) ELSE IA=I-6 FCOF=1D0 IF(IA.GE.17) WID2=WIDS(IA,1) ENDIF EI=KCHG(IA,1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV VALI=-0.5D0*(VI+AI) VARI=-0.5D0*(VI-AI) WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)* & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+ & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*( & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2)) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 390 CONTINUE C.....V8 -> quark anti-quark ELSEIF(KFLA.EQ.KTECHN+100021) THEN FAC=AS/6D0*SHR TANT3=RTCM(21) IF(ITCM(2).EQ.0) THEN IMDL=1 ELSEIF(ITCM(2).EQ.1) THEN IMDL=2 ENDIF DO 400 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 400 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1) RM1=PM1**2/SH IF(RM1.GT.0.25D0) GOTO 400 WID2=1D0 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN FMIX=1D0/TANT3**2 ELSE FMIX=TANT3**2 ENDIF WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX IF(I.EQ.6) WID2=WIDS(6,1) WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 400 CONTINUE ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR CLEBF=0D0 DO 410 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 410 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410 WID2=1D0 C...pi_tc -> g + g IF(I.EQ.7) THEN IF(KFLA.EQ.KTECHN+100111) THEN CLEBG=4D0/3D0 ELSE CLEBG=5D0/3D0 ENDIF FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2 & /(2D0*PARU(1))*SH*SHR*CLEBG WDTP(I)=FACP ELSE C...pi_tc -> f + fbar. IF(I.EQ.6) WID2=WIDS(6,1) FCOF=1D0 IKA=IABS(KFDP(IDC,1)) IF(IKA.LT.10) FCOF=3D0*RADC HM1=PYMRUN(KFDP(IDC,1),SH) WDTP(I)=FAC*FCOF*HM1**2*CLEBF* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 410 CONTINUE ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN FAC=AS/6D0*SHR ALPRHT=2.91D0*(3D0/ITCM(1)) TANT3=RTCM(21) SIN2T=2D0*TANT3/(TANT3**2+1D0) SINT3=TANT3/SQRT(TANT3**2+1D0) CSXPP=RTCM(22) RM82=RTCM(27)**2 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+ & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0) X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+ & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0) X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)- & SINT3**2)*2D0 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)- & SINT3**2)*2D0 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP) IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR GMV8=SHR*WDTPP(0) RMV8=PMAS(PYCOMP(KTECHN+100021),1) FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2) FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2) IF(ITCM(2).EQ.0) THEN IMDL=1 ELSE IMDL=2 ENDIF DO 420 I=1,MDCY(KC,3) IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR. & KFLA.EQ.KTECHN+300113)) GOTO 420 IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 420 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420 WID2=1D0 IF(I.LE.6) THEN IF(I.EQ.6) WID2=WIDS(6,1) XIG=1D0 IF(KFLA.EQ.KTECHN+200113) THEN XIG=0D0 XIJ=X12 ELSEIF(KFLA.EQ.KTECHN+300113) THEN XIG=0D0 XIJ=X21 ELSEIF(KFLA.EQ.KTECHN+100113) THEN XIJ=X11 ELSE XIJ=X22 ENDIF IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN FMIX=1D0/TANT3/SIN2T ELSE FMIX=-TANT3/SIN2T ENDIF XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC ELSEIF(I.EQ.7) THEN WDTP(I)=SHR*AS**2/(4D0*ALPRHT) ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN PSH=SHR*(1D0-RM1)/2D0 WDTP(I)=AS/9D0*PSH**3/RM82 IF(I.EQ.8) THEN WDTP(I)=2D0*WDTP(I)*CSXPP**2 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2) ELSE WDTP(I)=5D0*WDTP(I) WID2=WIDS(PYCOMP(KFDP(IDC,1)),2) ENDIF ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 420 CONTINUE ELSEIF(KFLA.EQ.KEXCIT+1) THEN C...d* excited quark. FAC=(SH/RTCM(41)**2)*SHR DO 430 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 430 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430 WID2=1D0 IF(I.EQ.1) THEN C...d* -> g + d. WDTP(I)=FAC*AS*RTCM(45)**2/3D0 WID2=1D0 ELSEIF(I.EQ.2) THEN C...d* -> gamma + d. QF=-RTCM(43)/2D0+RTCM(44)/6D0 WDTP(I)=FAC*AEM*QF**2/4D0 WID2=1D0 ELSEIF(I.EQ.3) THEN C...d* -> Z0 + d. QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)* & (1D0-RM1)**2*(2D0+RM1) WID2=WIDS(23,2) ELSEIF(I.EQ.4) THEN C...d* -> W- + u. WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)* & (1D0-RM1)**2*(2D0+RM1) IF(KFLR.GT.0) WID2=WIDS(24,3) IF(KFLR.LT.0) WID2=WIDS(24,2) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 430 CONTINUE ELSEIF(KFLA.EQ.KEXCIT+2) THEN C...u* excited quark. FAC=(SH/RTCM(41)**2)*SHR DO 440 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 440 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440 WID2=1D0 IF(I.EQ.1) THEN C...u* -> g + u. WDTP(I)=FAC*AS*RTCM(45)**2/3D0 WID2=1D0 ELSEIF(I.EQ.2) THEN C...u* -> gamma + u. QF=RTCM(43)/2D0+RTCM(44)/6D0 WDTP(I)=FAC*AEM*QF**2/4D0 WID2=1D0 ELSEIF(I.EQ.3) THEN C...u* -> Z0 + u. QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)* & (1D0-RM1)**2*(2D0+RM1) WID2=WIDS(23,2) ELSEIF(I.EQ.4) THEN C...u* -> W+ + d. WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)* & (1D0-RM1)**2*(2D0+RM1) IF(KFLR.GT.0) WID2=WIDS(24,2) IF(KFLR.LT.0) WID2=WIDS(24,3) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 440 CONTINUE ELSEIF(KFLA.EQ.KEXCIT+11) THEN C...e* excited lepton. FAC=(SH/RTCM(41)**2)*SHR DO 450 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 450 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450 WID2=1D0 IF(I.EQ.1) THEN C...e* -> gamma + e. QF=-RTCM(43)/2D0-RTCM(44)/2D0 WDTP(I)=FAC*AEM*QF**2/4D0 WID2=1D0 ELSEIF(I.EQ.2) THEN C...e* -> Z0 + e. QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)* & (1D0-RM1)**2*(2D0+RM1) WID2=WIDS(23,2) ELSEIF(I.EQ.3) THEN C...e* -> W- + nu. WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)* & (1D0-RM1)**2*(2D0+RM1) IF(KFLR.GT.0) WID2=WIDS(24,3) IF(KFLR.LT.0) WID2=WIDS(24,2) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 450 CONTINUE ELSEIF(KFLA.EQ.KEXCIT+12) THEN C...nu*_e excited neutrino. FAC=(SH/RTCM(41)**2)*SHR DO 460 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 460 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460 WID2=1D0 IF(I.EQ.1) THEN C...nu*_e -> Z0 + nu*_e. QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)* & (1D0-RM1)**2*(2D0+RM1) WID2=WIDS(23,2) ELSEIF(I.EQ.2) THEN C...nu*_e -> W+ + e. WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)* & (1D0-RM1)**2*(2D0+RM1) IF(KFLR.GT.0) WID2=WIDS(24,2) IF(KFLR.LT.0) WID2=WIDS(24,3) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 460 CONTINUE ELSEIF(KFLA.EQ.KDIMEN+39) THEN C...G* (graviton resonance): FAC=(PARP(50)**2/PARU(1))*SHR DO 470 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 470 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470 WID2=1D0 IF(I.LE.8) THEN C...G* -> q + qbar FCOF=3D0*RADC IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF* & PYHFTH(SH,SH*RM1,1D0) WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3* & (1D0+8D0*RM1/3D0)/320D0 IF(I.EQ.6) WID2=WIDS(6,1) IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1) ELSEIF(I.LE.16) THEN C...G* -> l+ + l-, nu + nubar FCOF=1D0 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3* & (1D0+8D0*RM1/3D0)/320D0 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1) ELSEIF(I.EQ.17) THEN C...G* -> g + g. WDTP(I)=FAC/20D0 ELSEIF(I.EQ.18) THEN C...G* -> gamma + gamma. WDTP(I)=FAC/160D0 ELSEIF(I.EQ.19) THEN C...G* -> Z0 + Z0. WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+ & 14D0*RM1/3D0+4D0*RM1**2)/160D0 WID2=WIDS(23,1) ELSEIF(I.EQ.20) THEN C...G* -> W+ + W-. WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+ & 14D0*RM1/3D0+4D0*RM1**2)/80D0 WID2=WIDS(24,1) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 470 CONTINUE ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos. PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1)) FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4 DO 480 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 480 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1) PM2=PMAS(PYCOMP(KFDP(IDC,2)),1) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1) IF(PM1+PM2+PM3.GE.SHR) GOTO 480 WID2=1D0 IF(I.LE.9) THEN C...nu_lR -> l- qbar q' FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1) IF(MOD(I,3).EQ.0) WID2=WIDS(6,2) ELSEIF(I.LE.18) THEN C...nu_lR -> l+ q qbar' FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1) IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3) ELSE C...nu_lR -> l- l'+ nu_lR' + charge conjugate. FCOF=1D0 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2) ENDIF X=(PM1+PM2+PM3)/SHR FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X) Y=(SHR/PMWR)**2 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4 WDTP(I)=FAC*FCOF*FX*FY WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 480 CONTINUE ELSEIF(KFLA.EQ.9900023) THEN C...Z_R0: FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR DO 490 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 490 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490 WID2=1D0 SYMMET=1D0 IF(I.LE.6) THEN C...Z_R0 -> q + qbar EF=KCHG(I,1)/3D0 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW) VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW FCOF=3D0*RADC IF(I.EQ.6) WID2=WIDS(6,1) ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN C...Z_R0 -> l+ + l- AF=-(1D0-2D0*XW) VF=-1D0+4D0*XW FCOF=1D0 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN C...Z0 -> nu_L + nu_Lbar, assumed Majorana. AF=-2D0*XW VF=0D0 FCOF=1D0 SYMMET=0.5D0 ELSEIF(I.LE.15) THEN C...Z0 -> nu_R + nu_R, assumed Majorana. AF=2D0*XW1 VF=0D0 FCOF=1D0 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1) SYMMET=0.5D0 ENDIF WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))* & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 490 CONTINUE ELSEIF(KFLA.EQ.9900024) THEN C...W_R+/-: FAC=(AEM/(24D0*XW))*SHR DO 500 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 500 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500 WID2=1D0 IF(I.LE.9) THEN C...W_R+/- -> q + qbar' FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1) IF(KFLR.GT.0) THEN IF(MOD(I,3).EQ.0) WID2=WIDS(6,2) ELSE IF(MOD(I,3).EQ.0) WID2=WIDS(6,3) ENDIF ELSEIF(I.LE.12) THEN C...W_R+/- -> l+/- + nu_R FCOF=1D0 ENDIF WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 500 CONTINUE ELSEIF(KFLA.EQ.9900041) THEN C...H_L++/--: FAC=(1D0/(8D0*PARU(1)))*SHR DO 510 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 510 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510 WID2=1D0 IF(I.LE.6) THEN C...H_L++/-- -> l+/- + l'+/- FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+ & (IABS(KFDP(IDC,2))-9)/2)**2 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF ELSEIF(I.EQ.7) THEN C...H_L++/-- -> W_L+/- + W_L+/- FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2* & (3D0*RM1+0.25D0/RM1-1D0) WID2=WIDS(24,4+(1-KFLS)/2) ENDIF WDTP(I)=FAC*FCOF* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 510 CONTINUE ELSEIF(KFLA.EQ.9900042) THEN C...H_R++/--: FAC=(1D0/(8D0*PARU(1)))*SHR DO 520 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 520 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520 WID2=1D0 IF(I.LE.6) THEN C...H_R++/-- -> l+/- + l'+/- FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+ & (IABS(KFDP(IDC,2))-9)/2)**2 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF ELSEIF(I.EQ.7) THEN C...H_R++/-- -> W_R+/- + W_R+/- FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0) WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2) ENDIF WDTP(I)=FAC*FCOF* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 520 CONTINUE ENDIF MINT(61)=0 MINT(62)=0 MINT(63)=0 RETURN END C*********************************************************************** C...PYOFSH C...Calculates partial width and differential cross-section maxima C...of channels/processes not allowed on mass-shell, and selects C...masses in such channels/processes. SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT2/,/PYINT5/ C...Local arrays. DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2), &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100), &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400), &WDTE(0:400,0:5) C...Find if particles equal, maximum mass, matrix elements, etc. MINT(51)=0 ISUB=MINT(1) KFD(1)=IABS(KFD1) KFD(2)=IABS(KFD2) MEQL=0 IF(KFD(1).EQ.KFD(2)) MEQL=1 MLM=0 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0)) IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN NOFF=44 PMMX=PMMO ELSE NOFF=40 PMMX=VINT(1) IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1)) ENDIF MMED=0 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND. &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR. &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR. &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3 LOOP=1 C...Find where Breit-Wigners are required, else select discrete masses. 100 DO 110 I=1,2 KFCA=PYCOMP(KFD(I)) IF(KFCA.GT.0) THEN PMD(I)=PMAS(KFCA,1) PGD(I)=PMAS(KFCA,2) ELSE PMD(I)=0D0 PGD(I)=0D0 ENDIF IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN MBW(I)=0 PMG(I)=PMD(I) RMG(I)=(PMG(I)/PMMX)**2 ELSE MBW(I)=1 ENDIF 110 CONTINUE C...Find allowed mass range and Breit-Wigner parameters. DO 120 I=1,2 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN PML(I)=PARP(42) PMU(I)=PMMX-PARP(42) IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I)) IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN ILM=I IF(MLM.EQ.2) ILM=3-I PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42)) IF(MBW(3-I).EQ.0) THEN PMU(I)=PMMX-PMD(3-I) ELSE PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42)) ENDIF IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)= & MIN(PMU(I),CKIN(NOFF+2*ILM)) IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX) IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX) IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1 IF(MBW(I).EQ.1) THEN ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I))) ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I))) IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)* & PGD(I))) ENDIF ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN ILM=I IF(MLM.EQ.2) ILM=3-I PML(I)=MAX(CKIN(48+I),PARP(42)) PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42)) IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I)) IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX) IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX) IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1 IF(MBW(I).EQ.1) THEN ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I))) ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I))) IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)* & PGD(I))) ENDIF ENDIF 120 CONTINUE IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0)) &THEN CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses') MINT(51)=1 RETURN ENDIF C...Calculation of partial width of resonance. IF(MOFSH.EQ.1) THEN C..If only one integration, pick that to be the inner. IF(MBW(1).EQ.0) THEN PM2=PMD(1) PMD(1)=PMD(2) PGD(1)=PGD(2) PML(1)=PML(2) PMU(1)=PMU(2) ELSEIF(MBW(2).EQ.0) THEN PM2=PMD(2) ENDIF C...Start outer loop of integration. IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2))) ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2))) NPT2=1 XPT2(1)=1D0 INX2(1)=0 FMAX2=0D0 ENDIF 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2)) PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S)))) ENDIF RM2=(PM2/PMMX)**2 C...Start inner loop of integration. PML1=PML(1) PMU1=MIN(PMU(1),PMMX-PM2) IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2) ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1))) ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1))) IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN FUNC2=0D0 GOTO 180 ENDIF NPT1=1 XPT1(1)=1D0 INX1(1)=0 FMAX1=0D0 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1)) PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S)))) RM1=(PM1/PMMX)**2 C...Evaluate function value - inner loop. FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2) IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+ & RM2**2+10D0*RM1*RM2) IF(FUNC1.GT.FMAX1) FMAX1=FUNC1 FPT1(NPT1)=FUNC1 C...Go to next position in inner loop. IF(NPT1.EQ.1) THEN NPT1=NPT1+1 XPT1(NPT1)=0D0 INX1(NPT1)=1 GOTO 140 ELSEIF(NPT1.LE.8) THEN NPT1=NPT1+1 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1 ISH1=ISH1+1 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1))) INX1(NPT1)=INX1(ISH1) INX1(ISH1)=NPT1 GOTO 140 ELSEIF(NPT1.LT.100) THEN ISN1=ISH1 150 ISH1=ISH1+1 IF(ISH1.GT.NPT1) ISH1=2 IF(ISH1.EQ.ISN1) GOTO 160 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1))) IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150 NPT1=NPT1+1 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1))) INX1(NPT1)=INX1(ISH1) INX1(ISH1)=NPT1 GOTO 140 ENDIF C...Calculate integral over inner loop. 160 FSUM1=0D0 DO 170 IPT1=2,NPT1 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))* & (XPT1(INX1(IPT1))-XPT1(IPT1)) 170 CONTINUE FUNC2=FSUM1*(ATU1-ATL1)/PARU(1) 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN IF(FUNC2.GT.FMAX2) FMAX2=FUNC2 FPT2(NPT2)=FUNC2 C...Go to next position in outer loop. IF(NPT2.EQ.1) THEN NPT2=NPT2+1 XPT2(NPT2)=0D0 INX2(NPT2)=1 GOTO 130 ELSEIF(NPT2.LE.8) THEN NPT2=NPT2+1 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1 ISH2=ISH2+1 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2))) INX2(NPT2)=INX2(ISH2) INX2(ISH2)=NPT2 GOTO 130 ELSEIF(NPT2.LT.100) THEN ISN2=ISH2 190 ISH2=ISH2+1 IF(ISH2.GT.NPT2) ISH2=2 IF(ISH2.EQ.ISN2) GOTO 200 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2))) IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190 NPT2=NPT2+1 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2))) INX2(NPT2)=INX2(ISH2) INX2(ISH2)=NPT2 GOTO 130 ENDIF C...Calculate integral over outer loop. 200 FSUM2=0D0 DO 210 IPT2=2,NPT2 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))* & (XPT2(INX2(IPT2))-XPT2(IPT2)) 210 CONTINUE FSUM2=FSUM2*(ATU2-ATL2)/PARU(1) IF(MEQL.EQ.1) FSUM2=2D0*FSUM2 ELSE FSUM2=FUNC2 ENDIF C...Save result; second integration for user-selected mass range. IF(LOOP.EQ.1) WIDW=FSUM2 WID2=FSUM2 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47) & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN LOOP=2 GOTO 100 ENDIF RET1=WIDW RET2=WID2/WIDW C...Select two decay product masses of a resonance. ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN 220 DO 230 I=1,2 IF(MBW(I).EQ.0) GOTO 230 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)* & (ATU(I)-ATL(I))) PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW)))) RMG(I)=(PMG(I)/PMMX)**2 230 CONTINUE IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR. & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220 C...Weight with matrix element (if none known, use beta factor). FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2))) IF(MMED.EQ.1) THEN WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2)) ELSEIF(MMED.EQ.2) THEN WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+ & RMG(2)**2+10D0*RMG(1)*RMG(2)) ELSEIF(MMED.EQ.3) THEN WTBE=FLAM*(RMG(1)+FLAM**2/12D0) ELSE WTBE=FLAM ENDIF IF(WTBE.LT.PYR(0)) GOTO 220 RET1=PMG(1) RET2=PMG(2) C...Find suitable set of masses for initialization of 2 -> 2 processes. ELSEIF(MOFSH.EQ.3) THEN IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1))) PMG(2)=PMD(2) ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN PMG(1)=PMD(1) PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2))) ELSE IDIV=-1 240 IDIV=IDIV+1 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1))) PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2))) IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240 ENDIF RET1=PMG(1) RET2=PMG(2) C...Evaluate importance of excluded tails of Breit-Wigners. IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2) & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2 IF(MEQL.LE.1) THEN VINT(80)=1D0 DO 250 I=1,2 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/ & PARU(1) 250 CONTINUE ELSE VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))* & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2))) ENDIF IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND. & MSTP(43).NE.2) VINT(80)=2D0*VINT(80) IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80) IF(MEQL.GE.1) VINT(80)=2D0*VINT(80) C...Pick one particle to be the lighter (if improves efficiency). ELSEIF(MOFSH.EQ.4) THEN IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2) & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0)) C...Select two masses according to Breit-Wigner + flat in s + 1/s. DO 270 I=1,2 IF(MBW(I).EQ.0) GOTO 270 PMV=PMU(I) IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I) ATV=ATU(I) IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I) RBR=PYR(0) IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR. & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR IF(RBR.LT.0.8D0) THEN PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I))) PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR)))) ELSEIF(RBR.LT.0.9D0) THEN PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2))) ELSEIF(RBR.LT.1.5D0) THEN PMG(I)=PML(I)*(PMV/PML(I))**PYR(0) ELSE PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)* & (PMV**2-PML(I)**2)))) ENDIF 270 CONTINUE IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR. & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN NGEN(0,1)=NGEN(0,1)+1 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1 GOTO 260 ELSE MINT(51)=1 RETURN ENDIF ENDIF RET1=PMG(1) RET2=PMG(2) C...Give weight for selected mass distribution. VINT(80)=1D0 DO 280 I=1,2 IF(MBW(I).EQ.0) GOTO 280 PMV=PMU(I) IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I) ATV=ATU(I) IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I) F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+ & (PMD(I)*PGD(I))**2)/PARU(1) F1=1D0 F2=1D0/PMG(I)**2 F3=1D0/PMG(I)**4 FI0=(ATV-ATL(I))/PARU(1) FI1=PMV**2-PML(I)**2 FI2=2D0*LOG(PMV/PML(I)) FI3=1D0/PML(I)**2-1D0/PMV**2 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR. & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+ & 5D0*F3/FI3)) ELSE VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2)) ENDIF VINT(80)=VINT(80)*FI0 280 CONTINUE IF(MEQL.GE.1) VINT(80)=2D0*VINT(80) ENDIF RETURN END C*********************************************************************** C...PYRECO C...Handles the possibility of colour reconnection in W+W- events, C...Based on the main scenarios of the Sjostrand and Khoze study: C...I, II, II', intermediate and instantaneous; plus one model C...along the lines of the Gustafson and Hakkinen: GH. C...Note: also handles Z0 Z0 and W-W+ events, but notation below C...is as if first resonance is W+ and second W-. SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter value; number of points in MC integration. PARAMETER (NPT=100) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ C...Local arrays. DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3), &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3), &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3), &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20), &TMC(20),IJOIN(100) C...Functions to give four-product and to do determinants. FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+ &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+ &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3) C...Only allow fraction of recoupling for GH, intermediate and C...instantaneous. IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN IF(PYR(0).GT.PARP(120)) RETURN ENDIF ISUB=MINT(1) C...Common part for scenarios I, II, II', and GH. IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR. &MSTP(115).EQ.5) THEN C...Read out frequently-used parameters. PI=PARU(1) HBAR=PARU(3) PMW=PMAS(24,1) IF(ISUB.EQ.22) PMW=PMAS(23,1) PGW=PMAS(24,2) IF(ISUB.EQ.22) PGW=PMAS(23,2) TFRAG=PARP(115) RHAD=PARP(116) FACT=PARP(117) BLOWR=PARP(118) BLOWT=PARP(119) C...Find range of decay products of the W's. C...Background: the W's are stored in IW1 and IW2. C...Their direct decay products in NSD1+1 through NSD1+4. C...Products after shower (if any) in NSD1+5 through NAFT1 C...for first W and in NAFT1+1 through N for the second. IF(NAFT1.GT.NSD1+4) THEN NBEG(1)=NSD1+5 NEND(1)=NAFT1 ELSE NBEG(1)=NSD1+1 NEND(1)=NSD1+2 ENDIF IF(N.GT.NAFT1) THEN NBEG(2)=NAFT1+1 NEND(2)=N ELSE NBEG(2)=NSD1+3 NEND(2)=NSD1+4 ENDIF C...Rearrange parton shower products along strings. NOLD=N CALL PYPREP(NSD1+1) IF(MINT(51).NE.0) RETURN C...Find partons pointing back to W+ and W-; store them with quark C...end of string first. NNP=0 NNM=0 ISGP=0 ISGM=0 DO 120 I=NOLD+1,N IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120 IF(IABS(K(I,2)).GE.22) GOTO 120 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2)) NNP=NNP+1 IF(ISGP.EQ.1) THEN INP(NNP)=I ELSE DO 100 I1=NNP,2,-1 INP(I1)=INP(I1-1) 100 CONTINUE INP(1)=I ENDIF IF(K(I,1).EQ.1) ISGP=0 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2)) NNM=NNM+1 IF(ISGM.EQ.1) THEN INM(NNM)=I ELSE DO 110 I1=NNM,2,-1 INM(I1)=INM(I1-1) 110 CONTINUE INM(1)=I ENDIF IF(K(I,1).EQ.1) ISGM=0 ENDIF 120 CONTINUE C...Boost to W+W- rest frame (not strictly needed). DO 130 J=1,3 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4)) 130 CONTINUE CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3)) CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3)) CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3)) C...Select decay vertices of W+ and W-. TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/ & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2) TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/ & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2) GTMAX=MAX(TP,TM) DO 140 J=1,3 XP(J)=TP*P(IW1,J)/P(IW1,4) XM(J)=TM*P(IW2,J)/P(IW2,4) 140 CONTINUE C...Begin scenario I specifics. IF(MSTP(115).EQ.1) THEN C...Reconstruct velocity and direction of W+ string pieces. DO 170 IIP=1,NNP-1 IF(K(INP(IIP),2).LT.0) GOTO 170 I1=INP(IIP) I2=INP(IIP+1) P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2) P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2) DO 150 J=1,3 V1(J)=P(I1,J)/P1A V2(J)=P(I2,J)/P2A BETP(IIP,J)=0.5D0*(V1(J)+V2(J)) DIRP(IIP,J)=V1(J)-V2(J) 150 CONTINUE BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2- & BETP(IIP,3)**2) DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2) DO 160 J=1,3 DIRP(IIP,J)=DIRP(IIP,J)/DIRL 160 CONTINUE 170 CONTINUE C...Reconstruct velocity and direction of W- string pieces. DO 200 IIM=1,NNM-1 IF(K(INM(IIM),2).LT.0) GOTO 200 I1=INM(IIM) I2=INM(IIM+1) P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2) P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2) DO 180 J=1,3 V1(J)=P(I1,J)/P1A V2(J)=P(I2,J)/P2A BETM(IIM,J)=0.5D0*(V1(J)+V2(J)) DIRM(IIM,J)=V1(J)-V2(J) 180 CONTINUE BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2- & BETM(IIM,3)**2) DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2) DO 190 J=1,3 DIRM(IIM,J)=DIRM(IIM,J)/DIRL 190 CONTINUE 200 CONTINUE C...Loop over number of space-time points. NACC=0 SUM=0D0 DO 250 IPT=1,NPT C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively). R=SQRT(-LOG(PYR(0))) PHI=2D0*PI*PYR(0) X=BLOWR*RHAD*R*COS(PHI) Y=BLOWR*RHAD*R*SIN(PHI) R=SQRT(-LOG(PYR(0))) PHI=2D0*PI*PYR(0) Z=BLOWR*RHAD*R*COS(PHI) T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI)) C...Reject impossible points. Weight for sample distribution. IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)* & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2) C...Loop over W+ string pieces and find one with largest weight. IMAXP=0 WTMAXP=1D-10 XD(1)=X-XP(1) XD(2)=Y-XP(2) XD(3)=Z-XP(3) XD(4)=T-TP DO 220 IIP=1,NNP-1 IF(K(INP(IIP),2).LT.0) GOTO 220 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3) BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4)) DO 210 J=1,3 XB(J)=XD(J)+BEDG*BETP(IIP,J) 210 CONTINUE XB(4)=BETP(IIP,4)*(XD(4)-BED) SR2=XB(1)**2+XB(2)**2+XB(3)**2 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+ & DIRP(IIP,3)*XB(3))**2 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/ & TFRAG**2) IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0 IF(WTP.GT.WTMAXP) THEN IMAXP=IIP WTMAXP=WTP ENDIF 220 CONTINUE C...Loop over W- string pieces and find one with largest weight. IMAXM=0 WTMAXM=1D-10 XD(1)=X-XM(1) XD(2)=Y-XM(2) XD(3)=Z-XM(3) XD(4)=T-TM DO 240 IIM=1,NNM-1 IF(K(INM(IIM),2).LT.0) GOTO 240 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3) BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4)) DO 230 J=1,3 XB(J)=XD(J)+BEDG*BETM(IIM,J) 230 CONTINUE XB(4)=BETM(IIM,4)*(XD(4)-BED) SR2=XB(1)**2+XB(2)**2+XB(3)**2 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+ & DIRM(IIM,3)*XB(3))**2 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/ & TFRAG**2) IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0 IF(WTM.GT.WTMAXM) THEN IMAXM=IIM WTMAXM=WTM ENDIF 240 CONTINUE C...Result of integration. WT=0D0 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN WT=WTMAXP*WTMAXM/WTSMP SUM=SUM+WT NACC=NACC+1 IAP(NACC)=IMAXP IAM(NACC)=IMAXM WTA(NACC)=WT ENDIF 250 CONTINUE RES=BLOWR**3*BLOWT*SUM/NPT C...Decide whether to reconnect and, if so, where. IACC=0 PREC=1D0-EXP(-FACT*RES) IF(PREC.GT.PYR(0)) THEN RSUM=PYR(0)*SUM DO 260 IA=1,NACC IACC=IA RSUM=RSUM-WTA(IA) IF(RSUM.LE.0D0) GOTO 270 260 CONTINUE 270 IIP=IAP(IACC) IIM=IAM(IACC) ENDIF C...Begin scenario II and II' specifics. ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN C...Loop through all string pieces, one from W+ and one from W-. NCROSS=0 TC(0)=0D0 DO 340 IIP=1,NNP-1 IF(K(INP(IIP),2).LT.0) GOTO 340 I1P=INP(IIP) I2P=INP(IIP+1) DO 330 IIM=1,NNM-1 IF(K(INM(IIM),2).LT.0) GOTO 330 I1M=INM(IIM) I2M=INM(IIM+1) C...Find endpoint velocity vectors. DO 280 J=1,3 V1P(J)=P(I1P,J)/P(I1P,4) V2P(J)=P(I2P,J)/P(I2P,4) V1M(J)=P(I1M,J)/P(I1M,4) V2M(J)=P(I2M,J)/P(I2M,4) 280 CONTINUE C...Define q matrix and find t. DO 290 J=1,3 Q(1,J)=V2P(J)-V1P(J) Q(2,J)=-(V2M(J)-V1M(J)) Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J) Q(4,J)=V1P(J)-V1M(J) 290 CONTINUE T=-DETER(1,2,3)/DETER(1,2,4) C...Find alpha and beta; i.e. coordinates of crossing point. S11=Q(1,1)*(T-TP) S12=Q(2,1)*(T-TM) S13=Q(3,1)+Q(4,1)*T S21=Q(1,2)*(T-TP) S22=Q(2,2)*(T-TM) S23=Q(3,2)+Q(4,2)*T DEN=S11*S22-S12*S21 ALP=(S12*S23-S22*S13)/DEN BET=(S21*S13-S11*S23)/DEN C...Check if solution acceptable. IANSW=1 IF(T.LT.GTMAX) IANSW=0 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0 C...Find point of crossing and check that not inconsistent. DO 300 J=1,3 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP) XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM) 300 CONTINUE D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+ & (XPP(3)-XMM(3))**2 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1 C...Find string eigentimes at crossing. IF(IANSW.EQ.1) THEN TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2- & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2)) TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2- & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2)) ELSE TAUP=0D0 TAUM=0D0 ENDIF C...Order crossings by time. End loop over crossings. IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN NCROSS=NCROSS+1 DO 310 I1=NCROSS,1,-1 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN IPC(I1)=IIP IMC(I1)=IIM TC(I1)=T TPC(I1)=TAUP TMC(I1)=TAUM GOTO 320 ELSE IPC(I1)=IPC(I1-1) IMC(I1)=IMC(I1-1) TC(I1)=TC(I1-1) TPC(I1)=TPC(I1-1) TMC(I1)=TMC(I1-1) ENDIF 310 CONTINUE 320 CONTINUE ENDIF 330 CONTINUE 340 CONTINUE C...Loop over crossings; find first (if any) acceptable one. IACC=0 IF(NCROSS.GE.1) THEN DO 350 IC=1,NCROSS PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2) IF(PNFRAG.GT.PYR(0)) THEN C...Scenario II: only compare with fragmentation time. IF(MSTP(115).EQ.2) THEN IACC=IC IIP=IPC(IACC) IIM=IMC(IACC) GOTO 360 C...Scenario II': also require that string length decreases. ELSE IIP=IPC(IC) IIM=IMC(IC) I1P=INP(IIP) I2P=INP(IIP+1) I1M=INM(IIM) I2M=INM(IIM+1) ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M) ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P) IF(ELNEW.LT.ELOLD) THEN IACC=IC IIP=IPC(IACC) IIM=IMC(IACC) GOTO 360 ENDIF ENDIF ENDIF 350 CONTINUE 360 CONTINUE ENDIF C...Begin scenario GH specifics. ELSEIF(MSTP(115).EQ.5) THEN C...Loop through all string pieces, one from W+ and one from W-. IACC=0 ELMIN=1D0 DO 380 IIP=1,NNP-1 IF(K(INP(IIP),2).LT.0) GOTO 380 I1P=INP(IIP) I2P=INP(IIP+1) DO 370 IIM=1,NNM-1 IF(K(INM(IIM),2).LT.0) GOTO 370 I1M=INM(IIM) I2M=INM(IIM+1) C...Look for largest decrease of (exponent of) Lambda measure. ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M) ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P) ELDIF=ELNEW/MAX(1D-10,ELOLD) IF(ELDIF.LT.ELMIN) THEN IACC=IIP+IIM ELMIN=ELDIF IPC(1)=IIP IMC(1)=IIM ENDIF 370 CONTINUE 380 CONTINUE IIP=IPC(1) IIM=IMC(1) ENDIF C...Common for scenarios I, II, II' and GH: reconnect strings. IF(IACC.NE.0) THEN MINT(32)=1 NJOIN=0 DO 390 IS=1,NNP+NNM NJOIN=NJOIN+1 IF(IS.LE.IIP) THEN I=INP(IS) ELSEIF(IS.LE.IIP+NNM-IIM) THEN I=INM(IS-IIP+IIM) ELSEIF(IS.LE.IIP+NNM) THEN I=INM(IS-IIP-NNM+IIM) ELSE I=INP(IS-NNM) ENDIF IJOIN(NJOIN)=I IF(K(I,2).LT.0) THEN CALL PYJOIN(NJOIN,IJOIN) NJOIN=0 ENDIF 390 CONTINUE C...Restore original event record if no reconnection. ELSE DO 400 I=NSD1+1,NOLD IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN K(I,4)=MOD(K(I,4),MSTU(5)**2) K(I,5)=MOD(K(I,5),MSTU(5)**2) ENDIF 400 CONTINUE DO 410 I=NOLD+1,N K(K(I,3),1)=3 410 CONTINUE N=NOLD ENDIF C...Boost back system. CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3)) CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3)) IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0, & BEWW(1),BEWW(2),BEWW(3)) C...Common part for intermediate and instantaneous scenarios. ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN MINT(32)=1 C...Remove old shower products and reset showering ones. N=NSD1+4 DO 420 I=NSD1+1,NSD1+4 K(I,1)=3 K(I,4)=MOD(K(I,4),MSTU(5)**2) K(I,5)=MOD(K(I,5),MSTU(5)**2) 420 CONTINUE C...Identify quark-antiquark pairs. IQ1=NSD1+1 IQ2=NSD1+2 IQ3=NSD1+3 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4 IQ4=2*NSD1+7-IQ3 C...Reconnect strings. IJOIN(1)=IQ1 IJOIN(2)=IQ4 CALL PYJOIN(2,IJOIN) IJOIN(1)=IQ3 IJOIN(2)=IQ2 CALL PYJOIN(2,IJOIN) C...Do new parton showers in intermediate scenario. IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN MSTJ50=MSTJ(50) MSTJ(50)=0 CALL PYSHOW(IQ1,IQ2,P(IW1,5)) CALL PYSHOW(IQ3,IQ4,P(IW2,5)) MSTJ(50)=MSTJ50 C...Do new parton showers in instantaneous scenario. ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2- & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2 PPM=SQRT(MAX(0D0,PPM2)) CALL PYSHOW(IQ1,IQ4,PPM) PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2- & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2 PPM=SQRT(MAX(0D0,PPM2)) CALL PYSHOW(IQ3,IQ2,PPM) ENDIF ENDIF RETURN END C*********************************************************************** C...PYKLIM C...Checks generated variables against pre-set kinematical limits; C...also calculates limits on variables used in generation. SUBROUTINE PYKLIM(ILIM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/, &/PYINT1/,/PYINT2/ C...Common kinematical expressions. MINT(51)=0 ISUB=MINT(1) ISTSB=ISET(ISUB) IF(ISUB.EQ.96) GOTO 100 SQM3=VINT(63) SQM4=VINT(64) IF(ILIM.NE.0) THEN IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN CKIN09=MAX(CKIN(9),CKIN(13)) CKIN10=MIN(CKIN(10),CKIN(14)) CKIN11=MAX(CKIN(11),CKIN(15)) CKIN12=MIN(CKIN(12),CKIN(16)) ELSE CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13))) CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14))) CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15))) CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16))) ENDIF ENDIF IF(ILIM.NE.1) THEN TAU=VINT(21) RM3=SQM3/(TAU*VINT(2)) RM4=SQM4/(TAU*VINT(2)) BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) ENDIF PTHMIN=CKIN(3) IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3) &PTHMIN=MAX(CKIN(3),CKIN(5)) IF(ILIM.EQ.0) THEN C...Check generated values of tau, y*, cos(theta-hat), and tau' against C...pre-set kinematical limits. YST=VINT(22) CTH=VINT(23) TAUP=VINT(26) TAUE=TAU IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP X1=SQRT(TAUE)*EXP(YST) X2=SQRT(TAUE)*EXP(-YST) XF=X1-X2 IF(MINT(47).NE.1) THEN IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1 ENDIF IF(MINT(45).NE.1) THEN IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1 ENDIF IF(MINT(46).NE.1) THEN IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1 ENDIF IF(MINT(45).EQ.2) THEN IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1 ENDIF IF(MINT(46).EQ.2) THEN IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1 ENDIF IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2)) EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/ & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH))) EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/ & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH))) Y3=YST+0.5D0*LOG(EXPY3) Y4=YST+0.5D0*LOG(EXPY4) YLARGE=MAX(Y3,Y4) YSMALL=MIN(Y3,Y4) ETALAR=20D0 ETASMA=-20D0 STH=SQRT(MAX(0D0,1D0-CTH**2)) EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)* & CTH)**2-4D0*RM3)) EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)* & CTH)**2-4D0*RM4)) IF(STH.GE.1D-10) THEN EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/ & (BE34*STH) EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/ & (BE34*STH) ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3))) ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4))) ETALAR=MAX(ETA3,ETA4) ETASMA=MIN(ETA3,ETA4) ENDIF CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4)) CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4)) SH=TAU*VINT(2) RPTS=4D0*VINT(71)**2/SH BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS)) RM34=MAX(1D-20,2D0*RM3*RM4) IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0) & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2))) RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L) THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH) UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH) IF(PTH.LT.PTHMIN) MINT(51)=1 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1 IF(THA.LT.CKIN(35)) MINT(51)=1 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1 IF(UHA.LT.CKIN(37)) MINT(51)=1 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1 ENDIF IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1 ENDIF C...Additional cuts on W2 (approximately) in DIS. IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN XBJ=X2 IF(IABS(MINT(12)).LT.20) XBJ=X1 Q2BJ=THA W2BJ=Q2BJ*(1D0-XBJ)/XBJ IF(W2BJ.LT.CKIN(39)) MINT(51)=1 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1 ENDIF ELSEIF(ILIM.EQ.1) THEN C...Calculate limits on tau C...0) due to definition TAUMN0=0D0 TAUMX0=1D0 C...1) due to limits on subsystem mass TAUMN1=CKIN(1)**2/VINT(2) TAUMX1=1D0 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2) C...2) due to limits on pT-hat (and non-overlapping rapidity intervals) TM3=SQRT(SQM3+PTHMIN**2) TM4=SQRT(SQM4+PTHMIN**2) YDCOSH=1D0 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12) TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2) TAUMX2=1D0 C...3) due to limits on pT-hat and cos(theta-hat) CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2) CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2) TAUMN3=0D0 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3= & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+ & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2) TAUMX3=1D0 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3= & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+ & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2) C...4) due to limits on x1 and x2 TAUMN4=CKIN(21)*CKIN(23) TAUMX4=CKIN(22)*CKIN(24) C...5) due to limits on xF TAUMN5=0D0 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26)) C...6) due to limits on that and uhat TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2) TAUMX6=1D0 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6= & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2) C...Net effect of all separate limits. VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6) VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6) IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN VINT(11)=1D0-1D-9 VINT(31)=1D0+1D-9 ELSEIF(MINT(47).EQ.5) THEN VINT(31)=MIN(VINT(31),1D0-2D-10) ELSEIF(MINT(47).GE.6) THEN VINT(31)=MIN(VINT(31),1D0-1D-10) ENDIF IF(VINT(31).LE.VINT(11)) MINT(51)=1 ELSEIF(ILIM.EQ.2) THEN C...Calculate limits on y* TAUE=TAU IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26) TAURT=SQRT(TAUE) C...0) due to kinematics YSTMN0=LOG(TAURT) YSTMX0=-YSTMN0 C...1) due to explicit limits YSTMN1=CKIN(7) YSTMX1=CKIN(8) C...2) due to limits on x1 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT) YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT) C...3) due to limits on x2 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT) YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT) C...4) due to limits on xF YEPMN4=0.5D0*ABS(CKIN(25))/TAURT YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25)) YEPMX4=0.5D0*ABS(CKIN(26))/TAURT YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26)) C...5) due to simultaneous limits on y-large and y-small YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11) YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12) YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN))) YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX))) YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN) YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX) C...6) due to simultaneous limits on cos(theta-hat) and y-large or C... y-small CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2)))) RZMN=BE34*MAX(CKIN(27),-CTHLIM) RZMX=BE34*MIN(CKIN(28),CTHLIM) YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX) YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN) YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN) YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX) YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX)) YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN)) C...Net effect of all separate limits. VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6) VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6) IF(MINT(47).EQ.1) THEN VINT(12)=-1D-9 VINT(32)=1D-9 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN VINT(12)=(1D0-1D-9)*YSTMX0 VINT(32)=(1D0+1D-9)*YSTMX0 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN VINT(12)=-(1D0+1D-9)*YSTMX0 VINT(32)=-(1D0-1D-9)*YSTMX0 ELSEIF(MINT(47).EQ.5) THEN YSTEE=LOG((1D0-1D-10)/TAURT) VINT(12)=MAX(VINT(12),-YSTEE) VINT(32)=MIN(VINT(32),YSTEE) ENDIF IF(VINT(32).LE.VINT(12)) MINT(51)=1 ELSEIF(ILIM.EQ.3) THEN C...Calculate limits on cos(theta-hat) YST=VINT(22) C...0) due to definition CTNMN0=-1D0 CTNMX0=0D0 CTPMN0=0D0 CTPMX0=1D0 C...1) due to explicit limits CTNMN1=MIN(0D0,CKIN(27)) CTNMX1=MIN(0D0,CKIN(28)) CTPMN1=MAX(0D0,CKIN(27)) CTPMX1=MAX(0D0,CKIN(28)) C...2) due to limits on pT-hat CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2)))) CTPMX2=-CTNMN2 CTNMX2=0D0 CTPMN2=0D0 IF(CKIN(4).GE.0D0) THEN CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/ & (BE34**2*TAU*VINT(2)))) CTPMN2=-CTNMX2 ENDIF C...3) due to limits on y-large and y-small CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST), & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST))) CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST), & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST)) CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST), & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST)) CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST), & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST))) C...4) due to limits on that CTNMN4=-1D0 CTNMX4=0D0 CTPMN4=0D0 CTPMX4=1D0 SH=TAU*VINT(2) IF(CKIN(35).GT.0D0) THEN CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34 IF(CTLIM.GT.0D0) THEN CTPMX4=CTLIM ELSE CTPMX4=0D0 CTNMX4=CTLIM ENDIF ENDIF IF(CKIN(36).GT.0D0) THEN CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34 IF(CTLIM.LT.0D0) THEN CTNMN4=CTLIM ELSE CTNMN4=0D0 CTPMN4=CTLIM ENDIF ENDIF C...5) due to limits on uhat CTNMN5=-1D0 CTNMX5=0D0 CTPMN5=0D0 CTPMX5=1D0 IF(CKIN(37).GT.0D0) THEN CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34 IF(CTLIM.LT.0D0) THEN CTNMN5=CTLIM ELSE CTNMN5=0D0 CTPMN5=CTLIM ENDIF ENDIF IF(CKIN(38).GT.0D0) THEN CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34 IF(CTLIM.GT.0D0) THEN CTPMX5=CTLIM ELSE CTPMX5=0D0 CTNMX5=CTLIM ENDIF ENDIF C...Net effect of all separate limits. VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5) VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5) VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5) VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5) IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1 ELSEIF(ILIM.EQ.4) THEN C...Calculate limits on tau' C...0) due to kinematics TAPMN0=TAU IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN PQRAT=(VINT(201)+VINT(206))/VINT(1) TAPMN0=(SQRT(TAU)+PQRAT)**2 ENDIF TAPMX0=1D0 C...1) due to explicit limits TAPMN1=CKIN(31)**2/VINT(2) TAPMX1=1D0 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2) C...Net effect of all separate limits. VINT(16)=MAX(TAPMN0,TAPMN1) VINT(36)=MIN(TAPMX0,TAPMX1) IF(MINT(47).EQ.1) THEN VINT(16)=1D0-1D-9 VINT(36)=1D0+1D-9 ELSEIF(MINT(47).EQ.5) THEN VINT(36)=MIN(VINT(36),1D0-2D-10) ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN VINT(36)=MIN(VINT(36),1D0-1D-10) ENDIF IF(VINT(36).LE.VINT(16)) MINT(51)=1 ENDIF RETURN C...Special case for low-pT and multiple interactions: C...effective kinematical limits for tau, y*, cos(theta-hat). 100 IF(ILIM.EQ.0) THEN ELSEIF(ILIM.EQ.1) THEN IF(MSTP(82).LE.1) THEN VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/ & VINT(2) ELSE VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2) ENDIF VINT(31)=1D0 ELSEIF(ILIM.EQ.2) THEN VINT(12)=0.5D0*LOG(VINT(21)) VINT(32)=-VINT(12) ELSEIF(ILIM.EQ.3) THEN IF(MSTP(82).LE.1) THEN ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/ & (VINT(21)*VINT(2)) ELSE ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/ & (VINT(21)*VINT(2)) ENDIF VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF)) VINT(33)=0D0 VINT(14)=0D0 VINT(34)=-VINT(13) ENDIF RETURN END C********************************************************************* C...PYKMAP C...Maps a uniform distribution into a distribution of a kinematical C...variable according to one of the possibilities allowed. It is C...assumed that kinematical limits have been set by a PYKLIM call. SUBROUTINE PYKMAP(IVAR,MVAR,VVAR) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/ C...Convert VVAR to tau variable. ISUB=MINT(1) ISTSB=ISET(ISUB) IF(IVAR.EQ.1) THEN TAUMIN=VINT(11) TAUMAX=VINT(31) IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN TAURE=VINT(73) GAMRE=VINT(74) ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN TAURE=VINT(75) GAMRE=VINT(76) ENDIF IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN TAU=1D0 ELSEIF(MVAR.EQ.1) THEN TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR ELSEIF(MVAR.EQ.2) THEN TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR) ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN) ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN AUPP=ATAN((TAUMAX-TAURE)/GAMRE) ALOW=ATAN((TAUMIN-TAURE)/GAMRE) TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR) ELSEIF(MINT(47).EQ.5) THEN AUPP=LOG(MAX(2D-10,1D0-TAUMAX)) ALOW=LOG(MAX(2D-10,1D0-TAUMIN)) TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP)) ELSE AUPP=LOG(MAX(1D-10,1D0-TAUMAX)) ALOW=LOG(MAX(1D-10,1D0-TAUMIN)) TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP)) ENDIF VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU)) C...Convert VVAR to y* variable. ELSEIF(IVAR.EQ.2) THEN YSTMIN=VINT(12) YSTMAX=VINT(32) TAUE=VINT(21) IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26) IF(MINT(47).EQ.1) THEN YST=0D0 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN YST=-0.5D0*LOG(TAUE) ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN YST=0.5D0*LOG(TAUE) ELSEIF(MVAR.EQ.1) THEN YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR) ELSEIF(MVAR.EQ.2) THEN YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR) ELSEIF(MVAR.EQ.3) THEN AUPP=ATAN(EXP(YSTMAX)) ALOW=ATAN(EXP(YSTMIN)) YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR)) ELSEIF(MVAR.EQ.4) THEN YST0=-0.5D0*LOG(TAUE) AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)) ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0)) YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW))) ELSE YST0=-0.5D0*LOG(TAUE) AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0)) ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)) YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0 ENDIF VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST)) C...Convert VVAR to cos(theta-hat) variable. ELSEIF(IVAR.EQ.3) THEN RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2) RSQM=1D0+RM34 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0) & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2))) CTNMIN=VINT(13) CTNMAX=VINT(33) CTPMIN=VINT(14) CTPMAX=VINT(34) IF(MVAR.EQ.1) THEN ANEG=CTNMAX-CTNMIN APOS=CTPMAX-CTPMIN IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN VCTN=VVAR*(ANEG+APOS)/ANEG CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN ELSE VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP ENDIF ELSEIF(MVAR.EQ.2) THEN RMNMIN=MAX(RM34,RSQM-CTNMIN) RMNMAX=MAX(RM34,RSQM-CTNMAX) RMPMIN=MAX(RM34,RSQM-CTPMIN) RMPMAX=MAX(RM34,RSQM-CTPMAX) ANEG=LOG(RMNMIN/RMNMAX) APOS=LOG(RMPMIN/RMPMAX) IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN VCTN=VVAR*(ANEG+APOS)/ANEG CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN ELSE VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP ENDIF ELSEIF(MVAR.EQ.3) THEN RMNMIN=MAX(RM34,RSQM+CTNMIN) RMNMAX=MAX(RM34,RSQM+CTNMAX) RMPMIN=MAX(RM34,RSQM+CTPMIN) RMPMAX=MAX(RM34,RSQM+CTPMAX) ANEG=LOG(RMNMAX/RMNMIN) APOS=LOG(RMPMAX/RMPMIN) IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN VCTN=VVAR*(ANEG+APOS)/ANEG CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM ELSE VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM ENDIF ELSEIF(MVAR.EQ.4) THEN RMNMIN=MAX(RM34,RSQM-CTNMIN) RMNMAX=MAX(RM34,RSQM-CTNMAX) RMPMIN=MAX(RM34,RSQM-CTPMIN) RMPMAX=MAX(RM34,RSQM-CTPMAX) ANEG=1D0/RMNMAX-1D0/RMNMIN APOS=1D0/RMPMAX-1D0/RMPMIN IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN VCTN=VVAR*(ANEG+APOS)/ANEG CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN) ELSE VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP) ENDIF ELSEIF(MVAR.EQ.5) THEN RMNMIN=MAX(RM34,RSQM+CTNMIN) RMNMAX=MAX(RM34,RSQM+CTNMAX) RMPMIN=MAX(RM34,RSQM+CTPMIN) RMPMAX=MAX(RM34,RSQM+CTPMAX) ANEG=1D0/RMNMIN-1D0/RMNMAX APOS=1D0/RMPMIN-1D0/RMPMAX IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN VCTN=VVAR*(ANEG+APOS)/ANEG CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM ELSE VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM ENDIF ENDIF IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH)) IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH)) VINT(23)=CTH C...Convert VVAR to tau' variable. ELSEIF(IVAR.EQ.4) THEN TAU=VINT(21) TAUPMN=VINT(16) TAUPMX=VINT(36) IF(MINT(47).EQ.1) THEN TAUP=1D0 ELSEIF(MVAR.EQ.1) THEN TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR ELSEIF(MVAR.EQ.2) THEN AUPP=(1D0-TAU/TAUPMX)**4 ALOW=(1D0-TAU/TAUPMN)**4 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0) ELSEIF(MINT(47).EQ.5) THEN AUPP=LOG(MAX(2D-10,1D0-TAUPMX)) ALOW=LOG(MAX(2D-10,1D0-TAUPMN)) TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP)) ELSE AUPP=LOG(MAX(1D-10,1D0-TAUPMX)) ALOW=LOG(MAX(1D-10,1D0-TAUPMN)) TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP)) ENDIF VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP)) C...Selection of extra variables needed in 2 -> 3 process: C...pT1, pT2, phi1, phi2, y3 for three outgoing particles. C...Since no options are available, the functions of PYKLIM C...and PYKMAP are joint for these choices. ELSEIF(IVAR.EQ.5) THEN C...Read out total energy and particle masses. MINT(51)=0 MPTPK=1 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352) & MPTPK=2 SHP=VINT(26)*VINT(2) SHPR=SQRT(SHP) PM1=VINT(201) PM2=VINT(206) PM3=SQRT(VINT(21))*VINT(1) IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN MINT(51)=1 RETURN ENDIF PMRS1=VINT(204)**2 PMRS2=VINT(209)**2 C...Specify coefficients of pT choice; upper and lower limits. IF(MPTPK.EQ.1) THEN HWT1=0.4D0 HWT2=0.4D0 ELSE HWT1=0.05D0 HWT2=0.05D0 ENDIF HWT3=1D0-HWT1-HWT2 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/ & (4D0*SHP) IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2) PTSMN1=CKIN(51)**2 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/ & (4D0*SHP) IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2) PTSMN2=CKIN(53)**2 C...Select transverse momenta according to C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2). HMX=PMRS1+PTSMX1 HMN=PMRS1+PTSMN1 IF(HMX.LT.1.0001D0*HMN) THEN MINT(51)=1 RETURN ENDIF HDE=PTSMX1-PTSMN1 RPT=PYR(0) IF(RPT.LT.HWT1) THEN PTS1=PTSMN1+PYR(0)*HDE ELSEIF(RPT.LT.HWT1+HWT2) THEN PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1) ELSE PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1) ENDIF WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+ & HWT3*HMN*HMX/(PMRS1+PTS1)**2) HMX=PMRS2+PTSMX2 HMN=PMRS2+PTSMN2 IF(HMX.LT.1.0001D0*HMN) THEN MINT(51)=1 RETURN ENDIF HDE=PTSMX2-PTSMN2 RPT=PYR(0) IF(RPT.LT.HWT1) THEN PTS2=PTSMN2+PYR(0)*HDE ELSEIF(RPT.LT.HWT1+HWT2) THEN PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2) ELSE PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2) ENDIF WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+ & HWT3*HMN*HMX/(PMRS2+PTS2)**2) C...Select azimuthal angles and check pT choice. PHI1=PARU(2)*PYR(0) PHI2=PARU(2)*PYR(0) PHIR=PHI2-PHI1 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR)) IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT. & CKIN(56)**2)) THEN MINT(51)=1 RETURN ENDIF C...Calculate transverse masses and check phase space not closed. PMS1=PM1**2+PTS1 PMS2=PM2**2+PTS2 PMS3=PM3**2+PTS3 PMT1=SQRT(PMS1) PMT2=SQRT(PMS2) PMT3=SQRT(PMS3) PM12=(PMT1+PMT2)**2 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN MINT(51)=1 RETURN ENDIF C...Select rapidity for particle 3 and check phase space not closed. Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2- & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3)) IF(Y3MAX.LT.1D-6) THEN MINT(51)=1 RETURN ENDIF Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX PZ3=PMT3*SINH(Y3) PE3=PMT3*COSH(Y3) C...Find momentum transfers in two mirror solutions (in 1-2 frame). PZ12=-PZ3 PE12=SHPR-PE3 PMS12=PE12**2-PZ12**2 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2)) IF(SQL12.LT.1D-6*SHP) THEN MINT(51)=1 RETURN ENDIF PMM1=PMS12+PMS1-PMS2 PMM2=PMS12+PMS2-PMS1 TFAC=-SHPR/(2D0*PMS12) T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12) T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12) T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12) T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12) C...Construct relative mirror weights and make choice. IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN WTPU=1D0 WTNU=1D0 ELSE WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2 ENDIF WTP=WTPU/(WTPU+WTNU) WTN=WTNU/(WTPU+WTNU) EPS=1D0 IF(WTN.GT.PYR(0)) EPS=-1D0 C...Store result of variable choice and associated weights. VINT(202)=PTS1 VINT(207)=PTS2 VINT(203)=PHI1 VINT(208)=PHI2 VINT(205)=WTPTS1 VINT(210)=WTPTS2 VINT(211)=Y3 VINT(212)=Y3MAX VINT(213)=EPS IF(EPS.GT.0D0) THEN VINT(214)=1D0/WTP VINT(215)=T1P VINT(216)=T2P ELSE VINT(214)=1D0/WTN VINT(215)=T1N VINT(216)=T2N ENDIF VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12) VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12) VINT(219)=0.5D0*(PMS12-PTS3) VINT(220)=SQL12 ENDIF RETURN END C*********************************************************************** C...PYSIGH C...Differential matrix elements for all included subprocesses C...Note that what is coded is (disregarding the COMFAC factor) C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where, C...when d(sigma-hat) is given in the zero-width limit, the delta C...function in tau is replaced by a (modified) Breit-Wigner: C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2), C...where H_res = s-hat/m_res*Gamma_res(s-hat); C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat); C...i.e., dimensionless quantities C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) * C...(2pi)^4 delta^4(P - sum p_i) C...COMFAC contains the factor pi/s (or equivalent) and C...the conversion factor from GeV^-2 to mb SUBROUTINE PYSIGH(NCHN,SIGS) C...Double precision and integer declarations IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT7/SIGT(0:6,0:6,0:5) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/, &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/, &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYSGCM/ C...Local arrays and complex variables DIMENSION XPQ(-25:25) C...Map of processes onto which routine to call C...in order to evaluate cross section: C...0 = not implemented; C...1 = standard QCD (including photons); C...2 = heavy flavours; C...3 = W/Z; C...4 = Higgs (2 doublets; including longitudinal W/Z scattering); C...5 = SUSY; C...6 = Technicolor; C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*). DIMENSION MAPPR(500) DATA (MAPPR(I),I=1,180)/ & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1, 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3, 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3, 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0, 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0, 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3, 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1, 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0, 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0, & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4, 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0, 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0, 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0, 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0, 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/ DATA (MAPPR(I),I=181,500)/ 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0, & 100*5, & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 30*0, 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0, 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6, 7 6, 6, 6, 6, 6, 6, 6, 0, 0, 0, 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0, 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0, & 4, 4, 18*0, 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0, 4 20*0, 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0, 8 20*0/ C...Reset number of channels and cross-section NCHN=0 SIGS=0D0 C...Read process to consider. ISUB=MINT(1) ISUBSV=ISUB MAP=MAPPR(ISUB) C...Read kinematical variables and limits ISTSB=ISET(ISUBSV) TAUMIN=VINT(11) YSTMIN=VINT(12) CTNMIN=VINT(13) CTPMIN=VINT(14) TAUPMN=VINT(16) TAU=VINT(21) YST=VINT(22) CTH=VINT(23) XT2=VINT(25) TAUP=VINT(26) TAUMAX=VINT(31) YSTMAX=VINT(32) CTNMAX=VINT(33) CTPMAX=VINT(34) TAUPMX=VINT(36) C...Derive kinematical quantities TAUE=TAU IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP X(1)=SQRT(TAUE)*EXP(YST) X(2)=SQRT(TAUE)*EXP(-YST) IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN IF(X(1).GT.1D0-1D-7) RETURN ELSEIF(MINT(45).EQ.3) THEN X(1)=MIN(1D0-1.1D-10,X(1)) ENDIF IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN IF(X(2).GT.1D0-1D-7) RETURN ELSEIF(MINT(46).EQ.3) THEN X(2)=MIN(1D0-1.1D-10,X(2)) ENDIF SH=MAX(1D0,TAU*VINT(2)) SQM3=VINT(63) SQM4=VINT(64) RM3=SQM3/SH RM4=SQM4/SH BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) RPTS=4D0*VINT(71)**2/SH BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS)) RM34=MAX(1D-20,2D0*RM3*RM4) RSQM=1D0+RM34 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0) &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2))) RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L) IF(ISTSB.EQ.0) THEN TH=VINT(45) UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH) SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2) ELSE C...Kinematics with incoming masses tricky: now depends on how C...subprocess has been set up w.r.t. order of incoming partons. RM1=0D0 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH RM2=0D0 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH IF(ISUB.EQ.35) THEN RM2=MIN(RM1,RM2) RM1=0D0 ENDIF BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4) TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3- & BE12*BE34*CTH) UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+ & BE12*BE34*CTH) SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2)) ENDIF SHR=SQRT(SH) SH2=SH**2 TH2=TH**2 UH2=UH**2 C...Choice of Q2 scale for hard process (e.g. alpha_s). IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN Q2=SH ELSEIF(ISTSB.EQ.8) THEN IF(MINT(107).EQ.4) Q2=VINT(307) IF(MINT(108).EQ.4) Q2=VINT(308) ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN Q2IN1=0D0 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2 Q2IN2=0D0 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2 IF(MSTP(32).EQ.1) THEN Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2) ELSEIF(MSTP(32).EQ.2) THEN Q2=SQPTH+0.5D0*(SQM3+SQM4) ELSEIF(MSTP(32).EQ.3) THEN Q2=MIN(-TH,-UH) ELSEIF(MSTP(32).EQ.4) THEN Q2=SH ELSEIF(MSTP(32).EQ.5) THEN Q2=-TH ELSEIF(MSTP(32).EQ.6) THEN XSF1=X(1) IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143) XSF2=X(2) IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144) Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)* & (SQPTH+0.5D0*(SQM3+SQM4)) ELSEIF(MSTP(32).EQ.7) THEN Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4)) ELSEIF(MSTP(32).EQ.8) THEN Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4) ELSEIF(MSTP(32).EQ.9) THEN Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4 ELSEIF(MSTP(32).EQ.10) THEN Q2=VINT(2) C..Begin JA 040914 ELSEIF(MSTP(32).EQ.11) THEN Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4)) ELSEIF(MSTP(32).EQ.12) THEN Q2=PARP(193) C..End JA ELSEIF(MSTP(32).EQ.13) THEN Q2=SQPTH ENDIF IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+ & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2 ENDIF C...Choice of Q2 scale for parton densities. Q2SF=Q2 C..Begin JA 040914 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5)) & Q2=PARP(194) C..End JA IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN Q2SF=PMAS(23,1)**2 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR. & ISUB.EQ.351) Q2SF=PMAS(24,1)**2 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR. & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2 IF(MSTP(39).EQ.2) Q2SF= & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207)) IF(MSTP(39).EQ.3) Q2SF=SH IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2) IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2 C..Begin JA 040914 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2 IF(MSTP(39).EQ.7) Q2SF= & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0 IF(MSTP(39).EQ.8) Q2SF=PARP(193) C..End JA ENDIF ENDIF IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH Q2PS=Q2SF Q2SF=Q2SF*PARP(34) IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2) IF(MSTP(69).GE.2) Q2SF=VINT(2) C...Identify to which class(es) subprocess belongs C...(in principle, a separate class, "+ gamma" should also be C...defined, but this ignored for present.) ISMECR=0 ISQCD=0 ISJETS=0 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.102.OR. & ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.ISUBSV.EQ.144.OR. & ISUBSV.EQ.152.OR.ISUBSV.EQ.157) ISMECR=1 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR. & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1 IF (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...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...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...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)