C********************************************************************* C********************************************************************* C* ** C* March 1997 ** C* ** C* The Lund Monte Carlo for Hadronic Processes ** C* ** C* PYTHIA version 6.1 ** C* ** C* Torbjorn Sjostrand ** C* Department of Theoretical Physics 2 ** C* Lund University ** C* Solvegatan 14A, S-223 62 Lund, Sweden ** C* phone +46 - 46 - 222 48 16 ** C* E-mail torbjorn@thep.lu.se ** C* ** C* SUSY parts by ** C* Stephen Mrenna ** C* Argonne National Laboratory ** C* 9700 South Cass Avenue, Argonne, IL 60439, USA ** C* phone + 1 - 630 - 252 - 7615 ** C* E-mail mrenna@hep.anl.gov ** C* ** C* Several parts are written by Hans-Uno Bengtsson ** C* PYSHOW is written together with Mats Bengtsson ** C* advanced popcorn baryon production written by Patrik Eden ** C* CTEQ 3 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* ** C* The latest program version and documentation is found on WWW ** C* http://www.thep.lu.se/tf2/staff/torbjorn/Pythia.html ** C* ** C* Copyright Torbjorn Sjostrand, Lund 1997 ** 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 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 PYSTAT to print cross-section and other information * 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 PYRAND to select subprocess and kinematics for event * C S PYSCAT to set up kinematics and colour flow of event * C S PYSSPA to simulate initial state spacelike showers * C S PYRESD to perform resonance decays * C S PYMULT to generate multiple interactions * C S PYREMN to add on target remnants * C S PYDIFF to set up kinematics for diffractive events * 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 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 pdf's * C S PYGBEH to evaluate Bethe-Heitler part of photon pdf's * C S PYGDIR to evaluate direct contribution to photon pdf's * 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 pronton parton distributions * C S PYGRVM to evaluate the GRV 94M pronton parton distributions * C S PYGRVD to evaluate the GRV 94D pronton 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 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 * C S PYMSIN to initialize the supersymmetry simulation * C S PYAPPS to determine MSSM parameters from SUGRA input * C F PYRNMQ to determine running quark masses * C F PYRNMT to determine running top mass * 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 PYVACU to determine Higgs masses in the MSSM * C S PYRGHM auxiliary to PYVACU * C S PYGFXX auxiliary to PYRGHM * C F PYFINT auxiliary to PYVACU * 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 PYXXZ5 auxiliary for neutralino 3-body decay * C F PYXXW5 auxiliary for ino charge change 3-body decay * 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 F PYXXZ2 auxiliary for chargino 3-body 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 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 * 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 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 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 timelike parton shower evolution * C S PYBOEI to include Bose-Einstein effects (crudely) * C F PYMASS to give the mass of a particle or parton * 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 PYUPIN dummy routine to initialize a user process * C S PYUPEV dummy routine to generate a user process event * C S PDFSET dummy routine to be removed when using PDFLIB * C S STRUCTM dummy routine to be removed when using PDFLIB * 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) 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(4000,2),BRAT(4000),KFDP(4000,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) 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/,/PYBINS/ C...PYDAT1, containing status codes and most parameters. DATA MSTU/ & 0, 0, 0, 4000,10000, 500, 4000, 0, 0, 2, 1 6, 1, 1, 0, 1, 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/ & 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, & 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, 1000D0, 1.0D0, 1.0D0, 1.0D0, 1.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, 0, 0, 0, 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, 0, 0, 0, 0, 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,2.5D0,0.6D0,0D0, 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.0D0,0D0,0D0, 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0, 5 -0.00001D0, -0.00001D0, -0.00001D0, 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, 0D0, 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0, 0D0, 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 60*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,0,-1,12*0,3,2*0,3,28*0,2,-1,20*0,4*3, &8*0,3*3,4*0,3*3,3*0,3*3,7*0,3*3,3*0,3*3,3*0,-2,-3,2*1,3*0,4,3*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,0,-1,2,-3,164*0/ DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,16*0,2,1,113*0,-1,0,2*-1, &3*0,-1,4*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,6*0,2*1,165*0/ DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,0,2*1, &11*0,1,2*0,1,26*0,1,0,2*1,20*0,4*1,5*0,6*1,4*0,9*1,4*0,12*1,3*0, &102*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,16*1,163*0/ DATA (KCHG(I,4),I= 1, 293)/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,210,211,213,215,220,221,223,225,310,311, &313,315,321,323,325,330,331,333,335,411,413,415,421,423,425,431, &433,435,440,441,443,445,511,513,515,521,523,525,531,533,535,541, &543,545,551,553,555,1103,1114,2101,2103,2110,2112,2114,2203,2210, &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/ DATA (KCHG(I,4),I= 294, 500)/20443,20513,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,4000001,4000002,4000011,4000012,163*0/ DATA (PMAS(I,1),I= 1, 214)/0.0099D0,0.0056D0,0.199D0,1.35D0, &5D0,175D0,2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0, &400D0,5*0D0,91.187D0,80.33D0,80D0,6*0D0,500D0,900D0,500D0, &3*300D0,350D0,200D0,5000D0,10*0D0,3*100D0,3*200D0,26*0D0,1D0,2D0, &5D0,16*0D0,0.13498D0,0.7685D0,1.318D0,0.49767D0,0D0,0.13957D0, &0.7669D0,1.318D0,0D0,0.54745D0,0.78194D0,1.275D0,2*0.49767D0, &0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,0D0,0.95777D0, &1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,2.0067D0,2.46D0, &1.9685D0,2.1124D0,2.5735D0,0D0,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, &0.77133D0,1.234D0,0.57933D0,0.77133D0,0D0,0.93957D0,1.233D0, &0.77133D0,0D0,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/ DATA (PMAS(I,1),I= 215, 500)/5.641D0,5.84D0,7.00575D0,5.38897D0, &5.40145D0,5.8D0,5.81D0,5.8D0,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, &4*400D0,163*0D0/ DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.4D0,16*0D0,2.47833D0, &2.069D0,0.00295D0,6*0D0,14.67788D0,0D0,16.79392D0,8.45231D0, &4.93534D0,5.80468D0,19.1898D0,0.39162D0,417.35283D0,62*0D0, &0.151D0,0.107D0,3*0D0,0.149D0,0.107D0,2*0D0,0.00843D0,0.185D0, &2*0D0,0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0D0,0.0002D0, &0.00443D0,0.076D0,2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0D0, &0.0013D0,0D0,0.002D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0, &2*0D0,0.02D0,4*0D0,0.12D0,4*0D0,0.12D0,3*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,2.60511D0,2.60839D0,0.42904D0,0.41921D0,163*0D0/ DATA (PMAS(I,3),I= 1, 500)/5*0D0,14D0,16*0D0,24.78326D0, &20.69D0,0.02954D0,6*0D0,146.77876D0,0D0,167.93924D0,84.52308D0, &49.35344D0,58.04675D0,191.89803D0,3.91624D0,4173.5283D0,62*0D0, &0.4D0,0.25D0,3*0D0,0.4D0,0.25D0,2*0D0,0.1D0,0.17D0,2*0D0,0.2D0, &0.12D0,0D0,0.2D0,0.12D0,0D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0, &2*0D0,0.12D0,2*0D0,0.05D0,0D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0, &2*0D0,0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,4*0D0,0.14D0,4*0D0,0.14D0, &3*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,26.05109D0,26.08388D0,4.29043D0,4.19206D0,163*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,0D0,7804.5D0,6*0D0, &26.762D0,3*0D0,3709D0,6*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0, &6*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,19*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,83*0D0,163*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 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 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, &7*1,10*0,2*1,0,3*1,26*0,3*1,16*0,3*1,3*0,2*1,0,7*1,0,2*1,0,12*1, &0,18*1,0,1,4*0,1,3*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,4*1,163*0/ DATA (MDCY(I,2),I= 1, 500)/1,9,17,25,33,41,54,64,2*0,74,78,80, &85,87,141,143,148,2*0,151,160,172,188,208,6*0,287,0,309,332,414, &494,521,524,525,10*0,534,539,0,544,564,588,26*0,606,607,611,16*0, &620,622,627,636,0,645,647,649,0,656,664,670,679,681,683,686,696, &702,705,0,716,722,733,739,802,805,813,874,876,884,917,919,0,923, &924,927,929,965,966,974,1010,1011,1019,1058,1059,1063,1094,1095, &1099,1100,1109,0,1111,4*0,1112,3*0,1115,1118,2*0,1119,1121,1124, &2*0,1128,1129,1132,1135,0,1138,1143,1145,1148,1150,2*0,1154,1155, &1156,1232,2*0,1236,1237,1238,1239,1240,2*0,1244,1245,1247,1248, &1250,1254,0,1255,1259,1263,1267,1271,1275,1279,2*0,1283,1284, &1285,1302,1311,2*0,1320,1321,1322,1323,1324,1333,2*0,1342,1343, &1344,1345,1346,1355,1356,2*0,1365,1374,1383,1392,1401,1410,1419, &1428,0,1437,1446,1455,1464,1473,1482,1491,1500,1509,1518,1519, &1520,1521,1522,1527,1530,1532,1537,1539,1544,1551,1555,1557,1559, &1561,1563,1565,1567,1569,1570,1572,1574,1576,1578,1580,1582,1584, &1586,1588,1589,1591,1593,1607,1609,1611,1615,1617,1619,1621,1623, &1625,1627,1629,1631,1633,1644,1658,1670,1682,1694,1706,1718,1731, &1742,1753,1764,1775,1786,1797,1858,1863,1965,2021,2139,2273,0, &2344,2360,2376,2392,2408,2424,2440,0,2455,0,2470,0,2485,2489, &2493,2496,163*0/ DATA (MDCY(I,3),I= 1, 500)/5*8,13,2*10,2*0,4,2,5,2,54,2,5,3, &2*0,9,12,16,20,79,6*0,22,0,23,82,80,27,3,1,9,10*0,2*5,0,20,24,18, &26*0,1,4,9,16*0,2,5,2*9,0,2*2,7,0,8,6,9,2*2,3,10,6,3,11,0,6,11,6, &63,3,8,61,2,8,33,2,4,0,1,3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,0, &1,4*0,3,3*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,5*12,13,6*11,61,5,102,56,118,134,71,0,6*16,15,0,15,0, &15,0,2*4,3,2,163*0/ DATA (MDME(I,1),I= 1,4000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1, &7*1,-1,1,-1,12*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,6*1,2*-1,7*1,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,197*1,2*-1,2*1,-1,20*1, &2*-1,6*1,2*-1,7*1,-1,3*1,-1,3*1,5*-1,3*1,-1,1,-1,6*1,2*-1,6*1, &2*-1,1892*1,1503*0/ DATA (MDME(I,2),I= 1,4000)/43*102,4*0,102,0,4*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,21*0,62*53,8*32,14*0, &16*32,27*0,62*53,18*0,62*53,9*0,18*53,3*32,0,6*32,3*0,2*32,3*0, &2*32,7*0,8*32,12*0,16*32,6*0,8*32,8*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,828*53,1515*0/ DATA (BRAT(I) ,I= 1, 418)/43*0D0,0.00003D0,0.00177D0,0.9982D0, &33*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.15403D0,0.11945D0,0.15402D0,0.11931D0,0.15215D0,3*0D0, &0.03357D0,0.0668D0,0.03357D0,0.0668D0,0.0335D0,0.0668D0,2*0D0, &0.32139D0,0.0165D0,2*0D0,0.0165D0,0.32067D0,2*0D0,0.00001D0, &0.00059D0,6*0D0,2*0.10814D0,0.10806D0,3*0D0,0.00031D0,0.04438D0, &0.88031D0,4*0D0,0.0002D0,0.05531D0,0D0,0.01838D0,0.00071D0,0D0, &0.00009D0,0.00032D0,62*0D0,0.14449D0,0.11223D0,0.14449D0, &0.11223D0,0.14443D0,0.05782D0,2*0D0,0.03172D0,0.06305D0, &0.03172D0,0.06305D0,0.03172D0,0.06305D0,8*0D0,0.24928D0,0.0128D0, &0.00001D0,0D0,0.0128D0,0.24882D0,0.00039D0,0D0,0.00001D0, &0.00046D0,0.22153D0,5*0D0,2*0.08464D0,0.08463D0,7*0D0,0.00005D0, &0.00097D0,5*0D0,0.00007D0,0D0,0.00049D0,0.00001D0,0.00006D0, &0.30591D0,0.68863D0,0D0,0.0038D0,66*0D0,0.00008D0,0.00167D0/ DATA (BRAT(I) ,I= 419, 722)/5*0D0,0.00013D0,0D0,0.00294D0, &0.00001D0,3*0D0,0.99517D0,63*0D0,0.00002D0,0.07231D0,2*0D0, &0.00001D0,0.00269D0,0D0,0.92497D0,18*0D0,0.0024D0,0.99483D0, &0.00278D0,1D0,3*0.21511D0,0.21478D0,2*0D0,2*0.06995D0,2*0D0,1D0, &3*0D0,0.95D0,0.05D0,3*0D0,4*0.25D0,16*0D0,4*0.25D0,20*0D0,1D0, &17*0D0,1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,0.5D0,0.08D0, &0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,0.998739D0, &0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0,0.144D0, &0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,0.1256D0, &2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,0.999877D0, &0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,0.104D0, &0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,0.0478D0, &0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,0.0221D0, &0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,0.023D0, &2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,0.665D0, &0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,0.043D0, &0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,0.0173D0, &0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,0.166D0, &0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,2*0.002D0, &0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0,0.48947D0/ DATA (BRAT(I) ,I= 723, 897)/0.34D0,3*0.043D0,0.027D0,0.0126D0, &0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0, &2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0, &0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,0.066D0, &0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,0.001D0, &0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,0.006D0, &0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,0.027D0, &0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,0.022D0, &0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,0.306D0, &0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0, &0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,0.027D0, &2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,0.062D0, &3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,0.0109D0, &0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,2*0.0016D0, &0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,0.0034D0, &0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,0.022D0, &0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,0.0511D0, &0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,0.16D0, &0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0, &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/ DATA (BRAT(I) ,I= 898,1063)/0.079D0,0.095D0,0.052D0,0.0078D0, &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0, &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0, &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0, &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0, &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0, &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0, &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0, &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0, &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0, &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0, &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0, &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0, &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0, &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0, &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0, &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0, &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0, &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0, &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/ DATA (BRAT(I) ,I=1064,1254)/0.122D0,0.006D0,0.012D0,0.035D0, &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0, &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0, &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0, &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0, &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0, &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0, &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0, &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0, &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0, &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0, &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0, &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0, &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0, &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0, &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0, &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0, &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0, &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0, &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/ DATA (BRAT(I) ,I=1255,1447)/2*0.08D0,0.76D0,3*0.08D0,0.76D0, &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0, &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0, &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0, &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0, &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0, &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0, &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0, &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0, &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0, &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/ DATA (BRAT(I) ,I=1448,1648)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0, &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0, &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0, &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0, &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0, &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0, &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0, &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0, &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0, &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0, &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0, &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/ DATA (BRAT(I) ,I=1649,4000)/0.008D0,0.024D0,0.425D0,0.02D0, &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,827*0D0,0.8516D0, &0.00539D0,0.04483D0,0.09819D0,0.85053D0,0.02152D0,0.02989D0, &0.09806D0,0.29439D0,0.10943D0,0.59618D0,0.38983D0,0.61017D0, &1503*0D0/ DATA (KFDP(I,1),I= 1, 375)/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,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,36,1000022,2*1000023, &3*1000025,4*1000035,2*1000024,2*1000037,1000001,2000001,1000001, &-1000001,1000002,2000002,1000002,-1000002,1000003,2000003/ DATA (KFDP(I,1),I= 376, 606)/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,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,5,6,21,2,1, &2,3,4,5,6,11,13,15,4,5,11,13,15,2*4,-11,-13,-15,2*24,2*52,1,2,3, &4,5,6,7,8,11,12,13,14,15,16,17,18,2*24,2*52,4*-1,4*-3,4*-5,4*-7, &-11,-13,-15,-17,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,82/ DATA (KFDP(I,1),I= 607,1001)/-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,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/ DATA (KFDP(I,1),I=1002,1428)/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,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/ DATA (KFDP(I,1),I=1429,1710)/-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,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,1000039,1000024,1000037, &1000022,1000023,1000025,1000035,1000001,2000001,1000001,2000001, &1000021,1000039,-1000024,-1000037,1000022,1000023,1000025, &1000035,1000004,2000004,1000004,2000004,1000021,1000039,1000024, &1000037,1000022,1000023,1000025,1000035,1000003,2000003,1000003, &2000003,1000021,1000039,-1000024,-1000037,1000022,1000023/ DATA (KFDP(I,1),I=1711,1900)/1000025,1000035,1000006,2000006, &1000006,2000006,1000021,1000039,1000024,1000037,1000022,1000023, &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022, &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035, &1000012,2000012,1000012,2000012,1000039,1000024,1000037,1000022, &1000023,1000025,1000035,1000011,2000011,1000011,2000011,1000039, &-1000024,-1000037,1000022,1000023,1000025,1000035,1000014, &2000014,1000014,2000014,1000039,1000024,1000037,1000022,1000023, &1000025,1000035,1000013,2000013,1000013,2000013,1000039,-1000024, &-1000037,1000022,1000023,1000025,1000035,1000016,2000016,1000016, &2000016,1000039,1000024,1000037,1000022,1000023,1000025,1000035, &1000015,2000015,1000015,2000015,1000039,1000001,-1000001,2000001, &-2000001,1000002,-1000002,2000002,-2000002,1000003,-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,10*1000039,16*1000022,1000024,-1000024,1000024, &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024, &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037/ DATA (KFDP(I,1),I=1901,2095)/-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, &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, &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,2000001, &-2000001,1000002,-1000002,2000002,-2000002,1000003,-1000003/ DATA (KFDP(I,1),I=2096,2323)/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, &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,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,2*1000039,15*1000024, &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025, &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004/ DATA (KFDP(I,1),I=2324,4000)/-1000003,-2000003,1000006,2000006, &-1000005,-2000005,1000012,2000012,-1000011,-2000011,1000014, &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015, &2*1000021,1000039,-1000024,-1000037,1000022,1000023,1000025, &1000035,4*1000001,1000002,2000002,1000002,2000002,1000021, &1000039,1000024,1000037,1000022,1000023,1000025,1000035, &4*1000002,1000001,2000001,1000001,2000001,1000021,1000039, &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003, &1000004,2000004,1000004,2000004,1000021,1000039,1000024,1000037, &1000022,1000023,1000025,1000035,4*1000004,1000003,2000003, &1000003,2000003,1000021,1000039,-1000024,-1000037,1000022, &1000023,1000025,1000035,4*1000005,1000006,2000006,1000006, &2000006,1000021,1000039,1000024,1000037,1000022,1000023,1000025, &1000035,4*1000006,1000005,2000005,1000005,2000005,1000021, &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035, &4*1000011,1000012,2000012,1000012,2000012,1000039,-1000024, &-1000037,1000022,1000023,1000025,1000035,4*1000013,1000014, &2000014,1000014,2000014,1000039,-1000024,-1000037,1000022, &1000023,1000025,1000035,4*1000015,1000016,2000016,1000016, &2000016,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1503*0/ DATA (KFDP(I,2),I= 1, 337)/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,4*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= 338, 524)/-7,-8,-11,-13,-15,-17,21,22,2*23, &-24,2*25,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,25,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,-5,-6,21,11/ DATA (KFDP(I,2),I= 525, 940)/-3,-4,-5,-6,-7,-8,-13,-15,-17,-4,-5, &-11,-13,-15,-5,-3,12,14,16,-24,-52,-24,-52,-1,-2,-3,-4,-5,-6,-7, &-8,-11,-12,-13,-14,-15,-16,-17,-18,23,51,23,51,2,4,6,8,2,4,6,8,2, &4,6,8,2,4,6,8,12,14,16,18,2*51,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12, &-13,-14,-15,-16,-17,-18,-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/ DATA (KFDP(I,2),I= 941,1318)/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, &-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/ DATA (KFDP(I,2),I=1319,1774)/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,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,1,2,2*1,4*2,2*24,2*37,2, &3,2*4,4*3,2*-24,2*-37,3,4,2*3,4*4,2*24,2*37,4,5,2*6,4*5,2*-24, &2*-37,5,6,2*5,4*6,2*24,2*37,6,4,11,2*12,4*11,2*-24,2*-37,12,2*11, &4*12,2*24,2*37,13,2*14,4*13,2*-24,2*-37,14,2*13,4*14,2*24,2*37/ DATA (KFDP(I,2),I=1775,2218)/15,2*16,4*15,2*-24,2*-37,16,2*15, &4*16,2*24,2*37,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,22,23,25,35,36,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,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,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,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/ DATA (KFDP(I,2),I=2219,4000)/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,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,1,2*2,4*1,23,25,35,36,2*-24,2*-37,1,2,2*1,4*2,23,25,35,36, &2*24,2*37,2,3,2*4,4*3,23,25,35,36,2*-24,2*-37,3,4,2*3,4*4,23,25, &35,36,2*24,2*37,4,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,6,2*5,4*6, &23,25,35,36,2*24,2*37,6,11,2*12,4*11,23,25,35,36,2*-24,2*-37,13, &2*14,4*13,23,25,35,36,2*-24,2*-37,15,2*16,4*15,23,25,35,36,2*-24, &2*-37,3*1,4*2,1,2*11,2*12,11,1503*0/ DATA (KFDP(I,3),I= 1,1087)/79*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, &470*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=1088,2186)/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,167*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,12*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,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,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,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/ DATA (KFDP(I,3),I=2187,4000)/-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,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,1657*0/ DATA (KFDP(I,4),I= 1,4000)/92*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,470*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,2450*0/ DATA (KFDP(I,5),I= 1,4000)/94*0,2*111,17*0,111,7*0,2*111,0, &3*111,0,111,665*0,-211,2*111,-211,111,-211,111,65*0,111,-211, &3*111,-211,111,3127*0/ C...PYDAT4, with particle names (character strings). DATA (CHAF(I,1),I= 1, 190)/'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',2*' ','reggeon', &'pomeron',2*' ','Z''0','Z"0','W''+','H0','A0','H+','eta_tech0', &'LQ_ue','R0',10*' ','pi_tech0','pi_tech+','pi''_tech0', &'rho_tech0','rho_tech+','omega_tech',24*' ','specflav', &'rndmflav','phasespa','c-hadron','b-hadron',5*' ','cluster', &'string','indep.','CMshower','SPHEaxis','THRUaxis','CLUSjet', &'CELLjet','table',' ','rho_diff0','pi0','rho0','a_20','K_L0', &'pi_diffr+','pi+','rho+','a_2+','omega_di','eta','omega','f_2', &'K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','phi_diff','eta''', &'phi','f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+', &'D*_s+','D*_2s+','J/psi_di','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','dd_1','Delta-', &'ud_0','ud_1','n_diffr0','n0','Delta0','uu_1','p_diffr+','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+'/ DATA (CHAF(I,1),I= 191, 317)/'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++','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+'/ DATA (CHAF(I,1),I= 318, 500)/'~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','d*','u*','e*-', &'nu*_e0',163*' '/ DATA (CHAF(I,2),I= 1, 206)/'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-',' ','LQ_uebar','Rbar0',11*' ','pi_tech-',2*' ', &'rho_tech-',26*' ','rndmflavbar',' ','c-hadronbar','b-hadronbar', &20*' ','pi_diffr-','pi-','rho-','a_2-',5*' ','Kbar0','K*bar0', &'K*_2bar0','K-','K*-','K*_2-',4*' ','D-','D*-','D*_2-','Dbar0', &'D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',4*' ','Bbar0', &'B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0','B*_sbar0', &'B*_2sbar0','B_c-','B*_c-','B*_2c-',3*' ','dd_1bar','Deltabar+', &'ud_0bar','ud_1bar','n_diffrbar0','nbar0','Deltabar0','uu_1bar', &'p_diffrbar-','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--'/ DATA (CHAF(I,2),I= 207, 324)/'Xi*_ccbar--','Omega_ccbar-', &'Omega*_ccbar-','Omega*_cccbar-','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'/ DATA (CHAF(I,2),I= 325, 500)/'~c_Rbar','~b_2bar','~t_2bar', &'~e_R+','~nu_eRbar','~mu_R+','~nu_muRbar','~tau_2+', &'~nu_tauRbar','d*bar','u*bar','e*bar+','nu*_ebar0',163*' '/ 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, -10D0, 10D0, 1 -10D0, 10D0, -10D0, 10D0, -10D0, 1 10D0, -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 140*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, 0, 5, 0, 0, 0, 0, 0, 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1, 3 1, 2, 0, 1, 0, 2, 1, 5, 2, 0, 4 1, 1, 3, 7, 3, 1, 1, 0, 1, 0, 5 4, 1, 3, 1, 5, 1, 1, 6, 1, 7, 6 1, 3, 2, 2, 1, 1, 2, 0, 0, 0, 7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8 1, 1, 100, 0, 0, 0, 0, 0, 0, 0, 9 1, 4, 1, 2, 0, 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, 50, 0, 0, 10, 0, 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0, 4 0, 0, 0, 0, 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, 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, 8 6, 115, 1998, 01, 27, 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.6D0, 1.0D0, 1.0D0, 3*0D0, 2 10*0D0, 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,2.0D0,0.70D0,0.006D0,0D0, 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0, 123D0, 246D0, 50D0, 2*0D0, 5 1.0D0, 9*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, 8*0D0, 8 1.40D0,1.55D0,0.5D0, 0.2D0,0.33D0,0.66D0, 0.7D0, 0.5D0,2*0D0, 9 0.44D0,0.20D0,2.0D0,1.0D0,0D0,3.0D0,1.0D0,0.75D0,0.44D0,2.0D0/ DATA (PARP(I),I=101,200)/ & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 6*0D0, 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 0.33333D0, 82D0, 1D0, 4D0, 200D0, 5*0D0, 5 0D0, 0D0, 0D0, 0D0, 6*0D0, 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 6*0D0, 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0, 8 20*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, -1, 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, -2, -2/ DATA (ISET(I),I=101,200)/ & -1, 1, 1, -2, -2, 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 -1, -2, -2, -2, -2, -2, -2, -2, -2, -2, 4 1, 1, 1, 1, 1, -2, 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)/200*-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, 0, 0, 0, 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 23, 5, 0, 0, 0, 0, 0, 0, 0, 0, 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4 32, 0, 34, 0, 37, 0, 40, 0, 39, 0, 4 0, 0, 4000001, 0, 4000002, 0, 38, 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, 39, 0, 39, 39, 39, 39, 11, 0, 6 11, 0, 0, 4000001, 0, 4000002, 0, 0, 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, 0, 0, 0, 0, 0, 0, 8 36, 6, 36, 6, 0, 0, 0, 0, 0, 0, 9 54, 0, 55, 0, 56, 0, 11, 0, 0, 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,500)/440*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,7*1, &10*0,2*1,0,3*1,245*0,19*2,0,7*2,0,2,0,2,0,4*1,163*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' ', ' '/ DATA (PROC(I),I=101,120)/ &'g + g -> gamma*/Z0 ', 'g + g -> h0 ', &'gamma + gamma -> h0 ', ' ', &' ', 'g + g -> J/Psi + gamma ', &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma', &' ', 'f + fbar -> gamma + h0 ', 1'f + fbar -> 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'g + g -> Z0 + q + qbar ', ' ', 3' ', ' ', 3' ', ' ', 3' ', ' ', 3' ', ' '/ 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 ', ' ', 4'd + g -> d* ', 'u + g -> u* ', 4'g + g -> eta_techni ', ' ', 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' ', ' ', 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' ', ' ', 8' ', 'g + g -> Q + Qbar + A0 ', 8'q + qbar -> Q + Qbar + A0 ', ' ', 8' ', ' ', 9'f + fbar -> rho_tech0 ', 'f + f'' -> rho_tech+/- ', 9'f + fbar -> omega_tech0 ', 'f+fbar -> f''+fbar'' (technic)', 9' ', ' ', 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,280)/ 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 '/ DATA (PROC(I),I=281,500)/220*' '/ 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, 1, 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,24D17,2*0D0, 3 69*0D0/ C...Data for histogramming routines. DATA IHIST/1000,20000,55,1/ DATA INDX/1000*0/ 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) 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(4000,2),BRAT(4000),KFDP(4000,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.4D0) & 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('USER','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) 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 140 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 IF(I.GE.INEW+3.AND.K(I-1,1).EQ.21.AND.K(I-1,3).EQ.0) & IMO1=IMO1-1 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 120 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 120 KC=PYCOMP(K(I1,2)) IF(I1.LT.I.AND.KC.EQ.0) GOTO 120 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 120 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 130 I1=JDAHEP(1,I),JDAHEP(2,I) I2=MOD(K(I1,4)/MSTU(5),MSTU(5)) JDAHEP(1,I2)=I 130 CONTINUE ENDIF IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 140 I1=JMOHEP(1,I) IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 140 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 140 IF(JDAHEP(1,I1).EQ.0) THEN JDAHEP(1,I1)=I ELSE JDAHEP(2,I1)=I ENDIF 140 CONTINUE DO 150 I=1,NHEP IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 150 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I) 150 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 180 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 160 J=1,5 P(I,J)=PHEP(J,I) 160 CONTINUE DO 170 J=1,4 V(I,J)=VHEP(J,I) 170 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 180 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) 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(4000,2),BRAT(4000),KFDP(4000,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*8,CHBEAM*8,CHTARG*8,CHLH(2)*6 C...Interface to PDFLIB. COMMON/W50512/QCDL4,QCDL5 SAVE /W50512/ DOUBLE PRECISION VALUE(20),QCDL4,QCDL5 CHARACTER*20 PARM(20) DATA VALUE/20*0D0/,PARM/20*' '/ C...Data:Lambda and n_f values for parton distributions; months. DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0, &14*0.2D0/,NFIN/20*4/ DATA CHLH/'lepton','hadron'/ C...Reset MINT and VINT arrays. Write headers. DO 100 J=1,400 MINT(J)=0 VINT(J)=0D0 100 CONTINUE IF(MSTU(12).GE.1) CALL PYLIST(0) IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) 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.10) THEN ALAM=ALAMIN(MSTP(51)) NF=NFIN(MSTP(51)) 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 MINT(123)=MSTP(14) 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)).GE.28.OR.IABS(MINT(12)).GE.28)) 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 ENDIF C...Set up kinematics of process. CALL PYINKI(0) C...Precalculate flavour selection weights CALL PYKFIN C...Loop over gamma-p or gamma-gamma alternatives. DO 160 IGA=1,MINT(121) MINT(122)=IGA C...Select partonic subprocesses to be included in the simulation. CALL PYINPR 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) 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 IF(MINT(48).EQ.0) THEN WRITE(MSTU(11),5500) STOP ENDIF MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94) 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 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.AND.(MINT(49).NE.0.OR.MSTP(131).NE.0).AND. & MSTP(82).GE.2) CALL PYMULT(1) C...Save results for gamma-p and gamma-gamma alternatives. IF(MINT(121).GT.1) CALL PYSAVE(1,IGA) 160 CONTINUE C...Initialization finished. 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('*')) 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) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/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/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/, &/PYINT4/,/PYINT5/,/PYUPPR/ C...Local array. DIMENSION VTX(4) C...Initial values for some counters. N=0 MINT(5)=MINT(5)+1 MINT(7)=0 MINT(8)=0 MINT(83)=0 MINT(84)=MSTP(126) MSTU(24)=0 MSTU70=0 MSTJ14=MSTJ(14) 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 260 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 270 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 250 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN C...Hard scattering (including low-pT): C...reconstruct kinematics and colour flow of hard scattering. 110 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 130 C...Showering of initial state partons (optional). ALAMSV=PARJ(81) PARJ(81)=PARP(72) IF(MSTP(61).GE.1.AND.MINT(47).GE.2) 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(MSTP(71).GE.1.AND.ISET(ISUB).EQ.11.AND.NFUP.GE.1) THEN DO 120 IUP=1,NFUP IPU3=IFUP(IUP,1)+MINT(84) IPU4=IFUP(IUP,2)+MINT(84) QMAX=SQRT(MAX(0D0,Q2UP(IUP))) CALL PYSHOW(IPU3,IPU4,QMAX) 120 CONTINUE ENDIF PARJ(81)=ALAMSV 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. IF(MSTP(81).GE.1.AND.MINT(50).EQ.1) CALL PYMULT(6) MINT(53)=N C...Hadron remnants and primordial kT. 130 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 ELSE C...Diffractive and elastic scattering. CALL PYDIFF ENDIF C...Check that no odd resonance left undecayed. IF(MSTP(111).GE.1) THEN NFIX=N DO 140 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 IF(MWID(PYCOMP(K(I,2))).NE.0) THEN CALL PYRESD(I) IF(MINT(51).EQ.1) GOTO 100 ENDIF ENDIF 140 CONTINUE ENDIF C...Recalculate energies from momenta and masses (if desired). IF(MSTP(113).GE.1) THEN DO 150 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) 150 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(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN DO 180 I=MINT(84)+1,N IF(K(I,2).EQ.94) THEN DO 170 I1=I+1,MIN(N,I+3) 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 160 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 160 CONTINUE IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3) ENDIF ENDIF 170 CONTINUE ENDIF 180 CONTINUE CALL PYEDIT(12) CALL PYEDIT(14) IF(MSTP(125).EQ.0) CALL PYEDIT(15) IF(MSTP(125).EQ.0) MINT(4)=0 DO 200 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 190 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 190 CONTINUE ENDIF 200 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 210 J=1,4 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))* & SIN(PARU(2)*PYR(0)) 210 CONTINUE DO 230 I=MINT(83)+1,N DO 220 J=1,4 V(I,J)=V(I,J)+VTX(J) 220 CONTINUE 230 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 240 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) 240 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. 250 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) 260 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. 270 CALL PYFRAM(MSTP(124)) MSTU(70)=MSTU70 PARU(21)=VINT(1) 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) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) 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(4000,2),BRAT(4000),KFDP(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/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 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/ C...Local arrays, character variables and data. DIMENSION WDTP(0:200),WDTE(0:200,0:5) 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 DATA PROGA/ &'VMD/hadron * VMD ','VMD/hadron * direct ', &'VMD/hadron * anomalous ','direct * direct ', &'direct * anomalous ','anomalous * anomalous '/ DATA DISGA/'e * VMD','e * anomalous'/ 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'' '/ 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) THEN WRITE(MSTU(11),5200) IGA,DISGA(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) 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 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),WDTP(J)/WDTP(0), & 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),WDTP(J)/WDTP(0), & 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) 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,'********* 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('=')) 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) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) 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(4000,2),BRAT(4000),KFDP(4000,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:200),WDTE(0:200,0:5),WDTPM(0:200), &WDTEM(0:200,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 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))/WDTP(0)**2 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0) 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 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))/WDTP(0)**2 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0) WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))/WDTP(0) 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))/WDTP(0)**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))/WDTP(0)**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)) 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(39,2),1) KFLQL=KFDP(MDCY(39,2),2) KCHG(39,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(39,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)// &CHAF(IABS(KFLQL),1)(1:LL)//' ' CHAF(39,2)=CHAF(39,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) 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) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/ C...Local arrays, character variables and data. CHARACTER CHFRAM*8,CHBEAM*8,CHTARG*8,CHCOM(3)*8,CHALP(2)*26, &CHIDNT(3)*8,CHTEMP*8,CHCDE(29)*8,CHINIT*76 DIMENSION LEN(3),KCDE(29),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_tauba','pi+ ','pi- ', &'n0 ','nbar0 ','p+ ','pbar- ','gamma ', &'lambda0 ','sigma- ','sigma0 ','sigma+ ','xi- ', &'xi0 ','omega- ','pi0 ','reggeon ','pomeron '/ 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,28,29/ C...Store initial energy. Default frame. VINT(290)=WIN MINT(111)=0 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)=8 DO 110 LL=8,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,6 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN CHTEMP=CHIDNT(I) CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:6)//' ' ENDIF 120 CONTINUE IF(CHIDNT(I)(7:7).EQ.'~') CHIDNT(I)(7:8)='ba' 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 150 I=1,2 DO 140 J=1,29 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) 150 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:3).EQ.'use') 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=(12-(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-specified 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:4).EQ.'four') 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=(12-(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-specified 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:4).EQ.'five') 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=(12-(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-specified 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...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!') 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) 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) 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) 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) 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) 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) 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 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) VINT(3)=P(1,5) IF(MINT(111).GE.4) VINT(4)=P(2,5) 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 IF(MINT(121).GT.1) PARP(81)=1.30D0+0.15D0*LOG(VINT(1)/200D0)/ & LOG(900D0/200D0) PTMN=PARP(81) ELSE IF(MINT(121).GT.1) PARP(82)=1.25D0+0.15D0*LOG(VINT(1)/200D0)/ & LOG(900D0/200D0) PTMN=PARP(82) ENDIF VINT(149)=4D0*PTMN**2/S 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) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(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/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/ C...Reset processes to be included. IF(MSEL.NE.0) THEN DO 100 I=1,500 MSUB(I)=0 100 CONTINUE ENDIF C...For e-gamma witn MSTP(14)=10 allow mixture of VMD and anomalous. IF(MINT(121).EQ.2) THEN MSUB(10)=1 MINT(123)=MINT(122)+1 C...For gamma-p or gamma-gamma with MSTP(14)=10 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. MSTP(57)=3 MSTP(85)=0 PARP(2)=2D0 PARU(115)=1D0 CKIN(5)=0.2D0 CKIN(6)=0.2D0 C...Define pT cut-off parameters and whether run involves low-pT. IF(MSTP(82).LE.1) THEN PTMVMD=1.30D0+0.15D0*LOG(VINT(1)/200D0)/LOG(900D0/200D0) ELSE PTMVMD=1.25D0+0.15D0*LOG(VINT(1)/200D0)/LOG(900D0/200D0) ENDIF 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/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 PARP(81)=PTMVMD PARP(82)=PTMVMD 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(33)=1 MSUB(54)=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(MSTP(82).GE.2) MSTP(85)=1 IF(IPTL.EQ.1) CKIN(3)=PTMANO C...Set up for direct * direct gamma (switch off leptons). ELSEIF(MINT(122).EQ.4) THEN MINT(123)=0 MSUB(58)=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(33)=1 MSUB(54)=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(MSTP(82).GE.2) MSTP(85)=1 IF(IPTL.EQ.1) CKIN(3)=PTMANO ENDIF C...End of special set up for gamma-p and gamma-gamma. CKIN(1)=2D0*CKIN(3) ENDIF C...Flavour information for individual beams. DO 120 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 IF(MINT(10+I).EQ.28.OR.MINT(10+I).EQ.29) MINT(40+I)=2 MINT(44+I)=MINT(40+I) IF(MSTP(11).GE.1.AND.IABS(MINT(10+I)).EQ.11) MINT(44+I)=3 120 CONTINUE C...If two gammas, whereof one direct, pick the first. IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN IF(MINT(123).GE.4.AND.MINT(123).LE.6) THEN MINT(41)=1 MINT(45)=1 ENDIF ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN IF(MINT(123).GE.4) 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 MINT(50)=0 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.MINT(123).GE.3) &MINT(50)=0 MINT(107)=0 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 ENDIF MINT(108)=0 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 ENDIF C...Select default processes according to incoming beams C...(already done for gamma-p and gamma-gamma with MSTP(14)=10). 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(34)=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. MSUB(58)=1 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. MSUB(33)=1 MSUB(34)=1 MSUB(54)=1 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 IF(MSTP(82).LE.1.AND.CKIN(3).LT.PARP(81)) MSUB(95)=1 IF(MSTP(82).GE.2.AND.CKIN(3).LT.PARP(82)) 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 130 J=1,MIN(8,MDCY(21,3)) MDME(MDCY(21,2)+J-1,1)=0 130 CONTINUE MDME(MDCY(21,2)+MSEL-1,1)=1 MSUB(85)=1 DO 140 J=1,MIN(12,MDCY(22,3)) MDME(MDCY(22,2)+J-1,1)=0 140 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 150 J=1,MIN(8,MDCY(21,3)) MDME(MDCY(21,2)+J-1,1)=0 150 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 160 I=201,280 IF(ISET(I).GE.0) MSUB(I)=1 160 CONTINUE ELSEIF(MINT(43).EQ.1) THEN C...Lepton-lepton processes: QED production of squarks. DO 170 I=201,214 MSUB(I)=1 170 CONTINUE MSUB(210)=0 MSUB(211)=0 MSUB(212)=0 DO 180 I=216,228 MSUB(I)=1 180 CONTINUE DO 190 I=261,263 MSUB(I)=1 190 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 200 I=271,280 MSUB(I)=1 200 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 210 I=201,214 MSUB(I)=1 210 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 220 I=237,242 MSUB(I)=1 220 CONTINUE DO 230 I=246,257 MSUB(I)=1 230 CONTINUE ENDIF ELSEIF(MSEL.EQ.44) THEN C...Neutralino/Chargino pair production. IF(MINT(43).EQ.4) THEN DO 240 I=216,236 MSUB(I)=1 240 CONTINUE ELSEIF(MINT(43).EQ.1) THEN DO 250 I=216,228 MSUB(I)=1 250 CONTINUE ENDIF ENDIF C...Find heaviest new quark flavour allowed in processes 81-84. KFLQM=1 DO 260 I=1,MIN(8,MDCY(21,3)) IDC=I+MDCY(21,2)-1 IF(MDME(IDC,1).LE.0) GOTO 260 KFLQM=I 260 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 270 I=1,MIN(12,MDCY(22,3)) IDC=I+MDCY(22,2)-1 IF(MDME(IDC,1).LE.0) GOTO 270 KFLFM=KFDP(IDC,1) 270 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 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) 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/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT7/SIGT(0:6,0:6,0:5) SAVE /PYDAT1/,/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) 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) IPROC=22 ELSEIF(KF2.GT.100) THEN IPROC=23 IF(MINT(123).EQ.2) IPROC=24 ELSE IPROC=25 IF(MINT(123).EQ.2) 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 DO 140 I=1,4 CONV=AEM/PARP(160+I) 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 DO 170 I=1,4 CONV=AEM/PARP(160+I) 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 DO 210 I1=1,4 DO 200 I2=1,4 CONV=AEM**2/(PARP(160+I1)*PARP(160+I2)) 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) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) 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(4000,2),BRAT(4000),KFDP(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/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...Select subprocess to study: skip cases not applicable. NPOSI=0 VINT(143)=1D0 VINT(144)=1D0 XSEC(0,1)=0D0 DO 460 ISUB=1,500 MINT(51)=0 IF(ISET(ISUB).EQ.11) THEN XSEC(ISUB,1)=1.00001D0*COEF(ISUB,1) NPOSI=NPOSI+1 GOTO 450 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN XSEC(ISUB,1)=SIGT(0,0,ISUB-90) IF(MSUB(ISUB).NE.1) GOTO 460 NPOSI=NPOSI+1 GOTO 450 ELSEIF(ISUB.EQ.96) THEN IF(MINT(50).EQ.0) GOTO 460 IF(MSUB(95).NE.1.AND.MSTP(81).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 ELSE IF(MSUB(ISUB).NE.1) GOTO 460 ENDIF MINT(1)=ISUB 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=30 PMAS(30,1)=PARP(45) PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2) ENDIF ELSEIF(ISUB.EQ.194) THEN KFR1=54 ENDIF CKMX=CKIN(2) IF(CKMX.LE.0D0) CKMX=VINT(1) KCR1=PYCOMP(KFR1) IF(KFR1.NE.0) THEN IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR. & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0 ENDIF IF(KFR1.NE.0) THEN TAUR1=PMAS(KCR1,1)**2/VINT(2) GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2) MINT(72)=1 MINT(73)=KFR1 VINT(73)=TAUR1 VINT(74)=GAMR1 ENDIF KFR2=0 IF(ISUB.EQ.141.OR.ISUB.EQ.194) THEN KFR2=23 IF(ISUB.EQ.194) KFR2=56 KCR2=PYCOMP(KFR2) TAUR2=PMAS(KCR2,1)**2/VINT(2) 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) VINT(71)=PARP(81) IF(ISUB.EQ.96.AND.MSTP(82).GE.2) VINT(71)=0.08D0*PARP(82) 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) VINT(204)=PMAS(23,1) IF(ISUB.EQ.124) VINT(204)=PMAS(24,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) VINT(204)=VINT(201) VINT(209)=VINT(204) 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).EQ.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).EQ.5) NPTS(2)=3 ENDIF NPTS(3)=1 IF(MINT(47).GE.4) NPTS(3)=3 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1 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-6,1D0-TAUMIN)/MAX(2D-6,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-6,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-6,1D0-TAUPMN)/MAX(2D-6,1D0-TAUPMX)) WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)* & TAUP/MAX(2D-6,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-6,EXP(YST0-YSTMIN)-1D0)/ & MAX(1D-6,EXP(YST0-YSTMAX)-1D0)) WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/ & MAX(1D-6,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-6,EXP(YST0+YSTMAX)-1D0)/ & MAX(1D-6,EXP(YST0+YSTMIN)-1D0)) WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/ & MAX(1D-6,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 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(NPOSI.EQ.0) THEN WRITE(MSTU(11),5900) STOP 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.MSTP(81).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 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('=')) 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) 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 gamma-gamma alnternatives. Also makes random C...choice between alternatives. SUBROUTINE PYSAVE(ISAVE,IGA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) 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) SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/ C...Local arrays and saved variables. DIMENSION NCP(10),NSUBCP(10,20),MSUBCP(10,20),COEFCP(10,20,20), &NGENCP(10,0:20,3),XSECCP(10,0:20,3),INTCP(10,20),RECP(10,20) SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,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 C...Save various common process variables. DO 140 J=1,10 INTCP(IGA,J)=MINT(40+J) 140 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) C...Save cross-section information only. ELSEIF(ISAVE.EQ.2) THEN DO 160 ICP=1,NCP(IGA) I=NSUBCP(IGA,ICP) DO 150 J=1,3 NGENCP(IGA,ICP,J)=NGEN(I,J) XSECCP(IGA,ICP,J)=XSEC(I,J) 150 CONTINUE 160 CONTINUE DO 170 J=1,3 NGENCP(IGA,0,J)=NGEN(0,J) XSECCP(IGA,0,J)=XSEC(0,J) 170 CONTINUE C...Choose between allowed alternatives. ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN IF(ISAVE.EQ.4) THEN XSUMCP=0D0 DO 180 IG=1,MINT(121) XSUMCP=XSUMCP+XSECCP(IG,0,1) 180 CONTINUE XSUMCP=XSUMCP*PYR(0) DO 190 IG=1,MINT(121) IGA=IG XSUMCP=XSUMCP-XSECCP(IG,0,1) IF(XSUMCP.LE.0D0) GOTO 200 190 CONTINUE 200 CONTINUE ENDIF C...Restore cross-section information. DO 210 I=1,500 MSUB(I)=0 210 CONTINUE DO 240 ICP=1,NCP(IGA) I=NSUBCP(IGA,ICP) MSUB(I)=MSUBCP(IGA,ICP) DO 220 J=1,20 COEF(I,J)=COEFCP(IGA,ICP,J) 220 CONTINUE DO 230 J=1,3 NGEN(I,J)=NGENCP(IGA,ICP,J) XSEC(I,J)=XSECCP(IGA,ICP,J) 230 CONTINUE 240 CONTINUE DO 250 J=1,3 NGEN(0,J)=NGENCP(IGA,0,J) XSEC(0,J)=XSECCP(IGA,0,J) 250 CONTINUE C...Restore various common process variables. DO 260 J=1,10 MINT(40+J)=INTCP(IGA,J) 260 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) C...Sum up cross-section info (for PYSTAT). ELSEIF(ISAVE.EQ.5) THEN DO 270 I=1,500 MSUB(I)=0 NGEN(I,1)=0 NGEN(I,3)=0 XSEC(I,3)=0D0 270 CONTINUE NGEN(0,1)=0 NGEN(0,2)=0 NGEN(0,3)=0 XSEC(0,3)=0 DO 290 IG=1,MINT(121) DO 280 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) 280 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) 290 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) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) 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(4000,2),BRAT(4000),KFDP(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/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/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYUPPR/,/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 MFAIL=0 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1 ISUB=0 LOOP=0 100 LOOP=LOOP+1 MINT(51)=0 C...Choice of process type - first event of pileup. IF(MINT(82).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) THEN C...For gamma-p or gamma-gamma first pick between alternatives. IF(MINT(121).GT.1) CALL PYSAVE(4,IGA) MINT(122)=IGA C...For gamma + gamma with different nature, flip at random. IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.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. RSUB=XSEC(0,1)*PYR(0) DO 110 I=1,500 IF(MSUB(I).NE.1) GOTO 110 ISUB=I RSUB=RSUB-XSEC(I,1) IF(RSUB.LE.0D0) GOTO 120 110 CONTINUE 120 IF(ISUB.EQ.95) ISUB=96 IF(ISUB.EQ.96) CALL PYMULT(2) 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) CALL PYMULT(2) ENDIF IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+1 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+1 IF(ISUB.EQ.96.AND.LOOP.EQ.1.AND.MINT(82).EQ.1) &NGEN(97,1)=NGEN(97,1)+1 MINT(1)=ISUB ISTSB=ISET(ISUB) C...Random choice of flavour for some SUSY processes. IF(ISUB.GE.201.AND.ISUB.LE.280) 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(MOD(ISUB,2).EQ.0) THEN KFPR(ISUB,1)=KSUSY1+1+INT(5D0*PYR(0)) ELSE KFPR(ISUB,1)=KSUSY2+1+INT(5D0*PYR(0)) ENDIF C...~q1 ~q2; ~q = ~d, ~u, ~s, ~c or ~b. 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(5D0*PYR(0)) KFPR(ISUB,2)=KSU2+1+INT(5D0*PYR(0)) C...~q ~q(bar); ~q = ~d, ~u, ~s, ~c or ~b. ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN KFPR(ISUB,1)=KSUSY1+1+INT(5D0*PYR(0)) KFPR(ISUB,2)=KFPR(ISUB,1) ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN KFPR(ISUB,1)=KSUSY2+1+INT(5D0*PYR(0)) KFPR(ISUB,2)=KFPR(ISUB,1) 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=30 PMAS(30,1)=PARP(45) PMAS(30,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2) ENDIF ELSEIF(ISUB.EQ.194) THEN KFR1=54 ENDIF CKMX=CKIN(2) IF(CKMX.LE.0D0) CKMX=VINT(1) KCR1=PYCOMP(KFR1) IF(KFR1.NE.0) THEN IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR. & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0 ENDIF IF(KFR1.NE.0) THEN TAUR1=PMAS(KCR1,1)**2/VINT(2) GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2) MINT(72)=1 MINT(73)=KFR1 VINT(73)=TAUR1 VINT(74)=GAMR1 ENDIF IF(ISUB.EQ.141.OR.ISUB.EQ.194) THEN KFR2=23 IF(ISUB.EQ.194) KFR2=56 KCR2=PYCOMP(KFR2) TAUR2=PMAS(KCR2,1)**2/VINT(2) 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 140 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 130 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 130 CONTINUE ELSEIF(KFLW.EQ.6) THEN PMMN(I)=PMAS(24,1)+PMAS(5,1) ENDIF ENDIF 140 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) VINT(204)=PMAS(23,1) IF(ISUB.EQ.124) VINT(204)=PMAS(24,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) VINT(204)=VINT(201) VINT(209)=VINT(204) 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.5.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 160 I1=I1MN,I1MX KFV1=110*I1+3 DO 150 I2=I2MN,I2MX KFV2=110*I2+3 VRN=VRN-SIGT(I1,I2,5) IF(VRN.LE.0D0) GOTO 170 150 CONTINUE 160 CONTINUE 170 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 190 I1=I1MN,I1MX KFV1=110*I1+3 DO 180 I2=I2MN,I2MX KFV2=110*I2+3 VRN=VRN-SIGT(I1,I2,JJ) IF(VRN.LE.0D0) GOTO 200 180 CONTINUE 190 CONTINUE 200 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 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 210 JT=1,2 PDIF(JT)=PMM(JT) VINT(66+JT)=PDIF(JT) IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102) 210 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. 220 DO 230 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 230 CONTINUE SQM3=PDIF(3)**2 SQM4=PDIF(4)**2 C..Additional mass factors, including resonance enhancement. IF(PDIF(3)+PDIF(4).GE.VINT(1)) GOTO 220 IF(ISUB.EQ.92) THEN FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3)) IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220 ELSEIF(ISUB.EQ.93) THEN FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4)) IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 220 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 220 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 220 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 220 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 220 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 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...Low-pT or multiple interactions (first semihard interaction). ELSEIF(ISTSB.EQ.9) THEN CALL PYMULT(3) ISUB=MINT(1) C...Generate user-defined process: kinematics plus weight. ELSEIF(ISTSB.EQ.11) THEN MSTI(51)=0 CALL PYUPEV(ISUB,SIGS) 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(0,2)=NGEN(0,2)-1 NGEN(ISUB,1)=NGEN(ISUB,1)-1 ENDIF IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) RETURN ENDIF C...Construct 'trivial' kinematical variables needed. KFL1=KUP(1,2) KFL2=KUP(2,2) VINT(41)=2D0*PUP(1,4)/VINT(1) VINT(42)=2D0*PUP(2,4)/VINT(1) 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(56)=Q2UP(0) VINT(55)=SQRT(MAX(0D0,VINT(56))) 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 DO 240 IUP=3,NUP IF(KUP(IUP,1).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(IUP,5)**2+ & PUP(IUP,1)**2+PUP(IUP,2)**2)/VINT(1) IF(KUP(IUP,1).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(IUP,1)**2+ & PUP(IUP,2)**2) 240 CONTINUE VINT(47)=SQRT(VINT(48)) C...Calculate parton distribution weights. IF(MINT(47).GE.2) THEN DO 260 I=3-MIN(2,MINT(45)),MIN(2,MINT(46)) MINT(105)=MINT(102+I) MINT(109)=MINT(106+I) IF(MSTP(57).LE.1) THEN CALL PYPDFU(MINT(10+I),VINT(40+I),Q2UP(0),XPQ) ELSE CALL PYPDFL(MINT(10+I),VINT(40+I),Q2UP(0),XPQ) ENDIF DO 250 KFL=-25,25 XSFX(I,KFL)=XPQ(KFL) 250 CONTINUE 260 CONTINUE ENDIF ENDIF C...Choose azimuthal angle. 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) C...Multiply cross-section by user-defined weights. IF(MSTP(173).EQ.1) THEN SIGS=PARP(173)*SIGS DO 270 ICHN=1,NCHN SIGH(ICHN)=PARP(173)*SIGH(ICHN) 270 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.LOOP.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 CALL PYMULT(4) ENDIF C...Check that weight not negative. VIOL=SIGSWT/XSEC(ISUB,1) IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174) 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. IF(MFAIL.EQ.0) THEN IF(VIOL.LT.PYR(0)) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) GOTO 100 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.1D0) 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 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 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) 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 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 CALL PYMULT(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)+1 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 290 RSIGS=SIGS*PYR(0) QT2=VINT(48) RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82))**2))**2) IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR. &PYR(0).GT.RQQBAR)) THEN DO 280 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 290 280 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. 290 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 320 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) 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 300 XE=XHRD**PYR(0) XG=MIN(0.999999D0,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 300 MINT(18+JT)=1 VINT(154+JT)=XE DO 310 KFLS=-25,25 XSFX(JT,KFLS)=XPQ(KFLS) 310 CONTINUE ENDIF 320 CONTINUE C...Pick scale where photon is resolved. IF(MINT(107).EQ.3) VINT(283)=PARP(15)**2* &(VINT(54)/PARP(15)**2)**PYR(0) IF(MINT(108).EQ.3) VINT(284)=PARP(15)**2* &(VINT(54)/PARP(15)**2)**PYR(0) 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) 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) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) 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(4000,2),BRAT(4000),KFDP(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/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/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/, &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYUPPR/,/PYSSMT/ C...Local arrays and saved variables DIMENSION WDTP(0:200),WDTE(0:200,0:5),PMQ(2),Z(2),CTHE(2), &PHI(2),KUPPO(20),VINTSV(41:66) 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 ENDIF 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)+20 I=MINT(83)+JT 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) THEN IGLGA=21 IF(ISUB.EQ.58) 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.12.AND.MSTP(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/PARU(155)**4 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180 ELSEIF(ISUB.EQ.54) THEN IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180 ELSEIF(ISUB.EQ.58) 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 IRUP=0 DO 210 IUP=3,NUP IF(KUP(IUP,1).NE.1) THEN ELSEIF(IRUP.LE.5) THEN IRUP=IRUP+1 MINT(20+IRUP)=KUP(IUP,2) 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.1.D-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.1.D-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.1.D-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.1.D-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 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.1.D-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.1.D-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.1.D-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.1.D-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.1.D-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.1.D-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.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)=25 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)=25 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)=25 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) THEN C...g + g -> Z0 + q + qbar 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(40,MINT(15)+MINT(16)) ELSEIF(ISUB.EQ.145) THEN C...q + l -> LQ (leptoquark) IF(IABS(MINT(16)).LE.8) JS=2 KFRES=ISIGN(39,MINT(14+JS)) KCC=28+JS KCS=ISIGN(1,MINT(14+JS)) 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_techni KFRES=38 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(39,MINT(14+JS)) KFLQL=KFDP(MDCY(39,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(39,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(39,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 ELSEIF(ISUB.EQ.191) THEN C...f + fbar -> rho_tech0. KFRES=54 ELSEIF(ISUB.EQ.192) THEN C...f + fbar' -> rho_tech+/- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) KFRES=ISIGN(55,KCH1+KCH2) ELSEIF(ISUB.EQ.193) THEN C...f + fbar -> omega_tech0. KFRES=56 ELSEIF(ISUB.EQ.194) THEN C...f + fbar -> f' + fbar' via mixture of s-channel C...rho_tech and omega_tech; th=(p(f)-p(f'))**2 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) MINT(22)=-MINT(21) 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_R + ~e_Lbar KCS=1 IF(MINT(2).EQ.2) KCS=-1 MINT(21)=ISIGN(KSUSY1+11,KCS) MINT(22)=-ISIGN(KSUSY2+11,KCS) 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 KCS=1 IF(MINT(2).EQ.2) KCS=-1 MINT(21)=ISIGN(KSUSY1+13,KCS) MINT(22)=-ISIGN(KSUSY2+13,KCS) 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 KCS=1 IF(MINT(2).EQ.2) KCS=-1 MINT(21)=ISIGN(KSUSY1+15,KCS) MINT(22)=-ISIGN(KSUSY2+15,KCS) 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(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(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(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(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(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(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 MINT(21)=ISIGN(KSUSY1+24,MINT(15)) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.227) THEN C...f + fbar -> ~chi+-2 + ~chi-+2 MINT(21)=ISIGN(KSUSY1+37,MINT(15)) 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=ISIGN(1,MINT(15)) KCH2=INT(1-KCH1)/2 IF(MINT(2).EQ.1) THEN MINT(22-KCH2)= -(KSUSY1+24) MINT(21+KCH2)= KSUSY1+37 IF(KCH2.EQ.0) JS=2 ELSE MINT(21+KCH2)= KSUSY1+24 MINT(22-KCH2)= -(KSUSY1+37) 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).NE.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).NE.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).NE.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).NE.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).NE.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).NE.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).NE.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).NE.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 MINT(21)=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 MINT(21)=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.280) THEN IF(ISUB.EQ.271) 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) 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) 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) 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) 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) 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) 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) 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) 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) 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 ENDIF CMRENNA-- ENDIF IF(ISET(ISUB).EQ.11) THEN C...Store documentation for user-defined processes BEZUP=(PUP(1,4)-PUP(2,4))/(PUP(1,4)+PUP(2,4)) KUPPO(1)=MINT(83)+5 KUPPO(2)=MINT(83)+6 I=MINT(83)+6 DO 450 IUP=3,NUP KUPPO(IUP)=0 IF(MSTP(128).GE.2.AND.KUP(IUP,3).NE.0) THEN IDOC=IDOC-1 MINT(4)=MINT(4)-1 GOTO 450 ENDIF I=I+1 KUPPO(IUP)=I K(I,1)=21 K(I,2)=KUP(IUP,2) K(I,3)=0 IF(KUP(IUP,3).NE.0) K(I,3)=KUPPO(KUP(IUP,3)) K(I,4)=0 K(I,5)=0 DO 440 J=1,5 P(I,J)=PUP(IUP,J) 440 CONTINUE 450 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 470 IUP=3,NUP N=N+1 K(N,1)=1 IF(KUP(IUP,1).NE.1) K(N,1)=11 K(N,2)=KUP(IUP,2) IF(MSTP(128).LE.0.OR.KUP(IUP,3).EQ.0) THEN K(N,3)=KUPPO(IUP) ELSE K(N,3)=MINT(84)+KUP(IUP,3) ENDIF K(N,4)=0 K(N,5)=0 DO 460 J=1,5 P(N,J)=PUP(IUP,J) 460 CONTINUE 470 CONTINUE CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP) C...Arrange colour flow for user-defined processes N=MINT(84) DO 480 IUP=1,NUP N=N+1 IF(KCHG(PYCOMP(K(N,2)),2).EQ.0) GOTO 480 IF(K(N,1).EQ.1) K(N,1)=3 IF(K(N,1).EQ.11) K(N,1)=14 IF(KUP(IUP,4).NE.0) K(N,4)=K(N,4)+MSTU(5)*(KUP(IUP,4)+ & MINT(84)) IF(KUP(IUP,5).NE.0) K(N,5)=K(N,5)+MSTU(5)*(KUP(IUP,5)+ & MINT(84)) IF(KUP(IUP,6).NE.0) K(N,4)=K(N,4)+KUP(IUP,6)+MINT(84) IF(KUP(IUP,7).NE.0) K(N,5)=K(N,5)+KUP(IUP,7)+MINT(84) 480 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 490 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)) 490 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 500 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(MWID(KCA).NE.0.AND.KFPR(ISUBSV,1).NE.0) THEN P(I,5)=SQRT(VINT(63+MOD(JS+JT,2))) ELSEIF(MWID(KCA).NE.0.AND.KFPR(ISUBSV,2).NE.0) THEN P(I,5)=SQRT(VINT(64)) 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)) 500 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 510 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 IF(IABS(K(I,2)).LE.22) THEN P(I,5)=PYMASS(K(I,2)) ELSE P(I,5)=SQRT(VINT(63+MOD(JS+JT,2))) ENDIF PT=SQRT(MAX(0D0,VINT(197+5*JT)-P(I,5)**2+VINT(196+5*JT)**2)) P(I,1)=PT*COS(VINT(198+5*JT)) P(I,2)=PT*SIN(VINT(198+5*JT)) 510 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) 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 520 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)) 520 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 530 J=1,5 P(I,J)=P(IPU5,J) 530 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 540 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) 540 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 560 JT=1,2 I1=MINT(83)+8+JT I2=MINT(84)+4+JT K(I1,1)=21 K(I1,2)=K(I2,2) DO 550 J=1,5 P(I1,J)=P(I2,J) 550 CONTINUE 560 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 570 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)) 570 CONTINUE C...Copy outgoing partons to documentation lines IMAX=2 IF(IDOC.EQ.9) IMAX=3 DO 590 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 580 J=1,5 P(I1,J)=P(I2,J) 580 CONTINUE 590 CONTINUE ELSEIF(IDOC.EQ.9) THEN C...Store colour connection indices DO 600 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)) 600 CONTINUE C...Copy outgoing partons to documentation lines DO 620 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 610 J=1,5 P(I1,J)=P(I2,J) 610 CONTINUE 620 CONTINUE ENDIF C...Low-pT events: remove gluons used for string drawing purposes IF(ISUB.EQ.95) THEN K(IPU3,1)=K(IPU3,1)+10 K(IPU4,1)=K(IPU4,1)+10 DO 630 J=41,66 VINTSV(J)=VINT(J) VINT(J)=0D0 630 CONTINUE DO 650 I=MINT(83)+5,MINT(83)+8 DO 640 J=1,5 P(I,J)=0D0 640 CONTINUE 650 CONTINUE ENDIF 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) 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) DATA IS/2*0/ C...Read out basic information; set global Q^2 scale. IPUS1=IPU1 IPUS2=IPU2 ISUB=MINT(1) Q2MX=VINT(56) IF(ISET(ISUB).EQ.2) Q2MX=PARP(67)*VINT(56) C...Initialize QCD evolution and check phase space. Q2MNC=PARP(62)**2 Q2MNCS(1)=Q2MNC IF(MSTP(66).EQ.1.AND.MINT(107).EQ.3) &Q2MNCS(1)=MAX(Q2MNC,VINT(283)) Q2MNCS(2)=Q2MNC IF(MSTP(66).EQ.1.AND.MINT(108).EQ.3) &Q2MNCS(2)=MAX(Q2MNC,VINT(284)) MCEV=0 XEC0=2D0*PARP(65)/VINT(1) ALAMS=PARU(112) PARU(112)=PARP(61) FQ2C=1D0 TCMX=0D0 IF(MINT(47).GE.2.AND.(MINT(47).NE.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. Q2MNE=PARP(68)**2 MEEV=0 XEE=1D-6 SPME=PMAS(11,1)**2 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(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN C...Initial values: flavours, momenta, virtualities. NS=N 100 N=NS 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) ZS(JT)=1D0 Q2S(JT)=Q2MX TEVCSV(JT)=TCMX ALAM(JT)=PARP(61) THE2(JT)=100D0 TEVESV(JT)=TEMX DO 110 KFL=-25,25 XFS(JT,KFL)=XSFX(JT,KFL) 110 CONTINUE 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. 150 N=N+1 JT=1 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2 IF(MORE(JT).EQ.0) JT=3-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(XEC0,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(MCEV.EQ.0.AND.MEEV.EQ.0) THEN Q2B=0D0 GOTO 250 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 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 Altarelli-Parisi weights. DO 170 KFL=-25,25 WTAPC(KFL)=0D0 WTAPE(KFL)=0D0 WTSF(KFL)=0D0 170 CONTINUE C...q -> q, 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)) 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) 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) 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 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 190 NTRY=NTRY+1 IF(NTRY.GT.500) THEN MINT(51)=1 RETURN ENDIF WTSUMC=0D0 WTSUME=0D0 XFBO=MAX(1D-10,XFB(KFLB)) DO 200 KFL=-25,25 WTSF(KFL)=XFB(KFL)/XFBO WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL) WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL) 200 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 210 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))) ENDIF C...Translate t into Q2 scale; choose between QCD and QED evolution. 220 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB)) 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(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 250 ELSEIF(MCE.EQ.1) THEN Q2B=Q2CB Q2REF=FQ2C*Q2B IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME) 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 230 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 230 IF(KFLA.EQ.25) THEN Q2B=0D0 GOTO 250 ENDIF C...Choose z value and corrective weight. WTZ=0D0 C...q -> q + g. 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) 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 210 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 210 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z)) IF(ALPRAT.LT.5D0*PYR(0)) GOTO 210 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0 ENDIF C...Impose angular constraint in first branching from interference C...with final state partons. 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 210 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 210 ENDIF ENDIF C...Option with angular ordering requirement. IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN THE2T=(4D0*Z**2*Q2B)/(VINT(2)*(1D0-Z)*XB**2) IF(THE2T.GT.THE2(JT)) GOTO 210 ENDIF ENDIF C...Weighting with new parton distributions. MINT(105)=MINT(102+JT) MINT(109)=MINT(106+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 190 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN TEVCB=0.5D0*(TEVCBS+TEVCB) GOTO 220 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN TEVEB=0.5D0*(TEVEBS+TEVEB) GOTO 220 ELSE XFBN=1D-10 XFN(KFLB)=XFBN ENDIF ENDIF DO 240 KFL=-25,25 XFB(KFL)=XFN(KFL) 240 CONTINUE XA=XB/Z 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 190 WTSFA=WTSF(KFLA) IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 190 C...Define two hard scatterers in their CM-frame. 250 IF(N.EQ.NS+2) THEN DQ2(JT)=Q2B DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR DO 270 JR=1,2 I=NS+JR IF(JR.EQ.1) IPO=IPUS1 IF(JR.EQ.2) IPO=IPUS2 DO 260 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 260 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 270 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 280 J=1,5 K(IT,J)=0 P(IT,J)=0D0 V(IT,J)=0D0 280 CONTINUE K(IT,1)=3 C...f -> f + g (gamma). IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN K(IT,2)=21 IF(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 P(IT,5)=PYMASS(K(IT,2)) IF(DMSMA.LE.P(IT,5)**2) GOTO 100 IF(MSTP(63).GE.1.AND.MCE.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 290 J=1,5 K(N+1,J)=0 P(N+1,J)=0D0 V(N+1,J)=0D0 290 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 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)),PARU(2)*PYR(0), & 0D0,0D0,0D0) ENDIF C...Update kinematics variables. IS(JT)=N DQ2(JT)=Q2B IF(MSTP(62).GE.3) THE2(JT)=THE2T DSH=DSHZ C...Save quantities; loop back. Q2S(JT)=Q2B 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 300 KFL=-25,25 XFS(JT,KFL)=XFA(KFL) 300 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 310 J=1,3 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4)) 310 CONTINUE K(N+2,1)=1 DO 320 J=1,5 P(N+2,J)=P(NS+1,J) 320 CONTINUE ROBOT=ROBO(3)**2+ROBO(4)**2+ROBO(5)**2 IF(ROBOT.GE.0.999999D0) THEN ROBOT=1.00001D0*SQRT(ROBOT) ROBO(3)=ROBO(3)/ROBOT ROBO(4)=ROBO(4)/ROBOT ROBO(5)=ROBO(5)/ROBOT ENDIF 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)) CALL PYROBO(MINT(83)+5,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4), &ROBO(5)) C...Store user information. Reset Lambda value. K(IPU1,3)=MINT(83)+3 K(IPU2,3)=MINT(83)+4 DO 330 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) 330 CONTINUE PARU(112)=ALAMS 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) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) 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(4000,2),BRAT(4000),KFDP(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/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/,/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:200),WDTE(0:200,0:5),DBEZQQ(3),DPMO(5),XM(5) 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...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. 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) 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) 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 ENDIF C...Define original resonance for odd cases. ELSE ISUB=0 IREF(1,1)=IRES ENDIF C...Check if initial resonance has been moved (in resonance + jet). DO 120 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 DO 110 I=IREF(1,JT)+1,N IF(K(I,1).LE.10.AND.K(I,2).EQ.K(IREF(1,JT),2)) & IREF(1,JT)=I 110 CONTINUE ELSE KDA=MOD(K(IREF(1,JT),4),MSTU(4)) IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA ENDIF ENDIF ENDIF 120 CONTINUE C...Loop over decay history. NP=1 IP=0 130 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...Start treatment of one, two or three resonances in parallel. 140 N=NSAV DO 220 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 C...Check whether particle can/is allowed to decay. IF(ID.EQ.0) GOTO 210 KFA=IABS(K(ID,2)) KCA=PYCOMP(KFA) IF(MWID(KCA).EQ.0) GOTO 210 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 210 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...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 210 RKFL=WDTE0S*PYR(0) IDL=0 150 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 150 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)) 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) C...Select masses; to begin with assume resonances narrow. DO 170 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 170 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 160 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 160 CONTINUE CMRENNA-- ELSEIF(KFLW.EQ.6) THEN PMMN(I)=PMAS(24,1)+PMAS(5,1) ENDIF 170 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)+PARJ(64).GT.P(ID,5)) THEN CALL PYERRM(13,'(PYRESD:) daughter masses too large') MINT(51)=1 RETURN 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 180 LOOP=LOOP+1 P(N+IWID3,5)=PYMASS(KFLW3) IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 180 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) RETURN 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 200 I=N+1,N+3 DO 190 J=1,5 K(I,J)=0 V(I,J)=0D0 190 CONTINUE 200 CONTINUE XM(1)=P(N+1,5) XM(2)=P(N+2,5) XM(3)=P(N+3,5) XM(5)=P(ID,5) CALL PYTBDY(XM) 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) 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 N=N+3 CMRENNA-- C...2) Everything else two-body decay. ELSE CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5)) 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 ENDIF C...End loop over resonances for daughter flavour and mass selection. MSTU(10)=MSTU10 210 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.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 RETURN ENDIF 220 CONTINUE C...Check for allowed combinations. Skip if no decays. IF(JTMAX.EQ.1) THEN IF(KDCY(1).EQ.0) GOTO 560 ELSEIF(JTMAX.EQ.2) THEN IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 560 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 140 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 140 ELSEIF(JTMAX.EQ.3) THEN IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 560 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 140 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 140 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 140 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 140 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 140 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 140 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 RETURN ENDIF C...Angular orientation according to matrix element. IF(MSTJ(106).EQ.1) THEN CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHI,THE,PHI) IF(MINT(11).LT.0) THE=PARU(1)-THE CTHE(1)=COS(THE) CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0) CALL PYROBO(NC+1,N,THE,PHI,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 240 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 230 J=1,5 P(I1,J)=P(I,J) 230 CONTINUE ENDIF 240 CONTINUE C...Generate parton shower. IF(MSTJ(101).EQ.5) CALL PYSHOW(N-1,N,P(ID,5)) C... End special case for Z0: skip ahead. MSTU(111)=MST111 PARU(112)=PAR112 GOTO 550 ENDIF C...Order incoming partons and outgoing resonances. IF(JTMAX.EQ.2.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) 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 250 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 250 CONTINUE C...Find charge, isospin, left- and righthanded couplings. DO 270 I=IMIN,IMAX DO 260 J=1,4 COUP(I,J)=0D0 260 CONTINUE KFA=IABS(K(ILIN(I),2)) IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 270 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) 270 CONTINUE C...Full propagator dependence and flavour correlations for 2 gamma*/Z. IF(ISUB.EQ.22) THEN DO 300 I=3,5,2 I1=IORD IF(I.EQ.5) I1=3-IORD DO 290 J1=1,2 DO 280 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 280 CONTINUE 290 CONTINUE 300 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 140 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 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 ENDIF IF(IP.GE.3) MZPWP=2 ENDIF C...Select random angles (begin of weighting procedure). 310 DO 320 JT=1,JTMAX IF(KDCY(JT).EQ.0) GOTO 320 IF(JTMAX.EQ.1.AND.ISUB.NE.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 320 CONTINUE IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN C...Construct massless four-vectors. DO 340 I=N+1,N+4 K(I,1)=1 DO 330 J=1,5 P(I,J)=0D0 V(I,J)=0D0 330 CONTINUE 340 CONTINUE DO 350 JT=1,JTMAX IF(KDCY(JT).EQ.0) GOTO 350 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)) 350 CONTINUE C...Store incoming and outgoing momenta, with random rotation to C...avoid accidental zeroes in HA expressions. DO 370 I=1,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 360 J=1,3 P(N+4+I,J)=P(ILIN(I),J) 360 CONTINUE 370 CONTINUE 380 THERR=ACOS(2D0*PYR(0)-1D0) PHIRR=PARU(2)*PYR(0) CALL PYROBO(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0) DO 400 I=1,IMAX IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*P(N+4+I,4)**2) GOTO 380 DO 390 J=1,4 PK(I,J)=P(N+4+I,J) 390 CONTINUE 400 CONTINUE 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 420 I1=IMIN,IMAX-1 DO 410 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) 410 CONTINUE 420 CONTINUE ENDIF DO 440 I=1,2 DO 430 J=1,4 PK(I,J)=-PK(I,J) 430 CONTINUE 440 CONTINUE DO 460 I1=IMIN,IMAX-1 DO 450 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) 450 CONTINUE 460 CONTINUE 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 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons. 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) 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)) WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+ & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5) ELSEIF(KFA.EQ.24) THEN WT=16D0*PKK(3,5)*PKK(4,6) 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. WT=(1D0+CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**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(2,1)*COUP(3,1)**2/16D0+ & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+ & COUP(1,3)**2*HGZ(2,3)*COUP(3,3)**2 CLIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+ & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+ & COUP(1,3)**2*HGZ(2,3)*COUP(3,4)**2 CRILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+ & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+ & COUP(1,4)**2*HGZ(2,3)*COUP(3,3)**2 CRIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+ & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+ & COUP(1,4)**2*HGZ(2,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+SQMW*PMAS(24,2)**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. 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)) 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))) 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(2,1)*COUP(3,1)**2/16D0+ & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+ & COUP(1,3)**2*HGZ(2,3)*COUP(3,3)**2 CLIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+ & COUP(1,1)*COUP(1,3)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+ & COUP(1,3)**2*HGZ(2,3)*COUP(3,4)**2 CRILF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+ & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,3)/4D0+ & COUP(1,4)**2*HGZ(2,3)*COUP(3,3)**2 CRIRF=COUP(1,1)**2*HGZ(2,1)*COUP(3,1)**2/16D0+ & COUP(1,1)*COUP(1,4)*HGZ(2,2)*COUP(3,1)*COUP(3,4)/4D0+ & COUP(1,4)**2*HGZ(2,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) THEN C...Angular weight for f + g -> f' + W+/- -> f' + 2 quarks/leptons. 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 VPI=PARU(119+2*KFAIC) API=PARU(120+2*KFAIC) 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 VPF=PARU(119+2*KFAFC) APF=PARU(120+2*KFAFC) 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. 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. 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.EQ.147.OR.ISUB.EQ.148) THEN C...Decays of (spin 1/2) q* -> q + (g,gamma) or (Z0,W+-). SIDE=1D0 IF(MINT(16).EQ.21) 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_tech0 -> W+ W-, C...W+ pi_tech-, pi_tech+ W- or pi_tech+ pi_tech-. WT=1D0-CTHE(1)**2 WTMAX=1D0 ELSEIF(IP.EQ.1) THEN C...Angular weight for f + fbar -> rho_tech0 -> 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_tech produced in rho_tech 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_tech+ -> W+ Z0, C...W+ pi_tech0, pi_tech+ Z0 or pi_tech+ pi_tech0. WT=1D0-CTHE(1)**2 WTMAX=1D0 ELSEIF(IP.EQ.1) THEN C...Angular weight for f + fbar' -> rho_tech+ -> f fbar'. CTHESG=CTHE(1)*ISIGN(1,MINT(15)) WT=(1D0+CTHESG)**2 WTMAX=4D0 ELSE C...Isotropic decay of W/Z/pi_tech produced in rho_tech+ 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_tech0 -> C...gamma pi_tech0 or Z0 pi_tech0. WT=1D0+CTHE(1)**2 WTMAX=2D0 ELSEIF(IP.EQ.1) THEN C...Angular weight for f + fbar -> omega_tech0 -> 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_tech produced in omega_tech decay. 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 310 C...Construct massive four-vectors using angles chosen. 470 DO 540 JT=1,JTMAX IF(KDCY(JT).EQ.0) GOTO 540 ID=IREF(IP,JT) DO 480 J=1,5 DPMO(J)=P(ID,J) 480 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)) 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)) ENDIF 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 IF(KFL3(JT).NE.0) K(ID,5)=NSD(JT)+3 ENDIF C...Add documentation lines. IF(ISUB.NE.0) THEN IDOC=MINT(83)+MINT(4) CMRENNA+++ IHI=NSD(JT)+2 IF(KFL3(JT).NE.0) IHI=IHI+1 DO 500 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 490 J=1,5 P(I1,J)=P(I,J) 490 CONTINUE ENDIF 500 CONTINUE ELSE K(NSD(JT)+1,3)=ID K(NSD(JT)+2,3)=ID IF(KFL3(JT).NE.0) K(NSD(JT)+3,3)=ID ENDIF C...Do showering if any of the two/three products can shower. NSHBEF=N IF(MSTP(71).GE.1) THEN ISHOW1=0 KFL1A=IABS(KFL1(JT)) IF(KFL1A.LE.22) ISHOW1=1 ISHOW2=0 KFL2A=IABS(KFL2(JT)) IF(KFL2A.LE.22) ISHOW2=1 ISHOW3=0 IF(KFL3(JT).NE.0) THEN KFL3A=IABS(KFL3(JT)) IF(KFL3A.LE.22) ISHOW3=1 ENDIF IF(ISHOW1.EQ.0.AND.ISHOW2.EQ.0.AND.ISHOW3.EQ.0) THEN ELSEIF(KFL3(JT).EQ.0) THEN CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5)) ELSE NSD1=NSD(JT)+1 NSD2=NSD(JT)+2 IF(ISHOW1.EQ.0.AND.ISHOW3.NE.0) THEN NSD1=NSD(JT)+3 ELSEIF(ISHOW2.EQ.0.AND.ISHOW3.NE.0) THEN NSD2=NSD(JT)+3 ENDIF PMSHOW=SQRT(MAX(0D0,(P(NSD1,4)+P(NSD2,4))**2- & (P(NSD1,1)+P(NSD2,1))**2-(P(NSD1,2)+P(NSD2,2))**2- & (P(NSD1,3)+P(NSD2,3))**2)) CALL PYSHOW(NSD1,NSD2,PMSHOW) ENDIF 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 510 I=NSHBEF+1,NSHAFT IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I 510 CONTINUE ENDIF IF(K(NSD2,1).GT.10) THEN DO 520 I=NSHBEF+1,NSHAFT IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND. & I.NE.NSD1) NSD2=I 520 CONTINUE ENDIF IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN DO 530 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 530 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) 540 CONTINUE C...Fill information for 2 -> 1 -> 2. 550 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.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) ENDIF C...Loop back if needed. 560 IF(IP.LT.NP) GOTO 130 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) 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),SIGSUM PARP(82)=0.9D0*PARP(82) VINT(149)=4D0*PARP(82)**2/VINT(2) GOTO 100 ENDIF IF(MSTP(122).GE.1) WRITE(MSTU(11),5200) PARP(82), SIGSUM C...Start iteration to find k factor. YKE=SIGSUM/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) DELTAB=0.02D0 IF(MSTP(82).EQ.4) DELTAB=MIN(0.01D0,0.05D0*PARP(84)) SP=0D0 SOP=0D0 B=-0.5D0*DELTAB 140 B=B+DELTAB IF(MSTP(82).EQ.3) THEN OV=EXP(-B**2)/PARU(2) ELSE 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) 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 XT2FAC=XSEC(96,1)/SIGT(0,0,5)*VINT(149)/(1D0-VINT(149)) ELSEIF(MSTP(82).EQ.2) THEN XT2=1D0 XT2FAC=VINT(146)*XSEC(96,1)/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)-1 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-1 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 IF(MSTP(82).EQ.3) THEN VINT(148)=PYR(0)/(PARU(2)*VINT(147)) ELSE 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)) 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 150 IBIN=IRBIN+1,20 RNCOR=RNCOR+NMUL(IBIN) SIGCOR=SIGCOR+SIGM(IBIN) 150 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/SIGT(0,0,5))) C...Generate additional multiple semihard interactions. ELSEIF(MMUL.EQ.6) THEN ISUBSV=MINT(1) DO 160 J=11,80 VINTSV(J)=VINT(J) 160 CONTINUE ISUB=96 MINT(1)=96 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 180 I=MINT(84)+1,NMAX KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2)) IF(KCS.EQ.0) GOTO 180 DO 170 J=1,4 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 170 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 170 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 170 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 170 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 170 CONTINUE 180 CONTINUE C...Set up starting values for iteration in xT2. 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) IF(MSTP(82).LE.1) THEN XT2FAC=XSEC(ISUB,1)*VINT(149)/((1D0-VINT(149))*SIGT(0,0,5)) ELSE XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/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. 190 IF(MSTP(82).LE.1) THEN XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) IF(XT2.LT.VINT(149)) GOTO 240 ELSE IF(XT2.LE.0.01001D0*VINT(149)) GOTO 240 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))* & LOG(PYR(0)))-VINT(149) IF(XT2.LE.0D0) GOTO 240 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 190 VINT(71)=0.5D0*VINT(1)*SQRT(XT2) CALL PYSIGH(NCHN,SIGS) IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 190 C...Reset K, P and V vectors. Select some variables. DO 210 I=N+1,N+2 DO 200 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 200 CONTINUE 210 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 230 I=N+1,N+2 DMIN=1D8 DO 220 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 220 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 230 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...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') IF(MSTU(21).GE.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 190 240 CONTINUE MINT(1)=ISUBSV DO 250 J=11,80 VINT(J)=VINTSV(J) 250 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) 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.MSTP(81).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 PT=SQRT(VINT(282+JT)) 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(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0) ROBO(5)=MAX(-0.999999D0,MIN(0.999999D0,(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).GT.0.999999D0) 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(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 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. 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.10) 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 PMTB=PPB*PNB PMTR=PMS(IR) PMTL=PMS(IL) SQLAM=SQRT(MAX(0D0,(PMTB-PMTR-PMTL)**2-4D0*PMTR*PMTL)) SQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4)) RKR=(PMTB+PMTR-PMTL+SQLAM*SQSGN)/(2D0*(PSYS(IR,4)+PSYS(IR,3)) & *PNB) RKL=(PMTB+PMTL-PMTR+SQLAM*SQSGN)/(2D0*(PSYS(IL,4)-PSYS(IL,3)) & *PPB) BER=(RKR**2-1D0)/(RKR**2+1D0) BEL=-(RKL**2-1D0)/(RKL**2+1D0) 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...PYDIFF C...Handles diffractive and elastic scattering. SUBROUTINE PYDIFF 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/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. IF(MINT(16+JT).LE.0) 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 IF((SQRT(SQM)+PARJ(32))**2.GE.VINT(62+JT)) GOTO 160 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) K(I+2,2)=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...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) 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(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-10.AND.XSECW.GT.1D-10) 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(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...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) 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) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) 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(4000,2),BRAT(4000),KFDP(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/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) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT4/,/PYMSSM/,/PYSSMT/ C...Local arrays and saved variables. DIMENSION WDTP(0:200),WDTE(0:200,0:5),MOFSV(3,2),WIDWSV(3,2), &WID2SV(3,2) SAVE MOFSV,WIDWSV,WID2SV DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/ C...Compressed code and sign; mass. KFLA=IABS(KFLR) KFLS=ISIGN(1,KFLR) KC=PYCOMP(KFLA) SHR=SQRT(SH) PMR=PMAS(KC,1) C...Reset width information. DO 110 I=0,200 WDTP(I)=0D0 DO 100 J=0,5 WDTE(I,J)=0D0 100 CONTINUE 110 CONTINUE C...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(0)=WDTP(0)+WDTP(I) C...Calculate secondary width (at most two identical/opposite). 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 130 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 130 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 130 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. 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) 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 AL=SHR*ZMIX(IZ,4)/(2.0D0*PMAS(24,1)*SINB) AR=-ET*ZMIX(IZ,1)*TANW BL=T3L*(ZMIX(IZ,2)-ZMIX(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*((FL**2+FR**2)* & (SH+PMNCHI**2-PMSTOP**2)+SMZ(IZ)*4D0*SHR*FL*FR)/SH IF(KFLR.GT.0) THEN WID2=WIDS(KFC1,2)*WIDS(KFC2,2) ELSE WID2=WIDS(KFC1,2)*WIDS(KFC2,3) ENDIF ENDIF CMRENNA-- ENDIF WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 130 CONTINUE ELSEIF(KFLA.EQ.7) THEN C...b' quark. FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR 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 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(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.8) THEN C...t' 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 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(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.17) THEN C...tau' lepton. 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 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(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.18) THEN C...nu'_tau neutrino. 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 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(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.21) THEN C...QCD: C***Note that widths are not given in dimensional quantities here. DO 180 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 180 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 180 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(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.22) THEN C...QED photon. 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...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(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.23) THEN C...Z0: ICASE=1 XWC=1D0/(16D0*XW*XW1) FAC=(AEM*XWC/3D0)*SHR 200 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 210 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 210 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 210 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(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 210 CONTINUE IF(MINT(61).GE.1) ICASE=3-ICASE IF(ICASE.EQ.2) GOTO 200 ELSEIF(KFLA.EQ.24) THEN C...W+/-: FAC=(AEM/(24D0*XW))*SHR 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.16) THEN C...W+/- -> q + qbar' FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1) IF(KFLR.GT.0) THEN IF(MOD(I,4).EQ.3) WID2=WIDS(6,2) IF(MOD(I,4).EQ.0) WID2=WIDS(8,2) IF(I.GE.13) WID2=WID2*WIDS(7,3) ELSE IF(MOD(I,4).EQ.3) WID2=WIDS(6,3) IF(MOD(I,4).EQ.0) WID2=WIDS(8,3) IF(I.GE.13) WID2=WID2*WIDS(7,2) ENDIF ELSEIF(I.LE.20) THEN C...W+/- -> l+/- + nu FCOF=1D0 IF(KFLR.GT.0) THEN IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2) ELSE IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3) ENDIF ENDIF WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 220 CONTINUE ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN C...h0 (or H0, or A0): IF(MSTP(49).EQ.0) THEN FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR ELSE FAC=(AEM/(8D0*XW))*(PMAS(KFHIGG,1)/PMAS(24,1))**2*SHR ENDIF DO 260 I=1,MDCY(KFHIGG,3) IDC=I+MDCY(KFHIGG,2)-1 IF(MDME(IDC,1).LT.0) GOTO 260 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 260 WID2=1D0 IF(I.LE.8) THEN C...h0 -> q + qbar WDTP(I)=FAC*3D0*RM1*(1D0-4D0*RM1)*SQRT(MAX(0D0, & 1D0-4D0*RM1))*RADC IF(MSTP(37).EQ.1.AND.MSTP(2).GE.1) WDTP(I)=WDTP(I)* & (LOG(MAX(4D0,PARP(37)**2*RM1*SH/PARU(117)**2))/ & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118))) 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 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*(1D0-4D0*RM1)*SQRT(MAX(0D0,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 230 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.1.D-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 230 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 240 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.1.D-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 240 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 250 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.1.D-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.1.D-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 250 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(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.KFLA.EQ.35) THEN C***H0 -> Z0 + h0 (not yet implemented). ELSEIF(I.EQ.19.AND.KFLA.EQ.35) THEN C...H0 -> h0 + h0. WDTP(I)=FAC*PARU(176)**2*0.25D0*PMAS(23,1)**4/SH**2* & SQRT(MAX(0D0,1D0-4D0*RM1)) WID2=WIDS(25,2)**2 ELSEIF(I.EQ.20.AND.KFLA.EQ.35) THEN C...H0 -> A0 + A0. WDTP(I)=FAC*PARU(177)**2*0.25D0*PMAS(23,1)**4/SH**2* & SQRT(MAX(0D0,1D0-4D0*RM1)) WID2=WIDS(36,2)**2 ELSEIF(I.EQ.18.AND.KFLA.EQ.36) THEN C...A0 -> Z0 + h0. WDTP(I)=FAC*PARU(186)**2*0.5D0*SQRT(MAX(0D0, & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=WIDS(23,2)*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(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(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 260 CONTINUE ELSEIF(KFLA.EQ.32) THEN C...Z'0: ICASE=1 XWC=1D0/(16D0*XW*XW1) FAC=(AEM*XWC/3D0)*SHR VINT(117)=0D0 270 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 VPI=PARU(119+2*KFAIC) API=PARU(120+2*KFAIC) SQMZ=PMAS(23,1)**2 HZ=SHR*FAC*VINT(117) SQMZP=PMAS(32,1)**2 HZP=SHR*FAC*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 280 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 280 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 280 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 VPF=PARU(123-2*MOD(I,2)) APF=PARU(124-2*MOD(I,2)) 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 VPF=PARU(127-2*MOD(I,2)) APF=PARU(128-2*MOD(I,2)) 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)+WDTPZ 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 280 CONTINUE IF(MINT(61).GE.1) ICASE=3-ICASE IF(ICASE.EQ.2) GOTO 270 ELSEIF(KFLA.EQ.34) THEN C...W'+/-: FAC=(AEM/(24D0*XW))*SHR 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) GOTO 290 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(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 290 CONTINUE ELSEIF(KFLA.EQ.37) THEN C...H+/-: FAC=(AEM/(8D0*XW))*(SH/PMAS(24,1)**2)*SHR DO 300 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 300 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 300 WID2=1D0 IF(I.LE.4) THEN C...H+/- -> q + qbar' RM1R=RM1 IF(MSTP(37).EQ.1.AND.MSTP(2).GE.1) RM1R=RM1* & (LOG(MAX(4D0,PARP(37)**2*RM1*SH/PARU(117)**2))/ & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118))) WDTP(I)=FAC*3D0*RADC*((RM1R*PARU(141)**2+RM2/PARU(141)**2)* & (1D0-RM1R-RM2)-4D0*RM1R*RM2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) 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)) 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(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.38) THEN C...Techni-eta. FAC=(SH/PARP(46)**2)*SHR DO 310 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 310 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 310 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(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.39) THEN C...LQ (leptoquark). FAC=(AEM/4D0)*PARU(151)*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 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=1D0 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.40) THEN C...R: FAC=(AEM/(12D0*XW))*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 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(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.51.OR.KFLA.EQ.52) THEN C...Techni-pi0 and techni-pi+-: FAC=(3D0/(32D0*PARU(1)*PARP(142)**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_tech -> f + f'. FCOF=1D0 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC WDTP(I)=FAC*FCOF*(PM1+PM2)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 340 CONTINUE ELSEIF(KFLA.EQ.53) THEN C...Techni-pi'0 not yet implemented. ELSEIF(KFLA.EQ.54) THEN C...Techni-rho0: ALPRHT=2.91D0*(3D0/PARP(144)) FAC=(ALPRHT/12D0)*SHR FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3) SQMZ=PMAS(23,1)**2 GMMZ=PMAS(23,1)*PMAS(23,2) 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 350 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 350 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 350 IF(I.EQ.1) THEN C...rho_tech0 -> W+ + W-. WDTP(I)=FAC*PARP(141)**4* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=WIDS(24,1) ELSEIF(I.EQ.2) THEN C...rho_tech0 -> W+ + pi_tech-. WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=WIDS(24,2)*WIDS(52,3) ELSEIF(I.EQ.3) THEN C...rho_tech0 -> pi_tech+ + W-. WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=WIDS(52,2)*WIDS(24,3) ELSEIF(I.EQ.4) THEN C...rho_tech0 -> pi_tech+ + pi_tech-. WDTP(I)=FAC*(1D0-PARP(141)**2)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=WIDS(52,1) ELSE C...rho_tech0 -> f + fbar. WID2=1D0 IF(I.LE.12) THEN IA=I-4 FCOF=3D0*RADC IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1) ELSE IA=I-2 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*(1D0-RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))* & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+ & (EI+VARI*BWZR)**2+(VARI*BWZI)**2) ENDIF 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.55) THEN C...Techni-rho+/-: ALPRHT=2.91D0*(3D0/PARP(144)) FAC=(ALPRHT/12D0)*SHR SQMW=PMAS(24,1)**2 GMMW=PMAS(24,1)*PMAS(24,2) FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)* & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2) 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 IF(I.EQ.1) THEN C...rho_tech+ -> W+ + Z0. WDTP(I)=FAC*PARP(141)**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_tech+ -> W+ + pi_tech0. WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 IF(KFLR.GT.0) THEN WID2=WIDS(24,2)*WIDS(51,2) ELSE WID2=WIDS(24,3)*WIDS(51,2) ENDIF ELSEIF(I.EQ.3) THEN C...rho_tech+ -> pi_tech+ + Z0. WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 IF(KFLR.GT.0) THEN WID2=WIDS(52,2)*WIDS(23,2) ELSE WID2=WIDS(52,3)*WIDS(23,2) ENDIF ELSEIF(I.EQ.4) THEN C...rho_tech+ -> pi_tech+ + pi_tech0. WDTP(I)=FAC*(1D0-PARP(141)**2)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 IF(KFLR.GT.0) THEN WID2=WIDS(52,2)*WIDS(51,2) ELSE WID2=WIDS(52,3)*WIDS(51,2) ENDIF ELSE C...rho_tech+ -> f + fbar'. IA=I-4 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*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) ENDIF 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.56) THEN C...Techni-omega: ALPRHT=2.91D0*(3D0/PARP(144)) FAC=(AEM/24D0)*(SHR**3/PARP(145)**2) FACF=(1D0/6D0)*(AEM**2/ALPRHT)*(PMAS(KFLA,1)**4/SHR**3)* & (2D0*PARP(143)-1D0)**2 SQMZ=PMAS(23,1)**2 GMMZ=PMAS(23,1)*PMAS(23,2) BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) DO 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 IF(I.EQ.1) THEN C...omega_tech0 -> gamma + pi_tech0. WDTP(I)=FAC* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=WIDS(51,2) ELSEIF(I.EQ.2) THEN C...omega_tech0 -> Z0 + pi_tech0 not known. WDTP(I)=0D0 WID2=WIDS(23,2)*WIDS(51,2) ELSE C...omega_tech0 -> f + fbar. WID2=1D0 IF(I.LE.10) THEN IA=I-2 FCOF=3D0*RADC IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1) ELSE IA=I 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*(1D0-RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))* & ((EI-VALI*BWZR)**2+(VALI*BWZI)**2+ & (EI-VARI*BWZR)**2+(VARI*BWZI)**2) ENDIF 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.KEXCIT+1) THEN C...d* excited quark. FAC=(SH/PARU(155)**2)*SHR 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 IF(I.EQ.1) THEN C...d* -> g + d. WDTP(I)=FAC*AS*PARU(159)**2/3D0 WID2=1D0 ELSEIF(I.EQ.2) THEN C...d* -> gamma + d. QF=-PARU(157)/2D0+PARU(158)/6D0 WDTP(I)=FAC*AEM*QF**2/4D0 WID2=1D0 ELSEIF(I.EQ.3) THEN C...d* -> Z0 + d. QF=-PARU(157)*XW1/2D0-PARU(158)*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*PARU(157)**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(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.KEXCIT+2) THEN C...u* excited quark. FAC=(SH/PARU(155)**2)*SHR 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 IF(I.EQ.1) THEN C...u* -> g + u. WDTP(I)=FAC*AS*PARU(159)**2/3D0 WID2=1D0 ELSEIF(I.EQ.2) THEN C...u* -> gamma + u. QF=PARU(157)/2D0+PARU(158)/6D0 WDTP(I)=FAC*AEM*QF**2/4D0 WID2=1D0 ELSEIF(I.EQ.3) THEN C...u* -> Z0 + u. QF=PARU(157)*XW1/2D0-PARU(158)*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*PARU(157)**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(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 ELSEIF(KFLA.EQ.KEXCIT+11) THEN C...e* excited lepton. FAC=(SH/PARU(155)**2)*SHR DO 400 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 400 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 400 IF(I.EQ.1) THEN C...e* -> gamma + e. QF=-PARU(157)/2D0-PARU(158)/2D0 WDTP(I)=FAC*AEM*QF**2/4D0 WID2=1D0 ELSEIF(I.EQ.2) THEN C...e* -> Z0 + e. QF=-PARU(157)*XW1/2D0+PARU(158)*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*PARU(157)**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(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.KEXCIT+12) THEN C...nu*_e excited neutrino. FAC=(SH/PARU(155)**2)*SHR 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 IF(I.EQ.1) THEN C...nu*_e -> Z0 + nu*_e. QF=PARU(157)*XW1/2D0+PARU(158)*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*PARU(157)**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(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 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) 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(4000,2),BRAT(4000),KFDP(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/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:200), &WDTE(0:200,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)) PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42)) IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=MIN(PMU(I), & CKIN(NOFF+2*ILM)) 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 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) 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. SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) 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 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) PGW=PMAS(24,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(K(IW1,2).GT.0) THEN JT=1 ELSE JT=2 ENDIF JR=3-JT IF(NAFT1.GT.NSD1+4) THEN NBEG(JT)=NSD1+5 NEND(JT)=NAFT1 ELSE NBEG(JT)=NSD1+1 NEND(JT)=NSD1+2 ENDIF IF(N.GT.NAFT1) THEN NBEG(JR)=NAFT1+1 NEND(JR)=N ELSE NBEG(JR)=NSD1+3 NEND(JR)=NSD1+4 ENDIF C...Rearrange parton shower products along strings. NOLD=N CALL PYPREP(NSD1+1) 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...Weight for sample distribution. 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) 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(4000,2),BRAT(4000),KFDP(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/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(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2)) EXPY3=MAX(1.D-10,(1D0+RM3-RM4+BE34*CTH)/ & MAX(1.D-10,(1D0+RM3-RM4-BE34*CTH))) EXPY4=MAX(1.D-10,(1D0-RM3+RM4-BE34*CTH)/ & MAX(1.D-10,(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=10D0 ETASMA=-10D0 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.1.D-6) 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(1.D10,MAX(1.D-10,EXPET3))) ETA4=LOG(MIN(1.D10,MAX(1.D-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(CTS3,CTS4)) CTSSMA=MAX(-1D0,MIN(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) 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)=0.99999D0 VINT(31)=1.00001D0 ELSEIF(MINT(47).EQ.5) THEN VINT(31)=MIN(VINT(31),0.999998D0) 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)=-0.00001D0 VINT(32)=0.00001D0 ELSEIF(MINT(47).EQ.2) THEN VINT(12)=0.99999D0*YSTMX0 VINT(32)=1.00001D0*YSTMX0 ELSEIF(MINT(47).EQ.3) THEN VINT(12)=-1.00001D0*YSTMX0 VINT(32)=-0.99999D0*YSTMX0 ELSEIF(MINT(47).EQ.5) THEN YSTEE=LOG(0.999999D0/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.KFPR(ISUB,2).GT.0) THEN PQRAT=2D0*PMAS(PYCOMP(KFPR(ISUB,2)),1)/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)=0.99999D0 VINT(36)=1.00001D0 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) VINT(11)=4D0*PARP(81)**2/VINT(2) IF(MSTP(82).GE.2) VINT(11)=PARP(82)**2/VINT(2) 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) ST2EFF=4D0*PARP(81)**2/(VINT(21)*VINT(2)) IF(MSTP(82).GE.2) ST2EFF=0.01D0*PARP(82)**2/(VINT(21)*VINT(2)) 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) 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) ELSE AUPP=LOG(MAX(2D-6,1D0-TAUMAX)) ALOW=LOG(MAX(2D-6,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) THEN YST=-0.5D0*LOG(TAUE) ELSEIF(MINT(47).EQ.3) 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-6,EXP(YST0-YSTMIN)-1D0)) ALOW=LOG(MAX(1D-6,EXP(YST0-YSTMAX)-1D0)) YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW))) ELSE YST0=-0.5D0*LOG(TAUE) AUPP=LOG(MAX(1D-6,EXP(YST0+YSTMIN)-1D0)) ALOW=LOG(MAX(1D-6,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-7,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0) ELSE AUPP=LOG(MAX(2D-6,1D0-TAUPMX)) ALOW=LOG(MAX(2D-6,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) 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) 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) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) 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(4000,2),BRAT(4000),KFDP(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/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/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/, &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/, &/PYSSMT/ C...Local arrays and complex variables DIMENSION X(2),XPQ(-25:25),KFAC(2,-40:40),WDTP(0:200), &WDTE(0:200,0:5),HGZ(6,3),HL3(3),HR3(3),HL4(3),HR4(3) COMPLEX A004,A204,A114,A00U,A20U,A11U COMPLEX CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF, &COULCK,COULCP,COULCD,COULCR,COULCS REAL A00L,A11L,A20L,COULXX C...Reset number of channels and cross-section NCHN=0 SIGS=0D0 C...Convert H or A process into equivalent h one ISUB=MINT(1) ISUBSV=ISUB 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 ENDIF CMRENNA++ C...Convert almost equivalent SUSY processes into each other C...Extract differences in flavours and couplings IF(ISUB.GE.200.AND.ISUB.LE.280) THEN C...Sleptons and sneutrinos IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN KFID=MOD(KFPR(ISUB,1),KSUSY1) ISUB=201 ILR=0 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN KFID=MOD(KFPR(ISUB,1),KSUSY1) ISUB=201 ILR=1 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN KFID=MOD(KFPR(ISUB,1),KSUSY1) ISUB=203 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN IF(ISUB.EQ.210) THEN RKF=2.0D0 ELSEIF(ISUB.EQ.211) THEN RKF=SFMIX(15,1)**2 ELSEIF(ISUB.EQ.212) THEN RKF=SFMIX(15,2)**2 ENDIF ISUB=210 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN IF(ISUB.EQ.213) THEN KFID=MOD(KFPR(ISUB,1),KSUSY1) RKF=2.0D0 ELSEIF(ISUB.EQ.214) THEN KFID=16 RKF=1.0D0 ENDIF ISUB=213 C...Neutralinos ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN IF(ISUB.EQ.216) THEN IZID1=1 IZID2=1 ELSEIF(ISUB.EQ.217) THEN IZID1=2 IZID2=2 ELSEIF(ISUB.EQ.218) THEN IZID1=3 IZID2=3 ELSEIF(ISUB.EQ.219) THEN IZID1=4 IZID2=4 ELSEIF(ISUB.EQ.220) THEN IZID1=1 IZID2=2 ELSEIF(ISUB.EQ.221) THEN IZID1=1 IZID2=3 ELSEIF(ISUB.EQ.222) THEN IZID1=1 IZID2=4 ELSEIF(ISUB.EQ.223) THEN IZID1=2 IZID2=3 ELSEIF(ISUB.EQ.224) THEN IZID1=2 IZID2=4 ELSEIF(ISUB.EQ.225) THEN IZID1=3 IZID2=4 ENDIF ISUB=216 C...Charginos ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN IF(ISUB.EQ.226) THEN IZID1=1 IZID2=1 ELSEIF(ISUB.EQ.227) THEN IZID1=2 IZID2=2 ELSEIF(ISUB.EQ.228) THEN IZID1=1 IZID2=2 ENDIF ISUB=226 C...Neutralino + chargino ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN IF(ISUB.EQ.229) THEN IZID1=1 IZID2=1 ELSEIF(ISUB.EQ.230) THEN IZID1=1 IZID2=2 ELSEIF(ISUB.EQ.231) THEN IZID1=1 IZID2=3 ELSEIF(ISUB.EQ.232) THEN IZID1=1 IZID2=4 ELSEIF(ISUB.EQ.233) THEN IZID1=2 IZID2=1 ELSEIF(ISUB.EQ.234) THEN IZID1=2 IZID2=2 ELSEIF(ISUB.EQ.235) THEN IZID1=2 IZID2=3 ELSEIF(ISUB.EQ.236) THEN IZID1=2 IZID2=4 ENDIF ISUB=229 C...Gluino + neutralino ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN IF(ISUB.EQ.237) THEN IZID=1 ELSEIF(ISUB.EQ.238) THEN IZID=2 ELSEIF(ISUB.EQ.239) THEN IZID=3 ELSEIF(ISUB.EQ.240) THEN IZID=4 ENDIF ISUB=237 C...Gluino + chargino ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN IF(ISUB.EQ.241) THEN IZID=1 ELSEIF(ISUB.EQ.242) THEN IZID=2 ENDIF ISUB=241 C...Squark + neutralino ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN ILR=0 IF(MOD(ISUB,2).NE.0) ILR=1 IF(ISUB.LE.247) THEN IZID=1 ELSEIF(ISUB.LE.249) THEN IZID=2 ELSEIF(ISUB.LE.251) THEN IZID=3 ELSEIF(ISUB.LE.253) THEN IZID=4 ENDIF ISUB=246 RKF=5D0 C...Squark + chargino ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN IF(ISUB.LE.255) THEN IZID=1 ELSEIF(ISUB.LE.257) THEN IZID=2 ENDIF IF(MOD(ISUB,2).EQ.0) THEN ILR=0 ELSE ILR=1 ENDIF ISUB=254 RKF=5D0 C...Squark + gluino ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN ISUB=258 RKF=5D0 C...Stops ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN ILR=0 IF(ISUB.EQ.262) ILR=1 ISUB=261 ELSEIF(ISUB.EQ.265) THEN ISUB=264 C...Squarks ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN ILR=0 IF(ISUB.LE.273) THEN IF(ISUB.EQ.273) ILR=1 ISUB=271 RKF=25D0 ELSEIF(ISUB.LE.276) THEN IF(ISUB.EQ.276) ILR=1 ISUB=274 RKF=25D0 ELSEIF(ISUB.LE.278) THEN IF(ISUB.EQ.278) ILR=1 ISUB=277 RKF=5D0 ELSE IF(ISUB.EQ.280) ILR=1 ISUB=279 RKF=5D0 ENDIF ENDIF ENDIF CMRENNA-- 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.0.9999D0) RETURN ELSEIF(MINT(45).EQ.3) THEN X(1)=MIN(0.9999989D0,X(1)) ENDIF IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN IF(X(2).GT.0.9999D0) RETURN ELSEIF(MINT(46).EQ.3) THEN X(2)=MIN(0.9999989D0,X(2)) ENDIF SH=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/(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) 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 TH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH) UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+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: hard, parton distributions, parton showers IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN Q2=SH ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN 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 ENDIF IF(ISTSB.EQ.9) Q2=SQPTH IF((ISTSB.EQ.9.AND.MSTP(82).GE.2).OR.(ISTSB.NE.9.AND. & MSTP(85).EQ.1)) Q2=Q2+PARP(82)**2 ENDIF Q2SF=Q2 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) & Q2SF=PMAS(24,1)**2 IF(ISUB.EQ.121.OR.ISUB.EQ.122) THEN Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2 IF(MSTP(39).EQ.2) Q2SF=Q2SF+MAX(VINT(202),VINT(207)) IF(MSTP(39).EQ.3) Q2SF=SH IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2) ENDIF ENDIF Q2PS=Q2SF Q2SF=Q2SF*PARP(34) IF(MSTP(68).GE.2.AND.MINT(47).EQ.5) Q2SF=VINT(2) 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 IF(MSTP(68).GE.1.AND.MINT(47).EQ.5) Q2PS=VINT(2) 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 VINT(48)=SQPTH 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 170 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) MINT(105)=MINT(102+I) MINT(109)=MINT(106+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 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) 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 SQMH=PMAS(KFHIGG,1)**2 GMMZ=PMAS(23,1)*PMAS(23,2) GMMW=PMAS(24,1)*PMAS(24,2) GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2) C...MRENNA+++ ZWID=PMAS(23,2) WWID=PMAS(24,2) TANW=SQRT(XW/XW1) C...MRENNA--- 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.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-6) 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-6) 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-6) 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-6) 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-6,1D0-TAUMIN)/MAX(2D-6,1D0-TAUMAX)) IF(ATAU7.GT.1D-6) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/ & MAX(2D-6,1D0-TAU) ENDIF COMFAC=COMFAC*ATAU1/(TAU*H1) ENDIF C...Phase space integral in y* IF(MINT(47).GE.4.AND.ISTSB.NE.9) THEN AYST0=YSTMAX-YSTMIN IF(AYST0.LT.1D-6) 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-6,EXP(YST0-YSTMIN)-1D0)/ & MAX(1D-6,EXP(YST0-YSTMAX)-1D0)) IF(AYST4.GT.1D-6) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/ & MAX(1D-6,1D0-EXP(YST-YST0)) ENDIF IF(MINT(46).EQ.3) THEN YST0=-0.5D0*LOG(TAUE) AYST5=LOG(MAX(1D-6,EXP(YST0+YSTMAX)-1D0)/ & MAX(1D-6,EXP(YST0+YSTMIN)-1D0)) IF(AYST5.GT.1D-6) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/ & MAX(1D-6,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-6,1D0-TAUPMN)/MAX(2D-6,1D0-TAUPMX)) H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-6,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.1.D-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...2 -> 2 processes: optional dampening by pT^4/(pT0^2+pT^2)^2 IF(MSTP(85).EQ.1.AND.MOD(ISTSB,2).EQ.0) COMFAC=COMFAC* &SQPTH**2/(PARP(82)**2+SQPTH)**2 C...gamma + gamma: include factor 2 when different nature IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4) &COMFAC=2D0*COMFAC 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...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ. &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN C...Calculate M_R and N_R functions for Higgs-like and QCD-like models IF(MSTP(46).LE.4) THEN HDTLH=LOG(PMAS(25,1)/PARP(44)) HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0 HDTNR=-1D0/18D0+HDTLH/6D0 ELSE HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2) HDTLQ=LOG(PARP(45)/PARP(44)) HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0 ENDIF C...Calculate lowest and next-to-lowest order partial wave amplitudes HDTV=1D0/(16D0*PARU(1)*PARP(47)**2) A00L=SNGL(HDTV*SH) A20L=-0.5*A00L A11L=A00L/6. HDTLS=LOG(SH/PARP(44)**2) A004=SNGL((HDTV*SH)**2/(4D0*PARU(1)))* & CMPLX(SNGL((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0- & (50D0/9D0)*HDTLS),SNGL(4D0*PARU(1))) A204=SNGL((HDTV*SH)**2/(4D0*PARU(1)))* & CMPLX(SNGL(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0- & (20D0/9D0)*HDTLS),SNGL(PARU(1))) A114=SNGL((HDTV*SH)**2/(6D0*PARU(1)))* & CMPLX(SNGL(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),SNGL(PARU(1)/6D0)) C...Unitarize partial wave amplitudes with Pade or K-matrix method IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN A00U=A00L/(1.-A004/A00L) A20U=A20L/(1.-A204/A20L) A11U=A11L/(1.-A114/A11L) ELSE A00U=(A00L+REAL(A004))/(1.-CMPLX(0.,A00L+REAL(A004))) A20U=(A20L+REAL(A204))/(1.-CMPLX(0.,A20L+REAL(A204))) A11U=(A11L+REAL(A114))/(1.-CMPLX(0.,A11L+REAL(A114))) ENDIF ENDIF C...Supersymmetric processes - all of type 2 -> 2 : C...correct final-state Breit-Wigners from fixed to running width. IF(ISUB.GE.200.AND.ISUB.LE.280.AND.MSTP(42).GT.0) THEN DO 160 I=1,2 KFLW=KFPR(ISUBSV,I) KCW=PYCOMP(KFLW) IF(PMAS(KCW,2).LT.PARP(41)) GOTO 160 IF(I.EQ.1) SQMI=SQM3 IF(I.EQ.2) SQMI=SQM4 SQMS=PMAS(KCW,1)**2 GMMS=PMAS(KCW,1)*PMAS(KCW,2) HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2) CALL PYWIDT(KFLW,SQMI,WDTP,WDTE) GMMI=SQRT(SQMI)*WDTP(0) HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2) COMFAC=COMFAC*(HBWI/HBWS) 160 CONTINUE ENDIF C...A: 2 -> 1, tree diagrams 170 IF(ISUB.LE.10) THEN IF(ISUB.EQ.1) THEN C...f + fbar -> gamma*/Z0 MINT(61)=2 CALL PYWIDT(23,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACZ=4D0*COMFAC*3D0 HP0=AEM/3D0*SH HP1=AEM/3D0*XWC*SH DO 180 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV HI0=HP0 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0 HI1=HP1 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+ & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)* & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/ & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)) 180 CONTINUE ELSEIF(ISUB.EQ.2) THEN C...f + fbar' -> W+/- CALL PYWIDT(24,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0 HP=AEM/(24D0*XW)*SH DO 200 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 200 IA=IABS(I) DO 190 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 190 JA=IABS(J) IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 190 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 HI=HP*2D0 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4)) SIGH(NCHN)=HI*FACBW*HF 190 CONTINUE 200 CONTINUE ELSEIF(ISUB.EQ.3) THEN C...f + fbar -> h0 (or H0, or A0) CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2) IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) & FACBW=0D0 HP=AEM/(8D0*XW)*SH/SQMW*SH HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) DO 210 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210 IA=IABS(I) RMQ=PMAS(IA,1)**2/SH HI=HP*RMQ IF(IA.LE.10) HI=HP*RMQ*FACA/3D0 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) HI=HI* & (LOG(MAX(4D0,PARP(37)**2*RMQ*SH/PARU(117)**2))/ & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118))) IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN IKFI=1 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2 IF(IA.GT.10) IKFI=3 HI=HI*PARU(150+10*IHIGG+IKFI)**2 ENDIF NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=HI*FACBW*HF 210 CONTINUE ELSEIF(ISUB.EQ.4) THEN C...gamma + W+/- -> W+/- ELSEIF(ISUB.EQ.5) THEN C...Z0 + Z0 -> h0 CALL PYWIDT(25,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2) IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0 HP=AEM/(8D0*XW)*SH/SQMW*SH HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) HI=HP/4D0 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2 DO 230 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 230 DO 220 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 220 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV EJ=KCHG(IABS(J),1)/3D0 AJ=SIGN(1D0,EJ) VJ=AJ-4D0*EJ*XWV NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF 220 CONTINUE 230 CONTINUE 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 CALL PYWIDT(25,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2) IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0 HP=AEM/(8D0*XW)*SH/SQMW*SH HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) HI=HP/2D0 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2 DO 250 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 250 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1) DO 240 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 240 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1) IF(EI*EJ.GT.0D0) GOTO 240 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF 240 CONTINUE 250 CONTINUE C...B: 2 -> 2, tree diagrams ELSEIF(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 270 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270 IA=IABS(I) DO 260 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260 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 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 260 CONTINUE 270 CONTINUE ENDIF ELSEIF(ISUB.LE.20) THEN IF(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)) IF(MSTP(5).GE.1) THEN C...Modifications from contact interactions (compositeness) FACCI1=FACQQ1+COMFAC*(SH2/PARU(155)**4) FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)* & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/PARU(155)**4) FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*PARU(156)/PARU(155)**2)* & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/PARU(155)**4) FACCI3=FACQQ1+COMFAC*(UH2/PARU(155)**4) ENDIF DO 290 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 290 DO 280 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 280 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.(IA.GE.3.OR. & JA.GE.3))) THEN SIGH(NCHN)=FACQQ1 IF(I.EQ.-J) SIGH(NCHN)=FACQQB ELSE SIGH(NCHN)=FACCI1 IF(I*J.LT.0) SIGH(NCHN)=FACCI3 IF(I.EQ.-J) SIGH(NCHN)=FACCIB ENDIF IF(I.EQ.J) THEN SIGH(NCHN)=0.5D0*SIGH(NCHN) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=2 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IA.GE.3)) THEN SIGH(NCHN)=0.5D0*FACQQ2 ELSE SIGH(NCHN)=0.5D0*FACCI2 ENDIF ENDIF 280 CONTINUE 290 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)) IF(MSTP(5).EQ.1) THEN C...Modifications from contact interactions (compositeness) FACCIB=FACQQB DO 300 I=1,2 FACCIB=FACCIB+COMFAC*(UH2/PARU(155)**4)*(WDTE(I,1)+ & WDTE(I,2)+WDTE(I,4)) 300 CONTINUE ELSEIF(MSTP(5).GE.2) THEN FACCIB=FACQQB+COMFAC*(UH2/PARU(155)**4)* & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) ENDIF DO 310 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IABS(I).GE.3)) THEN SIGH(NCHN)=FACQQB ELSE SIGH(NCHN)=FACCIB ENDIF 310 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 320 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320 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 320 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 330 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330 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 330 CONTINUE ELSEIF(ISUB.EQ.15) THEN C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only) FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH) C...gamma, gamma/Z interference and Z couplings to final fermion pairs HFGG=0D0 HFGZ=0D0 HFZZ=0D0 RADC4=1D0+PYALPS(SQM4)/PARU(1) DO 340 I=1,MIN(16,MDCY(23,3)) IDC=I+MDCY(23,2)-1 IF(MDME(IDC,1).LT.0) GOTO 340 IMDM=0 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4) & IMDM=1 IF(I.LE.8) THEN EF=KCHG(I,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV ELSEIF(I.LE.16) THEN EF=KCHG(I+2,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV ENDIF RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4 IF(4D0*RM1.LT.1D0) THEN FCOF=1D0 IF(I.LE.8) FCOF=3D0*RADC4 BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) IF(IMDM.EQ.1) THEN HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+ & AF**2*(1D0-4D0*RM1))*BE34 ENDIF ENDIF 340 CONTINUE C...Propagators: as simulated in PYOFSH and as desired HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) MINT(15)=1 MINT(61)=1 CALL PYWIDT(23,SQM4,WDTP,WDTE) HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) HFGG=HFGG*HFAEM*VINT(111)/SQM4 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4 C...Loop over flavours; consider full gamma/Z structure DO 350 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+ & (VI**2+AI**2)*HFZZ)/HBW4 350 CONTINUE ELSEIF(ISUB.EQ.16) THEN C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only) FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH) C...Propagators: as simulated in PYOFSH and as desired HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2) CALL PYWIDT(24,SQM4,WDTP,WDTE) GMMWC=SQRT(SQM4)*WDTP(0) HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2) FACWG=FACWG*HBW4C/HBW4 DO 370 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 370 DO 360 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 360 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0) FCKM=VCKM((IA+1)/2,(JA+1)/2) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACWG*FCKM*WIDSC 360 CONTINUE 370 CONTINUE ELSEIF(ISUB.EQ.17) THEN C...f + fbar -> g + h0 (q + qbar -> g + h0 only) ELSEIF(ISUB.EQ.18) THEN C...f + fbar -> gamma + gamma FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH) DO 380 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380 EI=KCHG(IABS(I),1)/3D0 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 380 CONTINUE ELSEIF(ISUB.EQ.19) THEN C...f + fbar -> gamma + (gamma*/Z0) FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH) C...gamma, gamma/Z interference and Z couplings to final fermion pairs HFGG=0D0 HFGZ=0D0 HFZZ=0D0 RADC4=1D0+PYALPS(SQM4)/PARU(1) DO 390 I=1,MIN(16,MDCY(23,3)) IDC=I+MDCY(23,2)-1 IF(MDME(IDC,1).LT.0) GOTO 390 IMDM=0 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4) & IMDM=1 IF(I.LE.8) THEN EF=KCHG(I,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV ELSEIF(I.LE.16) THEN EF=KCHG(I+2,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV ENDIF RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4 IF(4D0*RM1.LT.1D0) THEN FCOF=1D0 IF(I.LE.8) FCOF=3D0*RADC4 BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) IF(IMDM.EQ.1) THEN HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+ & AF**2*(1D0-4D0*RM1))*BE34 ENDIF ENDIF 390 CONTINUE C...Propagators: as simulated in PYOFSH and as desired HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) MINT(15)=1 MINT(61)=1 CALL PYWIDT(23,SQM4,WDTP,WDTE) HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) HFGG=HFGG*HFAEM*VINT(111)/SQM4 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4 C...Loop over flavours; consider full gamma/Z structure DO 400 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV FCOI=1D0 IF(IABS(I).LE.10) FCOI=FACA/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+ & (VI**2+AI**2)*HFZZ)/HBW4 400 CONTINUE ELSEIF(ISUB.EQ.20) THEN C...f + fbar' -> gamma + W+/- FACGW=COMFAC*0.5D0*AEM**2/XW C...Propagators: as simulated in PYOFSH and as desired HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2) CALL PYWIDT(24,SQM4,WDTP,WDTE) GMMWC=SQRT(SQM4)*WDTP(0) HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2) FACGW=FACGW*HBW4C/HBW4 C...Anomalous couplings TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH) TERM2=0D0 TERM3=0D0 IF(MSTP(5).GE.1) THEN TERM2=PARU(153)*(TH-UH)/(TH+UH) TERM3=0.5D0*PARU(153)**2*(TH*UH+(TH2+UH2)*SH/ & (4D0*SQMW))/(TH+UH)**2 ENDIF DO 420 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 420 DO 410 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 410 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 410 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 410 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0) IF(IA.LE.10) THEN FACWR=UH/(TH+UH)-1D0/3D0 FCKM=VCKM((IA+1)/2,(JA+1)/2) FCOI=FACA/3D0 ELSE FACWR=-TH/(TH+UH) FCKM=1D0 FCOI=1D0 ENDIF FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC 410 CONTINUE 420 CONTINUE ENDIF ELSEIF(ISUB.LE.30) THEN IF(ISUB.EQ.21) THEN C...f + fbar -> gamma + h0 ELSEIF(ISUB.EQ.22) THEN C...f + fbar -> (gamma*/Z0) + (gamma*/Z0) C...Kinematics dependence FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)- & SQM3*SQM4*(1D0/TH2+1D0/UH2)) C...gamma, gamma/Z interference and Z couplings to final fermion pairs DO 440 I=1,6 DO 430 J=1,3 HGZ(I,J)=0D0 430 CONTINUE 440 CONTINUE RADC3=1D0+PYALPS(SQM3)/PARU(1) RADC4=1D0+PYALPS(SQM4)/PARU(1) DO 450 I=1,MIN(16,MDCY(23,3)) IDC=I+MDCY(23,2)-1 IF(MDME(IDC,1).LT.0) GOTO 450 IMDM=0 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2 IF(I.LE.8) THEN EF=KCHG(I,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV ELSEIF(I.LE.16) THEN EF=KCHG(I+2,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV ENDIF RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3 IF(4D0*RM1.LT.1D0) THEN FCOF=1D0 IF(I.LE.8) FCOF=3D0*RADC3 BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) IF(IMDM.GE.1) THEN HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+ & AF**2*(1D0-4D0*RM1))*BE34 ENDIF ENDIF RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4 IF(4D0*RM1.LT.1D0) THEN FCOF=1D0 IF(I.LE.8) FCOF=3D0*RADC4 BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) IF(IMDM.GE.1) THEN HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+ & AF**2*(1D0-4D0*RM1))*BE34 ENDIF ENDIF 450 CONTINUE C...Propagators: as simulated in PYOFSH and as desired HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2) HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) MINT(15)=1 MINT(61)=1 CALL PYWIDT(23,SQM3,WDTP,WDTE) HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) DO 460 J=1,3 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3 460 CONTINUE MINT(61)=1 CALL PYWIDT(23,SQM4,WDTP,WDTE) HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) DO 470 J=1,3 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4 470 CONTINUE C...Loop over flavours; separate left- and right-handed couplings DO 490 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 490 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV VALI=VI-AI VARI=VI+AI FCOI=1D0 IF(IABS(I).LE.10) FCOI=FACA/3D0 DO 480 J=1,3 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J) HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J) HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J) HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J) 480 CONTINUE FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+ & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+ & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+ & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4) 490 CONTINUE ELSEIF(ISUB.EQ.23) THEN C...f + fbar' -> Z0 + W+/- FACZW=COMFAC*0.5D0*(AEM/XW)**2 FACZW=FACZW*WIDS(23,2) THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) FACBW=1D0/((SH-SQMW)**2+GMMW**2) DO 510 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 510 DO 500 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 500 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 500 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 500 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 EI=KCHG(IA,1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV EJ=KCHG(JA,1)/3D0 AJ=SIGN(1D0,EJ+0.1D0) VJ=AJ-4D0*EJ*XWV IF(VI+AI.GT.0) THEN VISAV=VI AISAV=AI VI=VJ AI=AJ VJ=VISAV AJ=AISAV ENDIF FCKM=1D0 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) FCOI=1D0 IF(IA.LE.10) FCOI=FACA/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+ & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))* & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+ & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+ & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))* & WIDS(24,(5-KCHW)/2) 500 CONTINUE 510 CONTINUE ELSEIF(ISUB.EQ.24) THEN C...f + fbar -> Z0 + h0 (or H0, or A0) THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) FACHZ=COMFAC*8D0*(AEM*XWC)**2* & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2) FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2) IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ* & PARU(154+10*IHIGG)**2 DO 520 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV FCOI=1D0 IF(IABS(I).LE.10) FCOI=FACA/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2) 520 CONTINUE ELSEIF(ISUB.EQ.25) THEN C...f + fbar -> W+ + W- C...Propagators: Z0, W+- as simulated in PYOFSH and as desired CALL PYWIDT(23,SH,WDTP,WDTE) GMMZC=SHR*WDTP(0) HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2) HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2) CALL PYWIDT(24,SQM3,WDTP,WDTE) GMMW3=SQRT(SQM3)*WDTP(0) HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2) HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2) CALL PYWIDT(24,SQM4,WDTP,WDTE) GMMW4=SQRT(SQM4)*WDTP(0) HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2) C...Kinematical functions THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4) GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2 GT=THUH34+4D0*THUH/TH2 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH GU=THUH34+4D0*THUH/UH2 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH C...Common factors and couplings FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4) FACWW=FACWW*WIDS(24,1) CGG=AEM**2/2D0 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH) CZZ=AEM**2/(32D0*XW**2)*HBWZC CNG=AEM**2/(4D0*XW) CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH) CNN=AEM**2/(16D0*XW**2) C...Coulomb factor for W+W- pair IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1)) COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH)) IF(COULE.LT.100D0*PMAS(24,2)) THEN COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+ & PMAS(24,2)**2)-COULE)) ELSE COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE)) ENDIF IF(COULE.GT.-100D0*PMAS(24,2)) THEN COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+ & PMAS(24,2)**2)+COULE)) ELSE COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/ & ABS(COULE))) ENDIF IF(MSTP(40).EQ.1) THEN COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/ & MAX(1D-10,2D0*COULP*COULP1)) FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34) ELSEIF(MSTP(40).EQ.2) THEN COULCK=CMPLX(SNGL(COULP1),SNGL(COULP2)) COULCP=CMPLX(0.,SNGL(COULP)) COULCD=(COULCK+COULCP)/(COULCK-COULCP) COULCR=1.+SNGL(PARU(101)*SQRT(SH))/(4.*COULCP)*LOG(COULCD) COULCS=CMPLX(0.,0.) NSTP=100 DO 530 ISTP=1,NSTP COULXX=(ISTP-0.5)/NSTP COULCS=COULCS+(1./COULXX)*LOG((1.+COULXX*COULCD)/ & (1.+COULXX/COULCD)) 530 CONTINUE COULCR=COULCR+SNGL(PARU(101)**2*SH)/(16.*COULCP*COULCK)* & (COULCS/NSTP) FACCOU=ABS(COULCR)**2 ELSEIF(MSTP(40).EQ.3) THEN COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+ & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1)) FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34) ENDIF ELSEIF(MSTP(40).EQ.4) THEN FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34) ELSE FACCOU=1D0 ENDIF VINT(95)=FACCOU FACWW=FACWW*FACCOU C...Loop over allowed flavours DO 540 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 540 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV FCOI=1D0 IF(IABS(I).LE.10) FCOI=FACA/3D0 IF(AI.LT.0D0) THEN DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+ & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT ELSE DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS- & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU ENDIF NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACWW*FCOI*DSIGWW 540 CONTINUE ELSEIF(ISUB.EQ.26) THEN C...f + fbar' -> W+/- + h0 (or H0, or A0) THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/ & ((SH-SQMW)**2+GMMW**2) FACHW=FACHW*WIDS(KFHIGG,2) IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW* & PARU(155+10*IHIGG)**2 DO 560 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 560 DO 550 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 550 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 550 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 550 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 FCKM=1D0 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) FCOI=1D0 IF(IA.LE.10) FCOI=FACA/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2) 550 CONTINUE 560 CONTINUE ELSEIF(ISUB.EQ.27) THEN C...f + fbar -> h0 + h0 ELSEIF(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 580 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 580 DO 570 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 570 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 570 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 570 CONTINUE 580 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 600 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 600 EI=KCHG(IABS(I),1)/3D0 FACGQ=FGQ*EI**2 DO 590 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 590 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 590 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACGQ 590 CONTINUE 600 CONTINUE ELSEIF(ISUB.EQ.30) THEN C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only) FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/ & (-SH*UH) C...gamma, gamma/Z interference and Z couplings to final fermion pairs HFGG=0D0 HFGZ=0D0 HFZZ=0D0 RADC4=1D0+PYALPS(SQM4)/PARU(1) DO 610 I=1,MIN(16,MDCY(23,3)) IDC=I+MDCY(23,2)-1 IF(MDME(IDC,1).LT.0) GOTO 610 IMDM=0 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4) & IMDM=1 IF(I.LE.8) THEN EF=KCHG(I,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV ELSEIF(I.LE.16) THEN EF=KCHG(I+2,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV ENDIF RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4 IF(4D0*RM1.LT.1D0) THEN FCOF=1D0 IF(I.LE.8) FCOF=3D0*RADC4 BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) IF(IMDM.EQ.1) THEN HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+ & AF**2*(1D0-4D0*RM1))*BE34 ENDIF ENDIF 610 CONTINUE C...Propagators: as simulated in PYOFSH and as desired HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) MINT(15)=1 MINT(61)=1 CALL PYWIDT(23,SQM4,WDTP,WDTE) HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) HFGG=HFGG*HFAEM*VINT(111)/SQM4 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4 C...Loop over flavours; consider full gamma/Z structure DO 630 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 630 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+ & (VI**2+AI**2)*HFZZ)/HBW4 DO 620 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 620 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 620 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACZQ 620 CONTINUE 630 CONTINUE ENDIF ELSEIF(ISUB.LE.40) THEN IF(ISUB.EQ.31) THEN C...f + g -> f' + W+/- (q + g -> q' + W+/- only) FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0* & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH) C...Propagators: as simulated in PYOFSH and as desired HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2) CALL PYWIDT(24,SQM4,WDTP,WDTE) GMMWC=SQRT(SQM4)*WDTP(0) HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2) FACWQ=FACWQ*HBW4C/HBW4 DO 650 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 650 IA=IABS(I) KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I)) WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0) DO 640 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 640 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 640 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC 640 CONTINUE 650 CONTINUE ELSEIF(ISUB.EQ.32) THEN C...f + g -> f + h0 (q + g -> q + h0 only) 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 670 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 670 EI=KCHG(IABS(I),1)/3D0 FACGQ=FGQ*EI**2 DO 660 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 660 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 660 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACGQ 660 CONTINUE 670 CONTINUE ELSEIF(ISUB.EQ.34) THEN C...f + gamma -> f + gamma FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH) DO 690 I=MMINA,MMAXA IF(I.EQ.0) GOTO 690 EI=KCHG(IABS(I),1)/3D0 FACGQ=FGQ*EI**4 DO 680 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 680 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 680 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACGQ 680 CONTINUE 690 CONTINUE ELSEIF(ISUB.EQ.35) THEN C...f + gamma -> f + (gamma*/Z0) FZQN=COMFAC*2D0*AEM**2*(SH2+UH2+2D0*SQM4*TH) FZQD=SQPTH*SQM4-SH*UH C...gamma, gamma/Z interference and Z couplings to final fermion pairs HFGG=0D0 HFGZ=0D0 HFZZ=0D0 RADC4=1D0+PYALPS(SQM4)/PARU(1) DO 700 I=1,MIN(16,MDCY(23,3)) IDC=I+MDCY(23,2)-1 IF(MDME(IDC,1).LT.0) GOTO 700 IMDM=0 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4) & IMDM=1 IF(I.LE.8) THEN EF=KCHG(I,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV ELSEIF(I.LE.16) THEN EF=KCHG(I+2,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV ENDIF RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4 IF(4D0*RM1.LT.1D0) THEN FCOF=1D0 IF(I.LE.8) FCOF=3D0*RADC4 BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) IF(IMDM.EQ.1) THEN HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+ & AF**2*(1D0-4D0*RM1))*BE34 ENDIF ENDIF 700 CONTINUE C...Propagators: as simulated in PYOFSH and as desired HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) MINT(15)=1 MINT(61)=1 CALL PYWIDT(23,SQM4,WDTP,WDTE) HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) HFGG=HFGG*HFAEM*VINT(111)/SQM4 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4 C...Loop over flavours; consider full gamma/Z structure DO 720 I=MMINA,MMAXA IF(I.EQ.0) GOTO 720 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+ & (VI**2+AI**2)*HFZZ)/HBW4 DO 710 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 710 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 710 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACZQ*FZQN/MAX(PMAS(IABS(I),1)**2*SQM4,FZQD) 710 CONTINUE 720 CONTINUE ELSEIF(ISUB.EQ.36) THEN C...f + gamma -> f' + W+/- FWQ=COMFAC*AEM**2/(2D0*XW)* & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH) C...Propagators: as simulated in PYOFSH and as desired HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2) CALL PYWIDT(24,SQM4,WDTP,WDTE) GMMWC=SQRT(SQM4)*WDTP(0) HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2) FWQ=FWQ*HBW4C/HBW4 DO 740 I=MMINA,MMAXA IF(I.EQ.0) GOTO 740 IA=IABS(I) EIA=ABS(KCHG(IABS(I),1)/3D0) FACWQ=FWQ*(EIA-SH/(SH+UH))**2 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I)) WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0) DO 730 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 730 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 730 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC 730 CONTINUE 740 CONTINUE ELSEIF(ISUB.EQ.37) THEN C...f + gamma -> f + h0 ELSEIF(ISUB.EQ.38) THEN C...f + Z0 -> f + g (q + Z0 -> q + g only) 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 (q + W+/- -> q' + g only) 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 (q + h0 -> q + g only) 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 (g + g -> q + qbar only) CALL PYWIDT(21,SH,WDTP,WDTE) FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* & UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* & TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 750 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 750 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 760 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)) 760 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.55) THEN C...g + Z -> f + fbar (g + Z -> q + qbar only) ELSEIF(ISUB.EQ.56) THEN C...g + W -> f + f'bar (g + W -> q + q'bar only) ELSEIF(ISUB.EQ.57) THEN C...g + h0 -> f + fbar (g + h0 -> q + qbar only) ELSEIF(ISUB.EQ.58) THEN C...gamma + gamma -> f + fbar CALL PYWIDT(22,SH,WDTP,WDTE) WDTESU=0D0 DO 770 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)) 770 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.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 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) IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 780 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 780 CONTINUE ELSEIF(ISUB.EQ.69) THEN C...gamma + gamma -> W+ + W- SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4)) FPROP=SH2/((SQMWE-TH)*(SQMWE-UH)) FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+ & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1) IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 790 NCHN=NCHN+1 ISIG(NCHN,1)=22 ISIG(NCHN,2)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACWW 790 CONTINUE ELSEIF(ISUB.EQ.70) THEN C...gamma + W+/- -> Z0 + W+/- SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4)) FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH)) FACZW=COMFAC*6D0*AEM**2*(XW1/XW)* & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+ & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2) DO 810 KCHW=1,-1,-2 DO 800 ISDE=1,2 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 800 NCHN=NCHN+1 ISIG(NCHN,ISDE)=22 ISIG(NCHN,3-ISDE)=24*KCHW ISIG(NCHN,3)=1 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2) 800 CONTINUE 810 CONTINUE ENDIF ELSEIF(ISUB.LE.80) THEN IF(ISUB.EQ.71) THEN C...Z0 + Z0 -> Z0 + Z0 IF(SH.LE.4.01D0*SQMZ) GOTO 840 IF(MSTP(46).LE.2) THEN C...Exact scattering ME:s for on-mass-shell gauge bosons BE2=1D0-4D0*SQMZ/SH TH=-0.5D0*SH*BE2*(1D0-CTH) UH=-0.5D0*SH*BE2*(1D0+CTH) IF(MAX(TH,UH).GT.-1D0) GOTO 840 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)* & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2) IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+ & (ASHIM+ATHIM+AUHIM)**2) IF(MSTP(46).EQ.2) FACZZ=0D0 ELSE C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)* & ABS(A00U+2.*A20U)**2 ENDIF FACZZ=FACZZ*WIDS(23,1) DO 830 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 830 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV AVI=AI**2+VI**2 DO 820 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 820 EJ=KCHG(IABS(J),1)/3D0 AJ=SIGN(1D0,EJ) VJ=AJ-4D0*EJ*XWV AVJ=AJ**2+VJ**2 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ 820 CONTINUE 830 CONTINUE 840 CONTINUE ELSEIF(ISUB.EQ.72) THEN C...Z0 + Z0 -> W+ + W- IF(SH.LE.4.01D0*SQMZ) GOTO 870 IF(MSTP(46).LE.2) THEN C...Exact scattering ME:s for on-mass-shell gauge bosons BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH)) CTH2=CTH**2 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH) UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH) IF(MAX(TH,UH).GT.-1D0) GOTO 870 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)* & (1D0-2D0*SQMZ/SH) ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0* & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0* & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2* & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+ & 2D0*(SQMW+SQMZ)/SH*BE2*CTH)) ATWIM=0D0 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0* & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0* & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2* & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2- & 2D0*(SQMW+SQMZ)/SH*BE2*CTH)) AUWIM=0D0 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH) A4IM=0D0 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)* & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2) IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+ & (ASHIM+ATWIM+AUWIM+A4IM)**2) IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+ & (ATWIM+AUWIM+A4IM)**2) ELSE C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)* & ABS(A00U-A20U)**2 ENDIF FACWW=FACWW*WIDS(24,1) DO 860 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 860 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV AVI=AI**2+VI**2 DO 850 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 850 EJ=KCHG(IABS(J),1)/3D0 AJ=SIGN(1D0,EJ) VJ=AJ-4D0*EJ*XWV AVJ=AJ**2+VJ**2 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACWW*AVI*AVJ 850 CONTINUE 860 CONTINUE 870 CONTINUE ELSEIF(ISUB.EQ.73) THEN C...Z0 + W+/- -> Z0 + W+/- IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 900 IF(MSTP(46).LE.2) THEN C...Exact scattering ME:s for on-mass-shell gauge bosons BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2 EP1=1D0-(SQMZ-SQMW)/SH EP2=1D0+(SQMZ-SQMW)/SH TH=-0.5D0*SH*BE2*(1D0-CTH) UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH) IF(MAX(TH,UH).GT.-1D0) GOTO 900 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH) ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+ & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+ & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH- & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2) ASWIM=0D0 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)* & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)* & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)- & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0* & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+ & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2* & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)* & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)* & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2* & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2* & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW* & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2) AUWIM=0D0 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)- & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2) A4IM=0D0 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4* & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2 IF(MSTP(46).LE.0) FACZW=0D0 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+ & (ATHIM+ASWIM+AUWIM+A4IM)**2) IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+ & (ASWIM+AUWIM+A4IM)**2) ELSE C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0* & ABS(A20U+3.*A11U*SNGL(CTH))**2 ENDIF FACZW=FACZW*WIDS(23,2) DO 890 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 890 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV AVI=AI**2+VI**2 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I)) DO 880 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 880 EJ=KCHG(IABS(J),1)/3D0 AJ=SIGN(1D0,EJ) VJ=AI-4D0*EJ*XWV AVJ=AJ**2+VJ**2 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J)) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=2 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ 880 CONTINUE 890 CONTINUE 900 CONTINUE ELSEIF(ISUB.EQ.75) THEN C...W+ + W- -> gamma + gamma ELSEIF(ISUB.EQ.76) THEN C...W+ + W- -> Z0 + Z0 IF(SH.LE.4.01D0*SQMZ) GOTO 930 IF(MSTP(46).LE.2) THEN C...Exact scattering ME:s for on-mass-shell gauge bosons BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH)) CTH2=CTH**2 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH) UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH) IF(MAX(TH,UH).GT.-1D0) GOTO 930 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)* & (1D0-2D0*SQMZ/SH) ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0* & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0* & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2* & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+ & 2D0*(SQMW+SQMZ)/SH*BE2*CTH)) ATWIM=0D0 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0* & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0* & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2* & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2- & 2D0*(SQMW+SQMZ)/SH*BE2*CTH)) AUWIM=0D0 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH) A4IM=0D0 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4* & (SH/SQMW)**2*SH2 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2) IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+ & (ASHIM+ATWIM+AUWIM+A4IM)**2) IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+ & (ATWIM+AUWIM+A4IM)**2) ELSE C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)* & ABS(A00U-A20U)**2 ENDIF FACZZ=FACZZ*WIDS(23,1) DO 920 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 920 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1) DO 910 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 910 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1) IF(EI*EJ.GT.0D0) GOTO 910 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J) 910 CONTINUE 920 CONTINUE 930 CONTINUE ELSEIF(ISUB.EQ.77) THEN C...W+/- + W+/- -> W+/- + W+/- IF(SH.LE.4.01D0*SQMW) GOTO 960 IF(MSTP(46).LE.2) THEN C...Exact scattering ME:s for on-mass-shell gauge bosons BE2=1D0-4D0*SQMW/SH BE4=BE2**2 CTH2=CTH**2 CTH3=CTH**3 TH=-0.5D0*SH*BE2*(1D0-CTH) UH=-0.5D0*SH*BE2*(1D0+CTH) IF(MAX(TH,UH).GT.-1D0) GOTO 960 SHANG=(1D0+BE2)**2 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG THANG=(BE2-CTH)**2 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG UHANG=(BE2+CTH)**2 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH ASGRE=XW*SGZANG ASGIM=0D0 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG ASZIM=0D0 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+ & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3) ATGRE=0.5D0*XW*SH/TH*TGZANG ATGIM=0D0 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG ATZIM=0D0 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+ & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3) AUGRE=0.5D0*XW*SH/UH*UGZANG AUGIM=0D0 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG AUZIM=0D0 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2) A4AIM=0D0 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2) A4SIM=0D0 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4* & (SH/SQMW)**2*SH2 IF(MSTP(46).LE.0) THEN AWWARE=ASHRE AWWAIM=ASHIM AWWSRE=0D0 AWWSIM=0D0 ELSEIF(MSTP(46).EQ.1) THEN AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM ELSE AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM ENDIF AWWA2=AWWARE**2+AWWAIM**2 AWWS2=AWWSRE**2+AWWSIM**2 ELSE C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)* & ABS(A00U+0.5*A20U+4.5*A11U*SNGL(CTH))**2 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2 ENDIF DO 950 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 950 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1) DO 940 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 940 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1) IF(EI*EJ.LT.0D0) THEN C...W+W- IF(MSTP(45).EQ.1) GOTO 940 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1) IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1) ELSE C...W+W+/W-W- IF(MSTP(45).EQ.2) GOTO 940 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2 IF(MSTP(46).GE.3) FACWW=FWWS IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4) IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5) ENDIF NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J) IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN) 940 CONTINUE 950 CONTINUE 960 CONTINUE 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+/- 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 980 I=MAX(-2,MMINA),MIN(2,MMAXA) IF(I.EQ.0) GOTO 980 EI=KCHG(IABS(I),1)/3D0 EJ=SIGN(1D0-ABS(EI),EI) DO 970 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 970 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 970 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2 970 CONTINUE 980 CONTINUE ENDIF C...C: 2 -> 2, tree diagrams with masses ELSEIF(ISUB.LE.90) THEN IF(ISUB.EQ.81) THEN C...q + qbar -> Q + Qbar FACQQB=COMFAC*AS**2*4D0/9D0*(((TH-SQM3)**2+ & (UH-SQM3)**2)/SH2+2D0*SQM3/SH) IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQM3,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 990 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 990 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQB 990 CONTINUE ELSEIF(ISUB.EQ.82) THEN C...g + g -> Q + Qbar IF(MSTP(34).EQ.0) THEN FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQM3)/(TH-SQM3)- & 2D0*(UH-SQM3)**2/SH2+4D0*(SQM3/SH)*(TH*UH-SQM3**2)/ & (TH-SQM3)**2) FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQM3)/(UH-SQM3)- & 2D0*(TH-SQM3)**2/SH2+4D0*(SQM3/SH)*(TH*UH-SQM3**2)/ & (UH-SQM3)**2) ELSE FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*((UH-SQM3)/(TH-SQM3)- & 2.25D0*(UH-SQM3)**2/SH2+4.5D0*(SQM3/SH)*(TH*UH-SQM3**2)/ & (TH-SQM3)**2+0.5D0*SQM3*TH/(TH-SQM3)**2-SQM3**2/ & (SH*(TH-SQM3))) FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*((TH-SQM3)/(UH-SQM3)- & 2.25D0*(TH-SQM3)**2/SH2+4.5D0*(SQM3/SH)*(TH*UH-SQM3**2)/ & (UH-SQM3)**2+0.5D0*SQM3*UH/(UH-SQM3)**2-SQM3**2/ & (SH*(UH-SQM3))) ENDIF IF(MSTP(35).GE.1) THEN FATRE=PYHFTH(SH,SQM3,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 1000 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 1000 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 1020 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1020 DO 1010 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1010 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 1010 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 1010 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1) & THEN NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2, & (IABS(I)+1)/2)*VINT(180+J) IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2, & (MINT(55)+1)/2)*VINT(180+J) WID2=1D0 IF(I.GT.0) THEN IF(MINT(55).EQ.6) WID2=WIDS(6,2) IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2= & WIDS(MINT(55),2) ELSE IF(MINT(55).EQ.6) WID2=WIDS(6,3) IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2= & WIDS(MINT(55),3) ENDIF IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2 ENDIF IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1) & THEN NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=2 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2, & (IABS(J)+1)/2)*VINT(180+I) IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2, & (MINT(55)+1)/2)*VINT(180+I) IF(J.GT.0) THEN IF(MINT(55).EQ.6) WID2=WIDS(6,2) IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2= & WIDS(MINT(55),2) ELSE IF(MINT(55).EQ.6) WID2=WIDS(6,3) IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2= & WIDS(MINT(55),3) ENDIF IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2 ENDIF 1010 CONTINUE 1020 CONTINUE ELSEIF(ISUB.EQ.84) THEN C...g + gamma -> Q + Qbar FMTU=SQM3/(SQM3-TH)+SQM3/(SQM3-UH) FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2* & ((SQM3-TH)/(SQM3-UH)+(SQM3-UH)/(SQM3-TH)+4D0*FMTU*(1D0-FMTU)) IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQM3,0D0) WID2=1D0 IF(MINT(55).EQ.6) WID2=WIDS(6,1) IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1) FACQQ=FACQQ*WID2 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ ENDIF IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=22 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ ENDIF ELSEIF(ISUB.EQ.85) THEN C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton) FMTU=SQM3/(SQM3-TH)+SQM3/(SQM3-UH) FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0* & ((SQM3-TH)/(SQM3-UH)+(SQM3-UH)/(SQM3-TH)+4D0*FMTU*(1D0-FMTU)) IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1) & FACFF=FACFF*PYHFTH(SH,SQM3,1D0) WID2=1D0 IF(MINT(56).EQ.6) WID2=WIDS(6,1) IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1) IF(MINT(56).EQ.17) WID2=WIDS(17,1) FACFF=FACFF*WID2 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=22 ISIG(NCHN,2)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACFF ENDIF ELSEIF(ISUB.EQ.86) THEN C...g + g -> J/Psi + g FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)* & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/ & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQG ENDIF ELSEIF(ISUB.EQ.87) THEN C...g + g -> chi_0c + g PGTW=(SH*TH+TH*UH+UH*SH)/SH2 QGTW=(SH*TH*UH)/SH**3 RGTW=SQM3/SH FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)* & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)- & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)- & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+ & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/ & (QGTW*(QGTW-RGTW*PGTW)**4) IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQG ENDIF ELSEIF(ISUB.EQ.88) THEN C...g + g -> chi_1c + g PGTW=(SH*TH+TH*UH+UH*SH)/SH2 QGTW=(SH*TH*UH)/SH**3 RGTW=SQM3/SH FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)* & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+ & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/ & (QGTW-RGTW*PGTW)**4 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQG ENDIF ELSEIF(ISUB.EQ.89) THEN C...g + g -> chi_2c + g PGTW=(SH*TH+TH*UH+UH*SH)/SH2 QGTW=(SH*TH*UH)/SH**3 RGTW=SQM3/SH FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)* & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)- & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+ & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+ & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2* & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4) IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQG ENDIF ENDIF C...D: Mimimum bias processes ELSEIF(ISUB.LE.100) THEN IF(ISUB.EQ.91) THEN C...Elastic scattering SIGS=SIGT(0,0,1) ELSEIF(ISUB.EQ.92) THEN C...Single diffractive scattering (first side, i.e. XB) SIGS=SIGT(0,0,2) ELSEIF(ISUB.EQ.93) THEN C...Single diffractive scattering (second side, i.e. AX) SIGS=SIGT(0,0,3) ELSEIF(ISUB.EQ.94) THEN C...Double diffractive scattering SIGS=SIGT(0,0,4) ELSEIF(ISUB.EQ.95) THEN C...Low-pT scattering SIGS=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- & MSTP(34)*2D0/3D0*SH2/(TH*UH)) DO 1040 I=-3,3 IF(I.EQ.0) GOTO 1040 DO 1030 J=-3,3 IF(J.EQ.0) GOTO 1030 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*SIGH(NCHN) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=112 SIGH(NCHN)=0.5D0*FACQQ2 ENDIF 1030 CONTINUE 1040 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 1050 I=-3,3 IF(I.EQ.0) GOTO 1050 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 1050 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 1070 I=-3,3 IF(I.EQ.0) GOTO 1070 DO 1060 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 1060 CONTINUE 1070 CONTINUE C...g + g -> q + qbar or g + g FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* & UH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* & TH2/SH2)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))*FACA 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)=531 SIGH(NCHN)=FACQQ1 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=532 SIGH(NCHN)=FACQQ2 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 ENDIF C...E: 2 -> 1, loop diagrams ELSEIF(ISUB.LE.110) THEN IF(ISUB.EQ.101) THEN C...g + g -> gamma*/Z0 ELSEIF(ISUB.EQ.102) THEN C...g + g -> h0 (or H0, or A0) CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) HS=SHR*WDTP(0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2) IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) & FACBW=0D0 HI=SHR*WDTP(13)/32D0 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1080 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=HI*FACBW*HF 1080 CONTINUE ELSEIF(ISUB.EQ.103) THEN C...gamma + gamma -> h0 (or H0, or A0) CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) HS=SHR*WDTP(0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2) IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) & FACBW=0D0 HI=SHR*WDTP(14)*2D0 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 1090 NCHN=NCHN+1 ISIG(NCHN,1)=22 ISIG(NCHN,2)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=HI*FACBW*HF 1090 CONTINUE C...Continuation C: 2 -> 2, tree diagrams with masses. ELSEIF(ISUB.EQ.106) THEN C...g + g -> J/Psi + gamma. EQ=2D0/3D0 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)* & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/ & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQG ENDIF ELSEIF(ISUB.EQ.107) THEN C...g + gamma -> J/Psi + g. EQ=2D0/3D0 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)* & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/ & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQG ENDIF IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=22 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQG ENDIF ELSEIF(ISUB.EQ.108) THEN C...gamma + gamma -> J/Psi + gamma. EQ=2D0/3D0 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)* & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/ & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=22 ISIG(NCHN,2)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQG ENDIF C...F: 2 -> 2, box diagrams ELSEIF(ISUB.EQ.110) THEN C...f + fbar -> gamma + h0 THUH=MAX(TH*UH,SH*CKIN(3)**2) FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH FACHG=FACHG*WIDS(KFHIGG,2) C...Calculate loop contributions for intermediate gamma* and Z0 CIGTOT=CMPLX(0.,0.) CIZTOT=CMPLX(0.,0.) JMAX=3*MSTP(1)+1 DO 1100 J=1,JMAX IF(J.LE.2*MSTP(1)) THEN FNC=1D0 EJ=KCHG(J,1)/3D0 AJ=SIGN(1D0,EJ+0.1D0) VJ=AJ-4D0*EJ*XWV BALP=SQM4/(2D0*PMAS(J,1))**2 BBET=SH/(2D0*PMAS(J,1))**2 ELSEIF(J.LE.3*MSTP(1)) THEN FNC=3D0 JL=2*(J-2*MSTP(1))-1 EJ=KCHG(10+JL,1)/3D0 AJ=SIGN(1D0,EJ+0.1D0) VJ=AJ-4D0*EJ*XWV BALP=SQM4/(2D0*PMAS(10+JL,1))**2 BBET=SH/(2D0*PMAS(10+JL,1))**2 ELSE BALP=SQM4/(2D0*PMAS(24,1))**2 BBET=SH/(2D0*PMAS(24,1))**2 ENDIF BABI=1D0/(BALP-BBET) IF(BALP.LT.1D0) THEN F0ALP=CMPLX(SNGL(ASIN(SQRT(BALP))),0.) F1ALP=F0ALP**2 ELSE F0ALP=CMPLX(SNGL(LOG(SQRT(BALP)+SQRT(BALP-1D0))), & -SNGL(0.5D0*PARU(1))) F1ALP=-F0ALP**2 ENDIF F2ALP=SNGL(SQRT(ABS(BALP-1D0)/BALP))*F0ALP IF(BBET.LT.1D0) THEN F0BET=CMPLX(SNGL(ASIN(SQRT(BBET))),0.) F1BET=F0BET**2 ELSE F0BET=CMPLX(SNGL(LOG(SQRT(BBET)+SQRT(BBET-1D0))), & -SNGL(0.5D0*PARU(1))) F1BET=-F0BET**2 ENDIF F2BET=SNGL(SQRT(ABS(BBET-1D0)/BBET))*F0BET IF(J.LE.3*MSTP(1)) THEN FIF=SNGL(0.5D0*BABI)+SNGL(BABI**2)*(SNGL(0.5D0*(1D0-BALP+ & BBET))*(F1BET-F1ALP)+SNGL(BBET)*(F2BET-F2ALP)) CIGTOT=CIGTOT+SNGL(FNC*EJ**2)*FIF CIZTOT=CIZTOT+SNGL(FNC*EJ*VJ)*FIF ELSE TXW=XW/XW1 CIGTOT=CIGTOT-0.5*(SNGL(BABI*(1.5D0+BALP))+SNGL(BABI**2)* & (SNGL(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+ & SNGL(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP))) CIZTOT=CIZTOT-SNGL(0.5D0*BABI*XW1)*(SNGL(5D0-TXW+2D0*BALP* & (1D0-TXW))*(1.+SNGL(2D0*BABI*BBET)*(F2BET-F2ALP))+ & SNGL(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))* & (F1BET-F1ALP)) ENDIF 1100 CONTINUE CIGTOT=CIGTOT/SNGL(SH) CIZTOT=CIZTOT*SNGL(XWC)/CMPLX(SNGL(SH-SQMZ),SNGL(GMMZ)) C...Loop over initial flavours DO 1110 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1110 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV FCOI=1D0 IF(IABS(I).LE.10) FCOI=FACA/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACHG*FCOI*(ABS(SNGL(EI)*CIGTOT+SNGL(VI)* & CIZTOT)**2+AI**2*ABS(CIZTOT)**2) 1110 CONTINUE ENDIF ELSEIF(ISUB.LE.120) THEN IF(ISUB.EQ.111) THEN C...f + fbar -> g + h0 (q + qbar -> g + h0 only) A5STUR=0D0 A5STUI=0D0 DO 1120 I=1,2*MSTP(1) SQMQ=PMAS(I,1)**2 EPSS=4D0*SQMQ/SH EPSH=4D0*SQMQ/SQMH CALL PYWAUX(1,EPSS,W1SR,W1SI) CALL PYWAUX(1,EPSH,W1HR,W1HI) CALL PYWAUX(2,EPSS,W2SR,W2SI) CALL PYWAUX(2,EPSH,W2HR,W2HI) A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+ & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR)) A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+ & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI)) 1120 CONTINUE FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW* & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2) FACGH=FACGH*WIDS(25,2) DO 1130 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1130 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACGH 1130 CONTINUE ELSEIF(ISUB.EQ.112) THEN C...f + g -> f + h0 (q + g -> q + h0 only) A5TSUR=0D0 A5TSUI=0D0 DO 1140 I=1,2*MSTP(1) SQMQ=PMAS(I,1)**2 EPST=4D0*SQMQ/TH EPSH=4D0*SQMQ/SQMH CALL PYWAUX(1,EPST,W1TR,W1TI) CALL PYWAUX(1,EPSH,W1HR,W1HI) CALL PYWAUX(2,EPST,W2TR,W2TI) CALL PYWAUX(2,EPSH,W2HR,W2HI) A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+ & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR)) A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+ & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI)) 1140 CONTINUE FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW* & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2) FACQH=FACQH*WIDS(25,2) DO 1160 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1160 DO 1150 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1150 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1150 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQH 1150 CONTINUE 1160 CONTINUE ELSEIF(ISUB.EQ.113) THEN C...g + g -> g + h0 A2STUR=0D0 A2STUI=0D0 A2USTR=0D0 A2USTI=0D0 A2TUSR=0D0 A2TUSI=0D0 A4STUR=0D0 A4STUI=0D0 DO 1170 I=1,2*MSTP(1) SQMQ=PMAS(I,1)**2 EPSS=4D0*SQMQ/SH EPST=4D0*SQMQ/TH EPSU=4D0*SQMQ/UH EPSH=4D0*SQMQ/SQMH IF(EPSH.LT.1.D-6) GOTO 1170 CALL PYWAUX(1,EPSS,W1SR,W1SI) CALL PYWAUX(1,EPST,W1TR,W1TI) CALL PYWAUX(1,EPSU,W1UR,W1UI) CALL PYWAUX(1,EPSH,W1HR,W1HI) CALL PYWAUX(2,EPSS,W2SR,W2SI) CALL PYWAUX(2,EPST,W2TR,W2TI) CALL PYWAUX(2,EPSU,W2UR,W2UI) CALL PYWAUX(2,EPSH,W2HR,W2HI) CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI) CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI) CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI) CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI) CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI) CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI) CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI) CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI) CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI) CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI) CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI) CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI) W3STUR=YHSTUR-Y3STUR-Y3UTSR W3STUI=YHSTUI-Y3STUI-Y3UTSI W3SUTR=YHSUTR-Y3SUTR-Y3TUSR W3SUTI=YHSUTI-Y3SUTI-Y3TUSI W3TSUR=YHTSUR-Y3TSUR-Y3USTR W3TSUI=YHTSUI-Y3TSUI-Y3USTI W3TUSR=YHTUSR-Y3TUSR-Y3SUTR W3TUSI=YHTUSI-Y3TUSI-Y3SUTI W3USTR=YHUSTR-Y3USTR-Y3TSUR W3USTI=YHUSTI-Y3USTI-Y3TSUI W3UTSR=YHUTSR-Y3UTSR-Y3STUR W3UTSI=YHUTSI-Y3UTSI-Y3STUI B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH* & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)* & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/ & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH* & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR) B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2* & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+ & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))* & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0* & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI) B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH* & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)* & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/ & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH* & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR) B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2* & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+ & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))* & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0* & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI) B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH* & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)* & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/ & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH* & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR) B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2* & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+ & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))* & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0* & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI) B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH* & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)* & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/ & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH* & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR) B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2* & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+ & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))* & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0* & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI) B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH* & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)* & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/ & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH* & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR) B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2* & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+ & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))* & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0* & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI) B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH* & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)* & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/ & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH* & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR) B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2* & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+ & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))* & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0* & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI) B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)* & (W2SR-W2HR+W3STUR)) B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI) B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)* & (W2TR-W2HR+W3TUSR)) B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI) B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)* & (W2UR-W2HR+W3USTR)) B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI) A2STUR=A2STUR+B2STUR+B2SUTR A2STUI=A2STUI+B2STUI+B2SUTI A2USTR=A2USTR+B2USTR+B2UTSR A2USTI=A2USTI+B2USTI+B2UTSI A2TUSR=A2TUSR+B2TUSR+B2TSUR A2TUSI=A2TUSI+B2TUSI+B2TSUI A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI 1170 CONTINUE FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3* & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+ & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2) FACGH=FACGH*WIDS(25,2) IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1180 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACGH 1180 CONTINUE ELSEIF(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 1190 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.1.D-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 1190 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 1200 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 1200 CONTINUE 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 C...G: 2 -> 3, tree diagrams ELSEIF(ISUB.LE.140) THEN IF(ISUB.EQ.121) THEN C...g + g -> Q + Qbar + h0 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1210 IA=KFPR(ISUBSV,2) PMF=PMAS(IA,1) FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2* & (0.5D0*PMF/PMAS(24,1))**2 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) FACQQH= & FACQQH*(LOG(MAX(4D0,PARP(37)**2*PMF**2/PARU(117)**2))/ & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118))) WID2=1D0 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1) FACQQH=FACQQH*WID2 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN IKFI=1 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2 IF(IA.GT.10) IKFI=3 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2 ENDIF CALL PYQQBH(WTQQBH) CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) HS=SHR*WDTP(0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2) IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) & FACBW=0D0 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQH*WTQQBH*FACBW 1210 CONTINUE ELSEIF(ISUB.EQ.122) THEN C...q + qbar -> Q + Qbar + h0 IA=KFPR(ISUBSV,2) PMF=PMAS(IA,1) FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2* & (0.5D0*PMF/PMAS(24,1))**2 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) FACQQH= & FACQQH*(LOG(MAX(4D0,PARP(37)**2*PMF**2/PARU(117)**2))/ & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118))) WID2=1D0 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1) FACQQH=FACQQH*WID2 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN IKFI=1 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2 IF(IA.GT.10) IKFI=3 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2 ENDIF CALL PYQQBH(WTQQBH) CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) HS=SHR*WDTP(0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2) IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) & FACBW=0D0 DO 1220 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1220 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQH*WTQQBH*FACBW 1220 CONTINUE ELSEIF(ISUB.EQ.123) THEN C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as C...inner process) FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR* & PARU(154+10*IHIGG)**2 FACPRP=1D0/((VINT(215)-VINT(204)**2)* & (VINT(216)-VINT(209)**2))**2 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219) FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218) CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) HS=SHR*WDTP(0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2) IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) & FACBW=0D0 DO 1240 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1240 IA=IABS(I) DO 1230 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1230 JA=IABS(J) EI=KCHG(IA,1)*ISIGN(1,I)/3D0 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I) VI=AI-4D0*EI*XWV EJ=KCHG(JA,1)*ISIGN(1,J)/3D0 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J) VJ=AJ-4D0*EJ*XWV FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW 1230 CONTINUE 1240 CONTINUE ELSEIF(ISUB.EQ.124) THEN C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as C...inner process) FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR* & PARU(155+10*IHIGG)**2 FACPRP=1D0/((VINT(215)-VINT(204)**2)* & (VINT(216)-VINT(209)**2))**2 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219) CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) HS=SHR*WDTP(0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2) IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) & FACBW=0D0 DO 1260 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1260 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1) DO 1250 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1250 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1) IF(EI*EJ.GT.0D0) GOTO 1250 FACLR=VINT(180+I)*VINT(180+J) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACLR*FACWW*FACBW 1250 CONTINUE 1260 CONTINUE ELSEIF(ISUB.EQ.131) THEN C...g + g -> Z0 + q + qbar ENDIF C...H: 2 -> 1, tree diagrams, non-standard model processes ELSEIF(ISUB.LE.160) THEN IF(ISUB.EQ.141) THEN C...f + fbar -> gamma*/Z0/Z'0 SQMZP=PMAS(32,1)**2 MINT(61)=2 CALL PYWIDT(32,SH,WDTP,WDTE) HP0=AEM/3D0*SH HP1=AEM/3D0*XWC*SH HP2=HP1 HS=SHR*VINT(117) HSP=SHR*WDTP(0) FACZP=4D0*COMFAC*3D0 DO 1270 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1270 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV IF(IABS(I).LT.10) THEN VPI=PARU(123-2*MOD(IABS(I),2)) API=PARU(124-2*MOD(IABS(I),2)) ELSE VPI=PARU(127-2*MOD(IABS(I),2)) API=PARU(128-2*MOD(IABS(I),2)) ENDIF HI0=HP0 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0 HI1=HP1 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0 HI2=HP2 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI* & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)* & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)* & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/ & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)* & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)* & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+ & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116)) 1270 CONTINUE ELSEIF(ISUB.EQ.142) THEN C...f + fbar' -> W'+/- SQMWP=PMAS(34,1)**2 CALL PYWIDT(34,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0 HP=AEM/(24D0*XW)*SH DO 1290 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1290 IA=IABS(I) DO 1280 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1280 JA=IABS(J) IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1280 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 1280 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 HI=HP*(PARU(133)**2+PARU(134)**2) IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)* & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4)) SIGH(NCHN)=HI*FACBW*HF 1280 CONTINUE 1290 CONTINUE ELSEIF(ISUB.EQ.143) THEN C...f + fbar' -> H+/- SQMHC=PMAS(37,1)**2 CALL PYWIDT(37,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2) HP=AEM/(8D0*XW)*SH/SQMW*SH DO 1310 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1310 IA=IABS(I) IM=(MOD(IA,10)+1)/2 DO 1300 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1300 JA=IABS(J) JM=(MOD(JA,10)+1)/2 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 1300 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 1300 IF(MOD(IA,2).EQ.0) THEN IU=IA IL=JA ELSE IU=JA IL=IA ENDIF RML=PMAS(IL,1)**2/SH RMU=PMAS(IU,1)**2/SH IF(IL.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) RML= & RML*(LOG(MAX(4D0,PARP(37)**2*RML*SH/PARU(117)**2))/ & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0- & 2D0*MSTU(118))) HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2) IF(IA.LE.10) HI=HI*FACA/3D0 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4)) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=HI*FACBW*HF 1300 CONTINUE 1310 CONTINUE ELSEIF(ISUB.EQ.144) THEN C...f + fbar' -> R SQMR=PMAS(40,1)**2 CALL PYWIDT(40,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0 HP=AEM/(12D0*XW)*SH DO 1330 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1330 IA=IABS(I) DO 1320 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1320 JA=IABS(J) IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 1320 HI=HP IF(IA.LE.10) HI=HI*FACA/3D0 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4)) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=HI*FACBW*HF 1320 CONTINUE 1330 CONTINUE ELSEIF(ISUB.EQ.145) THEN C...q + l -> LQ (leptoquark) SQMLQ=PMAS(39,1)**2 CALL PYWIDT(39,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2) IF(ABS(SHR-PMAS(39,1)).GT.PARP(48)*PMAS(39,2)) FACBW=0D0 HP=AEM/4D0*SH KFLQQ=KFDP(MDCY(39,2),1) KFLQL=KFDP(MDCY(39,2),2) DO 1350 I=MMIN1,MMAX1 IF(KFAC(1,I).EQ.0) GOTO 1350 IA=IABS(I) IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 1350 DO 1340 J=MMIN2,MMAX2 IF(KFAC(2,J).EQ.0) GOTO 1340 JA=IABS(J) IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 1340 IF(I*J.NE.KFLQQ*KFLQL) GOTO 1340 IF(JA.EQ.IA) GOTO 1340 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I) IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J) HI=HP*PARU(151) HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4)) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=HI*FACBW*HF 1340 CONTINUE 1350 CONTINUE ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN C...d + g -> d* and u + g -> u* (excited quarks) KFQSTR=KFPR(ISUB,1) KCQSTR=PYCOMP(KFQSTR) KFQEXC=MOD(KFQSTR,KEXCIT) CALL PYWIDT(KFQSTR,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2) FACBW=FACBW*AS*PARU(159)**2*SH/(3D0*PARU(155)**2) IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2)) & FACBW=0D0 HP=SH DO 1370 I=-KFQEXC,KFQEXC,2*KFQEXC DO 1360 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1360 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1360 HI=HP IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4)) NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=HI*FACBW*HF 1360 CONTINUE 1370 CONTINUE ELSEIF(ISUB.EQ.149) THEN C...g + g -> eta_techni CALL PYWIDT(38,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=COMFAC*0.5D0/((SH-PMAS(38,1)**2)**2+HS**2) IF(ABS(SHR-PMAS(38,1)).GT.PARP(48)*PMAS(38,2)) FACBW=0D0 HP=SH IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1380 HI=HP*WDTP(3) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=HI*FACBW*HF 1380 CONTINUE ENDIF C...I: 2 -> 2, tree diagrams, non-standard model processes ELSEIF(ISUB.LE.200) THEN IF(ISUB.EQ.161) THEN C...f + g -> f' + H+/- (b + g -> t + H+/- only) C...(choice of only b and t to avoid kinematics problems) SQMHC=PMAS(37,1)**2 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24 DO 1400 I=MMINA,MMAXA IA=IABS(I) IF(IA.NE.5) GOTO 1400 SQML=PMAS(IA,1)**2 IF(IA.LE.10.AND.MSTP(37).EQ.1.AND.MSTP(2).GE.1) SQML=SQML* & (LOG(MAX(4D0,PARP(37)**2*SQML/PARU(117)**2))/ & LOG(MAX(4D0,SH/PARU(117)**2)))**(24D0/(33D0-2D0*MSTU(118))) IUA=IA+MOD(IA,2) SQMQ=PMAS(IUA,1)**2 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW* & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH+ & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)* & (SQMHC-SQMQ-SH)/SH) KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I)) DO 1390 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1390 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 1390 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2) 1390 CONTINUE 1400 CONTINUE ELSEIF(ISUB.EQ.162) THEN C...q + g -> LQ + lbar; LQ=leptoquark SQMLQ=PMAS(39,1)**2 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)* & (UH2+SQMLQ**2)/(UH-SQMLQ)**2 KFLQQ=KFDP(MDCY(39,2),1) DO 1420 I=MMINA,MMAXA IF(IABS(I).NE.KFLQQ) GOTO 1420 KCHLQ=ISIGN(1,I) DO 1410 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1410 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1410 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACLQ*WIDS(39,(5-KCHLQ)/2) 1410 CONTINUE 1420 CONTINUE ELSEIF(ISUB.EQ.163) THEN C...g + g -> LQ + LQbar; LQ=leptoquark SQMLQ=PMAS(39,1)**2 FACLQ=COMFAC*FACA*WIDS(39,1)*(AS**2/2D0)* & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/ & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/ & ((TH-SQMLQ)*(UH-SQMLQ))) IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1430 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 C...Since don't know proper colour flow, randomize between alternatives ISIG(NCHN,3)=INT(1.5D0+PYR(0)) SIGH(NCHN)=FACLQ 1430 CONTINUE ELSEIF(ISUB.EQ.164) THEN C...q + qbar -> LQ + LQbar; LQ=leptoquark SQMLQ=PMAS(39,1)**2 FACLQA=COMFAC*WIDS(39,1)*(AS**2/9D0)* & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2 FACLQS=COMFAC*WIDS(39,1)*((PARU(151)**2*AEM**2/8D0)* & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)* & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH)) KFLQQ=KFDP(MDCY(39,2),1) DO 1440 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1440 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACLQA IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS 1440 CONTINUE ELSEIF(ISUB.EQ.165) THEN C...q + qbar -> l+ + l- (including contact term for compositeness) ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) KFF=IABS(KFPR(ISUB,1)) EF=KCHG(KFF,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV VALF=VF+AF VARF=VF-AF FCOF=1D0 IF(KFF.LE.10) FCOF=3D0 WID2=1D0 IF(KFF.EQ.6) WID2=WIDS(6,1) IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1) IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1) DO 1450 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1450 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV VALI=VI+AI VARI=VI-AI FCOI=1D0 IF(IABS(I).LE.10) FCOI=FACA/3D0 IF((MSTP(5).EQ.1.AND.IABS(I).LE.2).OR.MSTP(5).EQ.2) THEN FGZA=(EI*EF+VALI*VALF*ZRATR+PARU(156)*SH/ & (AEM*PARU(155)**2))**2+(VALI*VALF*ZRATI)**2+ & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2 ELSE FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+ & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2 ENDIF FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+ & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2) IF((MSTP(5).EQ.3.AND.IABS(I).EQ.2).OR.(MSTP(5).EQ.4.AND. & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*PARU(155)**4) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2 1450 CONTINUE ELSEIF(ISUB.EQ.166) THEN C...q + q'bar -> l + nu_l (including contact term for compositeness) WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2) WCIFAC=WFAC+SH2/(4D0*PARU(155)**4) KFF=IABS(KFPR(ISUB,1)) FCOF=1D0 IF(KFF.LE.10) FCOF=3D0 DO 1470 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1470 IA=IABS(I) DO 1460 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1460 JA=IABS(J) IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1460 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 1460 FCOI=1D0 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0 WID2=1D0 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND. & MOD(J,2).EQ.0)) THEN IF(KFF.EQ.5) WID2=WIDS(6,2) IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3) IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3) ELSE IF(KFF.EQ.5) WID2=WIDS(6,3) IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2) IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2) ENDIF NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2 IF((MSTP(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.MSTP(5).EQ.4) & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2 1460 CONTINUE 1470 CONTINUE ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN C...d + g -> d* and u + g -> u* (excited quarks) KFQSTR=KFPR(ISUB,2) KCQSTR=PYCOMP(KFQSTR) KFQEXC=MOD(KFQSTR,KEXCIT) FACQSA=COMFAC*(SH/PARU(155)**2)**2*(1D0-SQM4/SH) FACQSB=COMFAC*0.25D0*(SH/PARU(155)**2)**2*(1D0-SQM4/SH)* & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH) C...Propagators: as simulated in PYOFSH and as desired GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2) HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2) CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE) GMMQC=SQRT(SQM4)*WDTP(0) HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2) FACQSA=FACQSA*HBW4C/HBW4 FACQSB=FACQSB*HBW4C/HBW4 DO 1490 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1490 DO 1480 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1480 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=(4D0/3D0)*FACQSA NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=2 SIGH(NCHN)=(4D0/3D0)*FACQSA ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2 SIGH(NCHN)=FACQSA ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=(8D0/3D0)*FACQSB NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=2 SIGH(NCHN)=(8D0/3D0)*FACQSB ELSEIF(I.EQ.-J) THEN NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACQSB NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=2 SIGH(NCHN)=FACQSB ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2 SIGH(NCHN)=FACQSB ENDIF 1480 CONTINUE 1490 CONTINUE ELSEIF(ISUB.EQ.191) THEN C...q + qbar -> rho_tech0. SQMRHT=PMAS(54,1)**2 CALL PYWIDT(54,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2) IF(ABS(SHR-PMAS(54,1)).GT.PARP(48)*PMAS(54,2)) FACBW=0D0 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) ALPRHT=2.91D0*(3D0/PARP(144)) HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH) XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW)) BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) DO 1500 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1500 IA=IABS(I) EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV VALI=0.5D0*(VI+AI) VARI=0.5D0*(VI-AI) HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+ & (EI+VARI*BWZR)**2+(VARI*BWZI)**2) IF(IA.LE.10) HI=HI*FACA/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=HI*FACBW*HF 1500 CONTINUE ELSEIF(ISUB.EQ.192) THEN C...q + qbar' -> rho_tech+/-. SQMRHT=PMAS(55,1)**2 CALL PYWIDT(55,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2) IF(ABS(SHR-PMAS(55,1)).GT.PARP(48)*PMAS(55,2)) FACBW=0D0 ALPRHT=2.91D0*(3D0/PARP(144)) HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)* & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2) DO 1520 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1520 IA=IABS(I) DO 1510 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1510 JA=IABS(J) IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1510 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 1510 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4)) HI=HP IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=HI*FACBW*HF 1510 CONTINUE 1520 CONTINUE ELSEIF(ISUB.EQ.193) THEN C...q + qbar -> omega_tech0. SQMOMT=PMAS(56,1)**2 CALL PYWIDT(56,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2) IF(ABS(SHR-PMAS(56,1)).GT.PARP(48)*PMAS(56,2)) FACBW=0D0 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) ALPRHT=2.91D0*(3D0/PARP(144)) HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)* & (2D0*PARP(143)-1D0)**2 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) DO 1530 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1530 IA=IABS(I) EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV VALI=0.5D0*(VI+AI) VARI=0.5D0*(VI-AI) HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+ & (EI-VARI*BWZR)**2+(VARI*BWZI)**2) IF(IA.LE.10) HI=HI*FACA/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=HI*FACBW*HF 1530 CONTINUE ELSEIF(ISUB.EQ.194) THEN C...f + fbar -> f' + fbar' via s-channel rho_tech and omega_tech. SQMRHT=PMAS(54,1)**2 CALL PYWIDT(54,SH,WDTP,WDTE) HSRHT=SHR*WDTP(0) BWRHTR=SQMRHT**2*(SH-SQMRHT)/((SH-SQMRHT)**2+HSRHT**2) BWRHTI=SQMRHT**2*HSRHT/((SH-SQMRHT)**2+HSRHT**2) XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW)) SQMOMT=PMAS(56,1)**2 CALL PYWIDT(56,SH,WDTP,WDTE) HSOMT=SHR*WDTP(0) BWOMTR=SQMOMT**2*(SH-SQMOMT)/((SH-SQMOMT)**2+HSOMT**2) BWOMTI=SQMOMT**2*HSOMT/((SH-SQMOMT)**2+HSOMT**2) XWOMT=0.5D0/(1D0-XW) KFF=IABS(KFPR(ISUB,1)) EF=KCHG(KFF,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV VALF=0.5D0*(VF+AF) VARF=0.5D0*(VF-AF) FCOF=1D0 IF(KFF.LE.10) FCOF=3D0 WID2=1D0 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1) IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1) ALPRHT=2.91D0*(3D0/PARP(144)) FACTC=COMFAC*(AEM**2/(ALPRHT*SH2))**2*FCOF*WID2 BWZ=SH/(SH-SQMZ) ALEFTF=EF+VALF*XWRHT*BWZ ARIGHF=EF+VARF*XWRHT*BWZ BLEFTF=(EF-VALF*XWOMT*BWZ)*(2D0*PARP(143)-1D0) BRIGHF=(EF-VARF*XWOMT*BWZ)*(2D0*PARP(143)-1D0) DO 1540 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1540 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV VALI=0.5D0*(VI+AI) VARI=0.5D0*(VI-AI) FCOI=1D0 IF(IABS(I).LE.10) FCOI=FACA/3D0 ALEFTI=EI+VALI*XWRHT*BWZ ARIGHI=EI+VARI*XWRHT*BWZ BLEFTI=(EI-VALI*XWOMT*BWZ)*(2D0*PARP(143)-1D0) BRIGHI=(EI-VARI*XWOMT*BWZ)*(2D0*PARP(143)-1D0) DIFLL=(ALEFTI*ALEFTF*BWRHTR+BLEFTI*BLEFTF*BWOMTR)**2+ & (ALEFTI*ALEFTF*BWRHTI+BLEFTI*BLEFTF*BWOMTI)**2 DIFRR=(ARIGHI*ARIGHF*BWRHTR+BRIGHI*BRIGHF*BWOMTR)**2+ & (ARIGHI*ARIGHF*BWRHTI+BRIGHI*BRIGHF*BWOMTI)**2 DIFLR=(ALEFTI*ARIGHF*BWRHTR+BLEFTI*BRIGHF*BWOMTR)**2+ & (ALEFTI*ARIGHF*BWRHTI+BLEFTI*BRIGHF*BWOMTI)**2 DIFRL=(ARIGHI*ALEFTF*BWRHTR+BRIGHI*BLEFTF*BWOMTR)**2+ & (ARIGHI*ALEFTF*BWRHTI+BRIGHI*BLEFTF*BWOMTI)**2 FACSIG=(DIFLL+DIFRR)*UH2+(DIFLR+DIFRL)*TH2 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACTC*FCOI*FACSIG 1540 CONTINUE ENDIF CMRENNA++ C...J: 2 -> 2, tree diagrams, SUSY processes ELSEIF(ISUB.LE.210) THEN IF(ISUB.EQ.201) THEN C...f + fbar -> e_L + e_Lbar COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) DO 1570 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1570 EI=KCHG(IA,1)/3D0 TT3I=SIGN(1D0,EI+1D-6)/2D0 EJ=-1D0 TT3J=-1D0/2D0 FCOL=1D0 C...Color factor for e+ e- IF(IA.GE.11) FCOL=3D0 IF(ILR.EQ.1) THEN A1=SFMIX(KFID,3)**2 A2=SFMIX(KFID,4)**2 ELSEIF(ILR.EQ.0) THEN A1=SFMIX(KFID,1)**2 A2=SFMIX(KFID,2)**2 ENDIF XLQ=(TT3J-EJ*XW)*A1 XRQ=(-EJ*XW)*A2 XLF=(TT3I-EI*XW) XRF=(-EI*XW) TAA=2D0*(EI*EJ)**2 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/XW**2/XW1**2 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2) TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF+XRF)/XW/XW1 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH) TNN=0.0D0 TAN=0.0D0 TZN=0.0D0 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN FAC2=SQRT(2D0) TNN1=0D0 TNN2=0D0 TNN3=0D0 DO 1560 II=1,4 DK=1D0/(TH-SMZ(II)**2) FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)* & ZMIX(II,1)) FREK=FAC2*TANW*EI*ZMIX(II,1) TNN1=TNN1+FLEK**2*DK TNN2=TNN2+FREK**2*DK DO 1550 JJ=1,4 DL=1D0/(TH-SMZ(JJ)**2) FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)* & ZMIX(JJ,1)) FREL=FAC2*TANW*EJ*ZMIX(JJ,1) TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ) 1550 CONTINUE 1560 CONTINUE TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2+A2**2*TNN2**2) TNN=(TNN+2D0*SH*A1*A2*TNN3)/4D0/XW**2 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)* & (TNN1*XLF*A1+TNN2*XRF*A2) TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)* & (1D0-SQMZ/SH)/SH TZN=TZN/XW**2/XW1 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1+A2*TNN2)/XW ENDIF FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1+FACQQ2 1570 CONTINUE ELSEIF(ISUB.EQ.203) THEN C...f + fbar -> e_L + e_Rbar DO 1600 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1600 EI=KCHG(IABS(I),1)/3D0 TT3I=SIGN(1D0,EI)/2D0 EJ=-1 TT3J=-1D0/2D0 FCOL=1D0 C...Color factor for e+ e- IF(IA.GE.11) FCOL=3D0 A1=SFMIX(KFID,1)**2 A2=SFMIX(KFID,2)**2 XLQ=(TT3J-EJ*XW) XRQ=(-EJ*XW) XLF=(TT3I-EI*XW) XRF=(-EI*XW) TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/XW**2/XW1**2*A1*A2 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2) TNN=0.0D0 TZN=0.0D0 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN FAC2=SQRT(2D0) TNN1=0D0 TNN2=0D0 TNN3=0D0 DO 1590 II=1,4 DK=1D0/(TH-SMZ(II)**2) FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)* & ZMIX(II,1)) FREK=FAC2*TANW*EI*ZMIX(II,1) TNN1=TNN1+FLEK**2*DK TNN2=TNN2+FREK**2*DK DO 1580 JJ=1,4 DL=1D0/(TH-SMZ(JJ)**2) FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)* & ZMIX(JJ,1)) FREL=FAC2*TANW*EJ*ZMIX(JJ,1) TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ) 1580 CONTINUE 1590 CONTINUE TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2+TNN1**2) TNN=(TNN+SH*(A2**2+A1**2)*TNN3)/4D0 TZN=(UH*TH-SQM3*SQM4)*A1*A2 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1-XRF*TNN2)/XW1 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)* & (1D0-SQMZ/SH)/SH ENDIF FACQQ1=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2 FACQQ2=COMFAC*AEM**2/XW**2*(TNN+TZN)*FCOL/3D0 FACQQ=(FACQQ1+FACQQ2) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),3) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=2 SIGH(NCHN)=FACQQ*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) 1600 CONTINUE ELSEIF(ISUB.EQ.210) THEN C...q + qbar' -> W*- > ~l_L + ~nu_L FAC0=RKF*COMFAC*AEM**2/XW**2/12D0 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW) DO 1620 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1620 DO 1610 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1610 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1610 FCKM=3D0 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J) KCHW=2 IF(KCHSUM.LT.0) KCHW=3 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FAC0*FAC1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)), & 5-KCHW)*WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW) 1610 CONTINUE 1620 CONTINUE ENDIF ELSEIF(ISUB.LE.220) THEN IF(ISUB.EQ.213) THEN C...f + fbar -> ~nu_L + ~nu_Lbar COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) PROPZ=(SH-SQMZ)**2+ZWID**2*SQMZ XLL=0.5D0 XLR=0.0D0 DO 1630 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1630 EI=KCHG(IA,1)/3D0 FCOL=1D0 C...Color factor for e+ e- IF(IA.GE.11) FCOL=3D0 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0 XRQ=-EI*XW TZC=0.0D0 TCC=0.0D0 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/ & (TH-SMW(2)**2) TCC=TZC**2 TZC=TZC/XW1*(SH-SQMZ)/PROPZ*XLQ*XLL ENDIF FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ FACQQ2=TZC+TCC/4D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC & *AEM**2*FCOL/3D0/XW**2 1630 CONTINUE ELSEIF(ISUB.EQ.216) THEN C...q + qbar -> ~chi0_1 + ~chi0_1 IF(IZID1.EQ.IZID2) THEN COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) ELSE COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) ENDIF FACGG1=COMFAC*AEM**2/3D0/XW**2 IF(IZID1.EQ.IZID2) FACGG1=FACGG1/2D0 ZM12=SQM3 ZM22=SQM4 SR2=SQRT(2D0) WU2 = (UH-ZM12)*(UH-ZM22)/SH2 WT2 = (TH-ZM12)*(TH-ZM22)/SH2 XS2 = SMZ(IZID1)*SMZ(IZID2)/SH PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2 REPRPZ = (SH-SQMZ)/PROPZ2 OLPP=(-ZMIX(IZID1,3)*ZMIX(IZID2,3)+ & ZMIX(IZID1,4)*ZMIX(IZID2,4))/2D0 DO 1640 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1640 EI=KCHG(IABS(I),1)/3D0 FCOL=1D0 IF(ABS(I).GE.11) FCOL=3D0 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0 XRQ=-EI*XW XLQ=XLQ/XW1 XRQ=XRQ/XW1 C...Factored out sqrt(2) FR1=TANW*EI*ZMIX(IZID1,1) FR2=TANW*EI*ZMIX(IZID2,1) FL1=-(SIGN(1D0,EI)*ZMIX(IZID1,2)-TANW* & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID1,1))/2D0 FL2=-(SIGN(1D0,EI)*ZMIX(IZID2,2)-TANW* & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID2,1))/2D0 FR12=FR1**2 FR22=FR2**2 FL12=FL1**2 FL22=FL2**2 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2 FACS=OLPP**2*(XLQ**2+XRQ**2)*(WU2+WT2-2D0*XS2)*(SH2/PROPZ2) FACT=FL12*FL22*(WT2*SH2/(TH-XML2)**2+WU2*SH2/(UH-XML2)**2- & 2D0*XS2*SH2/(TH-XML2)/(UH-XML2)) FACU=FR12*FR22*(WT2*SH2/(TH-XMR2)**2+WU2*SH2/(UH-XMR2)**2- & 2D0*XS2*SH2/(TH-XMR2)/(UH-XMR2)) FACST=2D0*REPRPZ*OLPP*XLQ*FL1*FL2*( (WT2-XS2)*SH2/ & (TH-XML2) + (WU2-XS2)*SH2/(UH-XML2) ) FACSU=-2D0*REPRPZ*OLPP*XRQ*FR1*FR2*( (WT2-XS2)*SH2/ & (TH-XMR2) + (WU2-XS2)*SH2/(UH-XMR2) ) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACGG1*FCOL*(FACS+FACT+FACU+FACST+FACSU) 1640 CONTINUE ENDIF ELSEIF(ISUB.LE.230) THEN IF(ISUB.EQ.226) THEN C...f + fbar -> ~chi+_1 + ~chi-_1 FACGG1=COMFAC*AEM**2/3D0/XW**2 ZM12=SQM3 ZM22=SQM4 WU2 = (UH-ZM12)*(UH-ZM22)/SH2 WT2 = (TH-ZM12)*(TH-ZM22)/SH2 WS2 = SMW(IZID1)*SMW(IZID2)/SH PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2 REPRPZ = (SH-SQMZ)/PROPZ2 DIFF=0D0 IF(IZID1.EQ.IZID2) DIFF=1D0 DO 1650 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1650 EI=KCHG(IABS(I),1)/3D0 FCOL=1D0 IF(IABS(I).GE.11) FCOL=3D0 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0 XRQ=-EI*XW XLQ=XLQ/XW1 XRQ=XRQ/XW1 XLQ2=XLQ**2 XRQ2=XRQ**2 OLP=-VMIX(IZID1,1)*VMIX(IZID2,1)- & VMIX(IZID1,2)*VMIX(IZID2,2)/2D0+XW*DIFF ORP=-UMIX(IZID1,1)*UMIX(IZID2,1)- & UMIX(IZID1,2)*UMIX(IZID2,2)/2D0+XW*DIFF ORP2=ORP**2 OLP2=OLP**2 C...u-type quark - d-type squark IF(MOD(I,2).EQ.0) THEN FACT0 = UMIX(IZID1,1)*UMIX(IZID2,1) XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2 C...d-type quark - u-type squark ELSE FACT0 = VMIX(IZID1,1)*VMIX(IZID2,1) XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2 ENDIF FACA=2D0*XW**2*DIFF*(WT2+WU2+2D0*ABS(WS2))*EI**2 FACZ=0.5D0*((XLQ2+XRQ2)*(OLP2+ORP2)*(WT2+WU2)+ & 4D0*(XLQ2+XRQ2)*OLP*ORP*WS2-(XLQ2-XRQ2)*(OLP2-ORP2)* & (WU2-WT2))*SH2/PROPZ2 FACT=FACT0**2/4D0*WT2*SH2/(TH-XML2)**2 FACAZ=XW*REPRPZ*DIFF*( (XLQ+XRQ)*(OLP+ORP)*(WU2+ & WT2+2D0*ABS(WS2))-(XLQ-XRQ)*(OLP-ORP)*(WU2-WT2) )*SH*(-EI) FACTA=XW*DIFF/(TH-XML2)*(WT2+ABS(WS2))*SH*FACT0*(-EI) FACTZ=REPRPZ/(TH-XML2)*XLQ*FACT0*(OLP*WT2+ORP*WS2)*SH2 FACSUM=FACGG1*(FACA+FACAZ+FACZ+FACT+FACTA+FACTZ)*FCOL NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 IF(IZID1.EQ.IZID2) THEN SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) ELSE SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)* & WIDS(PYCOMP(KFPR(ISUBSV,1)),2) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=2 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,1)),3) ENDIF 1650 CONTINUE ELSEIF(ISUB.EQ.229) THEN C...q + qbar' -> ~chi0_1 + ~chi+-_1 FACGG1=COMFAC*AEM**2/6D0/XW**2 ZM12=SQM3 ZM22=SQM4 ZMU2 = PMAS(PYCOMP(KSUSY1+2),1)**2 ZMD2 = PMAS(PYCOMP(KSUSY1+1),1)**2 WU2 = (UH-ZM12)*(UH-ZM22)/SH2 WT2 = (TH-ZM12)*(TH-ZM22)/SH2 WS2 = SMW(IZID1)*SMZ(IZID2)/SH RT2I = 1D0/SQRT(2D0) PROPW = ((SH-SQMW)**2+WWID**2*SQMW) OL=-RT2I*ZMIX(IZID2,4)*VMIX(IZID1,2)+ & ZMIX(IZID2,2)*VMIX(IZID1,1) OR= RT2I*ZMIX(IZID2,3)*UMIX(IZID1,2)+ & ZMIX(IZID2,2)*UMIX(IZID1,1) OL2=OL**2 OR2=OR**2 CROSS=2D0*OL*OR FACST0=UMIX(IZID1,1) FACSU0=VMIX(IZID1,1) FACSU0=FACSU0*(0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0) FACST0=FACST0*(-0.5D0*ZMIX(IZID2,2)+TANW*ZMIX(IZID2,1)/6D0) FACT0=FACST0**2 FACU0=FACSU0**2 FACTU0=FACSU0*FACST0 FACST = -2D0*(SH-SQMW)/PROPW/(TH-ZMD2)*(WT2*SH2*OR & + SH2*WS2*OL)*FACST0 FACSU = 2D0*(SH-SQMW)/PROPW/(UH-ZMU2)*(WU2*SH2*OL & + SH2*WS2*OR)*FACSU0 FACT = WT2*SH2/(TH-ZMD2)**2*FACT0 FACU = WU2*SH2/(UH-ZMU2)**2*FACU0 FACTU = -2D0*WS2*SH2/(TH-ZMD2)/(UH-ZMU2)*FACTU0 FACW = (OR2*WT2+OL2*WU2+CROSS*WS2)/PROPW*SH2 FACGG1=FACGG1*(FACW+FACT+FACTU+FACU+FACSU+FACST) DO 1670 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 1670 DO 1660 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 1660 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1660 FCKM=3D0 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J) KCHW=2 IF(KCHSUM.LT.0) KCHW=3 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW) 1660 CONTINUE 1670 CONTINUE ENDIF ELSEIF(ISUB.LE.240) THEN IF(ISUB.EQ.237) THEN C...q + qbar -> gluino + ~chi0_1 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) FAC0=COMFAC*AS*AEM*4D0/9D0/XW GM2=SQM3 ZM2=SQM4 DO 1680 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1680 EI=KCHG(IABS(I),1)/3D0 IA=IABS(I) XLQC = -TANW*EI*ZMIX(IZID,1) XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW* & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0 XLQ2=XLQC**2 XRQ2=XRQC**2 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2) SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN) ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2) SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR) 1680 CONTINUE ENDIF ELSEIF(ISUB.LE.250) THEN IF(ISUB.EQ.241) THEN C...q + qbar' -> ~chi+-_1 + gluino FACWG=COMFAC*AS*AEM/XW*2D0/9D0 GM2=SQM3 ZM2=SQM4 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1) FAC0=UMIX(IZID,1)**2 FAC1=VMIX(IZID,1)**2 DO 1700 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1700 DO 1690 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1690 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1690 FCKM=1D0 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J) KCHW=2 IF(KCHSUM.LT.0) KCHW=3 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2) XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)* & SH/(TH-XMU2)/(UH-XMD2))/2D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN- & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW) 1690 CONTINUE 1700 CONTINUE ELSEIF(ISUB.EQ.243) THEN C...q + qbar -> gluino + gluino COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) XMT=SQM3-TH XMU=SQM3-UH DO 1710 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1710 NCHN=NCHN+1 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+ & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+ & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST + & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU ) XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+ & 2D0*SQM3*SH)/SH2 +4D0/9D0*(XMT**2/XST**2+ & XMU**2/XSU**2) - (XMT**2+SH*SQM3)/SH/XST + & SQM3*SH/XST/XSU/9D0- (XMU**2+SH*SQM3)/SH/XSU ) ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 C...1/2 for identical particles SIGH(NCHN)=0.25D0*(FACGG1+FACGG2) 1710 CONTINUE ELSEIF(ISUB.EQ.244) THEN C...g + g -> gluino + gluino COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) XMT=SQM3-TH XMU=SQM3-UH FACQQ1=COMFAC*AS**2*9D0/4D0*( & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 - & (XMT*XMU+SQM3*(UH-TH))/SH/XMT ) FACQQ2=COMFAC*AS**2*9D0/4D0*( & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 - & (XMU*XMT+SQM3*(TH-UH))/SH/XMU ) FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 + & SQM3*(SH-4D0*SQM3)/XMT/XMU) IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1720 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1/2D0 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=2 SIGH(NCHN)=FACQQ2/2D0 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=3 SIGH(NCHN)=FACQQ3/2D0 1720 CONTINUE ELSEIF(ISUB.EQ.246) THEN C...g + q_j -> ~chi0_1 + ~q_j FAC0=COMFAC*AS*AEM/6D0/XW ZM2=SQM4 QM2=SQM3 FACZQ0=FAC0*( (ZM2-TH)/SH + & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 - & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) ) KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1) DO 1740 I=-KFNSQ,KFNSQ,2*KFNSQ IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1740 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1740 EI=KCHG(IABS(I),1)/3D0 IA=IABS(I) XRQZ = -TANW*EI*ZMIX(IZID,1) XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW* & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0 IF(ILR.EQ.0) THEN BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2 ELSE BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2 ENDIF FACZQ=FACZQ0*BS KCHQ=2 IF(I.LT.0) KCHQ=3 DO 1730 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1730 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1730 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) 1730 CONTINUE 1740 CONTINUE ENDIF ELSEIF(ISUB.LE.260) THEN IF(ISUB.EQ.254) THEN C...g + q_j -> ~chi1_1 + ~q_i FAC0=COMFAC*AS*AEM/12D0/XW ZM2=SQM4 QM2=SQM3 AU=UMIX(IZID,1)**2 AD=VMIX(IZID,1)**2 FACZQ0=FAC0*( (ZM2-TH)/SH + & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 - & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) ) KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1) IF(MOD(KFNSQ1,2).EQ.0) THEN KFNSQ=KFNSQ1-1 KCHW=2 ELSE KFNSQ=KFNSQ1+1 KCHW=3 ENDIF DO 1760 I=-KFNSQ,KFNSQ,2*KFNSQ IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1760 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1760 IA=IABS(I) IF(MOD(IA,2).EQ.0) THEN FACZQ=FACZQ0*AU ELSE FACZQ=FACZQ0*AD ENDIF FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2 KCHQ=2 IF(I.LT.0) KCHQ=3 KCHWQ=KCHW IF(I.LT.0) KCHWQ=5-KCHW DO 1750 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1750 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1750 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ) 1750 CONTINUE 1760 CONTINUE ELSEIF(ISUB.EQ.258) THEN C...g + q_j -> gluino + ~q_i XG2=SQM4 XQ2=SQM3 XMT=XG2-TH XMU=XG2-UH XST=XQ2-TH XSU=XQ2-UH FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 - & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) + & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) + & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0* & (SH*(UH+XG2) & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH + & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+ & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU FACQG1=COMFAC*AS**2*FACQG1/2D0 FACQG2=COMFAC*AS**2*FACQG2/2D0 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1) DO 1780 I=-KFNSQ,KFNSQ,2*KFNSQ IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 1780 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 1780 KCHQ=2 IF(I.LT.0) KCHQ=3 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) DO 1770 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1770 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1770 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQG1*FACSEL NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=2 SIGH(NCHN)=FACQG2*FACSEL 1770 CONTINUE 1780 CONTINUE ENDIF ELSEIF(ISUB.LE.270) THEN IF(ISUB.EQ.261) THEN C...q_i + q_ibar -> ~t_1 + ~t_1bar FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )* & WIDS(PYCOMP(KFPR(ISUBSV,1)),1) KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1) FAC0=AS**2*4D0/9D0 DO 1790 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1790 IF(IA.GE.11.AND.IA.LE.18) THEN EI=KCHG(IA,1)/3D0 EJ=KCHG(KFNSQ,1)/3D0 T3I=SIGN(1D0,EI)/2D0 T3J=SIGN(1D0,EJ)/2D0 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2 XLF=2D0*(T3I-EI*XW) XRF=2D0*(-EI*XW) TAA=0.5D0*(EI*EJ)**2 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2) TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH) FAC0=AEM**2*12D0*(TAA+TZZ+TAZ) ENDIF NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1*FAC0 1790 CONTINUE ELSEIF(ISUB.EQ.263) THEN C...f + fbar -> ~t1 + ~t2bar DO 1800 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1800 EI=KCHG(IABS(I),1)/3D0 TT3I=SIGN(1D0,EI)/2D0 EJ=2D0/3D0 TT3J=1D0/2D0 FCOL=1D0 C...Color factor for e+ e- IF(IA.GE.11) FCOL=3D0 XLQ=2D0*(TT3J-EJ*XW) XRQ=2D0*(-EJ*XW) XLF=2D0*(TT3I-EI*XW) XRF=2D0*(-EI*XW) TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2) C...Factor of 2 for t1 t2bar + t2 t1bar FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),3) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=2 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) 1800 CONTINUE ELSEIF(ISUB.EQ.264) THEN C...g + g -> ~t_1 + ~t_1bar XSU=SQM3-UH XST=SQM3-TH FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0* & WIDS(PYCOMP(KFPR(ISUBSV,1)),1) FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST) FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST) IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1810 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 1810 CONTINUE ENDIF ELSEIF(ISUB.LE.280) THEN IF(ISUB.EQ.271) THEN C...q + q' -> ~q + ~q' (~g exchange) XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2 XMT=XMG2-TH XMU=XMG2-UH XSU1=SQM3-UH XSU2=SQM4-UH XST1=SQM3-TH XST2=SQM4-TH IF(ILR.EQ.1) THEN FACQQ1=COMFAC*AS**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 ) FACQQ2=COMFAC*AS**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 ) FACQQB=0.0D0 ELSE FACQQ1=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMT**2 ) FACQQ2=0.5D0*COMFAC*AS**2*4D0/9D0*( SH*XMG2/XMU**2 ) FACQQB=0.5D0*COMFAC*AS**2*4D0/9D0*( -2D0*SH*XMG2/3D0/ & XMT/XMU ) ENDIF KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1) KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1) DO 1830 I=-KFNSQI,KFNSQI,2*KFNSQI IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1830 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1830 KCHQ=2 IF(I.LT.0) KCHQ=3 DO 1820 J=-KFNSQJ,KFNSQJ,2*KFNSQJ IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1820 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1820 IF(I*J.LT.0) GOTO 1820 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ) IF(I.EQ.J) THEN IF(ISUBSV.LE.272) THEN SIGH(NCHN)=(FACQQ1+0.5D0*FACQQB)*RKF* & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2) ELSE SIGH(NCHN)=(FACQQ1+0.5D0*FACQQB)*RKF* & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ) ENDIF NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=2 IF(ISUBSV.LE.272) THEN SIGH(NCHN)=(FACQQ2+0.5D0*FACQQB)*RKF* & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2) ELSE SIGH(NCHN)=(FACQQ2+0.5D0*FACQQB)*RKF* & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ) ENDIF ENDIF 1820 CONTINUE 1830 CONTINUE ELSEIF(ISUB.EQ.274) THEN C...q + qbar -> ~q' + ~qbar' XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2 XMT=XMG2-TH XMU=XMG2-UH IF(ILR.EQ.0) THEN FACQQ1=COMFAC*AS**2*4D0/9D0*( & (UH*TH-SQM3*SQM4)/XMT**2 ) FACQQB=COMFAC*AS**2*4D0/9D0*( & (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT**2)) FACQQB=FACQQB+FACQQ1 ELSE FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 ) FACQQB=FACQQ1 ENDIF KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1) KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1) DO 1850 I=-KFNSQI,KFNSQI,2*KFNSQI IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 1850 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 1850 KCHQ=2 IF(I.LT.0) KCHQ=3 DO 1840 J=-KFNSQJ,KFNSQJ,2*KFNSQJ IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 1840 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 1840 IF(I*J.GT.0) GOTO 1840 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ) IF(I.EQ.-J) SIGH(NCHN)=FACQQB*RKF* & WIDS(PYCOMP(KFPR(ISUBSV,1)),1) 1840 CONTINUE 1850 CONTINUE ELSEIF(ISUB.EQ.277) THEN C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j C...if i .eq. j covered in 274 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 ) KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1) FAC0=0D0 DO 1860 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1860 IF(IA.EQ.KFNSQ) GOTO 1860 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN EI=KCHG(IA,1)/3D0 EJ=KCHG(KFNSQ,1)/3D0 T3J=SIGN(0.5D0,EJ) T3I=SIGN(1D0,EI)/2D0 IF(ILR.EQ.0) THEN XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1) XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2) ELSE XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3) XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4) ENDIF XLF=2D0*(T3I-EI*XW) XRF=2D0*(-EI*XW) IF(ILR.EQ.0) THEN XRQ=0D0 ELSE XLQ=0D0 ENDIF TAA=0.5D0*(EI*EJ)**2 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2) TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH) FAC0=AEM**2*12D0*(TAA+TZZ+TAZ) ELSEIF(IA.LE.6) THEN FAC0=AS**2*8D0/9D0/2D0 ENDIF NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) 1860 CONTINUE ELSEIF(ISUB.EQ.279) THEN C...g + g -> ~q_j + ~q_jbar XSU=SQM3-UH XST=SQM3-TH C...5=RKF because ~t ~tbar treated separately FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 ) FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST) FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST) IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1870 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=2 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) 1870 CONTINUE ENDIF CMRENNA-- ENDIF C...Multiply with parton distributions IF(ISUB.LE.90.OR.ISUB.GE.96) THEN DO 1880 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) 1880 CONTINUE ENDIF RETURN END C********************************************************************* C...PYPDFU C...Gives electron, photon, pi+, neutron, proton and hyperon C...parton distributions according to a few different parametrizations. C...Note that what is coded is x times the probability distribution, C...i.e. xq(x,Q2) etc. SUBROUTINE PYPDFU(KF,X,Q2,XPQ) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) 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/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6), &XPDIR(-6:6) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/ C...Local arrays. DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6), &XPPI(-6:6),XPPR(-6:6) C...Interface to PDFLIB. COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX SAVE /W50513/ DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU, &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX CHARACTER*20 PARM(20) DATA VALUE/20*0D0/,PARM/20*' '/ C...Data related to Schuler-Sjostrand photon distributions. DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/ C...Reset parton distributions. MINT(92)=0 DO 100 KFL=-25,25 XPQ(KFL)=0D0 100 CONTINUE C...Check x and particle species. IF(X.LE.0D0.OR.X.GE.1D0) THEN WRITE(MSTU(11),5000) X RETURN ENDIF KFA=IABS(KF) IF(KFA.NE.11.AND.KFA.NE.22.AND.KFA.NE.211.AND.KFA.NE.2112.AND. &KFA.NE.2212.AND.KFA.NE.3122.AND.KFA.NE.3112.AND.KFA.NE.3212 &.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.KFA.NE.3322.AND. &KFA.NE.3334.AND.KFA.NE.111) THEN WRITE(MSTU(11),5100) KF RETURN ENDIF C...Electron parton distribution call. IF(KFA.EQ.11) THEN CALL PYPDEL(X,Q2,XPEL) DO 110 KFL=-25,25 XPQ(KFL)=XPEL(KFL) 110 CONTINUE C...Photon parton distribution call (VDM+anomalous). ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN CALL PYPDGA(X,Q2,XPGA) DO 120 KFL=-6,6 XPQ(KFL)=XPGA(KFL) 120 CONTINUE ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN Q2MX=Q2 P2MX=0.36D0 IF(MSTP(55).GE.7) P2MX=4.0D0 IF(MSTP(57).EQ.0) Q2MX=P2MX CALL PYGGAM(MSTP(55)-4,X,Q2MX,0D0,MSTP(60),F2GAM,XPGA) DO 130 KFL=-6,6 XPQ(KFL)=XPGA(KFL) 130 CONTINUE VINT(231)=P2MX ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN Q2MX=Q2 P2MX=0.36D0 IF(MSTP(55).GE.11) P2MX=4.0D0 IF(MSTP(57).EQ.0) Q2MX=P2MX CALL PYGGAM(MSTP(55)-8,X,Q2MX,0D0,MSTP(60),F2GAM,XPGA) DO 140 KFL=-6,6 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL) 140 CONTINUE VINT(231)=P2MX ELSEIF(MSTP(56).EQ.2) THEN C...Call PDFLIB parton distributions. PARM(1)='NPTYPE' VALUE(1)=3 PARM(2)='NGROUP' VALUE(2)=MSTP(55)/1000 PARM(3)='NSET' VALUE(3)=MOD(MSTP(55),1000) IF(MINT(93).NE.3000000+MSTP(55)) THEN CALL PDFSET(PARM,VALUE) MINT(93)=3000000+MSTP(55) ENDIF XX=X QQ=SQRT(MAX(0D0,Q2MIN,Q2)) IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN) CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU) VINT(231)=Q2MIN XPQ(0)=GLU XPQ(1)=DNV XPQ(-1)=DNV XPQ(2)=UPV XPQ(-2)=UPV XPQ(3)=STR XPQ(-3)=STR XPQ(4)=CHM XPQ(-4)=CHM XPQ(5)=BOT XPQ(-5)=BOT XPQ(6)=TOP XPQ(-6)=TOP ELSE WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55) ENDIF C...Pion/gammaVDM parton distribution call. ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.(KFA.EQ.22.AND. & MINT(109).EQ.2)) THEN IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND. & MSTP(55).LE.12) THEN ISET=1+MOD(MSTP(55)-1,4) Q2MX=Q2 P2MX=0.36D0 IF(ISET.GE.3) P2MX=4.0D0 IF(MSTP(57).EQ.0) Q2MX=P2MX CALL PYGVMD(ISET,2,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA) DO 150 KFL=-6,6 XPQ(KFL)=XPGA(KFL) 150 CONTINUE VINT(231)=P2MX ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN CALL PYPDPI(X,Q2,XPPI) DO 160 KFL=-6,6 XPQ(KFL)=XPPI(KFL) 160 CONTINUE ELSEIF(MSTP(54).EQ.2) THEN C...Call PDFLIB parton distributions. PARM(1)='NPTYPE' VALUE(1)=2 PARM(2)='NGROUP' VALUE(2)=MSTP(53)/1000 PARM(3)='NSET' VALUE(3)=MOD(MSTP(53),1000) IF(MINT(93).NE.2000000+MSTP(53)) THEN CALL PDFSET(PARM,VALUE) MINT(93)=2000000+MSTP(53) ENDIF XX=X QQ=SQRT(MAX(0D0,Q2MIN,Q2)) IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN) CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU) VINT(231)=Q2MIN XPQ(0)=GLU XPQ(1)=DSEA XPQ(-1)=UPV+DSEA XPQ(2)=UPV+USEA XPQ(-2)=USEA XPQ(3)=STR XPQ(-3)=STR XPQ(4)=CHM XPQ(-4)=CHM XPQ(5)=BOT XPQ(-5)=BOT XPQ(6)=TOP XPQ(-6)=TOP ELSE WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53) ENDIF C...Anomalous photon parton distribution call. ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN Q2MX=Q2 P2MX=PARP(15)**2 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0 IF(MSTP(57).EQ.0) Q2MX=P2MX CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA) DO 170 KFL=-6,6 XPQ(KFL)=XPGA(KFL) 170 CONTINUE VINT(231)=P2MX ELSEIF(MSTP(56).EQ.1) THEN IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0 IF(MSTP(57).EQ.0) Q2MX=P2MX CALL PYGGAM(MSTP(55)-8,X,Q2MX,0D0,MSTP(60),F2GM,XPGA) DO 180 KFL=-6,6 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)) 180 CONTINUE VINT(231)=P2MX ELSEIF(MSTP(56).EQ.2) THEN IF(MSTP(57).EQ.0) Q2MX=P2MX CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA) DO 190 KFL=-6,6 XPQ(KFL)=XPGA(KFL) 190 CONTINUE VINT(231)=P2MX ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN IF(MSTP(57).EQ.0) Q2MX=P2MX CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA) DO 200 KFL=-6,6 XPQ(KFL)=XPGA(KFL) 200 CONTINUE VINT(231)=P2MX ELSE 210 RKF=11D0*PYR(0) KFR=1 IF(RKF.GT.1D0) KFR=2 IF(RKF.GT.5D0) KFR=3 IF(RKF.GT.6D0) KFR=4 IF(RKF.GT.10D0) KFR=5 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 210 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 210 IF(MSTP(57).EQ.0) Q2MX=P2MX CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA) DO 220 KFL=-6,6 XPQ(KFL)=XPGA(KFL) 220 CONTINUE VINT(231)=P2MX ENDIF C...Proton parton distribution call. ELSE IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.11) THEN CALL PYPDPR(X,Q2,XPPR) DO 230 KFL=-6,6 XPQ(KFL)=XPPR(KFL) 230 CONTINUE ELSEIF(MSTP(52).EQ.2) THEN C...Call PDFLIB parton distributions. PARM(1)='NPTYPE' VALUE(1)=1 PARM(2)='NGROUP' VALUE(2)=MSTP(51)/1000 PARM(3)='NSET' VALUE(3)=MOD(MSTP(51),1000) IF(MINT(93).NE.1000000+MSTP(51)) THEN CALL PDFSET(PARM,VALUE) MINT(93)=1000000+MSTP(51) ENDIF XX=X QQ=SQRT(MAX(0D0,Q2MIN,Q2)) IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN) CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU) VINT(231)=Q2MIN XPQ(0)=GLU XPQ(1)=DNV+DSEA XPQ(-1)=DSEA XPQ(2)=UPV+USEA XPQ(-2)=USEA XPQ(3)=STR XPQ(-3)=STR XPQ(4)=CHM XPQ(-4)=CHM XPQ(5)=BOT XPQ(-5)=BOT XPQ(6)=TOP XPQ(-6)=TOP ELSE WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51) ENDIF ENDIF C...Isospin average for pi0/gammaVDM. IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN XPV=XPQ(2)-XPQ(1) XPQ(2)=XPQ(1) XPQ(-2)=XPQ(-1) ELSE XPS=0.5D0*(XPQ(1)+XPQ(-2)) XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS XPQ(2)=XPS XPQ(-1)=XPS ENDIF IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN XPQ(1)=XPQ(1)+0.2D0*XPV XPQ(-1)=XPQ(-1)+0.2D0*XPV XPQ(2)=XPQ(2)+0.8D0*XPV XPQ(-2)=XPQ(-2)+0.8D0*XPV ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN XPQ(3)=XPQ(3)+XPV XPQ(-3)=XPQ(-3)+XPV ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN XPQ(4)=XPQ(4)+XPV XPQ(-4)=XPQ(-4)+XPV IF(MSTP(55).GE.9) THEN DO 240 KFL=-6,6 XPQ(KFL)=0D0 240 CONTINUE ENDIF ELSE XPQ(1)=XPQ(1)+0.5D0*XPV XPQ(-1)=XPQ(-1)+0.5D0*XPV XPQ(2)=XPQ(2)+0.5D0*XPV XPQ(-2)=XPQ(-2)+0.5D0*XPV ENDIF C...Rescale for gammaVDM by effective gamma -> rho coupling. IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN DO 250 KFL=-6,6 XPQ(KFL)=VINT(281)*XPQ(KFL) 250 CONTINUE VINT(232)=VINT(281)*XPV ENDIF C...Isospin conjugation for neutron. ELSEIF(KFA.EQ.2112) THEN XPS=XPQ(1) XPQ(1)=XPQ(2) XPQ(2)=XPS XPS=XPQ(-1) XPQ(-1)=XPQ(-2) XPQ(-2)=XPS C...Simple recipes for hyperon (average valence parton distribution). ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN XPVAL=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0 XPSEA=0.5D0*(XPQ(-1)+XPQ(-2)) XPQ(1)=XPSEA XPQ(2)=XPSEA XPQ(-1)=XPSEA XPQ(-2)=XPSEA XPQ(KFA/1000)=XPQ(KFA/1000)+XPVAL XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPVAL XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPVAL ENDIF C...Charge conjugation for antiparticle. IF(KF.LT.0) THEN DO 260 KFL=1,25 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 260 XPS=XPQ(KFL) XPQ(KFL)=XPQ(-KFL) XPQ(-KFL)=XPS 260 CONTINUE ENDIF C...Allow gluon also in position 21. XPQ(21)=XPQ(0) C...Check positivity and reset above maximum allowed flavour. DO 270 KFL=-25,25 XPQ(KFL)=MAX(0D0,XPQ(KFL)) IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0 270 CONTINUE C...Formats for error printouts. 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3) 5100 FORMAT(' Error: illegal particle code for parton distribution;', &' KF =',I5) 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =', &3I5) RETURN END C********************************************************************* C...PYPDFL C...Gives proton parton distribution at small x and/or Q^2 according to C...correct limiting behaviour. SUBROUTINE PYPDFL(KF,X,Q2,XPQ) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ C...Local arrays. DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3) DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/ C...Send everything but protons/neutrons/VMD pions directly to PYPDFU. MINT(92)=0 KFA=IABS(KF) IACC=0 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1 IF(IACC.EQ.0) THEN CALL PYPDFU(KF,X,Q2,XPQ) RETURN ENDIF C...Reset. Check x. DO 100 KFL=-25,25 XPQ(KFL)=0D0 100 CONTINUE IF(X.LE.0D0.OR.X.GE.1D0) THEN WRITE(MSTU(11),5000) X RETURN ENDIF C...Define valence content. KFC=KF NV1=2 NV2=1 IF(KF.EQ.2212) THEN KFV1=2 KFV2=1 ELSEIF(KF.EQ.-2212) THEN KFV1=-2 KFV2=-1 ELSEIF(KF.EQ.2112) THEN KFV1=1 KFV2=2 ELSEIF(KF.EQ.-2112) THEN KFV1=-1 KFV2=-2 ELSEIF(KF.EQ.211) THEN NV1=1 KFV1=2 KFV2=-1 ELSEIF(KF.EQ.-211) THEN NV1=1 KFV1=-2 KFV2=1 ELSEIF(MINT(105).LE.223) THEN KFV1=1 WTV1=0.2D0 KFV2=2 WTV2=0.8D0 ELSEIF(MINT(105).EQ.333) THEN KFV1=3 WTV1=1.0D0 KFV2=1 WTV2=0.0D0 ELSEIF(MINT(105).EQ.443) THEN KFV1=4 WTV1=1.0D0 KFV2=1 WTV2=0.0D0 ENDIF C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0. CALL PYPDFU(KFC,X,Q2,XPA) Q2MN=MAX(3D0,VINT(231)) Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X)))) XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0 C...Large Q2 and large x: naive call is enough. IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN DO 110 KFL=-25,25 XPQ(KFL)=XPA(KFL) 110 CONTINUE MINT(92)=1 C...Small Q2 and large x: dampen boundary value. ELSEIF(X.GT.XMN) THEN C...Evaluate at boundary and define dampening factors. CALL PYPDFU(KFC,X,Q2MN,XPA) FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN)) FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0 C...Separate valence and sea parts of parton distribution. IF(KFA.NE.22) THEN XFV1=XPA(KFV1)-XPA(-KFV1) XPA(KFV1)=XPA(-KFV1) XFV2=XPA(KFV2)-XPA(-KFV2) XPA(KFV2)=XPA(-KFV2) ELSE XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232) XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232) XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232) XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232) ENDIF C...Dampen valence and sea separately. Put back together. DO 120 KFL=-25,25 XPQ(KFL)=FS*XPA(KFL) 120 CONTINUE IF(KFA.NE.22) THEN XPQ(KFV1)=XPQ(KFV1)+FV*XFV1 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2 ELSE XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232) XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232) XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232) XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232) ENDIF MINT(92)=2 C...Large Q2 and small x: interpolate behaviour. ELSEIF(Q2.GT.Q2MN) THEN C...Evaluate at extremes and define coefficients for interpolation. CALL PYPDFU(KFC,XMN,Q2MN,XPA) VI232A=VINT(232) CALL PYPDFU(KFC,X,Q2B,XPB) VI232B=VINT(232) FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN) FVA=(X/XMN)**0.45D0*FLA FSA=(X/XMN)**(-0.08D0)*FLA FB=1D0-FLA C...Separate valence and sea parts of parton distribution. IF(KFA.NE.22) THEN XFVA1=XPA(KFV1)-XPA(-KFV1) XPA(KFV1)=XPA(-KFV1) XFVA2=XPA(KFV2)-XPA(-KFV2) XPA(KFV2)=XPA(-KFV2) XFVB1=XPB(KFV1)-XPB(-KFV1) XPB(KFV1)=XPB(-KFV1) XFVB2=XPB(KFV2)-XPB(-KFV2) XPB(KFV2)=XPB(-KFV2) ELSE XPA(KFV1)=XPA(KFV1)-WTV1*VI232A XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A XPA(KFV2)=XPA(KFV2)-WTV2*VI232A XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A XPB(KFV1)=XPB(KFV1)-WTV1*VI232B XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B XPB(KFV2)=XPB(KFV2)-WTV2*VI232B XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B ENDIF C...Interpolate for valence and sea. Put back together. DO 130 KFL=-25,25 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL) 130 CONTINUE IF(KFA.NE.22) THEN XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1) XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2) ELSE XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B) XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B) XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B) XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B) ENDIF MINT(92)=3 C...Small Q2 and small x: dampen boundary value and add term. ELSE C...Evaluate at boundary and define dampening factors. CALL PYPDFU(KFC,XMN,Q2MN,XPA) FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN) FA=1D0-FB FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0 C...Separate valence and sea parts of parton distribution. IF(KFA.NE.22) THEN XFV1=XPA(KFV1)-XPA(-KFV1) XPA(KFV1)=XPA(-KFV1) XFV2=XPA(KFV2)-XPA(-KFV2) XPA(KFV2)=XPA(-KFV2) ELSE XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232) XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232) XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232) XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232) ENDIF C...Dampen valence and sea separately. Add constant terms. C...Put back together. DO 140 KFL=-25,25 XPQ(KFL)=FSA*XPA(KFL) 140 CONTINUE IF(KFA.NE.22) THEN DO 150 KFL=-3,3 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL) 150 CONTINUE XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1) XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2) ELSE DO 160 KFL=-3,3 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL) 160 CONTINUE XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281)) XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281)) XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281)) XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281)) ENDIF XPQ(21)=XPQ(0) MINT(92)=4 ENDIF C...Format for error printout. 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3) RETURN END C********************************************************************* C...PYPDEL C...Gives electron parton distribution. SUBROUTINE PYPDEL(X,Q2,XPEL) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ C...Local arrays. DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6) C...Interface to PDFLIB. COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX SAVE /W50513/ DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU, &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX CHARACTER*20 PARM(20) DATA VALUE/20*0D0/,PARM/20*' '/ C...Some common constants. DO 100 KFL=-25,25 XPEL(KFL)=0D0 100 CONTINUE AEM=PARU(101) PME=PMAS(11,1) XL=LOG(MAX(1D-10,X)) X1L=LOG(MAX(1D-10,1D0-X)) HLE=LOG(MAX(3D0,Q2/PME**2)) HBE2=(AEM/PARU(1))*(HLE-1D0) C...Electron inside electron, see R. Kleiss et al., in Z physics at C...LEP 1, CERN 89-08, p. 34 IF(MSTP(59).LE.1) THEN HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2* & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0) HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))- & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)- & 4D0*XL/(1D0-X)-5D0-X) ELSE HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/ & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)* & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X) ENDIF IF(X.GT.0.9999D0.AND.X.LE.0.999999D0) THEN HEE=HEE*100D0**HBE2/(100D0**HBE2-1D0) ELSEIF(X.GT.0.999999D0) THEN HEE=0D0 ENDIF XPEL(11)=X*HEE C...Photon and (transverse) W- inside electron. AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2) IF(MSTP(13).LE.1) THEN HLG=HLE ELSE HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2)) ENDIF XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2) HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102)) XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2) C...Electron or positron inside photon inside electron. IF(MSTP(12).EQ.1) THEN XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+ & 2D0*X*(1D0+X)*XL) XPEL(11)=XPEL(11)+XFSEA XPEL(-11)=XFSEA C...Initialize PDFLIB photon parton distributions. IF(MSTP(56).EQ.2) THEN PARM(1)='NPTYPE' VALUE(1)=3 PARM(2)='NGROUP' VALUE(2)=MSTP(55)/1000 PARM(3)='NSET' VALUE(3)=MOD(MSTP(55),1000) IF(MINT(93).NE.3000000+MSTP(55)) THEN CALL PDFSET(PARM,VALUE) MINT(93)=3000000+MSTP(55) ENDIF ENDIF C...Quarks and gluons inside photon inside electron: C...numerical convolution required. DO 110 KFL=0,6 SXP(KFL)=0D0 110 CONTINUE SUMXPP=0D0 ITER=-1 120 ITER=ITER+1 SUMXP=SUMXPP NSTP=2**(ITER-1) IF(ITER.EQ.0) NSTP=2 DO 130 KFL=0,6 SXP(KFL)=0.5D0*SXP(KFL) 130 CONTINUE WTSTP=0.5D0/NSTP IF(ITER.EQ.0) WTSTP=0.5D0 C...Pick grid of x_{gamma} values logarithmically even. DO 150 ISTP=1,NSTP IF(ITER.EQ.0) THEN XLE=XL*(ISTP-1) ELSE XLE=XL*(ISTP-0.5D0)/NSTP ENDIF XE=MIN(0.999999D0,EXP(XLE)) XG=MIN(0.999999D0,X/XE) C...Evaluate photon inside electron parton distribution for convolution. XPGP=1D0+(1D0-XE)**2 IF(MSTP(13).LE.1) THEN XPGP=XPGP*HLE ELSE XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2)) ENDIF C...Evaluate photon parton distributions for convolution. IF(MSTP(56).EQ.1) THEN CALL PYPDGA(XG,Q2,XPGA) DO 140 KFL=0,5 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL) 140 CONTINUE ELSEIF(MSTP(56).EQ.2) THEN C...Call PDFLIB parton distributions. XX=XG QQ=SQRT(MAX(0D0,Q2MIN,Q2)) IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN) CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU) SXP(0)=SXP(0)+WTSTP*XPGP*GLU SXP(1)=SXP(1)+WTSTP*XPGP*DNV SXP(2)=SXP(2)+WTSTP*XPGP*UPV SXP(3)=SXP(3)+WTSTP*XPGP*STR SXP(4)=SXP(4)+WTSTP*XPGP*CHM SXP(5)=SXP(5)+WTSTP*XPGP*BOT SXP(6)=SXP(6)+WTSTP*XPGP*TOP ENDIF 150 CONTINUE SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2) IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT. & PARP(14)*(SUMXPP+SUMXP))) GOTO 120 C...Put convolution into output arrays. FCONV=AEMP*(-XL) XPEL(0)=FCONV*SXP(0) DO 160 KFL=1,6 XPEL(KFL)=FCONV*SXP(KFL) XPEL(-KFL)=XPEL(KFL) 160 CONTINUE ENDIF RETURN END C********************************************************************* C...PYPDGA C...Gives photon parton distribution. SUBROUTINE PYPDGA(X,Q2,XPGA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYDAT1/,/PYPARS/,/PYINT1/ C...Local arrays. DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3), &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3), &DGCS(4,3),DGDS(4,3),DGES(4,3) C...The following data lines are coefficients needed in the C...Drees and Grassie photon parton distribution parametrization. DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0, &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/ DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0, &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/ DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0, &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/ DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0, &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/ DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0, &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/ DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1, &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/ DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0, &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/ DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0, &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/ DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0, &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/ DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0, &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/ DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0, &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/ DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0, &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/ DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0, &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/ C...Photon parton distribution from Drees and Grassie. C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2. DO 100 KFL=-6,6 XPGA(KFL)=0D0 100 CONTINUE VINT(231)=1D0 IF(MSTP(57).LE.0) THEN T=LOG(1D0/0.16D0) ELSE T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0) ENDIF X1=1D0-X NF=3 IF(Q2.GT.25D0) NF=4 IF(Q2.GT.300D0) NF=5 NFE=NF-2 AEM=PARU(101) C...Evaluate gluon content. DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE)) DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE)) DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE)) XPGL=DGA*X**DGB*X1**DGC C...Evaluate up- and down-type quark content. DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE)) DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE)) DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE)) DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE)) DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE)) XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE)) DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE)) DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE)) DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE)) DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE)) DGF=9D0 IF(NF.EQ.4) DGF=10D0 IF(NF.EQ.5) DGF=55D0/6D0 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE IF(NF.LE.3) THEN XPQU=(XPQS+9D0*XPQN)/6D0 XPQD=(XPQS-4.5D0*XPQN)/6D0 ELSEIF(NF.EQ.4) THEN XPQU=(XPQS+6D0*XPQN)/8D0 XPQD=(XPQS-6D0*XPQN)/8D0 ELSE XPQU=(XPQS+7.5D0*XPQN)/10D0 XPQD=(XPQS-5D0*XPQN)/10D0 ENDIF C...Put into output arrays. XPGA(0)=AEM*XPGL XPGA(1)=AEM*XPQD XPGA(2)=AEM*XPQU XPGA(3)=AEM*XPQD IF(NF.GE.4) XPGA(4)=AEM*XPQU IF(NF.GE.5) XPGA(5)=AEM*XPQD DO 110 KFL=1,6 XPGA(-KFL)=XPGA(KFL) 110 CONTINUE RETURN END C********************************************************************* C...PYGGAM C...Constructs the F2 and parton distributions of the photon C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms. C...For F2, c and b are included by the Bethe-Heitler formula; C...in the 'MSbar' scheme additionally a Cgamma term is added. C...Contains the SaS sets 1D, 1M, 2D and 2M. C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6), &XPDIR(-6:6) COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6) SAVE /PYINT8/,/PYINT9/ C...Local arrays. DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6) C...Charm and bottom masses (low to compensate for J/psi etc.). DATA PMC/1.3D0/, PMB/4.6D0/ C...alpha_em and alpha_em/(2*pi). DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/ C...Lambda value for 4 flavours. DATA ALAM/0.20D0/ C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum. DATA FRACU/0.8D0/ C...VMD couplings f_V**2/(4*pi). DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/ C...Masses for rho (=omega) and phi. DATA PMRHO/0.770D0/, PMPHI/1.020D0/ C...Number of points in integration for IP2=1. DATA NSTEP/100/ C...Reset output. F2GM=0D0 DO 100 KFL=-6,6 XPDFGM(KFL)=0D0 XPVMD(KFL)=0D0 XPANL(KFL)=0D0 XPANH(KFL)=0D0 XPBEH(KFL)=0D0 XPDIR(KFL)=0D0 VXPVMD(KFL)=0D0 VXPANL(KFL)=0D0 VXPANH(KFL)=0D0 VXPDGM(KFL)=0D0 100 CONTINUE C...Set Q0 cut-off parameter as function of set used. IF(ISET.LE.2) THEN Q0=0.6D0 ELSE Q0=2D0 ENDIF Q02=Q0**2 C...Scale choice for off-shell photon; common factors. Q2A=Q2 FACNOR=1D0 IF(IP2.EQ.1) THEN P2MX=P2+Q02 Q2A=Q2+P2*Q02/MAX(Q02,Q2) FACNOR=LOG(Q2/Q02)/NSTEP ELSEIF(IP2.EQ.2) THEN P2MX=MAX(P2,Q02) ELSEIF(IP2.EQ.3) THEN P2MX=P2+Q02 Q2A=Q2+P2*Q02/MAX(Q02,Q2) ELSEIF(IP2.EQ.4) THEN P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/ & ((Q2+P2)*(Q02+P2))) ELSEIF(IP2.EQ.5) THEN P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/ & ((Q2+P2)*(Q02+P2))) P2MX=Q0*SQRT(P2MXA) FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX) ELSEIF(IP2.EQ.6) THEN P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/ & ((Q2+P2)*(Q02+P2))) P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02) ELSE P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/ & ((Q2+P2)*(Q02+P2))) P2MX=Q0*SQRT(P2MXA) P2MXB=P2MX P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02) P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB) ENDIF C...Call VMD parametrization for d quark and use to give rho, omega, C...phi. Note dipole dampening for off-shell photon. CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA) XFVAL=VXPGA(1) XPGA(1)=XPGA(2) XPGA(-1)=XPGA(-2) FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2 DO 110 KFL=-5,5 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL) 110 CONTINUE XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL XPVMD(3)=XPVMD(3)+FACS*XFVAL XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL XPVMD(-3)=XPVMD(-3)+FACS*XFVAL VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL VXPVMD(2)=FRACU*FACUD*XFVAL VXPVMD(3)=FACS*XFVAL VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL VXPVMD(-2)=FRACU*FACUD*XFVAL VXPVMD(-3)=FACS*XFVAL IF(IP2.NE.1) THEN C...Anomalous parametrizations for different strategies C...for off-shell photons; except full integration. C...Call anomalous parametrization for d + u + s. CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA) DO 120 KFL=-5,5 XPANL(KFL)=FACNOR*XPGA(KFL) VXPANL(KFL)=FACNOR*VXPGA(KFL) 120 CONTINUE C...Call anomalous parametrization for c and b. CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA) DO 130 KFL=-5,5 XPANH(KFL)=FACNOR*XPGA(KFL) VXPANH(KFL)=FACNOR*VXPGA(KFL) 130 CONTINUE CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA) DO 140 KFL=-5,5 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL) VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL) 140 CONTINUE ELSE C...Special option: loop over flavours and integrate over k2. DO 170 KF=1,5 DO 160 ISTEP=1,NSTEP Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP) IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR. & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA) FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0) IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0) DO 150 KFL=-5,5 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL) IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL) IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL) IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL) 150 CONTINUE 160 CONTINUE 170 CONTINUE ENDIF C...Call Bethe-Heitler term expression for charm and bottom. CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH) XPBEH(4)=XPBH XPBEH(-4)=XPBH CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH) XPBEH(5)=XPBH XPBEH(-5)=XPBH C...For MSbar subtraction call C^gamma term expression for d, u, s. IF(ISET.EQ.2.OR.ISET.EQ.4) THEN CALL PYGDIR(X,Q2,P2,Q02,XPGA) DO 180 KFL=-5,5 XPDIR(KFL)=XPGA(KFL) 180 CONTINUE ENDIF C...Store result in output array. DO 190 KFL=-5,5 CHSQ=1D0/9D0 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL) IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL) VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL) 190 CONTINUE RETURN END C********************************************************************* C...PYGVMD C...Evaluates the VMD parton distributions of a photon, C...evolved homogeneously from an initial scale P2 to Q2. C...Does not include dipole suppression factor. C...ISET is parton distribution set, see above; C...additionally ISET=0 is used for the evolution of an anomalous photon C...which branched at a scale P2 and then evolved homogeneously to Q2. C...ALAM is the 4-flavour Lambda, which is automatically converted C...to 3- and 5-flavour equivalents as needed. C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Local arrays and data. DIMENSION XPGA(-6:6), VXPGA(-6:6) DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/ C...Reset output. DO 100 KFL=-6,6 XPGA(KFL)=0D0 VXPGA(KFL)=0D0 100 CONTINUE KFA=IABS(KF) C...Calculate Lambda; protect against unphysical Q2 and P2 input. ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0) ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0) P2EFF=MAX(P2,1.2D0*ALAM3**2) IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2) IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2) Q2EFF=MAX(Q2,P2EFF) C...Find number of flavours at lower and upper scale. NFP=4 IF(P2EFF.LT.PMC**2) NFP=3 IF(P2EFF.GT.PMB**2) NFP=5 NFQ=4 IF(Q2EFF.LT.PMC**2) NFQ=3 IF(Q2EFF.GT.PMB**2) NFQ=5 C...Find s as sum of 3-, 4- and 5-flavour parts. S=0D0 IF(NFP.EQ.3) THEN Q2DIV=PMC**2 IF(NFQ.EQ.3) Q2DIV=Q2EFF S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2)) ENDIF IF(NFP.LE.4.AND.NFQ.GE.4) THEN P2DIV=P2EFF IF(NFP.EQ.3) P2DIV=PMC**2 Q2DIV=Q2EFF IF(NFQ.EQ.5) Q2DIV=PMB**2 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2)) ENDIF IF(NFQ.EQ.5) THEN P2DIV=PMB**2 IF(NFP.EQ.5) P2DIV=P2EFF S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2)) ENDIF C...Calculate frequent combinations of x and s. X1=1D0-X XL=-LOG(X) S2=S**2 S3=S**3 S4=S**4 C...Evaluate homogeneous anomalous parton distributions below or C...above threshold. IF(ISET.EQ.0) THEN IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN XVAL = X * 1.5D0 * (X**2+X1**2) XGLU = 0D0 XSEA = 0D0 ELSE XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 + & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 + & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) * & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S) XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) * & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) * & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL) XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) * & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) * & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL + & (2D0*X-1D0)*X*XL**2) ENDIF C...Evaluate set 1D parton distributions below or above threshold. ELSEIF(ISET.EQ.1) THEN IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0 XSEA = 0.100D0 * X1**3.76D0 ELSE XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) * & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S) XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) * & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 * & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) * & X**0.40D0 * X1**(1.76D0+3D0*S) XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/ & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) * & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S)) XSEA0 = 0.100D0 * X1**3.76D0 ENDIF C...Evaluate set 1M parton distributions below or above threshold. ELSEIF(ISET.EQ.2) THEN IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0 XSEA = 0D0 ELSE XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) * & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S) XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) * & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) * & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 * & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S) XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) * & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) * & XL**(2.8D0*S) XSEA0 = 0D0 ENDIF C...Evaluate set 2D parton distributions below or above threshold. ELSEIF(ISET.EQ.3) THEN IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X XGLU = 1.925D0 * X1**2 XSEA = 0.242D0 * X1**4 ELSE XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) * & X**(0.46D0+0.25D0*S) * & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) + & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S) XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) * & EXP(-18.67D0*S) * & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2)) & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) * & XL**(9.3D0*S/(1D0+1.7D0*S)) XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/ & (1D0-0.607D0*S+21.95D0*S2) * & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S XSEA0 = 0.242D0 * X1**4 ENDIF C...Evaluate set 2M parton distributions below or above threshold. ELSEIF(ISET.EQ.4) THEN IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X XGLU = 1.808D0 * X1**2 XSEA = 0.209D0 * X1**4 ELSE XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) * & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) * & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) * & XL**(5.15D0*S/(1D0+2D0*S)) + & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S) XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) * & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) * & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) * & XL**(10.9D0*S/(1D0+2.5D0*S)) XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) * & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) * & X1**(4D0+S) * XL**(0.45D0*S) XSEA0 = 0.209D0 * X1**4 ENDIF ENDIF C...Threshold factors for c and b sea. SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2)) XCHM=0D0 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2))) IF(ISET.EQ.0) THEN XCHM=XSEA*(1D0-(SCH/SLL)**2) ELSE XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL) ENDIF ENDIF XBOT=0D0 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2))) IF(ISET.EQ.0) THEN XBOT=XSEA*(1D0-(SBT/SLL)**2) ELSE XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL) ENDIF ENDIF C...Fill parton distributions. XPGA(0)=XGLU XPGA(1)=XSEA XPGA(2)=XSEA XPGA(3)=XSEA XPGA(4)=XCHM XPGA(5)=XBOT XPGA(KFA)=XPGA(KFA)+XVAL DO 110 KFL=1,5 XPGA(-KFL)=XPGA(KFL) 110 CONTINUE VXPGA(KFA)=XVAL VXPGA(-KFA)=XVAL RETURN END C********************************************************************* C...PYGANO C...Evaluates the parton distributions of the anomalous photon, C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2. C...KF=0 gives the sum over (up to) 5 flavours, C...KF<0 limits to flavours up to abs(KF), C...KF>0 is for flavour KF only. C...ALAM is the 4-flavour Lambda, which is automatically converted C...to 3- and 5-flavour equivalents as needed. C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Local arrays and data. DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5) DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/ C...Reset output. DO 100 KFL=-6,6 XPGA(KFL)=0D0 VXPGA(KFL)=0D0 100 CONTINUE IF(Q2.LE.P2) RETURN KFA=IABS(KF) C...Calculate Lambda; protect against unphysical Q2 and P2 input. ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2 ALAMSQ(4)=ALAM**2 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2 P2EFF=MAX(P2,1.2D0*ALAMSQ(3)) IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2) IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2) Q2EFF=MAX(Q2,P2EFF) XL=-LOG(X) C...Find number of flavours at lower and upper scale. NFP=4 IF(P2EFF.LT.PMC**2) NFP=3 IF(P2EFF.GT.PMB**2) NFP=5 NFQ=4 IF(Q2EFF.LT.PMC**2) NFQ=3 IF(Q2EFF.GT.PMB**2) NFQ=5 C...Define range of flavour loop. IF(KF.EQ.0) THEN KFLMN=1 KFLMX=5 ELSEIF(KF.LT.0) THEN KFLMN=1 KFLMX=KFA ELSE KFLMN=KFA KFLMX=KFA ENDIF C...Loop over flavours the photon can branch into. DO 110 KFL=KFLMN,KFLMX C...Light flavours: calculate t range and (approximate) s range. IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN TDIFF=LOG(Q2EFF/P2EFF) S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/ & LOG(P2EFF/ALAMSQ(NFQ))) IF(NFQ.GT.NFP) THEN Q2DIV=PMB**2 IF(NFQ.EQ.4) Q2DIV=PMC**2 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/ & LOG(P2EFF/ALAMSQ(NFQ))) SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/ & LOG(P2EFF/ALAMSQ(NFQ-1))) S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ) ENDIF IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN Q2DIV=PMC**2 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/ & LOG(P2EFF/ALAMSQ(4))) SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/ & LOG(P2EFF/ALAMSQ(3))) S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4) ENDIF C...u and s quark do not need a separate treatment when d has been done. ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN C...Charm: as above, but only include range above c threshold. ELSEIF(KFL.EQ.4) THEN IF(Q2.LE.PMC**2) GOTO 110 P2EFF=MAX(P2EFF,PMC**2) Q2EFF=MAX(Q2EFF,P2EFF) TDIFF=LOG(Q2EFF/P2EFF) S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/ & LOG(P2EFF/ALAMSQ(NFQ))) IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN Q2DIV=PMB**2 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/ & LOG(P2EFF/ALAMSQ(NFQ))) SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/ & LOG(P2EFF/ALAMSQ(NFQ-1))) S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ) ENDIF C...Bottom: as above, but only include range above b threshold. ELSEIF(KFL.EQ.5) THEN IF(Q2.LE.PMB**2) GOTO 110 P2EFF=MAX(P2EFF,PMB**2) Q2EFF=MAX(Q2,P2EFF) TDIFF=LOG(Q2EFF/P2EFF) S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/ & LOG(P2EFF/ALAMSQ(NFQ))) ENDIF C...Evaluate flavour-dependent prefactor (charge^2 etc.). CHSQ=1D0/9D0 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0 FAC=AEM2PI*2D0*CHSQ*TDIFF C...Evaluate parton distributions (normalized to unit momentum sum). IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 + & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 + & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) * & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S)) XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) * & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) * & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL) XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) * & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) * & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 + & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2) C...Threshold factors for c and b sea. SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2)) XCHM=0D0 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2))) XCHM=XSEA*(1D0-(SCH/SLL)**3) ENDIF XBOT=0D0 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2))) XBOT=XSEA*(1D0-(SBT/SLL)**3) ENDIF ENDIF C...Add contribution of each valence flavour. XPGA(0)=XPGA(0)+FAC*XGLU XPGA(1)=XPGA(1)+FAC*XSEA XPGA(2)=XPGA(2)+FAC*XSEA XPGA(3)=XPGA(3)+FAC*XSEA XPGA(4)=XPGA(4)+FAC*XCHM XPGA(5)=XPGA(5)+FAC*XBOT XPGA(KFL)=XPGA(KFL)+FAC*XVAL VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL 110 CONTINUE DO 120 KFL=1,5 XPGA(-KFL)=XPGA(KFL) VXPGA(-KFL)=VXPGA(KFL) 120 CONTINUE RETURN END C********************************************************************* C...PYGBEH C...Evaluates the Bethe-Heitler cross section for heavy flavour C...production. C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Local data. DATA AEM2PI/0.0011614D0/ C...Reset output. XPBH=0D0 SIGBH=0D0 C...Check kinematics limits. IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN W2=Q2*(1D0-X)/X-P2 BETA2=1D0-4D0*PM2/W2 IF(BETA2.LT.1D-10) RETURN BETA=SQRT(BETA2) RMQ=4D0*PM2/Q2 C...Simple case: P2 = 0. IF(P2.LT.1D-4) THEN IF(BETA.LT.0.99D0) THEN XBL=LOG((1D0+BETA)/(1D0-BETA)) ELSE XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2)) ENDIF SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+ & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2) C...Complicated case: P2 > 0, based on approximation of C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373 ELSE RPQ=1D0-4D0*X**2*P2/Q2 IF(RPQ.GT.1D-10) THEN RPBE=SQRT(RPQ*BETA2) IF(RPBE.LT.0.99D0) THEN XBL=LOG((1D0+RPBE)/(1D0-RPBE)) XBI=2D0*RPBE/(1D0-RPBE**2) ELSE RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2 XBL=LOG((1D0+RPBE)**2/RPBESN) XBI=2D0*RPBE/RPBESN ENDIF SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+ & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+ & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X) ENDIF ENDIF C...Multiply by charge-squared etc. to get parton distribution. CHSQ=1D0/9D0 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH RETURN END C********************************************************************* C...PYGDIR C...Evaluates the direct contribution, i.e. the C^gamma term, C...as needed in MSbar parametrizations. C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Local array and data. DIMENSION XPGA(-6:6) DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/ C...Reset output. DO 100 KFL=-6,6 XPGA(KFL)=0D0 100 CONTINUE C...Evaluate common x-dependent expression. XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X)) C...d, u, s part by simple charge factor. XPGA(1)=(1D0/9D0)*CGAM XPGA(2)=(4D0/9D0)*CGAM XPGA(3)=(1D0/9D0)*CGAM C...Also fill for antiquarks. DO 110 KF=1,5 XPGA(-KF)=XPGA(KF) 110 CONTINUE RETURN END C********************************************************************* C...PYPDPI C...Gives pi+ parton distribution according to two different C...parametrizations. SUBROUTINE PYPDPI(X,Q2,XPPI) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYDAT1/,/PYPARS/,/PYINT1/ C...Local arrays. DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6) C...The following data lines are coefficients needed in the C...Owens pion parton distribution parametrizations, see below. C...Expansion coefficients for up and down valence quark distributions. DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/ &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00, &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00, &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/ DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/ &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00, &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00, &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/ C...Expansion coefficients for gluon distribution. DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/ &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00, &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01, &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/ DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/ &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00, &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00, &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/ C...Expansion coefficients for (up+down+strange) quark sea distribution. DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/ &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00, &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00, &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/ DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/ &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00, &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01, &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/ C...Expansion coefficients for charm quark sea distribution. DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/ &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00, &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00, &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/ DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/ &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00, &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01, &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/ C...Euler's beta function, requires ordinary Gamma function EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y) C...Reset output array. DO 100 KFL=-6,6 XPPI(KFL)=0D0 100 CONTINUE IF(MSTP(53).LE.2) THEN C...Pion parton distributions from Owens. C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2. C...Determine set, Lambda and s expansion variable. NSET=MSTP(53) IF(NSET.EQ.1) ALAM=0.2D0 IF(NSET.EQ.2) ALAM=0.4D0 VINT(231)=4D0 IF(MSTP(57).LE.0) THEN SD=0D0 ELSE Q2IN=MIN(2D3,MAX(4D0,Q2)) SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2)) ENDIF C...Calculate parton distributions. DO 120 KFL=1,4 DO 110 IS=1,5 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+ & COW(3,IS,KFL,NSET)*SD**2 110 CONTINUE IF(KFL.EQ.1) THEN XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0) ELSE XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+ & TS(5)*X**2) ENDIF 120 CONTINUE C...Put into output array. XPPI(0)=XQ(2) XPPI(1)=XQ(3)/6D0 XPPI(2)=XQ(1)+XQ(3)/6D0 XPPI(3)=XQ(3)/6D0 XPPI(4)=XQ(4) XPPI(-1)=XQ(1)+XQ(3)/6D0 XPPI(-2)=XQ(3)/6D0 XPPI(-3)=XQ(3)/6D0 XPPI(-4)=XQ(4) C...Leading order pion parton distributions from Gluck, Reya and Vogt. C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and C...10^-5 < x < 1. ELSE C...Determine s expansion variable and some x expressions. VINT(231)=0.25D0 IF(MSTP(57).LE.0) THEN SD=0D0 ELSE Q2IN=MIN(1D8,MAX(0.25D0,Q2)) SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2)) ENDIF SD2=SD**2 XL=-LOG(X) XS=SQRT(X) C...Evaluate valence, gluon and sea distributions. XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)* & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD) XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0* & SD-0.175D0*SD2)+ & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+ & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0* & XL)))* & (1D0-X)**(0.390D0+1.053D0*SD) XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0- & X)**3.359D0* & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0* & XL))/ & XL**(2.538D0-0.763D0*SD) IF(SD.LE.0.888D0) THEN XFCHM=0D0 ELSE XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+ & 0.771D0*SD)* & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0* & XL)) ENDIF IF(SD.LE.1.351D0) THEN XFBOT=0D0 ELSE XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)* & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0* & XL)) ENDIF C...Put into output array. XPPI(0)=XFGLU XPPI(1)=XFSEA XPPI(2)=XFSEA XPPI(3)=XFSEA XPPI(4)=XFCHM XPPI(5)=XFBOT DO 130 KFL=1,5 XPPI(-KFL)=XPPI(KFL) 130 CONTINUE XPPI(2)=XPPI(2)+XFVAL XPPI(-1)=XPPI(-1)+XFVAL ENDIF RETURN END C********************************************************************* C...PYPDPR C...Gives proton parton distributions according to a few different C...parametrizations. SUBROUTINE PYPDPR(X,Q2,XPPR) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ C...Arrays and data. DIMENSION XPPR(-6:6),Q2MIN(6) DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0/ C...Reset output array. DO 100 KFL=-6,6 XPPR(KFL)=0D0 100 CONTINUE C...Common preliminaries. NSET=MAX(1,MIN(6,MSTP(51))) VINT(231)=Q2MIN(NSET) IF(MSTP(57).EQ.0) THEN Q2L=Q2MIN(NSET) ELSE Q2L=MAX(Q2MIN(NSET),Q2) ENDIF IF(NSET.GE.1.AND.NSET.LE.3) THEN C...Interface to the CTEQ 3 parton distributions. QRT=SQRT(MAX(1D0,Q2L)) C...Loop over flavours. DO 110 I=-6,6 IF(I.LE.0) THEN XPPR(I)=PYCTEQ(NSET,I,X,QRT) ELSEIF(I.LE.2) THEN XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I) ELSE XPPR(I)=XPPR(-I) ENDIF 110 CONTINUE ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN C...Interface to the GRV 94 distributions. IF(NSET.EQ.4) THEN CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL) ELSEIF(NSET.EQ.5) THEN CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL) ELSE CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL) ENDIF C...Put into output array. XPPR(0)=GL XPPR(-1)=0.5D0*(UDB+DEL) XPPR(-2)=0.5D0*(UDB-DEL) XPPR(-3)=SB XPPR(-4)=CHM XPPR(-5)=BOT XPPR(1)=DV+XPPR(-1) XPPR(2)=UV+XPPR(-2) XPPR(3)=SB XPPR(4)=CHM XPPR(5)=BOT ENDIF RETURN END C********************************************************************* C...PYCTEQ C...Gives the CTEQ 3 parton distribution function sets in C...parametrized form, of October 24, 1994. C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens, C...J. Qiu, W.K. Tung and H. Weerts. FUNCTION PYCTEQ (ISET, IPRT, X, Q) C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) C...Data on Lambda values of fits, minimum Q and quark masses. DIMENSION ALM(3), QMS(4:6) DATA ALM / 0.177D0, 0.239D0, 0.247D0 / DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 / C....Check flavour thresholds. Set up QI for SB. IP = IABS(IPRT) IF(IP .GE. 4) THEN IF(Q .LE. QMS(IP)) THEN PYCTEQ = 0D0 RETURN ENDIF QI = QMS(IP) ELSE QI = QMN ENDIF C...Use "standard lambda" of parametrization program for expansion. ALAM = ALM (ISET) SBL = LOG(Q/ALAM) / LOG(QI/ALAM) SB = LOG (SBL) SB2 = SB*SB SB3 = SB2*SB C...Expansion for CTEQ3L. IF(ISET .EQ. 1) THEN IF(IPRT .EQ. 2) THEN A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2- & 0.3171D+00*SB3) A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3 ELSEIF(IPRT .EQ. 1) THEN A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+ & 0.7728D+00*SB3) A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3 ELSEIF(IPRT .EQ. 0) THEN A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+ & 0.5343D+00*SB3) A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3 ELSEIF(IPRT .EQ. -1) THEN A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2- & 0.2031D+01*SB3) A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3 ELSEIF(IPRT .EQ. -2) THEN A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2- & 0.9872D-01*SB3) A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3 ELSEIF(IPRT .EQ. -3) THEN A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+ & 0.8390D+00*SB3) A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3 ELSEIF(IPRT .EQ. -4) THEN A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB + & 0.1651D-01*SB2) A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3 ELSEIF(IPRT .EQ. -5) THEN A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB + & 0.3702D+01*SB2) A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3 ELSEIF(IPRT .EQ. -6) THEN A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB - & 0.6943D+00*SB2) A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3 ENDIF C...Expansion for CTEQ3M. ELSEIF(ISET .EQ. 2) THEN IF(IPRT .EQ. 2) THEN A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2- & 0.2935D+00*SB3) A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3 ELSEIF(IPRT .EQ. 1) THEN A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2- & 0.4305D-01*SB3) A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3 ELSEIF(IPRT .EQ. 0) THEN A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+ & 0.1037D-01*SB3) A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3 ELSEIF(IPRT .EQ. -1) THEN A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2- & 0.1602D+01*SB3) A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3 ELSEIF(IPRT .EQ. -2) THEN A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+ & 0.2496D+00*SB3) A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3 ELSEIF(IPRT .EQ. -3) THEN A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+ & 0.1936D+01*SB3) A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3 ELSEIF(IPRT .EQ. -4) THEN A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB + & 0.5348D+00*SB2) A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3 ELSEIF(IPRT .EQ. -5) THEN A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB + & 0.1569D+01*SB2) A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3 ELSEIF(IPRT .EQ. -6) THEN A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB + & 0.8838D+01*SB2) A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3 ENDIF C...Expansion for CTEQ3D. ELSEIF(ISET .EQ. 3) THEN IF(IPRT .EQ. 2) THEN A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2- & 0.2902D+00*SB3) A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3 ELSEIF(IPRT .EQ. 1) THEN A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+ & 0.7257D+00*SB3) A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3 ELSEIF(IPRT .EQ. 0) THEN A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2- & 0.2734D-04*SB3) A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3 ELSEIF(IPRT .EQ. -1) THEN A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2- & 0.1671D+01*SB3) A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3 ELSEIF(IPRT .EQ. -2) THEN A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+ & 0.2223D+00*SB3) A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3 ELSEIF(IPRT .EQ. -3) THEN A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+ & 0.1937D+01*SB3) A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3 ELSEIF(IPRT .EQ. -4) THEN A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB + & 0.5137D+00*SB2) A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3 ELSEIF(IPRT .EQ. -5) THEN A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB + & 0.2143D+01*SB2) A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3 ELSEIF(IPRT .EQ. -6) THEN A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB + & 0.9998D+01*SB2) A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3 ENDIF ENDIF C...Calculation of x * f(x, Q). PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4)) & *(LOG(1D0+1D0/X))**A5 ) RETURN END C********************************************************************* C...PYGRVL C...Gives the GRV 94 L (leading order) parton distribution function set C...in parametrized form. C...Authors: M. Glueck, E. Reya and A. Vogt. SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL) C...Double precision declaration. IMPLICIT DOUBLE PRECISION (A - Z) C...Common expressions. MU2 = 0.23D0 LAM2 = 0.2322D0 * 0.2322D0 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2)) DS = SQRT (S) S2 = S * S S3 = S2 * S C...uv : NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2 AKU = 0.590D0 - 0.024D0 * S BKU = 0.131D0 + 0.063D0 * S AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU) C...dv : ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2 AKD = 0.376D0 BKD = 0.486D0 + 0.062D0 * S AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD) C...del : NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2 AKE = 0.409D0 - 0.005D0 * S BKE = 0.799D0 + 0.071D0 * S AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2 CE = 0.0D0 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE) C...udb : ALX = 1.451D0 BEX = 0.271D0 AKX = 0.410D0 - 0.232D0 * S BKX = 0.534D0 - 0.457D0 * S AGX = 0.890D0 - 0.140D0 * S BGX = -0.981D0 CX = 0.320D0 + 0.683D0 * S DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2 EX = 4.119D0 + 1.713D0 * S ESX = 0.682D0 + 2.978D0 * S UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX, & DX, EX, ESX) C...sb : STS = 0D0 ALS = 0.914D0 BES = 0.577D0 AKS = 1.798D0 - 0.596D0 * S AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2 EST = 3.981D0 + 1.638D0 * S ESS = 6.402D0 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS) C...cb : STC = 0.888D0 ALC = 1.01D0 BEC = 0.37D0 AKC = 0D0 AC = 0D0 BC = 4.24D0 - 0.804D0 * S DCT = 3.46D0 - 1.076D0 * S ECT = 4.61D0 + 1.49D0 * S ESC = 2.555D0 + 1.961D0 * S CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC) C...bb : STB = 1.351D0 ALB = 1.00D0 BEB = 0.51D0 AKB = 0D0 AB = 0D0 BB = 1.848D0 DBT = 2.929D0 + 1.396D0 * S EBT = 4.71D0 + 1.514D0 * S ESB = 4.02D0 + 1.239D0 * S BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB) C...gl : ALG = 0.524D0 BEG = 1.088D0 AKG = 1.742D0 - 0.930D0 * S BKG = - 0.399D0 * S2 AG = 7.486D0 - 2.185D0 * S BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3 EG = 0.807D0 + 2.005D0 * S ESG = 3.841D0 + 0.316D0 * S GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, & DG, EG, ESG) RETURN END C********************************************************************* C...PYGRVM C...Gives the GRV 94 M (MSbar) parton distribution function set C...in parametrized form. C...Authors: M. Glueck, E. Reya and A. Vogt. SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL) C...Double precision declaration. IMPLICIT DOUBLE PRECISION (A - Z) C...Common expressions. MU2 = 0.34D0 LAM2 = 0.248D0 * 0.248D0 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2)) DS = SQRT (S) S2 = S * S S3 = S2 * S C...uv : NU = 1.304D0 + 0.863D0 * S AKU = 0.558D0 - 0.020D0 * S BKU = 0.183D0 * S AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU) C...dv : ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2 AKD = 0.270D0 - 0.019D0 * S BKD = 0.260D0 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD) C...del : NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3 AKE = 0.409D0 - 0.007D0 * S BKE = 0.782D0 + 0.082D0 * S AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2 CE = 0.0D0 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE) C...udb : ALX = 0.877D0 BEX = 0.561D0 AKX = 0.275D0 BKX = 0.0D0 AGX = 0.997D0 BGX = 3.210D0 - 1.866D0 * S CX = 7.300D0 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2 EX = 3.077D0 + 1.446D0 * S ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX, & DX, EX, ESX) C...sb : STS = 0D0 ALS = 0.756D0 BES = 0.216D0 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S AS = -4.329D0 + 1.131D0 * S BS = 9.568D0 - 1.744D0 * S DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2 EST = 3.031D0 + 1.639D0 * S ESS = 5.837D0 + 0.815D0 * S SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS) C...cb : STC = 0.820D0 ALC = 0.98D0 BEC = 0D0 AKC = -0.625D0 - 0.523D0 * S AC = 0D0 BC = 1.896D0 + 1.616D0 * S DCT = 4.12D0 + 0.683D0 * S ECT = 4.36D0 + 1.328D0 * S ESC = 0.677D0 + 0.679D0 * S CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC) C...bb : STB = 1.297D0 ALB = 0.99D0 BEB = 0D0 AKB = - 0.193D0 * S AB = 0D0 BB = 0D0 DBT = 3.447D0 + 0.927D0 * S EBT = 4.68D0 + 1.259D0 * S ESB = 1.892D0 + 2.199D0 * S BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB) C...gl : ALG = 1.014D0 BEG = 1.738D0 AKG = 1.724D0 + 0.157D0 * S BKG = 0.800D0 + 1.016D0 * S AG = 7.517D0 - 2.547D0 * S BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S CG = 4.039D0 + 1.491D0 * S DG = 3.404D0 + 0.830D0 * S EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2 ESG = 3.256D0 - 0.436D0 * S GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG) RETURN END C********************************************************************* C...PYGRVD C...Gives the GRV 94 D (DIS) parton distribution function set C...in parametrized form. C...Authors: M. Glueck, E. Reya and A. Vogt. SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL) C...Double precision declaration. IMPLICIT DOUBLE PRECISION (A - Z) C...Common expressions. MU2 = 0.34D0 LAM2 = 0.248D0 * 0.248D0 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2)) DS = SQRT (S) S2 = S * S S3 = S2 * S C...uv : NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2 AKU = 0.563D0 - 0.025D0 * S BKU = 0.054D0 + 0.154D0 * S AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU) C...dv : ND = 0.156D0 - 0.017D0 * S AKD = 0.299D0 - 0.022D0 * S BKD = 0.259D0 - 0.015D0 * S AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD) C...del : NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2 AKE = 0.419D0 - 0.013D0 * S BKE = 1.064D0 - 0.038D0 * S AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE) C...udb : ALX = 1.215D0 BEX = 0.466D0 AKX = 0.326D0 + 0.150D0 * S BKX = 0.956D0 + 0.405D0 * S AGX = 0.272D0 BGX = 3.794D0 - 2.359D0 * DS CX = 2.014D0 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2 EX = 3.049D0 + 1.597D0 * S ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX, & DX, EX, ESX) C...sb : STS = 0D0 ALS = 0.175D0 BES = 0.344D0 AKS = 1.415D0 - 0.641D0 * DS AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3 EST = 4.546D0 + 0.372D0 * S2 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS) C...cb : STC = 0.820D0 ALC = 0.98D0 BEC = 0D0 AKC = -0.625D0 - 0.523D0 * S AC = 0D0 BC = 1.896D0 + 1.616D0 * S DCT = 4.12D0 + 0.683D0 * S ECT = 4.36D0 + 1.328D0 * S ESC = 0.677D0 + 0.679D0 * S CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC) C...bb : STB = 1.297D0 ALB = 0.99D0 BEB = 0D0 AKB = - 0.193D0 * S AB = 0D0 BB = 0D0 DBT = 3.447D0 + 0.927D0 * S EBT = 4.68D0 + 1.259D0 * S ESB = 1.892D0 + 2.199D0 * S BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB) C...gl : ALG = 1.258D0 BEG = 1.846D0 AKG = 2.423D0 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2 AG = 25.09D0 - 7.935D0 * S BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S CG = 590.3D0 - 173.8D0 * S DG = 5.196D0 + 1.857D0 * S EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2 ESG = 3.232D0 - 0.542D0 * S GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG) RETURN END C********************************************************************* C...PYGRVV C...Auxiliary for the GRV 94 parton distribution functions C...for u and d valence and d-u sea. C...Authors: M. Glueck, E. Reya and A. Vogt. FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D) C...Double precision declaration. IMPLICIT DOUBLE PRECISION (A - Z) C...Evaluation. DX = SQRT (X) PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) * & (1D0- X)**D RETURN END C********************************************************************* C...PYGRVW C...Auxiliary for the GRV 94 parton distribution functions C...for d+u sea and gluon. C...Authors: M. Glueck, E. Reya and A. Vogt. FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES) C...Double precision declaration. IMPLICIT DOUBLE PRECISION (A - Z) C...Evaluation. LX = LOG (1D0/X) PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D RETURN END C********************************************************************* C...PYGRVS C...Auxiliary for the GRV 94 parton distribution functions C...for s, c and b sea. C...Authors: M. Glueck, E. Reya and A. Vogt. FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES) C...Double precision declaration. IMPLICIT DOUBLE PRECISION (A - Z) C...Evaluation. IF(S.LE.STH) THEN PYGRVS = 0D0 ELSE DX = SQRT (X) LX = LOG (1D0/X) PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) * & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX)) ENDIF RETURN END C********************************************************************* C...PYHFTH C...Gives threshold attractive/repulsive factor for heavy flavour C...production. FUNCTION PYHFTH(SH,SQM,FRATT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYDAT1/,/PYPARS/,/PYINT1/ C...Value for alpha_strong. IF(MSTP(35).LE.1) THEN ALSSG=PARP(35) ELSE MST115=MSTU(115) MSTU(115)=MSTP(36) Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+ & PARP(36)**2))) ALSSG=PYALPS(Q2BN) MSTU(115)=MST115 ENDIF C...Evaluate attractive and repulsive factors. XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH))) FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR))) XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH))) FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0) PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU VINT(138)=PYHFTH RETURN END C********************************************************************* C...PYSPLI C...Splits a hadron remnant into two (partons or hadron + parton) C...in case it is more complicated than just a quark or a diquark. SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYPARS/,/PYINT1/ C...Local array. DIMENSION KFL(3) C...Preliminaries. Parton composition. KFA=IABS(KF) KFS=ISIGN(1,KF) KFL(1)=MOD(KFA/1000,10) KFL(2)=MOD(KFA/100,10) KFL(3)=MOD(KFA/10,10) IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN KFL(2)=INT(1.5D0+PYR(0)) IF(MINT(105).EQ.333) KFL(2)=3 IF(MINT(105).EQ.443) KFL(2)=4 KFL(3)=KFL(2) ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN KFL(2)=2 KFL(3)=2 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN KFL(2)=1 KFL(3)=1 ENDIF IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN KFLR=KFLIN*KFS ELSE KFLR=KFLIN ENDIF KFLCH=0 C...Subdivide lepton. IF(KFA.GE.11.AND.KFA.LE.18) THEN IF(KFLR.EQ.KFA) THEN KFLSP=KFS*22 ELSEIF(KFLR.EQ.22) THEN KFLSP=KFA ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN KFLSP=KFA+1 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN KFLSP=KFA-1 ELSEIF(KFLR.EQ.21) THEN KFLSP=KFA KFLCH=KFS*21 ELSE KFLSP=KFA KFLCH=-KFLR ENDIF C...Subdivide photon. ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN IF(KFLR.NE.21) THEN KFLSP=-KFLR ELSE RAGR=0.75D0*PYR(0) KFLSP=1 IF(RAGR.GT.0.125D0) KFLSP=2 IF(RAGR.GT.0.625D0) KFLSP=3 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP KFLCH=-KFLSP ENDIF C...Subdivide Reggeon or Pomeron. ELSEIF(KFA.EQ.28.OR.KFA.EQ.29) THEN IF(KFLIN.EQ.21) THEN KFLSP=KFS*21 ELSE KFLSP=-KFLIN ENDIF C...Subdivide meson. ELSEIF(KFL(1).EQ.0) THEN KFL(2)=KFL(2)*(-1)**KFL(2) KFL(3)=-KFL(3)*(-1)**IABS(KFL(2)) IF(KFLR.EQ.KFL(2)) THEN KFLSP=KFL(3) ELSEIF(KFLR.EQ.KFL(3)) THEN KFLSP=KFL(2) ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN KFLSP=KFL(2) KFLCH=KFL(3) ELSEIF(KFLR.EQ.21) THEN KFLSP=KFL(3) KFLCH=KFL(2) ELSEIF(KFLR*KFL(2).GT.0) THEN CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH) KFLSP=KFL(3) ELSE CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH) KFLSP=KFL(2) ENDIF C...Subdivide baryon. ELSE NAGR=0 DO 100 J=1,3 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1 100 CONTINUE IF(NAGR.GE.1) THEN RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0) IAGR=0 DO 110 J=1,3 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J 110 CONTINUE ELSE IAGR=1.00001D0+2.99998D0*PYR(0) ENDIF ID1=1 IF(IAGR.EQ.1) ID1=2 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3 ID2=6-IAGR-ID1 KSP=3 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1 ELSEIF(MOD(KFA,10).EQ.2) THEN IF(IAGR.EQ.1) KSP=1 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1 ENDIF KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP IF(KFLR.EQ.21) THEN KFLCH=KFL(IAGR) ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH) ELSEIF(NAGR.EQ.0) THEN CALL PYKFDI(10000+KFLSP,-KFLR,KFDUMP,KFLCH) KFLSP=KFL(IAGR) ENDIF ENDIF C...Add on correct sign for result. KFLCH=KFLCH*KFS KFLSP=KFLSP*KFS RETURN END C********************************************************************* C...PYGAMM C...Gives ordinary Gamma function Gamma(x) for positive, real arguments; C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions C...(Dover, 1965) 6.1.36. FUNCTION PYGAMM(X) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Local array and data. DIMENSION B(8) DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0, &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/ NX=INT(X) DX=X-NX PYGAMM=1D0 DXP=1D0 DO 100 I=1,8 DXP=DXP*DX PYGAMM=PYGAMM+B(I)*DXP 100 CONTINUE IF(X.LT.1D0) THEN PYGAMM=PYGAMM/X ELSE DO 110 IX=1,NX-1 PYGAMM=(X-IX)*PYGAMM 110 CONTINUE ENDIF RETURN END C*********************************************************************** C...PYWAUX C...Calculates real and imaginary parts of the auxiliary functions W1 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van C...der Bij, Nucl. Phys. B297 (1988) 221. SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ ASINH(X)=LOG(X+SQRT(X**2+1D0)) ACOSH(X)=LOG(X+SQRT(X**2-1D0)) IF(EPS.LT.0D0) THEN IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS)) IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2 WIM=0D0 ELSEIF(EPS.LT.1D0) THEN IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS)) IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS) IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS)) ELSE IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS)) IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2 WIM=0D0 ENDIF RETURN END C*********************************************************************** C...PYI3AU C...Calculates real and imaginary parts of the auxiliary function I3; C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij, C...Nucl. Phys. B297 (1988) 221. SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS)) IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS)) IF(EPS.LT.0D0) THEN IF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)- & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+ & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)- & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2- & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)* & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+ & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)* & EPS)) ELSEIF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).GE.1.D-4) THEN F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)- & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+ & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)- & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+ & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+ & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+ & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS)) ELSEIF(ABS(EPS).GE.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)- & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+ & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)- & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+ & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+ & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+ & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS)) ELSE F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)- & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)- & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2- & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+ & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0)) ENDIF F3IM=0D0 ELSEIF(EPS.LT.1D0) THEN IF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)- & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+ & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)- & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/ & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/ & (0.25D0*(RAT+1D0)*EPS)) F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/ & (0.25D0*(RAT+1D0)*EPS)) ELSEIF(ABS(EPS).LT.1.D-4.AND.ABS(RAT*EPS).GE.1.D-4) THEN F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)- & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+ & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)- & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+ & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))* & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS)) F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS)) ELSEIF(ABS(EPS).GE.1.D-4.AND.ABS(RAT*EPS).LT.1.D-4) THEN F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)- & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+ & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)- & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+ & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/ & (1D0+0.25D0*RAT*EPS-GA)) F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/ & (1D0+0.25D0*RAT*EPS-GA)) ELSE F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)- & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)- & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))* & LOG((GA+BE-1D0)/(BE-GA)) F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA)) ENDIF ELSE RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2) RCTHE=RSQ*(1D0-2D0*BE/EPS) RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2)) RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS) RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2)) R=SQRT(RSQ) THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R))) PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R))) F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)- & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+ & (PHI-THE)*(PHI+THE-PARU(1)) F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)- & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2) ENDIF Y3RE=2D0/(2D0*BE-1D0)*F3RE Y3IM=2D0/(2D0*BE-1D0)*F3IM RETURN END C*********************************************************************** C...PYSPEN C...Calculates real and imaginary part of Spence function; see C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365. FUNCTION PYSPEN(XREIN,XIMIN,IREIM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Local array and data. DIMENSION B(0:14) DATA B/ &1.000000D+00, -5.000000D-01, 1.666667D-01, &0.000000D+00, -3.333333D-02, 0.000000D+00, &2.380952D-02, 0.000000D+00, -3.333333D-02, &0.000000D+00, 7.575757D-02, 0.000000D+00, &-2.531135D-01, 0.000000D+00, 1.166667D+00/ XRE=XREIN XIM=XIMIN IF(ABS(1D0-XRE).LT.1.D-6.AND.ABS(XIM).LT.1.D-6) THEN IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0 IF(IREIM.EQ.2) PYSPEN=0D0 RETURN ENDIF XMOD=SQRT(XRE**2+XIM**2) IF(XMOD.LT.1.D-6) THEN IF(IREIM.EQ.1) PYSPEN=0D0 IF(IREIM.EQ.2) PYSPEN=0D0 RETURN ENDIF XARG=SIGN(ACOS(XRE/XMOD),XIM) SP0RE=0D0 SP0IM=0D0 SGN=1D0 IF(XMOD.GT.1D0) THEN ALGXRE=LOG(XMOD) ALGXIM=XARG-SIGN(PARU(1),XARG) SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0 SP0IM=-ALGXRE*ALGXIM SGN=-1D0 XMOD=1D0/XMOD XARG=-XARG XRE=XMOD*COS(XARG) XIM=XMOD*SIN(XARG) ENDIF IF(XRE.GT.0.5D0) THEN ALGXRE=LOG(XMOD) ALGXIM=XARG XRE=1D0-XRE XIM=-XIM XMOD=SQRT(XRE**2+XIM**2) XARG=SIGN(ACOS(XRE/XMOD),XIM) ALGYRE=LOG(XMOD) ALGYIM=XARG SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM)) SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE) SGN=-SGN ENDIF XRE=1D0-XRE XIM=-XIM XMOD=SQRT(XRE**2+XIM**2) XARG=SIGN(ACOS(XRE/XMOD),XIM) ZRE=-LOG(XMOD) ZIM=-XARG SPRE=0D0 SPIM=0D0 SAVERE=1D0 SAVEIM=0D0 DO 100 I=0,14 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1) TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1) SAVERE=TERMRE SAVEIM=TERMIM SPRE=SPRE+B(I)*TERMRE SPIM=SPIM+B(I)*TERMIM 100 CONTINUE 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM RETURN END C*********************************************************************** C...PYQQBH C...Calculates the matrix element for the processes C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t). C...REDUCE output and part of the rest courtesy Z. Kunszt, see C...Z. Kunszt, Nucl. Phys. B247 (1984) 339. SUBROUTINE PYQQBH(WTQQBH) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/ C...Local arrays and function. DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8) DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)- &PP(I,3)*PP(J,3) C...Mass parameters. WTQQBH=0D0 ISUB=MINT(1) SHPR=SQRT(VINT(26))*VINT(1) PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1) PH=SQRT(VINT(21))*VINT(1) SPQ=PQ**2 SPH=PH**2 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H. DO 100 I=1,2 PT=SQRT(MAX(0D0,VINT(197+5*I))) PP(I,1)=PT*COS(VINT(198+5*I)) PP(I,2)=PT*SIN(VINT(198+5*I)) 100 CONTINUE PP(3,1)=-PP(1,1)-PP(2,1) PP(3,2)=-PP(1,2)-PP(2,2) PMS1=SPQ+PP(1,1)**2+PP(1,2)**2 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2 PMS3=SPH+PP(3,1)**2+PP(3,2)**2 PMT3=SQRT(PMS3) PP(3,3)=PMT3*SINH(VINT(211)) PP(3,4)=PMT3*COSH(VINT(211)) PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+ &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12) PP(2,3)=-PP(1,3)-PP(3,3) PP(1,4)=SQRT(PMS1+PP(1,3)**2) PP(2,4)=SQRT(PMS2+PP(2,3)**2) C...Set up incoming kinematics and derived momentum combinations. DO 110 I=4,5 PP(I,1)=0D0 PP(I,2)=0D0 PP(I,3)=-0.5D0*SHPR*(-1)**I PP(I,4)=-0.5D0*SHPR 110 CONTINUE DO 120 J=1,4 PP(6,J)=PP(1,J)+PP(2,J) PP(7,J)=PP(1,J)+PP(3,J) PP(8,J)=PP(1,J)+PP(4,J) PP(9,J)=PP(1,J)+PP(5,J) PP(10,J)=-PP(2,J)-PP(3,J) PP(11,J)=-PP(2,J)-PP(4,J) PP(12,J)=-PP(2,J)-PP(5,J) PP(13,J)=-PP(4,J)-PP(5,J) 120 CONTINUE C...Derived kinematics invariants. X1=DOT(1,2) X2=DOT(1,3) X3=DOT(1,4) X4=DOT(1,5) X5=DOT(2,3) X6=DOT(2,4) X7=DOT(2,5) X8=DOT(3,4) X9=DOT(3,5) X10=DOT(4,5) C...Propagators. SS1=DOT(7,7)-SPQ SS2=DOT(8,8)-SPQ SS3=DOT(9,9)-SPQ SS4=DOT(10,10)-SPQ SS5=DOT(11,11)-SPQ SS6=DOT(12,12)-SPQ SS7=DOT(13,13) DX(1)=SS1*SS6 DX(2)=SS2*SS6 DX(3)=SS2*SS4 DX(4)=SS1*SS5 DX(5)=SS3*SS5 DX(6)=SS3*SS4 DX(7)=SS7*SS1 DX(8)=SS7*SS4 C...Define colour coefficients for g + g -> Q + Qbar + H. IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN DO 140 I=1,3 DO 130 J=1,3 CLR(I,J)=16D0/3D0 CLR(I+3,J+3)=16D0/3D0 CLR(I,J+3)=-2D0/3D0 CLR(I+3,J)=-2D0/3D0 130 CONTINUE 140 CONTINUE DO 160 L=1,2 DO 150 I=1,3 CLR(I,6+L)=-6D0 CLR(I+3,6+L)=6D0 CLR(6+L,I)=-6D0 CLR(6+L,I+3)=6D0 150 CONTINUE 160 CONTINUE DO 180 K1=1,2 DO 170 K2=1,2 CLR(6+K1,6+K2)=12D0 170 CONTINUE 180 CONTINUE C...Evaluate matrix elements for g + g -> Q + Qbar + H. FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2* & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2* & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2* & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+ & X10) FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4* & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+ & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6) FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10- & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+ & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2* & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6) FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1* & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1* & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1** & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4* & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5- & X4*X6*X5) FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4- & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3* & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5 & +X4*X9*X5+X4*X5**2) FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2* & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1* & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3* & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7* & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7- & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5) FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2* & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+ & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8* & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8* & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4* & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2* & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+ & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2) FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*( & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3* & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+ & X6) FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1* & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1* & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3* & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6* & X5+X4*X6*X5) FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3- & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4- & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1* & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4* & X6**2) FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1* & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1* & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4* & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1** & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4* & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5- & X4*X6*X5) FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3- & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2* & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3* & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*( & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1* & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1* & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3* & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5) FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3- & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2* & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2* & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5- & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*( & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9- & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10* & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3* & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5) FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3* & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3- & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3* & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5 & +X3*X8*X5+X3*X5**2) FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1* & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1* & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3* & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7* & X5+X4*X6*X5) FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+ & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2* & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2* & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10) FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2* & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4* & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+ & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4* & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+ & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3* & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5) FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2* & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+ & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9* & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8) FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2* & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2* & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+ & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+ & X10) FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2* & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+ & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7) FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1* & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3* & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7* & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2* & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5) FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4* & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9* & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2) FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*( & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4* & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+ & X7) FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+ & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2* & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+ & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+ & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+ & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(- & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10* & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2* & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5) FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+ & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2* & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+ & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2* & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+ & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*( & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3* & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10* & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+ & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5) FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4* & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+ & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+ & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5) FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1* & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12* & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2* & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8) FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9* & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7* & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8 & *X6) FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+ & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4* & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9* & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3* & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+ & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5) FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2* & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4* & X8) FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+ & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6 & )+2*X2*(-X10*X5+X9*X6+X8*X7) FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2* & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3* & X9*X5) FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2* & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4* & X8*X5) FM(9,10)=0.5D0*(FMXX+FM(9,10)) FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+ & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6 & )+2*X5*(-X10*X2+X9*X3+X8*X4) C...Repackage matrix elements. DO 200 I=1,8 DO 190 J=1,8 RM(I,J)=FM(I,J) 190 CONTINUE 200 CONTINUE RM(7,7)=FM(7,7)-2D0*FM(9,9) RM(7,8)=FM(7,8)-2D0*FM(9,10) RM(8,8)=FM(8,8)-2D0*FM(10,10) C...Produce final result: matrix elements * colours * propagators. DO 220 I=1,8 DO 210 J=I,8 FAC=8D0 IF(I.EQ.J)FAC=4D0 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J)) 210 CONTINUE 220 CONTINUE WTQQBH=-WTQQBH/256D0 ELSE C...Evaluate matrix elements for q + qbar -> Q + Qbar + H. A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9 & *X6+X8*X7) A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8- & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8* & X5) A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3* & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3 & *X9+X4*X8) C...Produce final result: matrix elements * propagators. A11=A11/DX(7)**2 A12=A12/(DX(7)*DX(8)) A22=A22/DX(8)**2 WTQQBH=-(A11+A22+2D0*A12)/8D0 ENDIF RETURN END C********************************************************************* C...PYMSIN C...Initializes supersymmetry: finds sparticle masses and C...branching ratios and stores this information. C...AUTHOR: STEPHEN MRENNA SUBROUTINE PYMSIN C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) 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(4000,2),BRAT(4000),KFDP(4000,5) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/, &/PYSSMT/ C...Local variables. INTEGER NSTR DOUBLE PRECISION ALFA,BETA DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW,AEM,FACT DOUBLE PRECISION PYALEM INTEGER I,J,J1,J2,I1,I2,I3,IKNT,K1 INTEGER KC,LKNT,IDLAM(200,3),IDLAM0(100,3),LKNT0 DOUBLE PRECISION XLAM(0:200),XLAM0(0:200),XALL DOUBLE PRECISION WDTP(0:200),WDTE(0:200,0:5) DOUBLE PRECISION ATERM,TAN2T,THETA,DENOM DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2 DOUBLE PRECISION COSW,SINW,WDMIN,WDMAX DOUBLE PRECISION DELM,XMDIF,BRLIM DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2 DOUBLE PRECISION ARG,SGNMU,R,GAM INTEGER IS1,IS2,IS3,IS4,JS1,JS2,JS3,JS4,KS1,KS2,KS3,KS4 INTEGER IMSSM,KFHIGG INTEGER IRPRTY INTEGER KFSUSY(36) DATA KFSUSY/ &1000001,2000001,1000002,2000002,1000003,2000003, &1000004,2000004,1000005,2000005,1000006,2000006, &1000011,2000011,1000012,2000012,1000013,2000013, &1000014,2000014,1000015,2000015,1000016,2000016, &1000021,1000022,1000023,1000025,1000035,1000024, &1000037,1000039, 25, 35, 36, 37/ C...Do nothing if SUSY not requested. IMSSM=IMSS(1) IF(IMSSM.EQ.0) RETURN C...First part of routine: set masses and couplings. C...Reset mixing values in sfermion sector to pure left/right. DO 100 I=1,16 SFMIX(I,1)=1D0 SFMIX(I,4)=1D0 SFMIX(I,2)=0D0 SFMIX(I,3)=0D0 100 CONTINUE C...Common couplings. TANB=RMSS(5) BETA=ATAN(TANB) COSB=COS(BETA) SINB=TANB*COSB COS2B=COS(2D0*BETA) ALFA=RMSS(18) XMW2=PMAS(24,1)**2 XMZ2=PMAS(23,1)**2 XW=PARU(102) C...Define sparticle masses for a general MSSM simulation. IF(IMSSM.EQ.1) THEN IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9) DO 110 I=1,5,2 KC=PYCOMP(KSUSY1+I) PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0) KC=PYCOMP(KSUSY2+I) PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0) KC=PYCOMP(KSUSY1+I+1) PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0) KC=PYCOMP(KSUSY2+I+1) PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0) 110 CONTINUE XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA)) IF(XARG.LT.0D0) THEN WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'// & ' FROM THE SUM RULE. ' WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). ' RETURN ELSE XARG=SQRT(XARG) ENDIF DO 120 I=11,15,2 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6) PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7) PMAS(PYCOMP(KSUSY1+I+1),1)=XARG PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0 120 CONTINUE IF(IMSS(8).EQ.1) THEN RMSS(13)=RMSS(6) RMSS(14)=RMSS(7) ENDIF C...Alternatively derive masses from SUGRA relations. ELSEIF(IMSSM.EQ.2) THEN CALL PYAPPS ENDIF C...Add in extra D-term contributions. IF(IMSS(7).EQ.1) THEN R=0.43D0 DX=RMSS(23) DY=RMSS(24) DS=RMSS(25) WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES ' WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY ' WRITE(MSTU(11),*) 'C DX = ',DX WRITE(MSTU(11),*) 'C DY = ',DY WRITE(MSTU(11),*) 'C DS = ',DS WRITE(MSTU(11),*) 'C ' DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' DQ2=DY/6D0-DX/3D0-DS/3D0 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0 DD2=DY/3D0+DX-2D0*DS/3D0 DL2=-DY/2D0+DX-2D0*DS/3D0 DE2=DY-DX/3D0-DS/3D0 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0 DHD2=-DY/2D0-2D0*DX/3D0+DS DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS) & /ABS(COS2B) DMA2 = 2D0*DMU2+DHU2+DHD2 DO 130 I=1,5,2 KC=PYCOMP(KSUSY1+I) PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2) KC=PYCOMP(KSUSY2+I) PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2) KC=PYCOMP(KSUSY1+I+1) PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2) KC=PYCOMP(KSUSY2+I+1) PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2) 130 CONTINUE DO 140 I=11,15,2 KC=PYCOMP(KSUSY1+I) PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2) KC=PYCOMP(KSUSY2+I) PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2) KC=PYCOMP(KSUSY1+I+1) PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2) 140 CONTINUE IF(RMSS(4)**2+DMU2.LT.0D0) THEN WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE ' STOP ENDIF SGNMU=SIGN(1D0,RMSS(4)) RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2) ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG) ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG) ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG) ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG) ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG) IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW ' STOP ENDIF RMSS(19)=SQRT(RMSS(19)**2+DMA2) RMSS(6)=SQRT(RMSS(6)**2+DL2) RMSS(7)=SQRT(RMSS(7)**2+DE2) WRITE(MSTU(11),*) ' MTL = ',RMSS(10) WRITE(MSTU(11),*) ' MBR = ',RMSS(11) WRITE(MSTU(11),*) ' MTR = ',RMSS(12) WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13) WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14) ENDIF C...Fix the third generation sfermions. CALL PYTHRG XARG=RMSS(13)**2-PMAS(24,1)**2*ABS(COS2B) IF(XARG.LT.0D0) THEN WRITE(MSTU(11),*) ' TAU SNEUTRINO MASS IS NEGATIVE FROM'// & ' THE SUM RULE. ' WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). ' RETURN ELSE PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG) ENDIF C...Fix the neutralino--chargino--gluino sector. CALL PYINOM C...Fix the Higgs sector. CALL PYHGGM(ALFA) C...Choose the Gunion-Haber convention. ALFA=-ALFA RMSS(18)=ALFA C...Print information on mass parameters. IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS ' WRITE(MSTU(11),*) ' M0 = ',RMSS(8) WRITE(MSTU(11),*) ' M1/2=',RMSS(1) WRITE(MSTU(11),*) ' TANB=',RMSS(5) WRITE(MSTU(11),*) ' MU = ',RMSS(4) WRITE(MSTU(11),*) ' AT = ',RMSS(16) WRITE(MSTU(11),*) ' MA = ',RMSS(19) WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1) WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' ENDIF IF(IMSS(20).EQ.1) THEN WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' WRITE(MSTU(11),*) ' DEBUG MODE ' WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2), & UMIX(2,1),UMIX(2,2) WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2), & VMIX(2,1),VMIX(2,2) WRITE(MSTU(11),*) ' ZMIX = ',ZMIX WRITE(MSTU(11),*) ' ALFA = ',ALFA WRITE(MSTU(11),*) ' BETA = ',BETA WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4) WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4) WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' ENDIF C...Set up the Higgs couplings - needed here since initialization C...in PYINRE did not yet occur when PYWIDT is called below. AL=ALFA BE=BETA SINA=SIN(AL) COSA=COS(AL) COSB=COS(BE) SINB=TANB*COSB C...tanb (used for H+) PARU(141)=TANB C...Firstly: h C...Coupling to d-type quarks PARU(161)=SINA/COSB C...Coupling to u-type quarks PARU(162)=-COSA/SINB C...Coupling to leptons PARU(163)=PARU(161) C...Coupling to Z PARU(164)=SIN(BE-AL) C...Coupling to W PARU(165)=PARU(164) C...Coupling to H+ PARU(168)=-SIN(BE-AL)-COS(2D0*BE)*SIN(BE+AL)/2D0/(1D0-XW) C...Secondly: H C...Coupling to d-type quarks PARU(171)=-COSA/COSB C...Coupling to u-type quarks PARU(172)=-SINA/SINB C...Coupling to leptons PARU(173)=PARU(171) C...Coupling to Z PARU(174)=COS(BE-AL) C...Coupling to W PARU(175)=PARU(174) C...Coupling to h PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL) C...Coupling to A PARU(177)=COS(2D0*BE)*COS(BE+AL) C...Coupling to H+ PARU(178)=-COS(BE-AL)+COS(2D0*BE)*COS(BE+AL)/2D0/(1D0-XW) C...Thirdly, A C...Coupling to d-type quarks PARU(181)=TANB C...Coupling to u-type quarks PARU(182)=1D0/PARU(181) C...Coupling to leptons PARU(183)=PARU(181) PARU(184)=0D0 PARU(185)=0D0 C...Coupling to Z h PARU(186)=COS(BE-AL) C...Coupling to Z H PARU(187)=SIN(BE-AL) PARU(188)=0D0 PARU(189)=0D0 PARU(190)=0D0 C...Finally: H+ C...Coupling to W h PARU(195)=COS(BE-AL) C...Tell that all Higgs couplings have been set. MSTP(4)=1 C...Second part of routine: set decay modes and branching ratios. C...Allow chi10 -> gravitino + gamma or not. KC=PYCOMP(KSUSY1+39) IF( IMSS(11) .NE. 0 ) THEN PMAS(KC,1)=RMSS(21)/1000000000D0 PMAS(KC,2)=0.0001D0 IRPRTY=0 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS ' ELSE PMAS(KC,1)=9999D0 IRPRTY=1 ENDIF C...Loop over sparticle and Higgs species. PMCHI1=PMAS(PYCOMP(KSUSY1+22),1) DO 200 I=1,36 KF=KFSUSY(I) KC=PYCOMP(KF) LKNT=0 C...Sfermion decays. IF(I.LE.24) THEN C...First check to see if sneutrino is lighter than chi10. IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND. & PMAS(KC,1).LT.PMCHI1) THEN ELSE CALL PYSFDC(KF,XLAM,IDLAM,LKNT) ENDIF C...Gluino decays. ELSEIF(I.EQ.25) THEN CALL PYGLUI(KF,XLAM,IDLAM,LKNT) C...Neutralino decays. ELSEIF(I.GE.26.AND.I.LE.29) THEN CALL PYNJDC(KF,XLAM,IDLAM,LKNT) C...chi10 stable or chi10 -> gravitino + gamma. IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN PMAS(KC,2)=1D-6 MDCY(KC,1)=0 MWID(KC)=0 ENDIF C...Chargino decays. ELSEIF(I.GE.30.AND.I.LE.31) THEN CALL PYCJDC(KF,XLAM,IDLAM,LKNT) C...Gravitino is stable. ELSEIF(I.EQ.32) THEN MDCY(KC,1)=0 MWID(KC)=0 C...Higgs decays. ELSEIF(I.GE.33.AND.I.LE.36) THEN C...Calculate decays to non-SUSY particles. CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE) LKNT=0 DO 150 I1=0,100 XLAM(I1)=0D0 150 CONTINUE DO 170 I1=1,MDCY(KC,3) K1=MDCY(KC,2)+I1-1 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR. & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 170 XLAM(I1)=WDTP(I1) XLAM(0)=XLAM(0)+XLAM(I1) DO 160 J1=1,3 IDLAM(I1,J1)=KFDP(K1,J1) 160 CONTINUE LKNT=LKNT+1 170 CONTINUE C...Add the decays to SUSY particles. CALL PYHEXT(KF,XLAM,IDLAM,LKNT) ENDIF C...Set stable particles. IF(LKNT.EQ.0) THEN MDCY(KC,1)=0 MWID(KC)=0 PMAS(KC,2)=1D-6 PMAS(KC,3)=1D-5 PMAS(KC,4)=0D0 C...Store branching ratios in the standard tables. ELSE IDC=MDCY(KC,2)+MDCY(KC,3)-1 DELM=1D6 DO 190 IL=1,LKNT IDCSV=IDC 180 IDC=IDC+1 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2) IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ. & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN BRAT(IDC)=XLAM(IL)/XLAM(0) XMDIF=PMAS(KC,1) IF(MDME(IDC,1).GE.1) THEN XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)- & PMAS(PYCOMP(KFDP(IDC,2)),1) IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF- & PMAS(PYCOMP(KFDP(IDC,3)),1) ENDIF IF(I.LE.32) THEN IF(XMDIF.GE.0D0) THEN DELM=MIN(DELM,XMDIF) ELSE WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF WRITE(MSTU(11),*) ' KF = ',KF WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3) ENDIF ENDIF GOTO 190 ELSEIF(IDC.EQ.IDCSV) THEN WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ', & 'channel not recognized:' WRITE(MSTU(11),*) KF,' -> ',(IDLAM(I,J),J=1,3) GOTO 190 ELSE GOTO 180 ENDIF 190 CONTINUE C...Store width, cutoff and lifetime. PMAS(KC,2)=XLAM(0) IF(PMAS(KC,2).LT.0.1D0*DELM) THEN PMAS(KC,3)=PMAS(KC,2)*10D0 ELSE PMAS(KC,3)=0.95D0*DELM ENDIF IF(PMAS(KC,2).NE.0D0) THEN PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12 ENDIF ENDIF 200 CONTINUE RETURN END C********************************************************************* C...PYAPPS C...Uses approximate analytical formulae to determine the full set of C...MSSM parameters from SUGRA input. C...See M. Drees and S.P. Martin, hep-ph/9504124 SUBROUTINE PYAPPS C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/ XMT=PMAS(6,1) XMZ2=PMAS(23,1)**2 XMW2=PMAS(24,1)**2 TANB=RMSS(5) BETA=ATAN(TANB) XW=PARU(102) XMG=RMSS(1) XMG2=XMG*XMG XM0=RMSS(8) XM02=XM0*XM0 AT=-RMSS(16) RMSS(15)=AT RMSS(17)=AT COSB=COS(BETA) SINB=TANB*COSB DTERM=XMZ2*COS(2D0*BETA) XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM) XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM) RMSS(6)=XMEL RMSS(7)=XMER XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM)) XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM)) XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM)) XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM)) DO 100 I=1,5,2 PMAS(PYCOMP(KSUSY1+I),1)=XMDL PMAS(PYCOMP(KSUSY2+I),1)=XMDR PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR 100 CONTINUE XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA)) IF(XARG.LT.0D0) THEN WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'// & ' FROM THE SUM RULE. ' WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). ' RETURN ELSE XARG=SQRT(XARG) ENDIF DO 110 I=11,15,2 PMAS(PYCOMP(KSUSY1+I),1)=XMEL PMAS(PYCOMP(KSUSY2+I),1)=XMER PMAS(PYCOMP(KSUSY1+I+1),1)=XARG PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0 110 CONTINUE XMNU=XARG RMT=PYRNMT(XMT) XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+ &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG)) RMB=3D0 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+ &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG)) XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0) ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/ &SINB)**2) RMSS(16)=-ATP XMU2=-XM02-0.52D0*XMG2-0.5D0*XMZ2+XTOP/(1D0-1D0/TANB**2) XMA2=(XMNU**2+XMU2-XBOT-XTAU/3D0)/SINB**2 XMU=SIGN(SQRT(XMU2),RMSS(4)) RMSS(4)=XMU RMSS(19)=SQRT(XMA2) ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM IF(ARG.GT.0D0) THEN RMSS(14)=SQRT(ARG) ELSE WRITE(MSTU(11),*) ' RIGHT STAU MASS < 0 ' STOP ENDIF ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM IF(ARG.GT.0D0) THEN RMSS(13)=SQRT(ARG) ELSE WRITE(MSTU(11),*) ' LEFT STAU MASS < 0 ' STOP ENDIF ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0) IF(ARG.GT.0D0) THEN RMSS(10)=SQRT(ARG) ELSE RMSS(10)=-SQRT(-ARG) ENDIF ARG=PYRNMQ(2,-2D0*XTOP/3D0) IF(ARG.GT.0D0) THEN RMSS(12)=SQRT(ARG) ELSE RMSS(12)=-SQRT(-ARG) ENDIF ARG=PYRNMQ(3,-2D0*XBOT/3D0) IF(ARG.GT.0D0) THEN RMSS(11)=SQRT(ARG) ELSE RMSS(11)=-SQRT(-ARG) ENDIF RETURN END C********************************************************************* C...PYRNMQ C...Determines the running mass of quarks. FUNCTION PYRNMQ(ID,DTERM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblock. COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) SAVE /PYMSSM/ C...Local variables. DOUBLE PRECISION PI,R DOUBLE PRECISION TOL DOUBLE PRECISION CI(3) EXTERNAL PYALPS DATA TOL/0.001D0/ DATA PI,R/3.141592654D0,.61803399D0/ DATA CI/0.47D0,0.07D0,0.02D0/ C=1D0-R CA=CI(ID) AG=(0.71D0)**2/4D0/PI AG=RMSS(20) XM0=RMSS(8) XMG=RMSS(1) XM02=XM0*XM0 XMG2=XMG*XMG AS=PYALPS(XM02+6D0*XMG2) CG=8D0/9D0*((AS/AG)**2-1D0) BX=XM02+(CA+CG)*XMG2+DTERM AX=MIN(50D0**2,0.5D0*BX) CX=MAX(2000D0**2,2D0*BX) X0=AX X3=CX IF(ABS(CX-BX).GT.ABS(BX-AX))THEN X1=BX X2=BX+C*(CX-BX) ELSE X2=BX X1=BX-C*(BX-AX) ENDIF AS1=PYALPS(X1) CG=8D0/9D0*((AS1/AG)**2-1D0) F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1) AS2=PYALPS(X2) CG=8D0/9D0*((AS2/AG)**2-1D0) F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2) 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN IF(F2.LT.F1) THEN X0=X1 X1=X2 X2=R*X1+C*X3 F1=F2 AS2=PYALPS(X2) CG=8D0/9D0*((AS2/AG)**2-1D0) F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2) ELSE X3=X2 X2=X1 X1=R*X2+C*X0 F2=F1 AS1=PYALPS(X1) CG=8D0/9D0*((AS1/AG)**2-1D0) F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1) ENDIF GOTO 100 ENDIF IF(F1.LT.F2) THEN PYRNMQ=X1 XMIN=X1 ELSE PYRNMQ=X2 XMIN=X2 ENDIF RETURN END C********************************************************************* C...PYRNMT C...Determines the running mass of the top quark. FUNCTION PYRNMT(XMT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblock. COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) SAVE /PYMSSM/ C...Local variables. DOUBLE PRECISION XMT DOUBLE PRECISION PI,R DOUBLE PRECISION TOL EXTERNAL PYALPS DATA TOL/0.001D0/ DATA PI,R/3.141592654D0,0.61803399D0/ C=1D0-R BX=XMT AX=MIN(50D0,BX*0.5D0) CX=MAX(300D0,2D0*BX) X0=AX X3=CX IF(ABS(CX-BX).GT.ABS(BX-AX))THEN X1=BX X2=BX+C*(CX-BX) ELSE X2=BX X1=BX-C*(BX-AX) ENDIF AS1=PYALPS(X1**2)/PI F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1) AS2=PYALPS(X2**2)/PI F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2) 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN IF(F2.LT.F1) THEN X0=X1 X1=X2 X2=R*X1+C*X3 F1=F2 AS2=PYALPS(X2**2)/PI F2=ABS(XMT/(1D0+4D0/3D0*AS2+11D0*AS2**2)-X2) ELSE X3=X2 X2=X1 X1=R*X2+C*X0 F2=F1 AS1=PYALPS(X1**2)/PI F1=ABS(XMT/(1D0+4D0/3D0*AS1+11D0*AS1**2)-X1) ENDIF GOTO 100 ENDIF IF(F1.LT.F2) THEN PYRNMT=X1 XMIN=X1 ELSE PYRNMT=X2 XMIN=X2 ENDIF RETURN END C********************************************************************* C...PYTHRG C...Calculates the mass eigenstates of the third generation sfermions. C...Created: 5-31-96 SUBROUTINE PYTHRG C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ C...Local variables. DOUBLE PRECISION BETA DOUBLE PRECISION PYRNMT DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2) DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL DOUBLE PRECISION SIN2T,COS2T,TWOT,ATR,AMQR,XXX,YYY,AMQL INTEGER ID1(3),ID2(3),ID3(3),ID4(3) INTEGER IF,I,J,II,JJ,IT,L LOGICAL DTERM DATA SMALL/1D-3/ DATA ID1/10,10,13/ DATA ID2/5,6,15/ DATA ID3/15,16,17/ DATA ID4/11,12,14/ DATA DTERM/.TRUE./ XMZ2=PMAS(23,1)**2 XMW2=PMAS(24,1)**2 TANB=RMSS(5) XMU=-RMSS(4) BETA=ATAN(TANB) COS2B=COS(2D0*BETA) C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS IOPT=IMSS(5) IF(IOPT.EQ.1) THEN CTT=RMSS(27) CTT2=CTT**2 STT2=1D0-CTT2 STT=SQRT(STT2) XM12=RMSS(12)**2 XM22=RMSS(10)**2 XMQL2=CTT2*XM12+STT2*XM22 XMQR2=STT2*XM12+CTT2*XM22 XMFR=PMAS(6,1) XMF2=PYRNMT(XMFR)**2 ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2) ATMT=SQRT(XMF2)*(ATOP+XMU/TANB) XTEST=(XMQL2-XMQR2)*(CTT2-STT2) IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN STT=-STT ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2) ENDIF RMSS(16)=ATOP C......SUBTRACT OUT D-TERM AND FERMION MASS XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0 IF(XMQL2.GE.0D0) THEN RMSS(10)=SQRT(XMQL2) ELSE RMSS(10)=-SQRT(-XMQL2) ENDIF IF(XMQR2.GE.0D0) THEN RMSS(12)=SQRT(XMQR2) ELSE RMSS(12)=-SQRT(-XMQR2) ENDIF C SAME FOR SBOTTOM SQUARK CTT=RMSS(26) CTT2=CTT**2 STT2=1D0-CTT2 STT=MAX(SQRT(STT2),1D-6) XMF=3D00 XMF2=XMF**2 XM12=RMSS(11)**2 XMQL2=RMSS(10)**2-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2 IF(ABS(CTT).EQ.1D0) THEN XM22=XM12 XM12=XMQL2 XMQR2=XM22 ELSEIF(CTT.EQ.0D0) THEN XM22=XMQL2 XMQR2=XM12 ELSE XM22=(XMQL2-CTT2*XM12)/STT2 XMQR2=STT2*XM12+CTT2*XM22 ENDIF ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2) ATMT=SQRT(XMF2)*(ABOT+XMU*TANB) XTEST=(XMQL2-XMQR2)*(CTT2-STT2) IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN STT=-STT ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2) ENDIF RMSS(15)=ABOT C......SUBTRACT OUT D-TERM AND FERMION MASS XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2 IF(XMQR2.GE.0D0) THEN RMSS(11)=SQRT(XMQR2) ELSE RMSS(11)=-SQRT(-XMQR2) ENDIF ENDIF DO 170 L=1,3 AMQL=RMSS(ID1(L)) IF(AMQL.LT.0D0) THEN XMQL2=-AMQL**2 ELSE XMQL2=AMQL**2 ENDIF IF=ID2(L) XMF=PMAS(IF,1) IF(L.EQ.1) XMF=3D0 IF(L.EQ.2) XMF=PYRNMT(XMF) XMF2=XMF**2 ATR=RMSS(ID3(L)) AMQR=RMSS(ID4(L)) IF(AMQR.LT.0D0) THEN XMQR2=-AMQR**2 ELSE XMQR2=AMQR**2 ENDIF AM2(1,1)=XMQL2+XMF2 AM2(2,2)=XMQR2+XMF2 IF(DTERM) THEN IF(L.EQ.1) THEN AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0 AM2(1,2)=XMF*(ATR+XMU*TANB) ELSEIF(L.EQ.2) THEN AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0 AM2(1,2)=XMF*(ATR+XMU/TANB) ELSEIF(L.EQ.3) THEN IF(IMSS(8).EQ.1) THEN AM2(1,1)=RMSS(6)**2 AM2(2,2)=RMSS(7)**2 AM2(1,2)=0D0 RMSS(13)=RMSS(6) RMSS(14)=RMSS(7) ELSE AM2(1,2)=XMF*(ATR+XMU*TANB) ENDIF ENDIF ENDIF AM2(2,1)=AM2(1,2) SAME=0.5D0*(AM2(1,1)+AM2(2,2)) DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1)) XMF12=SAME-DIFF XMF22=SAME+DIFF IF(XMF12.LT.0D0) THEN WRITE(MSTU(11),*) ' NEGATIVE**2 MASS FOR SFERMION ' STOP ENDIF IT=0 IF(XMF22-XMF12.GT.0D0) THEN RT(1,1) = SQRT((XMF22-AM2(1,1))/(XMF22-XMF12)) RT(2,2) = RT(1,1) RT(1,2) = -SIGN(SQRT(1D0-RT(1,1)**2),AM2(1,2)/(XMF22-XMF12)) RT(2,1) = -RT(1,2) ELSE RT(1,1) = 1D0 RT(2,2) = RT(1,1) RT(1,2) = 0D0 RT(2,1) = -RT(1,2) ENDIF 100 CONTINUE IT=IT+1 DO 140 I=1,2 DO 130 JJ=1,2 DI(I,JJ)=0D0 DO 120 II=1,2 DO 110 J=1,2 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II) 110 CONTINUE 120 CONTINUE 130 CONTINUE 140 CONTINUE IF(DI(1,1).GT.DI(2,2)) THEN WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION ' WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22) WRITE(MSTU(11),*) AM2 WRITE(MSTU(11),*) DI WRITE(MSTU(11),*) RT DI(1,1)=-RT(2,1) DI(2,2)=RT(1,2) DI(1,2)=-RT(2,2) DI(2,1)=RT(1,1) DO 160 I=1,2 DO 150 J=1,2 RT(I,J)=DI(I,J) 150 CONTINUE 160 CONTINUE GOTO 100 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'// & ' OFF DIAGONAL ELEMENTS ' WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22) WRITE(MSTU(11),*) DI WRITE(MSTU(11),*) ' ROTATION = ',RT C...STOP ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'// & ' NEGATIVE MASSES ' STOP ENDIF PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12) PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22) SFMIX(IF,1)=RT(1,1) SFMIX(IF,2)=RT(1,2) SFMIX(IF,3)=RT(2,1) SFMIX(IF,4)=RT(2,2) 170 CONTINUE RETURN END C********************************************************************* C...PYINOM C...Finds the mass eigenstates and mixing matrices for neutralinos C...and charginos. SUBROUTINE PYINOM C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ C...Local variables. DOUBLE PRECISION XMW,XMZ DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4) DOUBLE PRECISION ZP(4,4) DOUBLE PRECISION DETX,XI(2,2) DOUBLE PRECISION XXX,YYY,XMH,XML DOUBLE PRECISION COSW,SINW DOUBLE PRECISION XMU DOUBLE PRECISION TERMB,TERMC,DISCR,XMH2,XML2 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW DOUBLE PRECISION XM1,XM2,XM3,BETA DOUBLE PRECISION Q2,AEM,A1,A2,A3,AQ,RM1,RM2 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1 DOUBLE PRECISION PYALPS,PYALEM DOUBLE PRECISION PYRNM3 INTEGER IERR,INDEX(4),I,J,K,L,IOPT,ILR,KFNCHI(4) DATA KFNCHI/1000022,1000023,1000025,1000035/ IOPT=IMSS(2) IF(IMSS(1).EQ.2) THEN IOPT=1 ENDIF C...M1, M2, AND M3 ARE INDEPENDENT IF(IOPT.EQ.0) THEN XM1=RMSS(1) XM2=RMSS(2) XM3=RMSS(3) ELSEIF(IOPT.GE.1) THEN Q2=PMAS(23,1)**2 AEM=PYALEM(Q2) A2=AEM/PARU(102) A1=AEM/(1D0-PARU(102)) XM1=RMSS(1) XM2=RMSS(2) IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0 IF(IOPT.EQ.1) THEN XM2=XM1*A2/A1*3D0/5D0 ELSEIF(IOPT.EQ.3) THEN XM1=XM2*5D0/3D0*A1/A2 ENDIF XM3=PYRNM3(XM2/A2) IF(XM3.LE.0D0) THEN WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3 STOP ENDIF ENDIF C...GLUINO MASS IF(IMSS(3).EQ.1) THEN PMAS(PYCOMP(KSUSY1+21),1)=XM3 ELSE AQ=0D0 DO 110 I=1,4 DO 100 ILR=1,2 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0) & +(1D0-RM1)**2*LOG(ABS(1D0-RM1))) 100 CONTINUE 110 CONTINUE DO 130 I=5,6 DO 120 ILR=1,2 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2 RM2=PMAS(I,1)**2/XM3**2 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2 IF(ARG.GE.0D0) THEN X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG)) AX0=ABS(X0) X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG)) AX1=ABS(X1) IF(X0.EQ.1D0) THEN AT=-1D0 BT=0.25D0 ELSEIF(X0.EQ.0D0) THEN AT=0D0 BT=-0.25D0 ELSE AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+ & 0.5D0*X0**2*LOG(AX0) BT=(-1D0-2D0*X0)/4D0 ENDIF IF(X1.EQ.1D0) THEN AT=-1D0+AT BT=0.25D0+BT ELSEIF(X1.EQ.0D0) THEN AT=0D0+AT BT=-0.25D0+BT ELSE AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0* & X1**2*LOG(AX1)+AT BT=(-1D0-2D0*X1)/4D0+BT ENDIF AQ=AQ+AT+BT ELSE X0=0.5D0*(1D0+RM2-RM1) Y0=-0.5D0*SQRT(-ARG) AMGX0=SQRT(X0**2+Y0**2) AM1X0=SQRT((1D0-X0)**2+Y0**2) ARGX0=ATAN2(-X0,-Y0) AR1X0=ATAN2(1D0-X0,Y0) X1=X0 Y1=-Y0 AMGX1=AMGX0 AM1X1=AM1X0 ARGX1=ATAN2(-X1,-Y1) AR1X1=ATAN2(1D0-X1,Y1) AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2) & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0) BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 ) AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2) & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1) BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 ) AQ=AQ+AT+BT ENDIF 120 CONTINUE 130 CONTINUE PMAS(PYCOMP(KSUSY1+21),1)=XM3*(1D0+PYALPS(XM3**2)/(2D0*PARU(2))* & (15D0+AQ)) ENDIF C...NEUTRALINO MASSES XMZ=PMAS(23,1) XMW=PMAS(24,1) XMU=RMSS(4) SINW=SQRT(PARU(102)) COSW=SQRT(1D0-PARU(102)) TANB=RMSS(5) BETA=ATAN(TANB) COSB=COS(BETA) SINB=TANB*COSB AR(1,1) = XM1 AR(2,2) = XM2 AR(3,3) = 0D0 AR(4,4) = 0D0 AR(1,2) = 0D0 AR(2,1) = 0D0 AR(1,3) = -XMZ*SINW*COSB AR(3,1) = AR(1,3) AR(1,4) = XMZ*SINW*SINB AR(4,1) = AR(1,4) AR(2,3) = XMZ*COSW*COSB AR(3,2) = AR(2,3) AR(2,4) = -XMZ*COSW*SINB AR(4,2) = AR(2,4) AR(3,4) = -XMU AR(4,3) = -XMU CALL PYEIG4(AR,WR,ZR) DO 150 I=1,4 SMZ(I)=WR(I) PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I)) DO 140 J=1,4 ZMIX(I,J)=ZR(I,J) IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0 140 CONTINUE 150 CONTINUE C...CHARGINO MASSES AR(1,1) = XM2 AR(2,2) = XMU AR(1,2) = SQRT(2D0)*XMW*SINB AR(2,1) = SQRT(2D0)*XMW*COSB TERMB=AR(1,1)**2+AR(2,2)**2+AR(1,2)**2+AR(2,1)**2 TERMC=(AR(1,1)**2-AR(2,2)**2)**2+(AR(1,2)**2-AR(2,1)**2)**2 TERMC=TERMC+2D0*(AR(1,1)**2+AR(2,2)**2)* &(AR(1,2)**2+AR(2,1)**2)+ &8D0*AR(1,1)*AR(2,2)*AR(1,2)*AR(2,1) DISCR=TERMC IF(DISCR.LT.0D0) THEN WRITE(MSTU(11),*) ' PROBLEM WITH DISCR ' ELSE DISCR=SQRT(DISCR) ENDIF XML2=0.5D0*(TERMB-DISCR) XMH2=0.5D0*(TERMB+DISCR) XML=SQRT(XML2) XMH=SQRT(XMH2) PMAS(PYCOMP(KSUSY1+24),1)=XML PMAS(PYCOMP(KSUSY1+37),1)=XMH SMW(1)=XML SMW(2)=XMH XXX=AR(1,1)**2+AR(2,1)**2 YYY=AR(1,1)*AR(1,2)+AR(2,2)*AR(2,1) VMIX(2,2) = YYY/SQRT(YYY**2+(XML2-XXX)**2) VMIX(1,1) = SIGN(VMIX(2,2),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2) VMIX(2,1) = -(XML2-XXX)/SQRT(YYY**2+(XML2-XXX)**2) VMIX(1,2) = -SIGN(VMIX(2,1),AR(1,1)*AR(2,2)-0.5D0*AR(1,2)**2) ZR(1,1) = XML ZR(1,2) = 0D0 ZR(2,1) = 0D0 ZR(2,2) = XMH DETX = AR(1,1)*AR(2,2)-AR(1,2)*AR(2,1) XI(1,1) = AR(2,2)/DETX XI(2,2) = AR(1,1)/DETX XI(1,2) = -AR(1,2)/DETX XI(2,1) = -AR(2,1)/DETX DO 190 I=1,2 DO 180 J=1,2 UMIX(I,J)=0D0 DO 170 K=1,2 DO 160 L=1,2 UMIX(I,J)=UMIX(I,J)+ZR(I,K)*VMIX(K,L)*XI(L,J) 160 CONTINUE 170 CONTINUE 180 CONTINUE 190 CONTINUE RETURN END C********************************************************************* C...PYRNM3 C...Calculates the running of M3, the SU(3) gluino mass parameter. FUNCTION PYRNM3(RGUT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DOUBLE PRECISION PI,R DOUBLE PRECISION TOL EXTERNAL PYALPS DATA TOL/0.001D0/ DATA PI,R/3.141592654D0,0.61803399D0/ C=1D0-R BX=RGUT*PYALPS(RGUT**2) AX=MIN(50D0,BX*0.5D0) CX=MAX(2000D0,2D0*BX) X0=AX X3=CX IF(ABS(CX-BX).GT.ABS(BX-AX))THEN X1=BX X2=BX+C*(CX-BX) ELSE X2=BX X1=BX-C*(BX-AX) ENDIF AS1=PYALPS(X1**2) F1=ABS(X1-RGUT*AS1) AS2=PYALPS(X2**2) F2=ABS(X2-RGUT*AS2) 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN IF(F2.LT.F1) THEN X0=X1 X1=X2 X2=R*X1+C*X3 F1=F2 AS2=PYALPS(X2**2) F2=ABS(X2-RGUT*AS2) ELSE X3=X2 X2=X1 X1=R*X2+C*X0 F2=F1 AS1=PYALPS(X1**2) F1=ABS(X1-RGUT*AS1) ENDIF GOTO 100 ENDIF IF(F1.LT.F2) THEN PYRNM3=X1 XMIN=X1 ELSE PYRNM3=X2 XMIN=X2 ENDIF RETURN END C********************************************************************* C...PYEIG4 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix. C...Specific application: mixing in neutralino sector. SUBROUTINE PYEIG4(A,W,Z) IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Arrays: in call and local. DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4) C...Coefficients of fourth-degree equation from matrix. C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0. B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4)) B2=0D0 DO 110 I=1,3 DO 100 J=I+1,4 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I) 100 CONTINUE 110 CONTINUE B1=0D0 B0=0D0 DO 120 I=1,4 I1=MOD(I,4)+1 I2=MOD(I+1,4)+1 I3=MOD(I+2,4)+1 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+ & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))- & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I) B0=B0+(-1D0)**(I+1)*A(1,I)*( & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+ & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+ & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1))) 120 CONTINUE C...Coefficients of third-degree equation needed for C...separation into two second-degree equations. C...u**3 + c2 * u**2 + c1 * u + c0 = 0. C2=-B2 C1=B1*B3-4D0*B0 C0=-B1**2-B0*B3**2+4D0*B0*B2 CQ=C1/3D0-C2**2/9D0 CR=C1*C2/6D0-C0/2D0-C2**3/27D0 CQR=CQ**3+CR**2 C...Cases with one or three real roots. IF(CQR.GE.0D0) THEN S1=(CR+SQRT(CQR))**(1D0/3D0) S2=(CR-SQRT(CQR))**(1D0/3D0) U=S1+S2-C2/3D0 ELSE SABS=SQRT(-CQ) THE=ACOS(CR/SABS**3)/3D0 SRE=SABS*COS(THE) U=2D0*SRE-C2/3D0 ENDIF C...Find and solve two second-degree equations. P1=B3/2D0-SQRT(B3**2/4D0+U-B2) P2=B3/2D0+SQRT(B3**2/4D0+U-B2) Q1=U/2D0+SQRT(U**2/4D0-B0) Q2=U/2D0-SQRT(U**2/4D0-B0) IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN QSAV=Q1 Q1=Q2 Q2=QSAV ENDIF X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1) X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1) X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2) X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2) C...Order eigenvalues in asceding mass. W(1)=X(1) DO 150 I1=2,4 DO 130 I2=I1-1,1,-1 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140 W(I2+1)=W(I2) 130 CONTINUE 140 W(I2+1)=X(I1) 150 CONTINUE C...Find equation system for eigenvectors. DO 250 I=1,4 DO 170 J1=1,4 D(J1,J1)=A(J1,J1)-W(I) DO 160 J2=J1+1,4 D(J1,J2)=A(J1,J2) D(J2,J1)=A(J2,J1) 160 CONTINUE 170 CONTINUE C...Find largest element in matrix. DAMAX=0D0 DO 190 J1=1,4 DO 180 J2=1,4 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180 JA=J1 JB=J2 DAMAX=ABS(D(J1,J2)) 180 CONTINUE 190 CONTINUE C...Subtract others by multiple of row selected above. DAMAX=0D0 DO 210 J3=JA+1,JA+3 J1=J3-4*((J3-1)/4) RL=D(J1,JB)/D(JA,JB) DO 200 J2=1,4 D(J1,J2)=D(J1,J2)-RL*D(JA,J2) IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200 JC=J1 JD=J2 DAMAX=ABS(D(J1,J2)) 200 CONTINUE 210 CONTINUE C...Do one more subtraction of a row. DAMAX=0D0 DO 230 J3=JC+1,JC+3 J1=J3-4*((J3-1)/4) IF(J1.EQ.JA) GOTO 230 RL=D(J1,JD)/D(JC,JD) DO 220 J2=1,4 IF(J2.EQ.JB) GOTO 220 D(J1,J2)=D(J1,J2)-RL*D(JC,J2) IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220 JE=J1 DAMAX=ABS(D(J1,J2)) 220 CONTINUE 230 CONTINUE C...Construct unnormalized eigenvector. JF1=JD+1-4*(JD/4) JF2=JD+2-4*((JD+1)/4) IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4) IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4) E(JF1)=-D(JE,JF2) E(JF2)=D(JE,JF1) E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD) E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/ & D(JA,JB) C...Normalize and fill in final array. EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2) SGN=(-1D0)**INT(PYR(0)+0.5D0) DO 240 J=1,4 Z(I,J)=SGN*E(J)/EA 240 CONTINUE 250 CONTINUE RETURN END C********************************************************************* C...PYHGGM C...Determines the Higgs boson mass spectrum using several inputs. SUBROUTINE PYHGGM(ALPHA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/ C...Local variables. DOUBLE PRECISION AT,AB,XMU,TANB,XM32,XMT2 DOUBLE PRECISION ALPHA INTEGER I,J,IHOPT,II,JJ,IT DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2 IHOPT=IMSS(4) IF(IHOPT.EQ.2) THEN ALPHA=RMSS(18) RETURN ENDIF AT=RMSS(16) AB=RMSS(15) XMU=RMSS(4) TANB=RMSS(5) DMA=RMSS(19) DTANB=TANB DMQ=RMSS(10) DMUR=RMSS(12) DMDR=RMSS(11) DMTOP=PMAS(6,1) DMC=PMAS(PYCOMP(KSUSY1+37),1) DAU=AT DAD=AB DMU=XMU IF(IHOPT.EQ.0) THEN CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM, & DMHCH,DSA,DCA,DTANBA) ELSEIF(IHOPT.EQ.1) THEN CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM, & DMHCH,DSA,DCA,DTANBA) CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU, & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA, & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA) DMH=DMHP DHM=DHMP DMA=DAMP IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.1D-1) THEN WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM ' WRITE(MSTU(11),*) ' STOP1 MASSES = ', & PMAS(PYCOMP(1000006),1),DSTOP2 ENDIF IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.1D-1) THEN WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM ' WRITE(MSTU(11),*) ' STOP2 MASSES = ', & PMAS(PYCOMP(2000006),1),DSTOP1 ENDIF IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.1D-1) THEN WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM ' WRITE(MSTU(11),*) ' SBOT1 MASSES = ', & PMAS(PYCOMP(1000005),1),DSBOT2 ENDIF IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.1D-1) THEN WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM ' WRITE(MSTU(11),*) ' SBOT2 MASSES = ', & PMAS(PYCOMP(2000005),1),DSBOT1 ENDIF ENDIF ALPHA=ACOS(DCA) PMAS(25,1)=DMH PMAS(35,1)=DHM PMAS(36,1)=DMA PMAS(37,1)=DMHCH RETURN END C********************************************************************* C...PYSUBH C...This routine computes the renormalization group improved C...values of Higgs masses and couplings in the MSSM. C...Program based on the work by M. Carena, J.R. Espinosa, c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU C...All masses in GeV units. MA is the CP-odd Higgs mass, C...MTOP is the physical top mass, MQ and MUR are the soft C...supersymmetry breaking mass parameters of left handed C...and right handed stops respectively, AU and AD are the C...stop and sbottom trilinear soft breaking terms, C...respectively, and MU is the supersymmetric C...Higgs mass parameter. We use the conventions from C...the physics report of Haber and Kane: left right C...stop mixing term proportional to (AU - MU/TANB) C...We use as input TANB defined at the scale MTOP C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA C...where MH and HM are the lightest and heaviest CP-even C...Higgs masses, MHCH is the charged Higgs mass and C...ALPHA is the Higgs mixing angle C...TANBA is the angle TANB at the CP-odd Higgs mass scale C...Range of validity: C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and C...are the sbottom mass eigenvalues, respectively. This C...range automatically excludes the existence of tachyons. C...For the charged Higgs mass computation, the method is C...valid if C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2 C...where M_SUSY**2 is the average of the squared stop mass C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom C...masses have been assumed to be of order of the stop ones C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM, &XMHCH,SA,CA,TANBA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C...Local variables. DOUBLE PRECISION PYALEM,PYALPS DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM DOUBLE PRECISION XMHCH,SA,CA DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI DOUBLE PRECISION Q02 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2 DOUBLE PRECISION COS2BT,AU2,XMU2,XMZ,XMS3 XMZ = PMAS(23,1) Q02=XMZ**2 AEM=PYALEM(Q02) ALP1=AEM/(1D0-PARU(102)) ALP2=AEM/PARU(102) ALPH3Z=PYALPS(Q02) ALP1 = 0.0101D0 ALP2 = 0.0337D0 ALPH3Z = 0.12D0 V = 174.1D0 PI = PARU(1) TANBA = TANB TANBT = TANB C...MBOTTOM(MTOP) = 3. GEV XMB = 3D0 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z* &LOG(XMTOP**2/XMZ**2)) C...RMTOP= RUNNING TOP QUARK MASS RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI) XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0 T = LOG(XMS**2/XMTOP**2) SINB = TANB/((1D0 + TANB**2)**0.5D0) COSB = SINB/TANB C...IF(MA.LE.XMTOP) TANBA = TANBT IF(XMA.GT.XMTOP) &TANBA = TANBT*(1D0-3D0/32D0/PI**2* &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)* &LOG(XMA**2/XMTOP**2)) SINBT = TANBT/SQRT(1D0 + TANBT**2) COSBT = 1D0/SQRT(1D0 + TANBT**2) COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0) G1 = SQRT(ALP1*4D0*PI) G2 = SQRT(ALP2*4D0*PI) G3 = SQRT(ALP3*4D0*PI) HU = RMTOP/V/SINBT HD = XMB/V/COSBT HU2=HU*HU HD2=HD*HD HU4=HU2*HU2 HD4=HD2*HD2 AU2=AU**2 AD2=AD**2 XMS2=XMS**2 XMS3=XMS**3 XMS4=XMS2*XMS2 XMU2=XMU*XMU PI2=PI*PI XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2) XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2) AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4 &+ 3D0*(AU + AD)**2/XMS2)/6D0 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2) &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2) &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2 &- 16D0*G3**2) *T/16D0/PI2) XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2) &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2) &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2 &- 16D0*G3**2) *T/16D0/PI2) XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0* &(HU2 + HD2)*T/16D0/PI2) &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2) &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/ &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0 &- 16D0*G3**2) *T/16D0/PI2) &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/ &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2 &- 16D0*G3**2) *T/16D0/PI2) XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2) &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2) &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/ &XMS4)* &(1+ (6D0*HU2 -2D0* HD2 &- 16D0*G3**2) *T/16D0/PI2) &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/ &XMS4)* &(1+ (6D0*HD2 -2D0* HU2/2D0 &- 16D0*G3**2) *T/16D0/PI2) XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) * &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2) &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) * &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2) XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) * &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2) &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) * &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2) XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) * &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2) &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) * &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2) TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 + &2D0* XLAM6*SINBT*COSBT &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT &+ XLAM5*COSBT**2) DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) + &XLAM6*COSBT**2 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 + &2D0* XLAM6* COSBT*SINBT &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 * &((XLAM1* COSBT**2 +2D0* &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 + &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2) &*SINBT**2 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3 &+ XLAM4) + XLAM6*COSBT**2 &+ XLAM7* SINBT**2)) XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0 XHM = SQRT(XHM2) XMH = SQRT(XMH2) XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2 XMHCH = SQRT(XMHCH2) SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) - &((2D0*V**2*(XLAM1* COSBT**2 + 2D0* &XLAM6* COSBT*SINBT &+ XLAM5*SINBT**2) + XMA**2*SINBT**2) &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/ &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) + &XLAM6*COSBT**2 + XLAM7* SINBT**2) - &XMA**2*SINBT*COSBT))/2D0**0.5D0/ &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)* &(((TRM2**2 - 4D0* DETM2)**0.5D0) - &((2D0*V**2*(XLAM1* COSBT**2 + 2D0* &XLAM6* COSBT*SINBT &+ XLAM5*SINBT**2) + XMA**2*SINBT**2) &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))) SA = -SINALP CA = -COSALP 100 CONTINUE RETURN END C********************************************************************* C...PYPOLE C...This subroutine computes the CP-even higgs and CP-odd pole c...Higgs masses and mixing angles. C...Program based on the work by M. Carena, M. Quiros C...and C.E.M. Wagner, "Effective potential methods and C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP, C...AT,AB,MU C...where MCHI is the largest chargino mass, MA is the running C...CP-odd higgs mass, TANB is the value of the ratio of vacuum C...expectaion values at the scale MTOP, MQ is the third generation C...left handed squark mass parameter, MUR is the third generation C...right handed stop mass parameter, MDR is the third generation C...right handed sbottom mass parameter, MTOP is the pole top quark C...mass; AT,AB are the soft supersymmetry breaking trilinear C...couplings of the stop and sbottoms, respectively, and MU is the C...supersymmetric mass parameter C...The parameter IHIGGS=0,1,2,3 corresponds to the c...number of Higgses whose pole mass is computed c...by the subroutine PYVACU(...). If IHIGGS=0 only running c...masses are given, what makes the running of the program c...much faster and it is quite generally a good approximation c...(for a theoretical discussion see ref. below). c...If IHIGGS=1, only the pole c...mass for H is computed. If IHIGGS=2, then h and H, and c...if IHIGGS=3, then h,H,A polarizations are computed C...Output: MH and MHP which are the lightest CP-even Higgs running C...and pole masses, respectively; HM and HMP are the heaviest CP-even C...Higgs running and pole masses, repectively; SA and CA are the C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is C...the value of TANB at the CP-odd Higgs mass scale C...This subroutine makes use of CERN library subroutine C...integration package, which makes the computation of the C...pole Higgs masses somewhat faster. We thank P. Janot for this C...improvement. Those who are not able to call the CERN C...libraries, please use the subroutine SUBHPOLE2.F, which C...although somewhat slower, gives identical results SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU, &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP CALL PYVACU(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU, &XMH,XMHP,HM,HMP,AMP,STOP1,STOP2,SBOT1,SBOT2, &SA,CA,STOP1W,STOP2W,TANBA) SINB = TANB/(TANB**2+1D0)**0.5D0 COSB = 1D0/(TANB**2+1D0)**0.5D0 SINBMA = SINB*CA - COSB*SA RETURN END C********************************************************************* C...PYVACU C...Computes Higgs masses and mixing angles, see PYPOLE above. SUBROUTINE PYVACU(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR, &XMT,AT,AB,XMU,XMH,XMHP,HM,HMP,AMP,STOP1,STOP2, &SBOT1,SBOT2,SA,CA,STOP1W,STOP2W,TANBA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) C...Parameters. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2), &SSBOT2(2),B(2,2),COUPB(2,2), &HCOUPT(2,2),HCOUPB(2,2), &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3) DELTA(1,1) = 1D0 DELTA(2,2) = 1D0 DELTA(1,2) = 0D0 DELTA(2,1) = 0D0 V = 174.1D0 XMZ=91.18D0 PI=3.14159D0 ALP3Z=0.12D0 ALP3=1D0/(1D0/ALP3Z+23D0/6D0/PI*LOG(XMT/XMZ)) C RXMT = XMT/(1D0+4*ALP3/3D0/PI) RXMT = PYRNMT(XMT) HT = RXMT /V CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB, &XMU,XMH,HM,SA,CA,TANBA) SINB = TANB/(TANB**2+1D0)**0.5D0 COSB = 1D0/(TANB**2+1D0)**0.5D0 COS2B = SINB**2 - COSB**2 SINBPA = SINB*CA + COSB*SA COSBPA = COSB*CA - SINB*SA RMBOT = 3D0 XMQ2 = XMQ**2 XMUR2 = XMUR**2 IF(XMUR.LT.0D0) XMUR2=-XMUR2 XMDR2 = XMDR**2 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B IF(XMST11.LT.0D0) GOTO 500 IF(XMST22.LT.0D0) GOTO 500 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B IF(XMSB11.LT.0D0) GOTO 500 IF(XMSB22.LT.0D0) GOTO 500 WMST11 = RXMT**2 + XMQ2 WMST22 = RXMT**2 + XMUR2 XMST12 = RXMT*(AT - XMU/TANB) XMSB12 = RMBOT*(AB - XMU*TANB) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C...STOP EIGENVALUES CALCULATION CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC STOP12 = 0.5D0*(XMST11+XMST22) + &0.5D0*((XMST11+XMST22)**2 - &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0 STOP22 = 0.5D0*(XMST11+XMST22) - &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 - &XMST12**2))**0.5D0 IF(STOP22.LT.0D0) GOTO 500 SSTOP2(1) = STOP12 SSTOP2(2) = STOP22 STOP1 = STOP12**0.5D0 STOP2 = STOP22**0.5D0 STOP1W = STOP1 STOP2W = STOP2 IF(XMST12.EQ.0D0) XST11 = 1D0 IF(XMST12.EQ.0D0) XST12 = 0D0 IF(XMST12.EQ.0D0) XST21 = 0D0 IF(XMST12.EQ.0D0) XST22 = 1D0 IF(XMST12.EQ.0D0) GOTO 110 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0 110 T(1,1) = XST11 T(2,2) = XST22 T(1,2) = XST12 T(2,1) = XST21 SBOT12 = 0.5D0*(XMSB11+XMSB22) + &0.5D0*((XMSB11+XMSB22)**2 - &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0 SBOT22 = 0.5D0*(XMSB11+XMSB22) - &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 - &XMSB12**2))**0.5D0 IF(SBOT22.LT.0D0) GOTO 500 SBOT1 = SBOT12**0.5D0 SBOT2 = SBOT22**0.5D0 SSBOT2(1) = SBOT12 SSBOT2(2) = SBOT22 IF(XMSB12.EQ.0D0) XSB11 = 1D0 IF(XMSB12.EQ.0D0) XSB12 = 0D0 IF(XMSB12.EQ.0D0) XSB21 = 0D0 IF(XMSB12.EQ.0D0) XSB22 = 1D0 IF(XMSB12.EQ.0D0) GOTO 130 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0 130 B(1,1) = XSB11 B(2,2) = XSB22 B(1,2) = XSB12 B(2,1) = XSB21 SINT = 0.2320D0 SQR = 2D0**0.5D0 VP = 174.1D0*SQR CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C...STARTING OF LIGHT HIGGS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IF(IHIGGS.EQ.0) GOTO 490 DO 150 I = 1,2 DO 140 J = 1,2 COUPT(I,J) = & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) + & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J)) & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J) & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) + & T(1,J)*T(2,I)) 140 CONTINUE 150 CONTINUE DO 170 I = 1,2 DO 160 J = 1,2 COUPB(I,J) = & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) + & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J)) & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J) & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) + & B(1,J)*B(2,I)) 160 CONTINUE 170 CONTINUE PRUN = XMH EPS = 1D-4*PRUN ITER = 0 180 ITER = ITER + 1 DO 230 I3 = 1,3 PR(I3)=PRUN+(I3-2)*EPS/2 P2=PR(I3)**2 POLT = 0D0 DO 200 I = 1,2 DO 190 J = 1,2 POLT = POLT + COUPT(I,J)**2*3D0* & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2 190 CONTINUE 200 CONTINUE POLB = 0D0 DO 220 I = 1,2 DO 210 J = 1,2 POLB = POLB + COUPB(I,J)**2*3D0* & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2 210 CONTINUE 220 CONTINUE RXMT2 = RXMT**2 XMT2=XMT**2 POLTT = & 3D0*RXMT**2/8D0/PI**2/ V **2* & CA**2/SINB**2 * & (-2D0*XMT**2+0.5D0*P2)* & PYFINT(P2,XMT2,XMT2) POL = POLT + POLB + POLTT POLAR(I3) = P2 - XMH**2 - POL 230 CONTINUE DERIV = (POLAR(3)-POLAR(1))/EPS DRUN = - POLAR(2)/DERIV PRUN = PRUN + DRUN P2 = PRUN**2 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 240 GOTO 180 240 CONTINUE XMHP = P2**0.5D0 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C...END OF LIGHT HIGGS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 250 IF(IHIGGS.EQ.1) GOTO 490 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C... STARTING OF HEAVY HIGGS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC DO 270 I = 1,2 DO 260 J = 1,2 HCOUPT(I,J) = & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) + & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J)) & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J) & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) + & T(1,J)*T(2,I)) 260 CONTINUE 270 CONTINUE DO 290 I = 1,2 DO 280 J = 1,2 HCOUPB(I,J) = & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) + & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J)) & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J) & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) + & B(1,J)*B(2,I)) HCOUPB(I,J)=0D0 280 CONTINUE 290 CONTINUE PRUN = HM EPS = 1D-4*PRUN ITER = 0 300 ITER = ITER + 1 DO 350 I3 = 1,3 PR(I3)=PRUN+(I3-2)*EPS/2 HP2=PR(I3)**2 HPOLT = 0D0 DO 320 I = 1,2 DO 310 J = 1,2 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0* & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2 310 CONTINUE 320 CONTINUE HPOLB = 0D0 DO 340 I = 1,2 DO 330 J = 1,2 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0* & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2 330 CONTINUE 340 CONTINUE RXMT2 = RXMT**2 XMT2 = XMT**2 HPOLTT = & 3D0*RXMT**2/8D0/PI**2/ V **2* & SA**2/SINB**2 * & (-2D0*XMT**2+0.5D0*HP2)* & PYFINT(HP2,XMT2,XMT2) HPOL = HPOLT + HPOLB + HPOLTT POLAR(I3) =HP2-HM**2-HPOL 350 CONTINUE DERIV = (POLAR(3)-POLAR(1))/EPS DRUN = - POLAR(2)/DERIV PRUN = PRUN + DRUN HP2 = PRUN**2 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 360 GOTO 300 360 CONTINUE 370 CONTINUE HMP = HP2**0.5D0 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C... END OF HEAVY HIGGS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IF(IHIGGS.EQ.2) GOTO 490 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C...BEGINNING OF PSEUDOSCALAR HIGGS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC DO 390 I = 1,2 DO 380 J = 1,2 ACOUPT(I,J) = & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)* & (T(1,I)*T(2,J) -T(1,J)*T(2,I)) 380 CONTINUE 390 CONTINUE DO 410 I = 1,2 DO 400 J = 1,2 ACOUPB(I,J) = & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)* & (B(1,I)*B(2,J) -B(1,J)*B(2,I)) 400 CONTINUE 410 CONTINUE PRUN = XMA EPS = 1D-4*PRUN ITER = 0 420 ITER = ITER + 1 DO 470 I3 = 1,3 PR(I3)=PRUN+(I3-2)*EPS/2 AP2=PR(I3)**2 APOLT = 0D0 DO 440 I = 1,2 DO 430 J = 1,2 APOLT = APOLT + ACOUPT(I,J)**2*3D0* & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2 430 CONTINUE 440 CONTINUE APOLB = 0D0 DO 460 I = 1,2 DO 450 J = 1,2 APOLB = APOLB + ACOUPB(I,J)**2*3D0* & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2 450 CONTINUE 460 CONTINUE RXMT2 = RXMT**2 XMT2=XMT**2 APOLTT = & 3D0*RXMT**2/8D0/PI**2/ V **2* & COSB**2/SINB**2 * & (-0.5D0*AP2)* & PYFINT(AP2,XMT2,XMT2) APOL = APOLT + APOLB + APOLTT POLAR(I3) = AP2 - XMA**2 -APOL 470 CONTINUE DERIV = (POLAR(3)-POLAR(1))/EPS DRUN = - POLAR(2)/DERIV PRUN = PRUN + DRUN AP2 = PRUN**2 IF( ABS(DRUN) .LT. 1D-4 ) GOTO 480 GOTO 420 480 CONTINUE AMP = AP2**0.5D0 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C...END OF PSEUDOSCALAR HIGGS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IF(IHIGGS.EQ.3) GOTO 490 490 CONTINUE RETURN 500 CONTINUE WRITE(MSTU(11),*) ' EXITING IN PYVACU ' WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22 STOP END C********************************************************************* C...PYRGHM C...Auxiliary routine to PYVACU for SUSY Higgs calculations. SUBROUTINE PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDL,XMT,AU,AD,XMU, &XMHP,HMP,SA,CA,TANBA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DIMENSION VH(2,2),XM2(2,2),XM2P(2,2) XMZ = 91.18D0 ALP1 = 0.0101D0 ALP2 = 0.0337D0 ALP3Z = 0.12D0 V = 174.1D0 PI = 3.14159D0 TANBA = TANB TANBT = TANB C...MBOTTOM(XMT) = 3. GEV XMB = 3D0 ALP3 = ALP3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALP3Z* &LOG(XMT**2/XMZ**2)) C...RXMT= RUNNING TOP QUARK MASS RXMT = XMT/(1D0+4D0*ALP3/3D0/PI) TQ = LOG((XMQ**2+XMT**2)/XMT**2) TU = LOG((XMUR**2 + XMT**2)/XMT**2) TD = LOG((XMDL**2 + XMT**2)/XMT**2) SINB = TANB/((1D0 + TANB**2)**0.5D0) COSB = SINB/TANB IF(XMA.GT.XMT) &TANBA = TANB*(1D0-3D0/32D0/PI**2* &(RXMT**2/V**2/SINB**2-XMB**2/V**2/COSB**2)* &LOG(XMA**2/XMT**2)) IF(XMA.LT.XMT.OR.XMA.EQ.XMT) TANBT = TANBA SINB = TANBT/((1D0 + TANBT**2)**0.5D0) COSB = 1D0/((1D0 + TANBT**2)**0.5D0) COS2B = (TANBT**2 - 1D0)/(TANBT**2 + 1D0) G1 = (ALP1*4D0*PI)**0.5D0 G2 = (ALP2*4D0*PI)**0.5D0 G3 = (ALP3*4D0*PI)**0.5D0 HU = RXMT/V/SINB HD = XMB/V/COSB CALL PYGFXX(XMA,TANBA,XMQ,XMUR,XMDL,XMT,AU,AD, &XMU,VH,STOP1,STOP2) IF(XMQ.GT.XMUR) TP = TQ - TU IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TP = TU - TQ IF(XMQ.GT.XMUR) TDP = TU IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) TDP = TQ IF(XMQ.GT.XMDL) TPD = TQ - TD IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TPD = TD - TQ IF(XMQ.GT.XMDL) TDPD = TD IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) TDPD = TQ IF(XMQ.GT.XMDL) DLAM1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM1 = 3D0/32D0/PI**2* &HD**2*(G1**2/3D0+G2**2)*TPD IF(XMQ.GT.XMUR) DLAM2 =12D0/96D0/PI**2*G1**2*HU**2*TP IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM2 = 3D0/32D0/PI**2* &HU**2*(-G1**2/3D0+G2**2)*TP DLAM3 = 0D0 DLAM4 = 0D0 IF(XMQ.GT.XMDL) DLAM3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD IF(XMQ.LT.XMDL.OR.XMQ.EQ.XMDL) DLAM3 = 3D0/64D0/PI**2*HD**2* &(G2**2-G1**2/3D0)*TPD IF(XMQ.GT.XMUR) DLAM3 = DLAM3 - &1D0/16D0/PI**2*G1**2*HU**2*TP IF(XMQ.LT.XMUR.OR.XMQ.EQ.XMUR) DLAM3 = DLAM3 + &3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP IF(XMQ.LT.XMUR) DLAM4 = -3D0/32D0/PI**2*G2**2*HU**2*TP IF(XMQ.LT.XMDL) DLAM4 = DLAM4 - 3D0/32D0/PI**2*G2**2* &HD**2*TPD XLAM1 = ((G1**2 + G2**2)/4D0)* &(1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2) &+(3D0*HD**4/16D0/PI**2) *TPD*(1D0 &+ (3D0*HD**2/2D0 + HU**2/2D0 &- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2) &+(3D0*HD**4/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0 &- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAM1 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2* &(TP + TDP)/8D0/PI**2) &+(3D0*HU**4/16D0/PI**2) *TP*(1D0 &+ (3D0*HU**2/2D0 + HD**2/2D0 &- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2) &+(3D0*HU**4/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0 &- 8D0*G3**2) * TDP/16D0/PI**2) + DLAM2 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0* &(HU**2)*(TP + TDP)/16D0/PI**2 -3D0* &(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM3 XLAM4 = (- G2**2/2D0)*(1D0 &-3D0*(HU**2)*(TP + TDP)/16D0/PI**2 &-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAM4 XLAM5 = 0D0 XLAM6 = 0D0 XLAM7 = 0D0 XM2(1,1) = 2D0*V**2*(XLAM1*COSB**2+2D0*XLAM6* &COSB*SINB + XLAM5*SINB**2) + XMA**2*SINB**2 XM2(2,2) = 2D0*V**2*(XLAM5*COSB**2+2D0*XLAM7* &COSB*SINB + XLAM2*SINB**2) + XMA**2*COSB**2 XM2(1,2) = 2D0*V**2*(XLAM6*COSB**2+(XLAM3+XLAM4)* &COSB*SINB + XLAM7*SINB**2) - XMA**2*SINB*COSB XM2(2,1) = XM2(1,2) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C...THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC XMSSU=(0.5D0*(XMQ**2+XMUR**2)+XMT**2)**0.5D0 IF(XMC.GT.XMSSU) GOTO 100 IF(XMC.LT.XMT) XMC=XMT TCHAR=LOG(XMSSU**2/XMC**2) DEL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR DEL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4 &+4D0/32/PI**2*G1**2*G2**2)*TCHAR DEM112=2D0*DEL12*V**2*COSB**2 DEM222=2D0*DEL12*V**2*SINB**2 DEM122=2D0*DEL3P4*V**2*SINB*COSB XM2(1,1)=XM2(1,1)+DEM112 XM2(2,2)=XM2(2,2)+DEM222 XM2(1,2)=XM2(1,2)+DEM122 XM2(2,1)=XM2(2,1)+DEM122 100 CONTINUE CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C...END OF CHARGINOS/NEUTRALINOS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC DO 120 I = 1,2 DO 110 J = 1,2 XM2P(I,J) = XM2(I,J) + VH(I,J) 110 CONTINUE 120 CONTINUE TRM2P = XM2P(1,1) + XM2P(2,2) DETM2P = XM2P(1,1)*XM2P(2,2) - XM2P(1,2)*XM2P(2,1) XMH2P = (TRM2P - (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0 HM2P = (TRM2P + (TRM2P**2 - 4D0* DETM2P)**0.5D0)/2D0 HMP = HM2P**0.5D0 IF(XMH2P.LT.0D0) GOTO 130 XMHP = XMH2P**0.5D0 S2ALP = 2D0*XM2P(1,2)/(TRM2P**2-4D0*DETM2P)**0.5D0 C2ALP = (XM2P(1,1)-XM2P(2,2))/(TRM2P**2-4D0*DETM2P)**0.5D0 IF(C2ALP.GT.0D0) ALP = ASIN(S2ALP)/2D0 IF(C2ALP.LT.0D0) ALP = -PI/2D0-ASIN(S2ALP)/2D0 SA = SIN(ALP) CA = COS(ALP) SQBMA = (SINB*CA - COSB*SA)**2 130 XIN = 1D0 140 CONTINUE RETURN END C********************************************************************* C...PYGFXX C...Auxiliary routine to PYRGHM for SUSY Higgs calculations. SUBROUTINE PYGFXX(XMA,TANB,XMQ,XMUR,XMDL,XMT,AT,AB,XMU,VH, &STOP1,STOP2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DIMENSION DIAH(2),VH(2,2),VH1(2,2),VH2(2,2), &VH3T(2,2),VH3B(2,2), &HMIX(2,2),AL(2,2),XM2(2,2) C...Statement function. G(X,Y) = 2D0 - (X+Y)/(X-Y)*LOG(X/Y) IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0 XMQ2 = XMQ**2 XMUR2 = XMUR**2 XMDL2 = XMDL**2 TANBA = TANB SINBA = TANBA/(TANBA**2+1D0)**0.5D0 COSBA = SINBA/TANBA SINB = TANB/(TANB**2+1D0)**0.5D0 COSB = SINB/TANB PI = 3.14159D0 G2 = (0.0336D0*4D0*PI)**0.5D0 G12 = (0.0101D0*4D0*PI) G1 = G12**0.5D0 XMZ = 91.18D0 V = 174.1D0 MW = (G2**2*V**2/2D0)**0.5D0 ALP3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(XMT**2/XMZ**2)) XMB = 3D0 IF(XMQ.GT.XMUR) XMST = XMQ IF(XMUR.GT.XMQ.OR.XMUR.EQ.XMQ) XMST = XMUR XMSUT = (XMST**2 + XMT**2)**0.5D0 IF(XMQ.GT.XMDL) XMSB = XMQ IF(XMDL.GT.XMQ.OR.XMDL.EQ.XMQ) XMSB = XMDL XMSUB = (XMSB**2 + XMB**2)**0.5D0 TT = LOG(XMSUT**2/XMT**2) TB = LOG(XMSUB**2/XMT**2) RXMT = XMT/(1D0+4D0*ALP3/3D0/PI) HT = RXMT/(174.1D0*SINB) HTST = RXMT/174.1D0 HB = XMB/174.1D0/COSB G32 = ALP3*4D0*PI BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2 AL2 = 3D0/8D0/PI**2*HT**2 BT2ST = -(8D0*G32 - 9D0*HTST**2/2D0)/(4D0*PI)**2 ALST = 3D0/8D0/PI**2*HTST**2 AL1 = 3D0/8D0/PI**2*HB**2 AL(1,1) = AL1 AL(1,2) = (AL2+AL1)/2D0 AL(2,1) = (AL2+AL1)/2D0 AL(2,2) = AL2 XMT4 = RXMT**4*(1D0+2D0*BT2*TT- AL2*TT) XMT2 = SQRT(XMT4) XMBOT4 = XMB**4*(1D0+2D0*BB2*TB - AL1*TB) XMBOT2 = SQRT(XMBOT4) IF(XMA.GT.XMT) THEN VI = 174.1D0*(1D0 + 3D0/32D0/PI**2*HTST**2* & LOG(XMT**2/XMA**2)) H1I = VI* COSBA H2I = VI*SINBA H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUT**2))**0.25D0 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUT**2))**0.25D0 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMA**2/XMSUB**2))**0.25D0 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMA**2/XMSUB**2))**0.25D0 ELSE VI = 174.1D0 H1I = VI*COSB H2I = VI*SINB H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUT**2))**0.25D0 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUT**2))**0.25D0 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(XMT**2/XMSUB**2))**0.25D0 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(XMT**2/XMSUB**2))**0.25D0 ENDIF TANBST = H2T/H1T SINBT = TANBST/(1D0+TANBST**2)**0.5D0 COSBT = SINBT/TANBST TANBSB = H2B/H1B SINBB = TANBSB/(1D0+TANBSB**2)**0.5D0 COSBB = SINBB/TANBSB STOP12 = (XMQ2 + XMUR2)*0.5D0 + XMT2 &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) &+(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + &XMQ2 - XMUR2)**2*0.25D0 + XMT2*(AT-XMU/TANBST)**2)**0.5D0 STOP22 = (XMQ2 + XMUR2)*0.5D0 + XMT2 &+1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) &- (((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + &XMQ2 - XMUR2)**2*0.25D0 &+ XMT2*(AT-XMU/TANBST)**2)**0.5D0 IF(STOP22.LT.0D0) GOTO 120 SBOT12 = (XMQ2 + XMDL2)*0.5D0 &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) &+ (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0 SBOT22 = (XMQ2 + XMDL2)*0.5D0 &- 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) &- (((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + &XMQ2 - XMDL2)**2*0.25D0 + XMBOT2*(AB-XMU*TANBSB)**2)**0.5D0 IF(SBOT22.LT.0D0) GOTO 120 STOP1 = STOP12**0.5D0 STOP2 = STOP22**0.5D0 SBOT1 = SBOT12**0.5D0 SBOT2 = SBOT22**0.5D0 VH1(1,1) = 1D0/TANBST VH1(2,1) = -1D0 VH1(1,2) = -1D0 VH1(2,2) = TANBST VH2(1,1) = TANBST VH2(1,2) = -1D0 VH2(2,1) = -1D0 VH2(2,2) = 1D0/TANBST CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C...D-TERMS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC STW=0.2320D0 F1T=(XMQ2-XMUR2)/(STOP12-STOP22)*(0.5D0-4D0/3D0*STW)* &LOG(STOP1/STOP2) &+(0.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(XMQ2+XMT2)) &+ 2D0/3D0*STW*LOG(STOP1*STOP2/(XMUR2+XMT2)) F1B=(XMQ2-XMDL2)/(SBOT12-SBOT22)*(-0.5D0+2D0/3D0*STW)* &LOG(SBOT1/SBOT2) &+(-0.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(XMQ2+XMBOT2)) &- 1D0/3D0*STW*LOG(SBOT1*SBOT2/(XMDL2+XMBOT2)) F2T=XMT2**0.5D0*(AT-XMU/TANBST)/(STOP12-STOP22)* &(-0.5D0*LOG(STOP12/STOP22) &+(4D0/3D0*STW-0.5D0)*(XMQ2-XMUR2)/(STOP12-STOP22)* &G(STOP12,STOP22)) F2B=XMBOT2**0.5D0*(AB-XMU*TANBSB)/(SBOT12-SBOT22)* &(0.5D0*LOG(SBOT12/SBOT22) &+(-2D0/3D0*STW+0.5D0)*(XMQ2-XMDL2)/(SBOT12-SBOT22)* &G(SBOT12,SBOT22)) VH3B(1,1) = XMBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/ &(XMQ2+XMBOT2)/(XMDL2+XMBOT2)) &+ 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))* &LOG(SBOT1**2/SBOT2**2)) + &XMBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/ &(SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22) VH3T(1,1) = &XMT4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2 &-STOP2**2))**2*G(STOP12,STOP22) VH3B(1,1)=VH3B(1,1)+ &XMZ**2*(2*XMBOT2*F1B-XMBOT2**0.5D0*AB*F2B) VH3T(1,1) = VH3T(1,1) + &XMZ**2*(XMT2**0.5D0*XMU/TANBST*F2T) VH3T(2,2) = XMT4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/ &(XMQ2+XMT2)/(XMUR2+XMT2)) &+ 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))* &LOG(STOP1**2/STOP2**2)) + &XMT4/(SINBT**2)*(AT*(AT-XMU/TANBST)/ &(STOP1**2-STOP2**2))**2*G(STOP12,STOP22) VH3B(2,2) = &XMBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2 &-SBOT2**2))**2*G(SBOT12,SBOT22) VH3T(2,2)=VH3T(2,2)+ &XMZ**2*(-2*XMT2*F1T+XMT2**0.5D0*AT*F2T) VH3B(2,2) = VH3B(2,2) -XMZ**2*XMBOT2**0.5D0*XMU*TANBSB*F2B VH3T(1,2) = - &XMT4/(SINBT**2)*XMU*(AT-XMU/TANBST)/ &(STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT* &(AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22)) VH3B(1,2) = &- XMBOT4/(COSBB**2)*XMU*(AT-XMU*TANBSB)/ &(SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB* &(AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22)) VH3T(1,2)=VH3T(1,2) + &XMZ**2*(XMT2/TANBST*F1T-XMT2**0.5D0*(AT/TANBST+XMU)/2D0*F2T) VH3B(1,2)=VH3B(1,2) &+XMZ**2*(-XMBOT2*TANBSB*F1B+XMBOT2**0.5D0*(AB*TANBSB+XMU)/2D0*F2B) VH3T(2,1) = VH3T(1,2) VH3B(2,1) = VH3B(1,2) TQ = LOG((XMQ2 + XMT2)/XMT2) TU = LOG((XMUR2+XMT2)/XMT2) TQD = LOG((XMQ2 + XMB**2)/XMB**2) TD = LOG((XMDL2+XMB**2)/XMB**2) DO 110 I = 1,2 DO 100 J = 1,2 VH(I,J) = & 6D0/(8D0*PI**2*(H1T**2+H2T**2)) & *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) + & 6D0/(8D0*PI**2*(H1B**2+H2B**2)) & *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0) 100 CONTINUE 110 CONTINUE GOTO 150 120 DO 140 I =1,2 DO 130 J = 1,2 VH(I,J) = -1D+15 130 CONTINUE 140 CONTINUE 150 CONTINUE RETURN END C********************************************************************* C...PYFINT C...Auxiliary routine to PYVACU for SUSY Higgs calculations. FUNCTION PYFINT(A,B,C) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblock. COMMON/PYINTS/XXM(20) SAVE/PYINTS/ C...Local variables. EXTERNAL PYFISB XXM(1)=A XXM(2)=B XXM(3)=C XLO=0D0 XHI=1D0 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3) RETURN END C********************************************************************* C...PYFISB C...Auxiliary routine to PYFINT for SUSY Higgs calculations. FUNCTION PYFISB(X) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblock. COMMON/PYINTS/XXM(20) SAVE/PYINTS/ PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/ &(X*(XXM(2)-XXM(3))+XXM(3))) RETURN END C********************************************************************* C...PYSFDC C...Calculates decays of sfermions. SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ C...Local variables. INTEGER KFIN,KCIN DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ, &XMZ2,AXMJ,AXMI DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP DOUBLE PRECISION PYLAMF,XL DOUBLE PRECISION TANW,XW,AEM,C1,AS DOUBLE PRECISION CA,CB,AL,AR,BL,BR,ALP,ARP,BLP,BRP DOUBLE PRECISION CH1,CH2,CH3,CH4 DOUBLE PRECISION XMBOT,XMTOP DOUBLE PRECISION XLAM(0:200) INTEGER IDLAM(200,3) INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL,IFP,II DOUBLE PRECISION SR2 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K DOUBLE PRECISION CW DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL DOUBLE PRECISION COSA,SINA,TANB DOUBLE PRECISION PYALEM,PI,PYALPS,EI,PYRNMT DOUBLE PRECISION GHRR,GHLL,GHLR,CF,XMB,BLR INTEGER IG,KF1,KF2,ILR2,IDP INTEGER IGG(4),KFNCHI(4),KFCCHI(2) DATA IGG/23,25,35,36/ DATA PI/3.141592654D0/ DATA SR2/1.4142136D0/ DATA KFNCHI/1000022,1000023,1000025,1000035/ DATA KFCCHI/1000024,1000037/ C...COUNT THE NUMBER OF DECAY MODES LKNT=0 C...NO NU_R DECAYS IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR. &KFIN.EQ.KSUSY2+16) RETURN XMW=PMAS(24,1) XMW2=XMW**2 XMZ=PMAS(23,1) XMZ2=XMZ**2 XW=PARU(102) TANW = SQRT(XW/(1D0-XW)) CW=SQRT(1D0-XW) C...KCIN KCIN=PYCOMP(KFIN) C...ILR is 1 for left and 2 for right. ILR=KFIN/KSUSY1 C...IFL is matching non-SUSY flavour. IFL=MOD(KFIN,KSUSY1) C...IDU is weak isospin, 1 for down and 2 for up. IDU=2-MOD(IFL,2) XMI=PMAS(KCIN,1) XMI2=XMI**2 AEM=PYALEM(XMI2) AS =PYALPS(XMI2) C1=AEM/XW XMI3=XMI**3 EI=KCHG(IFL,1)/3D0 XMBOT=3D0 XMTOP=PYRNMT(PMAS(6,1)) XMBOT=0D0 TANB=RMSS(5) BETA=ATAN(TANB) ALFA=RMSS(18) CBETA=COS(BETA) SBETA=TANB*CBETA SINA=SIN(ALFA) COSA=COS(ALFA) XMU=-RMSS(4) ATRIT=RMSS(16) ATRIB=RMSS(15) ATRIL=RMSS(17) C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION IF(IMSS(11).EQ.1) THEN XMP=RMSS(28) IDG=39+KSUSY1 XMGR=PMAS(PYCOMP(IDG),1) XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI IF(IFL.EQ.5) THEN XMF=XMBOT ELSEIF(IFL.EQ.6) THEN XMF=XMTOP ELSE XMF=PMAS(IFL,1) ENDIF IF(XMI.GT.XMGR+XMF) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=IFL IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4 ENDIF ENDIF C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO C...CHARGED DECAYS: DO 100 IX=1,2 C...DI -> U CHI1-,CHI2- IF(IDU.EQ.1) THEN XMFP=PMAS(IFL+1,1) XMF =PMAS(IFL,1) C...UI -> D CHI1+,CHI2+ ELSE XMFP=PMAS(IFL-1,1) XMF =PMAS(IFL,1) ENDIF XMJ=SMW(IX) AXMJ=ABS(XMJ) IF(XMI.GE.AXMJ+XMFP) THEN XMA2=XMJ**2 XMB2=XMFP**2 IF(IDU.EQ.2) THEN IF(IFL.EQ.6) THEN XMFP=XMBOT XMF =XMTOP ELSEIF(IFL.LT.6) THEN XMF=0D0 XMFP=0D0 ENDIF BL=VMIX(IX,1) AL=-XMFP*UMIX(IX,2)/SR2/XMW/CBETA BR=-XMF*VMIX(IX,2)/SR2/XMW/SBETA AR=0D0 ELSE IF(IFL.EQ.5) THEN XMF =XMBOT XMFP=XMTOP ELSEIF(IFL.LT.5) THEN XMF=0D0 XMFP=0D0 ENDIF BL=UMIX(IX,1) AL=-XMFP*VMIX(IX,2)/SR2/XMW/SBETA BR=-XMF*UMIX(IX,2)/SR2/XMW/CBETA AR=0D0 ENDIF ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL AL=ALP BL=BLP AR=ARP BR=BRP C...F1 -> F` CHI IF(ILR.EQ.1) THEN CA=AL CB=BL C...F2 -> F` CHI ELSE CA=AR CB=BR ENDIF LKNT=LKNT+1 XL=PYLAMF(XMI2,XMA2,XMB2) C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)* & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMFP) IDLAM(LKNT,3)=0 IF(IDU.EQ.1) THEN IDLAM(LKNT,1)=-KFCCHI(IX) IDLAM(LKNT,2)=IFL+1 ELSE IDLAM(LKNT,1)=KFCCHI(IX) IDLAM(LKNT,2)=IFL-1 ENDIF ENDIF 100 CONTINUE C...NEUTRAL DECAYS DO 110 IX=1,4 C...DI -> D CHI10 XMF=PMAS(IFL,1) XMJ=SMZ(IX) AXMJ=ABS(XMJ) IF(XMI.GE.AXMJ+XMF) THEN XMA2=XMJ**2 XMB2=XMF**2 IF(IDU.EQ.1) THEN IF(IFL.EQ.5) THEN XMF=XMBOT ELSEIF(IFL.LT.5) THEN XMF=0D0 ENDIF BL=-ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI+1) AL=XMF*ZMIX(IX,3)/XMW/CBETA AR=-2D0*EI*TANW*ZMIX(IX,1) BR=AL ELSE IF(IFL.EQ.6) THEN XMF=XMTOP ELSEIF(IFL.LT.5) THEN XMF=0D0 ENDIF BL=ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-1) AL=XMF*ZMIX(IX,4)/XMW/SBETA AR=-2D0*EI*TANW*ZMIX(IX,1) BR=AL ENDIF ALP=SFMIX(IFL,1)*AL + SFMIX(IFL,2)*AR BLP=SFMIX(IFL,1)*BL + SFMIX(IFL,2)*BR ARP=SFMIX(IFL,4)*AR + SFMIX(IFL,3)*AL BRP=SFMIX(IFL,4)*BR + SFMIX(IFL,3)*BL AL=ALP BL=BLP AR=ARP BR=BRP C...F1 -> F CHI IF(ILR.EQ.1) THEN CA=AL CB=BL C...F2 -> F CHI ELSE CA=AR CB=BR ENDIF LKNT=LKNT+1 XL=PYLAMF(XMI2,XMA2,XMB2) C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)* & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMF) IDLAM(LKNT,1)=KFNCHI(IX) IDLAM(LKNT,2)=IFL IDLAM(LKNT,3)=0 ENDIF 110 CONTINUE C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS C...IG=23,25,35,36 DO 120 II=1,4 IG=IGG(II) IF(ILR.EQ.1) GOTO 120 XMB=PMAS(IG,1) XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1) IF(XMI.LT.XMSF1+XMB) GOTO 120 IF(IG.EQ.23) THEN BL=-SIGN(.5D0,EI)/CW+EI*XW/CW BR=EI*XW/CW BLR=0D0 ELSEIF(IG.EQ.25) THEN IF(IFL.EQ.5) THEN XMF=XMBOT ELSEIF(IFL.EQ.6) THEN XMF=XMTOP ELSEIF(IFL.LT.5) THEN XMF=0D0 ELSE XMF=PMAS(IFL,1) ENDIF IF(IDU.EQ.2) THEN GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+ & XMF**2/XMW*COSA/SBETA GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+ & XMF**2/XMW*COSA/SBETA ELSE GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+ & XMF**2/XMW*(-SINA)/CBETA GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+ & XMF**2/XMW*(-SINA)/CBETA ENDIF IF(IFL.EQ.5) THEN AT=ATRIB ELSEIF(IFL.EQ.6) THEN AT=ATRIT ELSEIF(IFL.EQ.15) THEN AT=ATRIL ELSE AT=0D0 ENDIF IF(IDU.EQ.2) THEN GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+ & AT*COSA) ELSE GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA- & AT*SINA) ENDIF BL=GHLL BR=GHRR BLR=-GHLR ELSEIF(IG.EQ.35) THEN IF(IFL.EQ.5) THEN XMF=XMBOT ELSEIF(IFL.EQ.6) THEN XMF=XMTOP ELSEIF(IFL.LT.5) THEN XMF=0D0 ELSE XMF=PMAS(IFL,1) ENDIF IF(IDU.EQ.2) THEN GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+ & XMF**2/XMW*SINA/SBETA GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+ & XMF**2/XMW*SINA/SBETA ELSE GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+ & XMF**2/XMW*COSA/CBETA GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+ & XMF**2/XMW*COSA/CBETA ENDIF IF(IFL.EQ.5) THEN AT=ATRIB ELSEIF(IFL.EQ.6) THEN AT=ATRIT ELSEIF(IFL.EQ.15) THEN AT=ATRIL ELSE AT=0D0 ENDIF IF(IDU.EQ.2) THEN GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+ & AT*SINA) ELSE GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+ & AT*COSA) ENDIF BL=GHLL BR=GHRR BLR=GHLR ELSEIF(IG.EQ.36) THEN GHLL=0D0 GHRR=0D0 IF(IFL.EQ.5) THEN XMF=XMBOT ELSEIF(IFL.EQ.6) THEN XMF=XMTOP ELSEIF(IFL.LT.5) THEN XMF=0D0 ELSE XMF=PMAS(IFL,1) ENDIF IF(IFL.EQ.5) THEN AT=ATRIB ELSEIF(IFL.EQ.6) THEN AT=ATRIT ELSEIF(IFL.EQ.15) THEN AT=ATRIL ELSE AT=0D0 ENDIF IF(IDU.EQ.2) THEN GHLR=XMF/2D0/XMW*(-XMU+AT/TANB) ELSE GHLR=XMF/2D0/XMW/(-XMU+AT*TANB) ENDIF BL=GHLL BR=GHRR BLR=GHLR ENDIF AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+ & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+ & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR XL=PYLAMF(XMI2,XMSF1**2,XMB**2) LKNT=LKNT+1 IF(IG.EQ.23) THEN XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2 ELSE XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2 ENDIF IDLAM(LKNT,3)=0 IDLAM(LKNT,1)=KFIN-KSUSY1 IDLAM(LKNT,2)=IG 120 CONTINUE C...SF -> SF' + W XMB=PMAS(24,1) IF(MOD(IFL,2).EQ.0) THEN KF1=KSUSY1+IFL-1 ELSE KF1=KSUSY1+IFL+1 ENDIF KF2=KF1+KSUSY1 XMSF1=PMAS(PYCOMP(KF1),1) XMSF2=PMAS(PYCOMP(KF2),1) IF(XMI.GT.XMB+XMSF1) THEN IF(MOD(IFL,2).EQ.0) THEN IF(ILR.EQ.1) THEN AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1) ELSE AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1) ENDIF ELSE IF(ILR.EQ.1) THEN AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1) ELSE AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1) ENDIF ENDIF XL=PYLAMF(XMI2,XMSF1**2,XMB**2) LKNT=LKNT+1 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2 IDLAM(LKNT,3)=0 IDLAM(LKNT,1)=KF1 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1)) ENDIF IF(XMI.GT.XMB+XMSF2) THEN IF(MOD(IFL,2).EQ.0) THEN IF(ILR.EQ.1) THEN AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3) ELSE AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3) ENDIF ELSE IF(ILR.EQ.1) THEN AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3) ELSE AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3) ENDIF ENDIF XL=PYLAMF(XMI2,XMSF2**2,XMB**2) LKNT=LKNT+1 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2 IDLAM(LKNT,3)=0 IDLAM(LKNT,1)=KF2 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1)) ENDIF C...SF -> SF' + HC XMB=PMAS(37,1) IF(MOD(IFL,2).EQ.0) THEN KF1=KSUSY1+IFL-1 ELSE KF1=KSUSY1+IFL+1 ENDIF KF2=KF1+KSUSY1 XMSF1=PMAS(PYCOMP(KF1),1) XMSF2=PMAS(PYCOMP(KF2),1) IF(XMI.GT.XMB+XMSF1) THEN XMF=0D0 XMFP=0D0 AT=0D0 AB=0D0 IF(MOD(IFL,2).EQ.0) THEN C...T1-> B1 HC IF(ILR.EQ.1) THEN CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1) CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2) CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2) CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1) C...T2-> B1 HC ELSE CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1) CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2) CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2) CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1) ENDIF IF(IFL.EQ.6) THEN XMF=XMTOP XMFP=XMBOT AT=ATRIT AB=ATRIB ENDIF ELSE C...B1 -> T1 HC IF(ILR.EQ.1) THEN CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1) CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2) CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2) CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1) C...B2-> T1 HC ELSE CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1) CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2) CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1) CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2) ENDIF IF(IFL.EQ.5) THEN XMF=XMTOP XMFP=XMBOT AT=ATRIT AB=ATRIB ENDIF ENDIF XL=PYLAMF(XMI2,XMSF1**2,XMB**2) LKNT=LKNT+1 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+ & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+ & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB) XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2 IDLAM(LKNT,3)=0 IDLAM(LKNT,1)=KF1 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1)) ENDIF IF(XMI.GT.XMB+XMSF2) THEN XMF=0D0 XMFP=0D0 AT=0D0 AB=0D0 IF(MOD(IFL,2).EQ.0) THEN C...T1-> B2 HC IF(ILR.EQ.1) THEN CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1) CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2) CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1) CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2) C...T2-> B2 HC ELSE CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3) CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4) CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4) CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3) ENDIF IF(IFL.EQ.6) THEN XMF=XMTOP XMFP=XMBOT AT=ATRIT AB=ATRIB ENDIF ELSE C...B1 -> T2 HC IF(ILR.EQ.1) THEN CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1) CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2) CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2) CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1) C...B2-> T2 HC ELSE CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3) CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4) CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4) CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3) ENDIF IF(IFL.EQ.5) THEN XMF=XMTOP XMFP=XMBOT AT=ATRIT AB=ATRIB ENDIF ENDIF XL=PYLAMF(XMI2,XMSF1**2,XMB**2) LKNT=LKNT+1 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+ & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+ & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB) XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2 IDLAM(LKNT,3)=0 IDLAM(LKNT,1)=KF2 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1)) ENDIF C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO IF(IFL.LE.6) THEN XMFP=0D0 XMF=0D0 IF(IFL.EQ.6) XMF=PMAS(6,1) IF(IFL.EQ.5) XMF=PMAS(5,1) XMJ=PMAS(PYCOMP(KSUSY1+21),1) AXMJ=ABS(XMJ) IF(XMI.GE.AXMJ+XMF) THEN AL=-SFMIX(IFL,2) BL=SFMIX(IFL,1) AR=-SFMIX(IFL,4) BR=SFMIX(IFL,3) C...F1 -> F CHI IF(ILR.EQ.1) THEN CA=AL CB=BL C...F2 -> F CHI ELSE CA=AR CB=BR ENDIF LKNT=LKNT+1 XMA2=XMJ**2 XMB2=XMF**2 XL=PYLAMF(XMI2,XMA2,XMB2) XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)* & (CA**2+CB**2)-4D0*CA*CB*XMJ*XMF) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=IFL IDLAM(LKNT,3)=0 ENDIF ENDIF C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT. &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI) C...M*M = C1**2 * G**2/(16PI**2) C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3) LKNT=LKNT+1 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2) XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL) IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3 IDLAM(LKNT,1)=KSUSY1+22 IDLAM(LKNT,2)=4 IDLAM(LKNT,3)=0 ENDIF IKNT=LKNT XLAM(0)=0D0 DO 130 I=1,IKNT IF(XLAM(I).LT.0D0) XLAM(I)=0D0 XLAM(0)=XLAM(0)+XLAM(I) 130 CONTINUE IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3 RETURN END C********************************************************************* C...PYGLUI C...Calculates gluino decay modes. SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4) COMMON/PYINTS/XXM(20) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/ C...Local variables. INTEGER KFIN,KCIN,KF DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2, &XMZ,XMZ2,AXMJ,AXMI DOUBLE PRECISION XMI2,XMI3,XMJ2,XMA2,XMB2,XMFP DOUBLE PRECISION C1L,C1R,D1L,D1R DOUBLE PRECISION C2L,C2R,D2L,D2R DOUBLE PRECISION PYLAMF,XL DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN DOUBLE PRECISION CA,CB,AL,AR,BL,BR DOUBLE PRECISION ALFA,BETA DOUBLE PRECISION SW,CW,SINB,COSB,QT,T3 DOUBLE PRECISION XLAM(0:200) INTEGER IDLAM(200,3) INTEGER LKNT,IX,IC,ILR,IDU,J,IJ,I,IKNT,IFL DOUBLE PRECISION SR2 DOUBLE PRECISION GAM DOUBLE PRECISION PYALEM,PI,PYALPS,EI DOUBLE PRECISION PYGAUS EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2 DOUBLE PRECISION PREC INTEGER KFNCHI(4),KFCCHI(2) DATA PI/3.141592654D0/ DATA SR2/1.4142136D0/ DATA PREC/1D-2/ DATA KFNCHI/1000022,1000023,1000025,1000035/ DATA KFCCHI/1000024,1000037/ C...COUNT THE NUMBER OF DECAY MODES LKNT=0 IF(KFIN.NE.KSUSY1+21) RETURN KCIN=PYCOMP(KFIN) XMW=PMAS(24,1) XMW2=XMW**2 XMZ=PMAS(23,1) XMZ2=XMZ**2 XW=PARU(102) TANW = SQRT(XW/(1D0-XW)) XMI=PMAS(KCIN,1) AXMI=ABS(XMI) XMI2=XMI**2 AEM=PYALEM(XMI2) AS =PYALPS(XMI2) C1=AEM/XW XMI3=XMI**3 BETA=ATAN(RMSS(5)) C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON IF(IMSS(11).EQ.1) THEN XMP=RMSS(28) IDG=39+KSUSY1 XMGR=PMAS(PYCOMP(IDG),1) XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI IF(AXMI.GT.XMGR) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=21 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC ENDIF ENDIF C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK DO 110 IFL=1,6 DO 100 ILR=1,2 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1) AXMJ=ABS(XMJ) XMF=PMAS(IFL,1) IDU=3-(1+MOD(IFL,2)) IF(XMI.GE.AXMJ+XMF) THEN AL=SFMIX(IFL,1) BL=SFMIX(IFL,2) AR=SFMIX(IFL,3) BR=SFMIX(IFL,4) C...F1 -> F CHI IF(ILR.EQ.1) THEN CA=AL CB=BL C...F2 -> F CHI ELSE CA=AR CB=BR ENDIF LKNT=LKNT+1 XMA2=XMJ**2 XMB2=XMF**2 XL=PYLAMF(XMI2,XMA2,XMB2) XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)* & (CA**2+CB**2)+4D0*CA*CB*XMI*XMF) IDLAM(LKNT,1)=ILR*KSUSY1+IFL IDLAM(LKNT,2)=-IFL IDLAM(LKNT,3)=0 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=0 ENDIF 100 CONTINUE 110 CONTINUE C...3-BODY DECAYS TO GAUGINO FERMION-FERMION C...GLUINO -> NI Q QBAR DO 160 IX=1,4 XMJ=SMZ(IX) AXMJ=ABS(XMJ) IF(XMI.GE.AXMJ) THEN XXM(1)=0D0 XXM(2)=XMJ XXM(3)=0D0 XXM(4)=XMI XXM(5)=PMAS(PYCOMP(KSUSY1+1),1) XXM(6)=PMAS(PYCOMP(KSUSY2+1),1) XXM(7)=1D6 XXM(8)=0D0 XXM(9)=0D0 XXM(10)=0D0 S12MIN=0D0 S12MAX=(XMI-AXMJ)**2 C...D-TYPE QUARKS XXM(11)=0D0 XXM(12)=0D0 XXM(13)=1D0 XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0) XXM(15)=1D0 XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0) IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 120 IF(XMI.GE.AXMJ+2D0*PMAS(1,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2) IDLAM(LKNT,1)=KFNCHI(IX) IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-1 ENDIF IF(XMI.GE.AXMJ+2D0*PMAS(3,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IX) IDLAM(LKNT,2)=3 IDLAM(LKNT,3)=-3 ENDIF 120 CONTINUE IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 130 IF(XMI.GE.AXMJ+2D0*PMAS(5,1)) THEN CALL PYTBBN(IX,80,-1D0/3D0,AXMI,GAM) LKNT=LKNT+1 XLAM(LKNT)=GAM IDLAM(LKNT,1)=KFNCHI(IX) IDLAM(LKNT,2)=5 IDLAM(LKNT,3)=-5 ENDIF C...U-TYPE QUARKS 130 CONTINUE XXM(5)=PMAS(PYCOMP(KSUSY1+2),1) XXM(6)=PMAS(PYCOMP(KSUSY2+2),1) XXM(13)=1D0 XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0) XXM(15)=1D0 XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0) IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 140 IF(XMI.GE.AXMJ+2D0*PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-2) IDLAM(LKNT,1)=KFNCHI(IX) IDLAM(LKNT,2)=2 IDLAM(LKNT,3)=-2 ENDIF IF(XMI.GE.AXMJ+2D0*PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IX) IDLAM(LKNT,2)=4 IDLAM(LKNT,3)=-4 ENDIF 140 CONTINUE C...INCLUDE THE DECAY GLUINO -> NJ + T + T~ C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 150 XMF=PMAS(6,1) IF(XMI.GE.AXMJ+2D0*XMF) THEN CALL PYTBBN(IX,80,2D0/3D0,AXMI,GAM) LKNT=LKNT+1 XLAM(LKNT)=GAM IDLAM(LKNT,1)=KFNCHI(IX) IDLAM(LKNT,2)=6 IDLAM(LKNT,3)=-6 ENDIF 150 CONTINUE ENDIF 160 CONTINUE C...GLUINO -> CI Q QBAR' DO 190 IX=1,2 XMJ=SMW(IX) AXMJ=ABS(XMJ) IF(XMI.GE.AXMJ) THEN S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 XXM(1)=0D0 XXM(2)=XMJ XXM(3)=0D0 XXM(4)=XMI XXM(5)=0D0 XXM(6)=0D0 XXM(9)=1D6 XXM(10)=0D0 XXM(7)=UMIX(IX,1)*SR2 XXM(8)=VMIX(IX,1)*SR2 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1) XXM(12)=PMAS(PYCOMP(KSUSY1+2),1) IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 170 IF(XMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(IX) IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-2 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ENDIF IF(XMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(IX) IDLAM(LKNT,2)=3 IDLAM(LKNT,3)=-4 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ENDIF 170 CONTINUE IF(XMI.GE.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) GOTO 180 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 180 XMF=PMAS(6,1) XMFP=PMAS(5,1) IF(XMI.GE.AXMJ+XMF+XMFP) THEN CALL PYTBBC(IX,80,AXMI,GAM) LKNT=LKNT+1 XLAM(LKNT)=GAM IDLAM(LKNT,1)=KFCCHI(IX) IDLAM(LKNT,2)=5 IDLAM(LKNT,3)=-6 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ENDIF 180 CONTINUE ENDIF 190 CONTINUE IKNT=LKNT XLAM(0)=0D0 DO 200 I=1,IKNT IF(XLAM(I).LT.0D0) XLAM(I)=0D0 XLAM(0)=XLAM(0)+XLAM(I) 200 CONTINUE IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6 RETURN END C********************************************************************* C...PYTBBN C...Calculates the three-body decay of gluinos into C...neutralinos and third generation fermions. SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ C...Local variables. EXTERNAL PYSIMP,PYLAMF INTEGER LIN,NN DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100) DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24 DOUBLE PRECISION XLN1,XLN2,B1,B2 DOUBLE PRECISION E,XMGLU,GAM DOUBLE PRECISION PYSIMP,PYLAMF DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4) SAVE HRB,HLB,FLB,FRB DOUBLE PRECISION ALPHAW,ALPHAS,GSU2 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4) SAVE HLT,HRT,FLT,FRT DOUBLE PRECISION AMC(2),AMN(4),AN(4,4),ZN(3),FLU(4),FRU(4), &FLD(4),FRD(4) SAVE AMC,AMN,AN,ZN,FLU,FRU,FLD,FRD DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA SAVE AMSB,AMST DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2 DOUBLE PRECISION ROT1(4,4) LOGICAL IFIRST SAVE IFIRST DATA IFIRST/.TRUE./ TANB=RMSS(5) SINB=TANB/SQRT(1D0+TANB**2) COSB=SINB/TANB XW=PARU(102) SINW=SQRT(XW) COSW=SQRT(1D0-XW) TANW=SINW/COSW AMW=PMAS(24,1) COSC=SFMIX(5,1) SINC=SFMIX(5,3) COSA=SFMIX(6,1) SINA=SFMIX(6,3) AMBOT=0D0 AMTOP=PYRNMT(PMAS(6,1)) W2=SQRT(2D0) FAKT1=AMBOT/W2/AMW/COSB FAKT2=AMTOP/W2/AMW/SINB IF(IFIRST) THEN DO 110 II=1,4 AMN(II)=SMZ(II) DO 100 J=1,4 ROT1(II,J)=0D0 AN(II,J)=0D0 100 CONTINUE 110 CONTINUE ROT1(1,1)=COSW ROT1(1,2)=-SINW ROT1(2,1)=-ROT1(1,2) ROT1(2,2)=ROT1(1,1) ROT1(3,3)=COSB ROT1(3,4)=SINB ROT1(4,3)=-ROT1(3,4) ROT1(4,4)=ROT1(3,3) DO 140 II=1,4 DO 130 J=1,4 DO 120 JJ=1,4 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J) 120 CONTINUE 130 CONTINUE 140 CONTINUE DO 150 J=1,4 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4)) ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1)) ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0* & XW)*AN(J,2)/COSW HRT(J)=ZN(1)*COSA-ZN(3)*SINA HLT(J)=ZN(1)*COSA+ZN(2)*SINA FLT(J)=ZN(3)*COSA+ZN(1)*SINA FRT(J)=ZN(2)*COSA-ZN(1)*SINA FLU(J)=ZN(3) FRU(J)=ZN(2) ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4)) ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1)) ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW HRB(J)=ZN(1)*COSC-ZN(3)*SINC HLB(J)=ZN(1)*COSC+ZN(2)*SINC FLB(J)=ZN(3)*COSC+ZN(1)*SINC FRB(J)=ZN(2)*COSC-ZN(1)*SINC FLD(J)=ZN(3) FRD(J)=ZN(2) 150 CONTINUE AMST(1)=PMAS(PYCOMP(KSUSY1+6),1) AMST(2)=PMAS(PYCOMP(KSUSY2+6),1) AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1) AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1) IFIRST=.FALSE. ENDIF IF(NINT(3D0*E).EQ.2) THEN HL=HLT(I) HR=HRT(I) FL=FLT(I) FR=FRT(I) COSD=SFMIX(6,1) SIND=SFMIX(6,3) XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2 XM=PMAS(6,1) ELSE HL=HLB(I) HR=HRB(I) FL=FLB(I) FR=FRB(I) COSD=SFMIX(5,1) SIND=SFMIX(5,3) XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2 XM=PMAS(5,1) ENDIF COSD2=COSD*COSD SIND2=SIND*SIND COS2D=COSD2-SIND2 SIN2D=SIND*COSD*2D0 HL2=HL*HL HR2=HR*HR FL2=FL*FL FR2=FR*FR FF=FL*FR HH=HL*HR HFL=HL*FL HFR=HR*FR HRFL=HR*FL HLFR=HL*FR XM2=XM*XM XMG=XMGLU XMG2=XMG*XMG ALPHAW=PYALEM(XMG2) ALPHAS=PYALPS(XMG2) XMR=AMN(I) XMR2=XMR*XMR XMQ4=XMG*XM2*XMR XM24=(XMG2+XM2)*(XM2+XMR2) SMIN=4D0*XM2 SMAX=(XMG-ABS(XMR))**2 XMQA=XMG2+2D0*XM2+XMR2 DO 170 LIN=1,NN-1 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN) GRS=SBAR-XMQA W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR) W=DSQRT(W) XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W))) XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W))) B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W) B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W) G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D & +2D0*(FF*SIND2-HH*COSD2))*W G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D) & +4D0*HFL*XM*XMR)*XLN1 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D) & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1)) & +8D0*HFL*XMQ4*SIN2D)*B1 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D) & +4D0*HFR*XMR*XM)*XLN2 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2)) & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2) & -8D0*HFR*XMQ4*SIN2D)*B2 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2) & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2) & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2) & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))* & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2) & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1)) G(5)=(2D0*(HH*COSD2-FF*SIND2) & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1) & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR) & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2) & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2) & +COS2D*XM*(SBAR+XMG2-XMR2)) & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2)) & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2)) G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2) & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2) & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2) & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2 SUMME(LIN)=0D0 DO 160 J=0,6 SUMME(LIN)=SUMME(LIN)+G(J) 160 CONTINUE 170 CONTINUE SUMME(0)=0D0 SUMME(NN)=0D0 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN) &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3) RETURN END C********************************************************************* C...PYTBBC C...Calculates the three-body decay of gluinos into C...charginos and third generation fermions. SUBROUTINE PYTBBC(I,NN,XMGLU,GAM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ C...Local variables. EXTERNAL PYSIMP,PYLAMF INTEGER I,NN,LIN DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4) DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX DOUBLE PRECISION SUMME(0:100),A(4,8) DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2 DOUBLE PRECISION XMGLU,GAM DOUBLE PRECISION PYSIMP,PYLAMF DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2), &DDD(2),EEE(2),FFF(2) SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF DOUBLE PRECISION ALPHAW,ALPHAS,GSU2 DOUBLE PRECISION AMC(2),AMN(4) SAVE AMC,AMN DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA SAVE AMSB,AMST DOUBLE PRECISION SINW,COSW,TANW,COSW2,SINW2 LOGICAL IFIRST SAVE IFIRST DATA IFIRST/.TRUE./ TANB=RMSS(5) SINB=TANB/SQRT(1D0+TANB**2) COSB=SINB/TANB XW=PARU(102) SINW=SQRT(XW) COSW=SQRT(1D0-XW) AMW=PMAS(24,1) COSC=SFMIX(5,1) SINC=SFMIX(5,3) COSA=SFMIX(6,1) SINA=SFMIX(6,3) AMBOT=0D0 AMTOP=PYRNMT(PMAS(6,1)) W2=SQRT(2D0) AMW=PMAS(24,1) FAKT1=AMBOT/W2/AMW/COSB FAKT2=AMTOP/W2/AMW/SINB IF(IFIRST) THEN AMC(1)=SMW(1) AMC(2)=SMW(2) DO 100 JJ=1,2 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA 100 CONTINUE AMST(1)=PMAS(PYCOMP(KSUSY1+6),1) AMST(2)=PMAS(PYCOMP(KSUSY2+6),1) AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1) AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1) IFIRST=.FALSE. ENDIF AMTOP=PMAS(6,1) ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I) ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I) VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I) VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I) COS2A=COSA**2-SINA**2 SIN2A=SINA*COSA*2D0 COS2C=COSC**2-SINC**2 SIN2C=SINC*COSC*2D0 XMG=XMGLU XMT=AMTOP XMB=0D0 XMR=AMC(I) XMG2=XMG*XMG ALPHAW=PYALEM(XMG2) ALPHAS=PYALPS(XMG2) XMT2=XMT*XMT XMB2=XMB*XMB XMR2=XMR*XMR XMQ2=XMG2+XMT2+XMB2+XMR2 XMQ4=XMG*XMT*XMB*XMR XMQ3=XMG2*XMR2+XMT2*XMB2 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2) XMGTBR=(XMG2+XMT2)*(XMB2+XMR2) XMST(1)=AMST(1)*AMST(1) XMST(2)=AMST(1)*AMST(1) XMST(3)=AMST(2)*AMST(2) XMST(4)=AMST(2)*AMST(2) XMSB(1)=AMSB(1)*AMSB(1) XMSB(2)=AMSB(2)*AMSB(2) XMSB(3)=AMSB(1)*AMSB(1) XMSB(4)=AMSB(2)*AMSB(2) A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I) A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I)) A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I)) A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I)) A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I)) A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I)) A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I)) A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I)) A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I) A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I)) A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I)) A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I)) A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I)) A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I)) A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I)) A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I)) A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I) A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I)) A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I)) A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I)) A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I)) A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I)) A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I)) A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I)) A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I) A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I)) A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I)) A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I)) A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I)) A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I)) A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I)) A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I)) SMAX=(XMG-ABS(XMR))**2 SMIN=(XMB+XMT)**2+0.1D0 DO 120 LIN=0,NN-1 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN) AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR GRS=SBAR-XMQ2 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2) W=DSQRT(W)/2D0/SBAR ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W))) ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W))) ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W))) ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W))) SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A) & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2)) & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2) & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4) & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W)) SUMME(LIN)=SUMME(LIN)-ULR(2)*W & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A) & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2)) & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2) & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4) & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W)) SUMME(LIN)=SUMME(LIN)-VLR(1)*W & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C) & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2)) & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2) & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4) & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W)) SUMME(LIN)=SUMME(LIN)-VLR(2)*W & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C) & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2)) & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2) & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4) & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W)) SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1)) & *((AAA(I)*BBB(I)-XX1(I)*XX2(I)) & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1) & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1)) SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1)) & *((EEE(I)*FFF(I)-CCC(I)*DDD(I)) & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1) & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1)) DO 110 J=1,4 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3) & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2) & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2) & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR) & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8)) & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W))) & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3) & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2) & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2) & -A(J,6)*(XMG2+XMR2-SBAR) & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8)) & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W)))) & /(GRS+XMSB(J)+XMST(J)) 110 CONTINUE 120 CONTINUE SUMME(NN)=0D0 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN) &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3) RETURN END C********************************************************************* C...PYNJDC C...Calculates decay widths for the neutralinos (admixtures of C...Bino, W3-ino, Higgs1-ino, Higgs2-ino) C...Input: KCIN = KF code for particle C...Output: XLAM = widths C... IDLAM = KF codes for decay particles C... IKNT = number of decay channels defined C...AUTHOR: STEPHEN MRENNA C...Last change: C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma C...when CHIGAMMA .NE. 0 C...10 FEB 96: Calculate this decay for small tan(beta) SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4) COMMON/PYINTS/XXM(20) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/ C...Local variables. INTEGER KFIN,KCIN DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2, &XMZ,XMZ2,AXMJ,AXMI DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG,XMK DOUBLE PRECISION S12MIN,S12MAX DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2 DOUBLE PRECISION PYLAMF,XL,QIJ,RIJ DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3 DOUBLE PRECISION PYX2XH,PYX2XG DOUBLE PRECISION XLAM(0:200) INTEGER IDLAM(200,3) INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID INTEGER ITH(3),KF1,KF2 INTEGER ITHC DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3) DOUBLE PRECISION SR2 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K DOUBLE PRECISION GAMCON,XMT1,XMT2 DOUBLE PRECISION PYALEM,PI,PYALPS DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP DOUBLE PRECISION RAT1,RAT2 DOUBLE PRECISION T3T,CA,CB,FCOL DOUBLE PRECISION ALFA,BETA,TANB DOUBLE PRECISION PYGAUS,PYXXGA EXTERNAL PYXXW5,PYGAUS,PYXXZ5 DOUBLE PRECISION PREC INTEGER KFNCHI(4),KFCCHI(2) DATA ETAH/1D0,1D0,-1D0/ DATA ITH/25,35,36/ DATA ITHC/37/ DATA PREC/1D-2/ DATA PI/3.141592654D0/ DATA SR2/1.4142136D0/ DATA KFNCHI/1000022,1000023,1000025,1000035/ DATA KFCCHI/1000024,1000037/ C...COUNT THE NUMBER OF DECAY MODES LKNT=0 XMW=PMAS(24,1) XMW2=XMW**2 XMZ=PMAS(23,1) XMZ2=XMZ**2 XW=1D0-XMW2/XMZ2 TANW = SQRT(XW/(1D0-XW)) C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER KCIN=PYCOMP(KFIN) IX=1 IF(KFIN.EQ.KFNCHI(2)) IX=2 IF(KFIN.EQ.KFNCHI(3)) IX=3 IF(KFIN.EQ.KFNCHI(4)) IX=4 XMI=SMZ(IX) XMI2=XMI**2 AXMI=ABS(XMI) AEM=PYALEM(XMI2) AS =PYALPS(XMI2) C1=AEM/XW XMI3=ABS(XMI**3) TANB=RMSS(5) BETA=ATAN(TANB) ALFA=RMSS(18) CBETA=COS(BETA) SBETA=TANB*CBETA CALFA=COS(ALFA) SALFA=SIN(ALFA) C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS IF(IX.EQ.1.AND.IMSS(11).EQ.0) THEN RETURN ENDIF C...FORCE CHI0_2 -> CHI0_1 + GAMMA IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN XMJ=SMZ(1) AXMJ=ABS(XMJ) LKNT=LKNT+1 GAMCON=AEM**3/8D0/PI/XMW2/XW XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2) IDLAM(LKNT,1)=KSUSY1+22 IDLAM(LKNT,2)=22 IDLAM(LKNT,3)=0 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT) GOTO 290 ENDIF C...GRAVITINO DECAY MODES IF(IMSS(11).EQ.1) THEN XMP=RMSS(28) IDG=39+KSUSY1 XMGR=PMAS(PYCOMP(IDG),1) SINW=SQRT(XW) COSW=SQRT(1D0-XW) XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI IF(AXMI.GT.XMGR+PMAS(22,1)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=22 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*(ZMIX(IX,1)*COSW+ZMIX(IX,2)*SINW)**2 ENDIF IF(AXMI.GT.XMGR+XMZ) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=23 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*((ZMIX(IX,1)*SINW-ZMIX(IX,2)*COSW)**2 + $ .5D0*(ZMIX(IX,3)*CBETA-ZMIX(IX,4)*SBETA)**2)*(1D0-XMZ2/XMI2)**4 ENDIF IF(AXMI.GT.XMGR+PMAS(25,1)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=25 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SALFA-ZMIX(IX,4)*CALFA)**2)* $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4 ENDIF IF(AXMI.GT.XMGR+PMAS(35,1)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=35 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*CALFA+ZMIX(IX,4)*SALFA)**2)* $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4 ENDIF IF(AXMI.GT.XMGR+PMAS(36,1)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=36 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*((ZMIX(IX,3)*SBETA+ZMIX(IX,4)*CBETA)**2)* $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4 ENDIF ENDIF DO 180 IJ=1,IX-1 XMJ=SMZ(IJ) AXMJ=ABS(XMJ) XMJ2=XMJ**2 C...CHI0_I -> CHI0_J + GAMMA IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN RAT1=ZMIX(IJ,1)**2+ZMIX(IJ,2)**2 RAT1=RAT1/( 1D-6+ZMIX(IX,3)**2+ZMIX(IX,4)**2 ) RAT2=ZMIX(IX,1)**2+ZMIX(IX,2)**2 RAT2=RAT2/( 1D-6+ZMIX(IJ,3)**2+ZMIX(IJ,4)**2 ) IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR. & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=22 IDLAM(LKNT,3)=0 GAMCON=AEM**3/8D0/PI/XMW2/XW XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2) ENDIF ENDIF C...CHI0_I -> CHI0_J + Z0 IF(AXMI.GE.AXMJ+XMZ) THEN LKNT=LKNT+1 GL=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4)) GR=-GL XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=23 IDLAM(LKNT,3)=0 ELSEIF(AXMI.GE.AXMJ) THEN FID=11 EI=KCHG(FID,1)/3D0 T3=-0.5D0 XXM(1)=0D0 XXM(2)=XMJ XXM(3)=0D0 XXM(4)=XMI XXM(5)=PMAS(PYCOMP(KSUSY1+11),1) XXM(6)=PMAS(PYCOMP(KSUSY2+11),1) XXM(7)=XMZ XXM(8)=PMAS(23,2) XXM(9)=-0.5D0*(ZMIX(IX,3)*ZMIX(IJ,3)-ZMIX(IX,4)*ZMIX(IJ,4)) XXM(10)=-XXM(9) XXM(11)=(T3-EI*XW)/(1D0-XW) XXM(12)=-EI*XW/(1D0-XW) XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1)) XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1)) XXM(15)=SR2*TANW*(EI*ZMIX(IX,1)) XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1)) S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 C...CHARGED LEPTONS IF( XXM(5).LT.AXMI ) THEN XXM(5)=1D6 ENDIF IF(XXM(6).LT.AXMI ) THEN XXM(6)=1D6 ENDIF IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=11 IDLAM(LKNT,3)=-11 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=13 IDLAM(LKNT,3)=-13 ENDIF ENDIF 100 CONTINUE IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN XXM(5)=PMAS(PYCOMP(KSUSY1+15),1) XXM(6)=PMAS(PYCOMP(KSUSY2+15),1) ELSE XXM(6)=PMAS(PYCOMP(KSUSY1+15),1) XXM(5)=PMAS(PYCOMP(KSUSY2+15),1) ENDIF IF( XXM(5).LT.AXMI ) THEN XXM(5)=1D6 ENDIF IF(XXM(6).LT.AXMI ) THEN XXM(6)=1D6 ENDIF IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=15 IDLAM(LKNT,3)=-15 ENDIF C...NEUTRINOS 110 CONTINUE FID=12 EI=KCHG(FID,1)/3D0 T3=0.5D0 XXM(5)=PMAS(PYCOMP(KSUSY1+12),1) XXM(6)=1D6 XXM(11)=(T3-EI*XW)/(1D0-XW) XXM(12)=-EI*XW/(1D0-XW) XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1)) XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1)) XXM(15)=SR2*TANW*(EI*ZMIX(IX,1)) XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1)) IF( XXM(5).LT.AXMI ) THEN XXM(5)=1D6 ENDIF LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=12 IDLAM(LKNT,3)=-12 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=14 IDLAM(LKNT,3)=-14 120 CONTINUE XXM(5)=PMAS(PYCOMP(KSUSY1+16),1) IF( XXM(5).LT.AXMI ) THEN XXM(5)=1D6 ENDIF LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=16 IDLAM(LKNT,3)=-16 C...D-TYPE QUARKS 130 CONTINUE XXM(5)=PMAS(PYCOMP(KSUSY1+1),1) XXM(6)=PMAS(PYCOMP(KSUSY2+1),1) FID=1 EI=KCHG(FID,1)/3D0 T3=-0.5D0 XXM(11)=(T3-EI*XW)/(1D0-XW) XXM(12)=-EI*XW/(1D0-XW) XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1)) XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1)) XXM(15)=SR2*TANW*(EI*ZMIX(IX,1)) XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1)) IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 140 IF( XXM(5).LT.AXMI ) THEN XXM(5)=1D6 ELSEIF( XXM(6).LT.AXMI ) THEN XXM(6)=1D6 ENDIF IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0 IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-1 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=3 IDLAM(LKNT,3)=-3 ENDIF ENDIF 140 CONTINUE IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN XXM(5)=PMAS(PYCOMP(KSUSY1+5),1) XXM(6)=PMAS(PYCOMP(KSUSY2+5),1) ELSE XXM(6)=PMAS(PYCOMP(KSUSY1+5),1) XXM(5)=PMAS(PYCOMP(KSUSY2+5),1) ENDIF IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 150 IF(XXM(5).LT.AXMI) THEN XXM(5)=1D6 ELSEIF(XXM(6).LT.AXMI) THEN XXM(6)=1D6 ENDIF IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0 IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=5 IDLAM(LKNT,3)=-5 ENDIF C...U-TYPE QUARKS 150 CONTINUE XXM(5)=PMAS(PYCOMP(KSUSY1+2),1) XXM(6)=PMAS(PYCOMP(KSUSY2+2),1) FID=2 EI=KCHG(FID,1)/3D0 T3=0.5D0 XXM(11)=(T3-EI*XW)/(1D0-XW) XXM(12)=-EI*XW/(1D0-XW) XXM(13)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1)) XXM(14)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1)) XXM(15)=SR2*TANW*(EI*ZMIX(IX,1)) XXM(16)=SR2*TANW*(EI*ZMIX(IJ,1)) IF( XXM(5).LT.AXMI .AND. XXM(6).LT.AXMI ) GOTO 160 IF(XXM(5).LT.AXMI) THEN XXM(5)=1D6 ELSEIF(XXM(6).LT.AXMI) THEN XXM(6)=1D6 ENDIF IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3)*3D0 IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=2 IDLAM(LKNT,3)=-2 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=4 IDLAM(LKNT,3)=-4 ENDIF ENDIF 160 CONTINUE ENDIF C...CHI0_I -> CHI0_J + H0_K EH(1)=SIN(ALFA) EH(2)=COS(ALFA) EH(3)=-SIN(BETA) DH(1)=COS(ALFA) DH(2)=-SIN(ALFA) DH(3)=COS(BETA) QIJ=ZMIX(IX,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IX,2)- & TANW*(ZMIX(IX,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IX,1)) RIJ=ZMIX(IX,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IX,2)- & TANW*(ZMIX(IX,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IX,1)) DO 170 IH=1,3 XMH=PMAS(ITH(IH),1) XMH2=XMH**2 IF(AXMI.GE.AXMJ+XMH) THEN LKNT=LKNT+1 XL=PYLAMF(XMI2,XMJ2,XMH2) F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH)) F12K=F21K C...SIGN OF MASSES I,J XMK=XMJ IF(IH.EQ.3) XMK=-XMK XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=ITH(IH) IDLAM(LKNT,3)=0 ENDIF 170 CONTINUE 180 CONTINUE C...CHI0_I -> CHI+_J + W- DO 220 IJ=1,2 XMJ=SMW(IJ) AXMJ=ABS(XMJ) XMJ2=XMJ**2 IF(AXMI.GE.AXMJ+XMW) THEN LKNT=LKNT+1 GL=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2 GR=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=-24 IDLAM(LKNT,3)=0 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-KFCCHI(IJ) IDLAM(LKNT,2)=24 IDLAM(LKNT,3)=0 ELSEIF(AXMI.GE.AXMJ) THEN S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 XXM(5)=ZMIX(IX,2)*VMIX(IJ,1)-ZMIX(IX,4)*VMIX(IJ,2)/SR2 XXM(6)=ZMIX(IX,2)*UMIX(IJ,1)+ZMIX(IX,3)*UMIX(IJ,2)/SR2 C...LEPTONS FID=11 EI=KCHG(FID,1)/3D0 T3=-0.5D0 XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1) FID=12 EI=KCHG(FID,1)/3D0 T3=0.5D0 XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1) XXM(1)=0D0 XXM(2)=XMJ XXM(3)=0D0 XXM(4)=XMI XXM(9)=PMAS(24,1) XXM(10)=PMAS(24,2) XXM(11)=PMAS(PYCOMP(KSUSY1+11),1) XXM(12)=PMAS(PYCOMP(KSUSY1+12),1) IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 190 IF(XXM(11).LT.AXMI) THEN XXM(11)=1D6 ELSEIF(XXM(12).LT.AXMI) THEN XXM(12)=1D6 ENDIF IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=11 IDLAM(LKNT,3)=-12 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=13 IDLAM(LKNT,3)=-14 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ENDIF ENDIF 190 CONTINUE IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN XXM(11)=PMAS(PYCOMP(KSUSY1+15),1) XXM(12)=PMAS(PYCOMP(KSUSY1+16),1) ELSE XXM(11)=PMAS(PYCOMP(KSUSY2+15),1) XXM(12)=PMAS(PYCOMP(KSUSY1+16),1) ENDIF IF(XXM(11).LT.AXMI) THEN XXM(11)=1D6 ENDIF IF(XXM(12).LT.AXMI) THEN XXM(12)=1D6 ENDIF IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC) XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=15 IDLAM(LKNT,3)=-16 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ENDIF C...NOW, DO THE QUARKS 200 CONTINUE FID=1 EI=KCHG(FID,1)/3D0 T3=-0.5D0 XXM(7)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*UMIX(IJ,1) FID=2 EI=KCHG(FID,1)/3D0 T3=0.5D0 XXM(8)=-SR2*(T3*ZMIX(IX,2)-TANW*(T3-EI)*ZMIX(IX,1))*VMIX(IJ,1) XXM(11)=PMAS(PYCOMP(KSUSY1+1),1) XXM(12)=PMAS(PYCOMP(KSUSY1+2),1) IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 210 IF(XXM(11).LT.AXMI) THEN XXM(11)=1D6 ELSEIF(XXM(12).LT.AXMI) THEN XXM(12)=1D6 ENDIF IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-2 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=3 IDLAM(LKNT,3)=-4 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ENDIF ENDIF 210 CONTINUE ENDIF 220 CONTINUE 230 CONTINUE C...CHI0_I -> CHI+_I + H- DO 240 IJ=1,2 XMJ=SMW(IJ) AXMJ=ABS(XMJ) XMJ2=XMJ**2 XMHP=PMAS(ITHC,1) XMHP2=XMHP**2 IF(AXMI.GE.AXMJ+XMHP) THEN LKNT=LKNT+1 GL=CBETA*(ZMIX(IX,4)*VMIX(IJ,1)+(ZMIX(IX,2)+ & ZMIX(IX,1)*TANW)*VMIX(IJ,2)/SR2) GR=SBETA*(ZMIX(IX,3)*UMIX(IJ,1)-(ZMIX(IX,2)+ & ZMIX(IX,1)*TANW)*UMIX(IJ,2)/SR2) XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=-ITHC IDLAM(LKNT,3)=0 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ELSE ENDIF 240 CONTINUE C...2-BODY DECAYS TO FERMION SFERMION DO 250 J=1,16 IF(J.GE.7.AND.J.LE.10) GOTO 250 KF1=KSUSY1+J KF2=KSUSY2+J XMSF1=PMAS(PYCOMP(KF1),1) XMSF2=PMAS(PYCOMP(KF2),1) XMF=PMAS(J,1) IF(J.LE.6) THEN FCOL=3D0 ELSE FCOL=1D0 ENDIF EI=KCHG(J,1)/3D0 T3T=SIGN(1D0,EI) IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0 IF(MOD(J,2).EQ.0) THEN BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T) AL=XMF*ZMIX(IX,4)/XMW/SBETA AR=-2D0*EI*TANW*ZMIX(IX,1) BR=AL ELSE BL=T3T*ZMIX(IX,2)+TANW*ZMIX(IX,1)*(2D0*EI-T3T) AL=XMF*ZMIX(IX,3)/XMW/CBETA AR=-2D0*EI*TANW*ZMIX(IX,1) BR=AL ENDIF C...D~ D_L IF(AXMI.GE.XMF+XMSF1) THEN LKNT=LKNT+1 XMA2=XMSF1**2 XMB2=XMF**2 XL=PYLAMF(XMI2,XMA2,XMB2) CA=AL*SFMIX(J,1)+AR*SFMIX(J,2) CB=BL*SFMIX(J,1)+BR*SFMIX(J,2) XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI) IDLAM(LKNT,1)=KF1 IDLAM(LKNT,2)=-J IDLAM(LKNT,3)=0 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=0 ENDIF C...D~ D_R IF(AXMI.GE.XMF+XMSF2) THEN LKNT=LKNT+1 XMA2=XMSF2**2 XMB2=XMF**2 CA=AL*SFMIX(J,3)+AR*SFMIX(J,4) CB=BL*SFMIX(J,3)+BR*SFMIX(J,4) XL=PYLAMF(XMI2,XMA2,XMB2) XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI) IDLAM(LKNT,1)=KF2 IDLAM(LKNT,2)=-J IDLAM(LKNT,3)=0 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=0 ENDIF 250 CONTINUE C...3-BODY DECAY TO Q Q~ GLUINO XMJ=PMAS(PYCOMP(KSUSY1+21),1) IF(AXMI.GE.XMJ) THEN AXMJ=ABS(XMJ) XXM(1)=0D0 XXM(2)=XMJ XXM(3)=0D0 XXM(4)=XMI XXM(5)=PMAS(PYCOMP(KSUSY1+1),1) XXM(6)=PMAS(PYCOMP(KSUSY2+1),1) XXM(7)=1D6 XXM(8)=0D0 XXM(9)=0D0 XXM(10)=0D0 S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 C...ALL QUARKS BUT T XXM(11)=0D0 XXM(12)=0D0 XXM(13)=1D0 XXM(14)=-SR2*(-0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0) XXM(15)=1D0 XXM(16)=SR2*(-TANW*ZMIX(IX,1)/3D0) IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 260 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-1 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=3 IDLAM(LKNT,3)=-3 ENDIF ENDIF 260 CONTINUE IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN XXM(5)=PMAS(PYCOMP(KSUSY1+5),1) XXM(6)=PMAS(PYCOMP(KSUSY2+5),1) ELSE XXM(6)=PMAS(PYCOMP(KSUSY1+5),1) XXM(5)=PMAS(PYCOMP(KSUSY2+5),1) ENDIF IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 270 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=5 IDLAM(LKNT,3)=-5 ENDIF C...U-TYPE QUARKS 270 CONTINUE XXM(5)=PMAS(PYCOMP(KSUSY1+2),1) XXM(6)=PMAS(PYCOMP(KSUSY2+2),1) XXM(13)=1D0 XXM(14)=-SR2*(0.5D0*ZMIX(IX,2)+TANW*ZMIX(IX,1)/6D0) XXM(15)=1D0 XXM(16)=SR2*(2D0*TANW*ZMIX(IX,1)/3D0) IF( XXM(5).LT.AXMI .OR. XXM(6).LT.AXMI ) GOTO 280 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ5,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=2 IDLAM(LKNT,3)=-2 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=4 IDLAM(LKNT,3)=-4 ENDIF ENDIF 280 CONTINUE ENDIF 290 IKNT=LKNT XLAM(0)=0D0 DO 300 I=1,IKNT IF(XLAM(I).LT.0D0) XLAM(I)=0D0 XLAM(0)=XLAM(0)+XLAM(I) 300 CONTINUE IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6 RETURN END C********************************************************************* C...PYCJDC C...Calculate decay widths for the charginos (admixtures of C...charged Wino and charged Higgsino. C...Input: KCIN = KF code for particle C...Output: XLAM = widths C... IDLAM = KF codes for decay particles C... IKNT = number of decay channels defined C...AUTHOR: STEPHEN MRENNA C...Last change: C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e C...when CHIENU .NE. 0 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4) COMMON/PYINTS/XXM(20) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTS/ C...Local variables. INTEGER KFIN,KCIN DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2, &XMZ,XMZ2,AXMJ,AXMI DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG DOUBLE PRECISION S12MIN,S12MAX DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2,XMK DOUBLE PRECISION PYLAMF,XL DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3,BETA,ALFA DOUBLE PRECISION PYX2XH,PYX2XG DOUBLE PRECISION XLAM(0:200) INTEGER IDLAM(200,3) INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID INTEGER ITH(3) INTEGER ITHC DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3) DOUBLE PRECISION SR2 DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB DOUBLE PRECISION PYALEM,PI,PYALPS DOUBLE PRECISION AL,BL,AR,BR,ALP,BLP,ARP,BRP DOUBLE PRECISION CA,CB,FCOL INTEGER KF1,KF2,ISF INTEGER KFNCHI(4),KFCCHI(2) DOUBLE PRECISION TEMP DOUBLE PRECISION PYGAUS EXTERNAL PYGAUS,PYXXZ5,PYXXW5,PYXXZ2 DOUBLE PRECISION PREC DATA ITH/25,35,36/ DATA ITHC/37/ DATA ETAH/1D0,1D0,-1D0/ DATA SR2/1.4142136D0/ DATA PI/3.141592654D0/ DATA PREC/1D-2/ DATA KFNCHI/1000022,1000023,1000025,1000035/ DATA KFCCHI/1000024,1000037/ C...COUNT THE NUMBER OF DECAY MODES LKNT=0 XMW=PMAS(24,1) XMW2=XMW**2 XMZ=PMAS(23,1) XMZ2=XMZ**2 XW=1D0-XMW2/XMZ2 TANW = SQRT(XW/(1D0-XW)) C...1 OR 2 DEPENDING ON CHARGINO TYPE IX=1 IF(KFIN.EQ.KFCCHI(2)) IX=2 KCIN=PYCOMP(KFIN) XMI=SMW(IX) XMI2=XMI**2 AXMI=ABS(XMI) AEM=PYALEM(XMI2) AS =PYALPS(XMI2) C1=AEM/XW XMI3=ABS(XMI**3) TANB=RMSS(5) BETA=ATAN(TANB) CBETA=COS(BETA) SBETA=TANB*CBETA ALFA=RMSS(18) C...GRAVITINO DECAY MODES IF(IMSS(11).EQ.1) THEN XMP=RMSS(28) IDG=39+KSUSY1 XMGR=PMAS(PYCOMP(IDG),1) SINW=SQRT(XW) COSW=SQRT(1D0-XW) XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI IF(AXMI.GT.XMGR+XMW) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=24 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*(.5D0*(VMIX(IX,1)**2+UMIX(IX,1)**2)+ & .5D0*((VMIX(IX,2)*SBETA)**2+(UMIX(IX,2)*CBETA)**2))* & (1D0-XMW2/XMI2)**4 ENDIF IF(AXMI.GT.XMGR+PMAS(37,1)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=37 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*(.5D0*((VMIX(IX,2)*CBETA)**2+ & (UMIX(IX,2)*SBETA)**2)) & *(1D0-PMAS(37,1)**2/XMI2)**4 ENDIF ENDIF C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS IF(IX.EQ.1) GOTO 150 XMJ=SMW(1) AXMJ=ABS(XMJ) XMJ2=XMJ**2 C...CHI_2+ -> CHI_1+ + Z0 IF(AXMI.GE.AXMJ+XMZ) THEN LKNT=LKNT+1 GL=VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2) GR=UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2) XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GL,GR) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=23 IDLAM(LKNT,3)=0 C...CHARGED LEPTONS ELSEIF(AXMI.GE.AXMJ) THEN XXM(5)=-(VMIX(2,1)*VMIX(1,1)+0.5D0*VMIX(2,2)*VMIX(1,2)) XXM(6)=-(UMIX(2,1)*UMIX(1,1)+0.5D0*UMIX(2,2)*UMIX(1,2)) XXM(9)=XMZ XXM(10)=PMAS(23,2) XXM(1)=0D0 XXM(2)=XMJ XXM(3)=0D0 XXM(4)=XMI S12MIN=0D0 S12MAX=(AXMJ-AXMI)**2 XXM(7)= (-0.5D0+XW)/(1D0-XW) XXM(8)= XW/(1D0-XW) XXM(11)=PMAS(PYCOMP(KSUSY1+12),1) XXM(12)=VMIX(2,1)*VMIX(1,1) IF( XXM(11).LT.AXMI ) THEN XXM(11)=1D6 ENDIF IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=11 IDLAM(LKNT,3)=-11 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=13 IDLAM(LKNT,3)=-13 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=15 IDLAM(LKNT,3)=-15 ENDIF ENDIF ENDIF C...NEUTRINOS 100 CONTINUE XXM(7)= (0.5D0)/(1D0-XW) XXM(8)= 0D0 XXM(11)=PMAS(PYCOMP(KSUSY1+11),1) XXM(12)=UMIX(2,1)*UMIX(1,1) IF( XXM(11).LT.AXMI ) THEN XXM(11)=1D6 ENDIF IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=12 IDLAM(LKNT,3)=-12 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=14 IDLAM(LKNT,3)=-14 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=16 IDLAM(LKNT,3)=-16 ENDIF C...D-TYPE QUARKS 110 CONTINUE XXM(7)= (-0.5D0+XW/3D0)/(1D0-XW) XXM(8)= XW/3D0/(1D0-XW) XXM(11)=PMAS(PYCOMP(KSUSY1+2),1) XXM(12)=VMIX(2,1)*VMIX(1,1) IF( XXM(11).LT.AXMI ) GOTO 120 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-1 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=3 IDLAM(LKNT,3)=-3 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=5 IDLAM(LKNT,3)=-5 ENDIF ENDIF ENDIF C...U-TYPE QUARKS 120 CONTINUE XXM(7)= (0.5D0-2D0*XW/3D0)/(1D0-XW) XXM(8)= -2D0*XW/3D0/(1D0-XW) XXM(11)=PMAS(PYCOMP(KSUSY1+1),1) XXM(12)=UMIX(2,1)*UMIX(1,1) IF( XXM(11).LT.AXMI ) GOTO 130 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ2,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=2 IDLAM(LKNT,3)=-2 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=4 IDLAM(LKNT,3)=-4 ENDIF ENDIF 130 CONTINUE ENDIF C...CHI_2+ -> CHI_1+ + H0_K EH(2)=COS(ALFA) EH(1)=SIN(ALFA) EH(3)=-SBETA DH(2)=-SIN(ALFA) DH(1)=COS(ALFA) DH(3)=COS(BETA) DO 140 IH=1,3 XMH=PMAS(ITH(IH),1) XMH2=XMH**2 C...NO 3-BODY OPTION IF(AXMI.GE.AXMJ+XMH) THEN LKNT=LKNT+1 XL=PYLAMF(XMI2,XMJ2,XMH2) F21K=(VMIX(2,1)*UMIX(1,2)*EH(IH) - & VMIX(2,2)*UMIX(1,1)*DH(IH))/SR2 F12K=(VMIX(1,1)*UMIX(2,2)*EH(IH) - & VMIX(1,2)*UMIX(2,1)*DH(IH))/SR2 XMK=XMJ*ETAH(IH) XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,F12K,F21K) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=ITH(IH) IDLAM(LKNT,3)=0 ENDIF 140 CONTINUE C...CHI1 JUMPS TO HERE 150 CONTINUE C...CHI+_I -> CHI0_J + W+ DO 180 IJ=1,4 XMJ=SMZ(IJ) AXMJ=ABS(XMJ) XMJ2=XMJ**2 IF(AXMI.GE.AXMJ+XMW) THEN LKNT=LKNT+1 GL=ZMIX(IJ,2)*VMIX(IX,1)-ZMIX(IJ,4)*VMIX(IX,2)/SR2 GR=ZMIX(IJ,2)*UMIX(IX,1)+ZMIX(IJ,3)*UMIX(IX,2)/SR2 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GL,GR) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=24 IDLAM(LKNT,3)=0 C...LEPTONS ELSEIF(AXMI.GE.AXMJ) THEN XMF1=0D0 XMF2=0D0 S12MIN=(XMF1+XMF2)**2 S12MAX=(AXMJ-AXMI)**2 XXM(5)=-1D0/SR2*ZMIX(IJ,4)*VMIX(IX,2)+ZMIX(IJ,2)*VMIX(IX,1) XXM(6)= 1D0/SR2*ZMIX(IJ,3)*UMIX(IX,2)+ZMIX(IJ,2)*UMIX(IX,1) FID=11 EI=KCHG(FID,1)/3D0 T3=-0.5D0 XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1) FID=12 EI=KCHG(FID,1)/3D0 T3=0.5D0 XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1) XXM(4)=XMI XXM(1)=XMF1 XXM(2)=XMJ XXM(3)=XMF2 XXM(9)=PMAS(24,1) XXM(10)=PMAS(24,2) XXM(11)=PMAS(PYCOMP(KSUSY1+11),1) XXM(12)=PMAS(PYCOMP(KSUSY1+12),1) C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW, C...--> 1/(16PI)/M**3*(AEM/XW)**2 IF(XXM(11).LT.AXMI) THEN XXM(11)=1D6 ENDIF IF(XXM(12).LT.AXMI) THEN XXM(12)=1D6 ENDIF IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN LKNT=LKNT+1 TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC) XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=-11 IDLAM(LKNT,3)=12 C...ONLY DECAY CHI+1 -> E+ NU_E IF( IMSS(12).NE. 0 ) GOTO 220 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN LKNT=LKNT+1 XXM(11)=PMAS(PYCOMP(KSUSY1+13),1) XXM(12)=PMAS(PYCOMP(KSUSY1+14),1) IF(XXM(11).LT.AXMI) THEN XXM(11)=1D6 ELSEIF(XXM(12).LT.AXMI) THEN XXM(12)=1D6 ENDIF TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC) XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=-13 IDLAM(LKNT,3)=14 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN LKNT=LKNT+1 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN XXM(11)=PMAS(PYCOMP(KSUSY1+15),1) ELSE XXM(11)=PMAS(PYCOMP(KSUSY2+15),1) ENDIF XXM(12)=PMAS(PYCOMP(KSUSY1+16),1) IF(XXM(11).LT.AXMI) THEN XXM(11)=1D6 ENDIF IF(XXM(12).LT.AXMI) THEN XXM(12)=1D6 ENDIF TEMP=PYGAUS(PYXXW5,S12MIN,S12MAX,PREC) XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=-15 IDLAM(LKNT,3)=16 ENDIF ENDIF ENDIF C...NOW, DO THE QUARKS 160 CONTINUE FID=1 EI=KCHG(FID,1)/3D0 T3=-0.5D0 XXM(7)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*UMIX(IX,1) FID=1 EI=KCHG(FID,1)/3D0 T3=0.5D0 XXM(8)=-SR2*(T3*ZMIX(IJ,2)-TANW*(T3-EI)*ZMIX(IJ,1))*VMIX(IX,1) XXM(11)=PMAS(PYCOMP(KSUSY1+1),1) XXM(12)=PMAS(PYCOMP(KSUSY1+2),1) IF( XXM(11).LT.AXMI .AND. XXM(12).LT.AXMI ) GOTO 170 IF(XXM(11).LT.AXMI) THEN XXM(11)=1D6 ELSEIF(XXM(12).LT.AXMI) THEN XXM(12)=1D6 ENDIF IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=-1 IDLAM(LKNT,3)=2 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=-3 IDLAM(LKNT,3)=4 ENDIF ENDIF 170 CONTINUE ENDIF 180 CONTINUE C...CHI+_I -> CHI0_J + H+ DO 190 IJ=1,4 XMJ=SMZ(IJ) AXMJ=ABS(XMJ) XMJ2=XMJ**2 XMHP=PMAS(ITHC,1) XMHP2=XMHP**2 IF(AXMI.GE.AXMJ+XMHP) THEN LKNT=LKNT+1 GL=CBETA*(ZMIX(IJ,4)*VMIX(IX,1)+(ZMIX(IJ,2)+ & ZMIX(IJ,1)*TANW)*VMIX(IX,2)/SR2) GR=SBETA*(ZMIX(IJ,3)*UMIX(IX,1)-(ZMIX(IJ,2)+ & ZMIX(IJ,1)*TANW)*UMIX(IX,2)/SR2) XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GL,GR) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=ITHC IDLAM(LKNT,3)=0 ELSE ENDIF 190 CONTINUE C...2-BODY DECAYS TO FERMION SFERMION DO 200 J=1,16 IF(J.GE.7.AND.J.LE.10) GOTO 200 IF(MOD(J,2).EQ.0) THEN KF1=KSUSY1+J-1 ELSE KF1=KSUSY1+J+1 ENDIF KF2=KF1+KSUSY1 XMSF1=PMAS(PYCOMP(KF1),1) XMSF2=PMAS(PYCOMP(KF2),1) XMF=PMAS(J,1) IF(J.LE.6) THEN FCOL=3D0 ELSE FCOL=1D0 ENDIF C...U~ D_L IF(MOD(J,2).EQ.0) THEN XMFP=PMAS(J-1,1) AL=UMIX(IX,1) BL=-XMF*VMIX(IX,2)/XMW/SBETA/SR2 AR=-XMFP*UMIX(IX,2)/XMW/CBETA/SR2 BR=0D0 ISF=J-1 ELSE XMFP=PMAS(J+1,1) AL=VMIX(IX,1) BL=-XMF*UMIX(IX,2)/XMW/CBETA/SR2 BR=0D0 AR=-XMFP*VMIX(IX,2)/XMW/SBETA/SR2 ISF=J+1 ENDIF C...~U_L D IF(AXMI.GE.XMF+XMSF1) THEN LKNT=LKNT+1 XMA2=XMSF1**2 XMB2=XMF**2 XL=PYLAMF(XMI2,XMA2,XMB2) CA=AL*SFMIX(ISF,1)+AR*SFMIX(ISF,2) CB=BL*SFMIX(ISF,1)+BR*SFMIX(ISF,2) XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI) IDLAM(LKNT,3)=0 IF(MOD(J,2).EQ.0) THEN IDLAM(LKNT,1)=-KF1 IDLAM(LKNT,2)=J ELSE IDLAM(LKNT,1)=KF1 IDLAM(LKNT,2)=-J ENDIF ENDIF C...U~ D_R IF(AXMI.GE.XMF+XMSF2) THEN LKNT=LKNT+1 XMA2=XMSF2**2 XMB2=XMF**2 CA=AL*SFMIX(ISF,3)+AR*SFMIX(ISF,4) CB=BL*SFMIX(ISF,3)+BR*SFMIX(ISF,4) XL=PYLAMF(XMI2,XMA2,XMB2) XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* & (CA**2+CB**2)+4D0*CA*CB*XMF*XMI) IDLAM(LKNT,3)=0 IF(MOD(J,2).EQ.0) THEN IDLAM(LKNT,1)=-KF2 IDLAM(LKNT,2)=J ELSE IDLAM(LKNT,1)=KF2 IDLAM(LKNT,2)=-J ENDIF ENDIF 200 CONTINUE C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH C...A 2-BODY -- 2-BODY CHAIN XMJ=PMAS(PYCOMP(KSUSY1+21),1) IF(AXMI.GE.XMJ) THEN AXMJ=ABS(XMJ) S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 XXM(1)=0D0 XXM(2)=XMJ XXM(3)=0D0 XXM(4)=XMI XXM(5)=0D0 XXM(6)=0D0 XXM(9)=1D6 XXM(10)=0D0 XXM(7)=UMIX(IX,1)*SR2 XXM(8)=VMIX(IX,1)*SR2 XXM(11)=PMAS(PYCOMP(KSUSY1+1),1) XXM(12)=PMAS(PYCOMP(KSUSY1+2),1) IF( XXM(11).LT.AXMI .OR. XXM(12).LT.AXMI ) GOTO 210 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXW5,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=-1 IDLAM(LKNT,3)=2 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=-3 IDLAM(LKNT,3)=4 ENDIF ENDIF 210 CONTINUE ENDIF 220 IKNT=LKNT XLAM(0)=0D0 DO 230 I=1,IKNT XLAM(0)=XLAM(0)+XLAM(I) IF(XLAM(I).LT.0D0) THEN WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN, & (IDLAM(I,J),J=1,3) XLAM(I)=0D0 ENDIF 230 CONTINUE IF(XLAM(0).EQ.0D0) THEN XLAM(0)=1D-6 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0) WRITE(MSTU(11),*) LKNT WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT) ENDIF RETURN END C********************************************************************* C...PYXXZ5 C...Calculates chi0 -> chi0 + f + ~f. FUNCTION PYXXZ5(X) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYINTS/XXM(20) SAVE /PYDAT1/,/PYINTS/ C...Local variables. DOUBLE PRECISION PYXXZ5,X DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,WPROP2 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2 DOUBLE PRECISION SIJ DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSU,XMSD DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,FLI,FLJ,FRI,FRJ DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL INTEGER I DATA SR2/1.4142136D0/ C...Statement functions. C...Integral from x to y of (t-a)(b-t) dt. TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B) C...Integral from x to y of (t-a)(b-t)/(t-c) dt. TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))- &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A) C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt. TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+ &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C))) C...Integral from x to y of (t-a)/(b-t) dt. UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A) C...Integral from x to y of 1/(t-a) dt. TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A))) XM12=XXM(1)**2 XM22=XXM(2)**2 XM32=XXM(3)**2 S=XXM(4)**2 S13=X S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S) S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)* &( (X-XM22-S)**2 -4D0*XM22*S ) ) S23MIN=(S23AVE-S23DEL) S23MAX=(S23AVE+S23DEL) XMV=XXM(7) XMG=XXM(8) XMSD=XXM(5)**2 XMSU=XXM(6)**2 OL=XXM(9) OR=XXM(10) OL2=OL**2 OR2=OR**2 LE=XXM(11) RE=XXM(12) LE2=LE**2 RE2=RE**2 FLI=XXM(13) FLJ=XXM(14) FRI=XXM(15) FRJ=XXM(16) WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2 SIJ=2D0*XXM(2)*XXM(4)*S13 IF(XMV.LE.1000D0) THEN WW=2D0*(LE2+RE2)*(OL2)*( 2D0*TINT(S23MAX,S23MIN,XM22,S) & +SIJ*(S23MAX-S23MIN) )/WPROP2 IF(XXM(5).LE.10000D0) THEN WFL1=2D0*FLI*FLJ*OL*LE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSD) & + SIJ*TPROP(S23MAX,S23MIN,XMSD) ) WFL1=WFL1*(S13-XMV**2)/WPROP2 ELSE WFL1=0D0 ENDIF IF(XXM(6).LE.10000D0) THEN WFL2=2D0*FRI*FRJ*OR*RE*( 2D0*TINT2(S23MAX,S23MIN,XM22,S,XMSU) & + SIJ*TPROP(S23MAX,S23MIN,XMSU) ) WFL2=WFL2*(S13-XMV**2)/WPROP2 ELSE WFL2=0D0 ENDIF ELSE WW=0D0 WFL1=0D0 WFL2=0D0 ENDIF IF(XXM(5).LE.10000D0) THEN WF1=0.5D0*(FLI*FLJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSD) & + SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSD) ) ELSE WF1=0D0 ENDIF IF(XXM(6).LE.10000D0) THEN WF2=0.5D0*(FRI*FRJ)**2*( 2D0*TINT3(S23MAX,S23MIN,XM22,S,XMSU) & + SIJ*UTINT(S23MAX,S23MIN,XMSU,XM22+S-S13-XMSU) ) ELSE WF2=0D0 ENDIF C...WFL1=0.0 C...WFL2=0.0 PYXXZ5=(WW+WF1+WF2+WFL1+WFL2) IF(PYXXZ5.LT.0D0) THEN WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ5 ' WRITE(MSTU(11),*) XXM(1),XXM(2),XXM(3),XXM(4) WRITE(MSTU(11),*) (XXM(I),I=5,8) WRITE(MSTU(11),*) (XXM(I),I=9,12) WRITE(MSTU(11),*) (XXM(I),I=13,16) WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2 WRITE(MSTU(11),*) S23MIN,S23MAX PYXXZ5=0D0 ENDIF RETURN END C********************************************************************* C...PYXXW5 C...Calculates chi0(+) -> chi+(0) + f + ~f'. FUNCTION PYXXW5(X) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYINTS/XXM(20) SAVE /PYDAT1/,/PYINTS/ C...Local variables. DOUBLE PRECISION PYXXW5,X DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2 DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSD,XMSU DOUBLE PRECISION SIJ DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL INTEGER IK SAVE IK DATA IK/0/ DATA SR2/1.4142136D0/ C...Statement functions. C...Integral from x to y of (t-a)(b-t) dt. TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B) C...Integral from x to y of (t-a)(b-t)/(t-c) dt. TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))- &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A) C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt. TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+ &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C))) C...Integral from x to y of (t-a)/(b-t) dt. UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A) C...Integral from x to y of 1/(t-a) dt. TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A))) XM12=XXM(1)**2 XM22=XXM(2)**2 XM32=XXM(3)**2 S=XXM(4)**2 S13=X IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN S23AVE=0.5D0*(XM22+S-S13) S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S ) ELSE S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S) S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)* & ( (X-XM22-S)**2 -4D0*XM22*S ) ) ENDIF S23MIN=(S23AVE-S23DEL) S23MAX=(S23AVE+S23DEL) IF(S23DEL.LT.1D-3) THEN PYXXW5=0D0 RETURN ENDIF XMV=XXM(9) XMG=XXM(10) XMSD=XXM(11)**2 XMSU=XXM(12)**2 OL=XXM(5) OR=XXM(6) FLD=XXM(7) FLU=XXM(8) WPROP2=((S13-XMV**2)**2+(XMV*XMG)**2) SIJ=S13*XXM(2)*XXM(4) IF(XMV.LE.1000D0) THEN WW=(OR**2+OL**2)*TINT(S23MAX,S23MIN,XM22,S) & -2D0*OL*OR*SIJ*(S23MAX-S23MIN) WW=WW/WPROP2 IF(XXM(11).LE.10000D0) THEN WWD=OL*SIJ*TPROP(S23MAX,S23MIN,XMSD) & -OR*TINT2(S23MAX,S23MIN,XM22,S,XMSD) WWD=-WWD*SR2*FLD WWD=WWD*(S13-XMV**2)/WPROP2 ELSE WWD=0D0 ENDIF IF(XXM(12).LE.10000D0) THEN WWU=OR*SIJ*TPROP(S23MAX,S23MIN,XMSU) & -OL*TINT2(S23MAX,S23MIN,XM22,S,XMSU) WWU=WWU*SR2*FLU WWU=WWU*(S13-XMV**2)/WPROP2 ELSE WWU=0D0 ENDIF ELSE WW=0D0 WWD=0D0 WWU=0D0 ENDIF IF(XXM(12).LE.10000D0) THEN WU=0.5D0*FLU**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU) ELSE WU=0D0 ENDIF IF(XXM(11).LE.10000D0) THEN WD=0.5D0*FLD**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD) ELSE WD=0D0 ENDIF IF(XXM(11).LE.10000D0.AND.XXM(12).LE.10000D0) THEN WUD=FLU*FLD*SIJ*UTINT(S23MAX,S23MIN,XMSD,XM22+S-S13-XMSU) ELSE WUD=0D0 ENDIF PYXXW5=WW+WU+WD+WWU+WWD+WUD IF(PYXXW5.LT.0D0) THEN IF(IK.EQ.0) THEN WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXW5 ' WRITE(MSTU(11),*) WW,WU,WD WRITE(MSTU(11),*) WWD,WWU,WUD WRITE(MSTU(11),*) SQRT(S13) WRITE(MSTU(11),*) TINT(S23MAX,S23MIN,XM22,S) IK=1 ENDIF PYXXW5=0D0 ENDIF RETURN END C********************************************************************* C...PYXXGA C...Calculates chi0_i -> chi0_j + gamma. FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL DOUBLE PRECISION F1,F2 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR) F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL) PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2 RETURN END C********************************************************************* C...PYX2XG C...Calculates the decay rate for ino -> ino + gauge boson. FUNCTION PYX2XG(C1,XM1,XM2,XM3,GL,GR) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GL,GR DOUBLE PRECISION XL,PYLAMF,C1 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3 XMI2=XM1**2 XMI3=ABS(XM1**3) XMJ2=XM2**2 XMV2=XM3**2 XL=PYLAMF(XMI2,XMJ2,XMV2) PYX2XG=C1/8D0/XMI3*SQRT(XL) &*((GL**2+GR**2)*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))- &12D0*GL*GR*XM1*XM2*XMV2) RETURN END C********************************************************************* C...PYX2XH C...Calculates the decay rate for ino -> ino + H. FUNCTION PYX2XH(C1,XM1,XM2,XM3,GL,GR) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DOUBLE PRECISION PYX2XH,XM1,XM2,XM3,GL,GR DOUBLE PRECISION XL,PYLAMF,C1 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3 XMI2=XM1**2 XMI3=ABS(XM1**3) XMJ2=XM2**2 XMV2=XM3**2 XL=PYLAMF(XMI2,XMJ2,XMV2) PYX2XH=C1/8D0/XMI3*SQRT(XL) &*((GL**2+GR**2)*(XMI2+XMJ2-XMV2)+ &4D0*GL*GR*XM1*XM2) RETURN END C********************************************************************* C...PYXXZ2 C...Calculates chi+ -> chi+ + f + ~f. FUNCTION PYXXZ2(X) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYINTS/XXM(20) SAVE /PYDAT1/,/PYINTS/ C...Local variables. DOUBLE PRECISION PYXXZ2,X DOUBLE PRECISION XM12,XM22,XM32,S,S23,S13,S12,WPROP2 DOUBLE PRECISION WW,WU,WD,WWU,WWD,WUD DOUBLE PRECISION SR2,OL,OR,FLD,FLU,XMV,XMG,XMSL DOUBLE PRECISION SIJ DOUBLE PRECISION LE,RE,LE2,RE2,OL2,OR2,CT DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL INTEGER I DATA SR2/1.4142136D0/ C...Statement functions. C...Integral from x to y of (t-a)(b-t) dt. TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B) C...Integral from x to y of (t-a)(b-t)/(t-c) dt. TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))- &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A) C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt. TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+ &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C))) C...Integral from x to y of 1/(t-a) dt. TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A))) XM12=XXM(1)**2 XM22=XXM(2)**2 XM32=XXM(3)**2 S=XXM(4)**2 S13=X IF(XXM(1).EQ.0.AND.XXM(3).EQ.0D0) THEN S23AVE=0.5D0*(XM22+S-S13) S23DEL=0.5D0*SQRT( (X-XM22-S)**2-4D0*XM22*S ) ELSE S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S) S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)* & ( (X-XM22-S)**2 -4D0*XM22*S ) ) ENDIF S23MIN=(S23AVE-S23DEL) S23MAX=(S23AVE+S23DEL) IF(S23DEL.LT.1D-3) THEN PYXXZ2=0D0 RETURN ENDIF XMV=XXM(9) XMG=XXM(10) XMSL=XXM(11)**2 OL=XXM(5) OR=XXM(6) OL2=OL**2 OR2=OR**2 LE=XXM(7) RE=XXM(8) LE2=LE**2 RE2=RE**2 CT=XXM(12) WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2 SIJ=XXM(2)*XXM(4)*S13 WW=(LE2+RE2)*(OR2+OL2)*2D0*TINT(S23MAX,S23MIN,XM22,S) &- 4D0*(LE2+RE2)*OL*OR*SIJ*(S23MAX-S23MIN) WW=WW/WPROP2 IF(XMSL.GT.1D4*S) THEN WD=0D0 WWD=0D0 ELSE WD=0.5D0*CT**2*TINT3(S23MAX,S23MIN,XM22,S,XMSL) WWD=OL*TINT2(S23MAX,S23MIN,XM22,S,XMSL)- & OR*SIJ*TPROP(S23MAX,S23MIN,XMSL) WWD=2D0*WWD*LE*CT*(S13-XMV**2)/WPROP2 ENDIF PYXXZ2=(WW+WD+WWD) IF(PYXXZ2.LT.0D0) THEN WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ2 ' WRITE(MSTU(11),*) WW,WD,WWD WRITE(MSTU(11),*) S23MIN,S23MAX WRITE(MSTU(11),*) (XXM(I),I=1,4) WRITE(MSTU(11),*) (XXM(I),I=5,8) WRITE(MSTU(11),*) (XXM(I),I=9,12) PYXXZ2=0D0 ENDIF RETURN END C********************************************************************* C...PYHEXT C...Calculates the non-standard decay modes of the Higgs boson. SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/ C...Local variables. INTEGER KFIN DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2, &XMZ,XMZ2,AXMJ,AXMI DOUBLE PRECISION XMFP,XMF1,XMF2,XMSL,XMG DOUBLE PRECISION S12MIN,S12MAX DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMHP2,XMA2,XMB2 DOUBLE PRECISION PYLAMF,XL,CF,EI INTEGER IDU,IC,ILR,IFL DOUBLE PRECISION TANW,XW,AEM,C1,AS DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR DOUBLE PRECISION XLAM(0:200) INTEGER IDLAM(200,3) INTEGER LKNT,IX,IH,J,IJ,I,IKNT,IK INTEGER ITH(4) INTEGER KFNCHI(4),KFCCHI(2) DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3) DOUBLE PRECISION SR2 DOUBLE PRECISION BETA,ALFA DOUBLE PRECISION CBETA,SBETA,GR,GL,F12K,F21K,TANB DOUBLE PRECISION PYALEM,PI,PYALPS DOUBLE PRECISION AL,BL,AR,BR,ALP,ARP,BLP,BRP,ALR DOUBLE PRECISION XMK,AXMK,XMK2,COSA,SINA,CW,XML DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL DOUBLE PRECISION XMJL,XMJR,XM1,XM2 DATA ITH/25,35,36,37/ DATA ETAH/1D0,1D0,-1D0/ DATA SR2/1.4142136D0/ DATA PI/3.141592654D0/ DATA KFNCHI/1000022,1000023,1000025,1000035/ DATA KFCCHI/1000024,1000037/ C...COUNT THE NUMBER OF DECAY MODES LKNT=IKNT XMW=PMAS(24,1) XMW2=XMW**2 XMZ=PMAS(23,1) XMZ2=XMZ**2 XW=PARU(102) TANW = SQRT(XW/(1D0-XW)) CW=SQRT(1D0-XW) C...1 - 4 DEPENDING ON Higgs species. IH=1 IF(KFIN.EQ.ITH(2)) IH=2 IF(KFIN.EQ.ITH(3)) IH=3 IF(KFIN.EQ.ITH(4)) IH=4 XMI=PMAS(KFIN,1) XMI2=XMI**2 AXMI=ABS(XMI) AEM=PYALEM(XMI2) AS =PYALPS(XMI2) C1=AEM/XW XMI3=ABS(XMI**3) TANB=RMSS(5) BETA=ATAN(TANB) CBETA=COS(BETA) SBETA=TANB*CBETA ALFA=RMSS(18) COSA=COS(ALFA) SINA=SIN(ALFA) ATRIT=RMSS(16) ATRIB=RMSS(15) ATRIL=RMSS(17) XMUZ=-RMSS(4) IF(IH.EQ.4) GOTO 180 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS C...H0_K -> CHI0_I + CHI0_J EH(1)=SINA EH(2)=COSA EH(3)=-SBETA DH(1)=COSA DH(2)=-SINA DH(3)=CBETA DO 110 IJ=1,4 XMJ=SMZ(IJ) AXMJ=ABS(XMJ) DO 100 IK=1,IJ XMK=SMZ(IK) AXMK=ABS(XMK) IF(AXMI.GE.AXMJ+AXMK) THEN LKNT=LKNT+1 F21K=0.5D0* & EH(IH)*( ZMIX(IK,3)*ZMIX(IJ,2)+ZMIX(IJ,3)*ZMIX(IK,2) & -TANW*(ZMIX(IK,3)*ZMIX(IJ,1)+ZMIX(IJ,3)*ZMIX(IK,1)) )+ & 0.5D0*DH(IH)*( ZMIX(IK,4)*ZMIX(IJ,2)+ZMIX(IJ,4)*ZMIX(IK,2) & -TANW*(ZMIX(IK,4)*ZMIX(IJ,1)+ZMIX(IJ,4)*ZMIX(IK,1)) ) F12K=0.5D0* & EH(IH)*(ZMIX(IJ,3)*ZMIX(IK,2)+ZMIX(IK,3)*ZMIX(IJ,2) & -TANW*(ZMIX(IJ,3)*ZMIX(IK,1)+ZMIX(IK,3)*ZMIX(IJ,1)))+ & 0.5D0*DH(IH)*( ZMIX(IJ,4)*ZMIX(IK,2)+ZMIX(IK,4)*ZMIX(IJ,2) & -TANW*(ZMIX(IJ,4)*ZMIX(IK,1)+ZMIX(IK,4)*ZMIX(IJ,1)) ) C...SIGN OF MASSES I,J XML=XMK*ETAH(IH) XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K) IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0 IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=KFNCHI(IK) IDLAM(LKNT,3)=0 ENDIF 100 CONTINUE 110 CONTINUE C...H0_K -> CHI+_I CHI-_J DO 130 IJ=1,2 XMJ=SMW(IJ) AXMJ=ABS(XMJ) DO 120 IK=1,2 XMK=SMW(IK) AXMK=ABS(XMK) IF(AXMI.GE.AXMJ+AXMK) THEN LKNT=LKNT+1 F21K=(VMIX(IJ,1)*UMIX(IK,2)*EH(IH) - & VMIX(IJ,2)*UMIX(IK,1)*DH(IH))/SR2 F12K=(VMIX(IK,1)*UMIX(IJ,2)*EH(IH) - & VMIX(IK,2)*UMIX(IJ,1)*DH(IH))/SR2 XML=-XMK*ETAH(IH) XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,F12K,F21K) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=-KFCCHI(IK) IDLAM(LKNT,3)=0 ENDIF 120 CONTINUE 130 CONTINUE C...HIGGS TO SFERMION SFERMION DO 160 IFL=1,16 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 160 IJ=KSUSY1+IFL XMJL=PMAS(PYCOMP(IJ),1) XMJR=PMAS(PYCOMP(IJ+KSUSY1),1) IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN XMJ=XMJL XMJ2=XMJ**2 XL=PYLAMF(XMI2,XMJ2,XMJ2) XMF=PMAS(IFL,1) EI=KCHG(IFL,1)/3D0 IDU=2-MOD(IFL,2) IF(IH.EQ.1) THEN IF(IDU.EQ.1) THEN GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+ & XMF**2/XMW*SINA/CBETA GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+ & XMF**2/XMW*SINA/CBETA IF(IFL.EQ.5) THEN GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA- & ATRIB*SINA) ELSEIF(IFL.EQ.15) THEN GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA- & ATRIL*SINA) ELSE GHLR=0D0 ENDIF ELSE GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)- & XMF**2/XMW*COSA/SBETA GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)- & XMF**2/XMW*COSA/SBETA IF(IFL.EQ.6) THEN GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA- & ATRIT*COSA) ELSE GHLR=0D0 ENDIF ENDIF ELSEIF(IH.EQ.2) THEN IF(IDU.EQ.1) THEN GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)- & XMF**2/XMW*COSA/CBETA GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)- & XMF**2/XMW*COSA/CBETA IF(IFL.EQ.5) THEN GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+ & ATRIB*COSA) ELSEIF(IFL.EQ.15) THEN GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+ & ATRIL*COSA) ELSE GHLR=0D0 ENDIF ELSE GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)- & XMF**2/XMW*SINA/SBETA GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)- & XMF**2/XMW*SINA/SBETA IF(IFL.EQ.6) THEN GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+ & ATRIT*SINA) ELSE GHLR=0D0 ENDIF ENDIF ELSEIF(IH.EQ.3) THEN GHLL=0D0 GHRR=0D0 GHLR=0D0 IF(IDU.EQ.1) THEN IF(IFL.EQ.5) THEN GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ) ELSEIF(IFL.EQ.15) THEN GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ) ENDIF ELSE IF(IFL.EQ.6) THEN GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ) ENDIF ENDIF ENDIF IF(IH.EQ.3) GOTO 140 AL=SFMIX(IFL,1)**2 AR=SFMIX(IFL,2)**2 ALR=SFMIX(IFL,1)*SFMIX(IFL,2) IF(IFL.LE.6) THEN CF=3D0 ELSE CF=1D0 ENDIF IF(AXMI.GE.2D0*XMJ) THEN LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* & (GHLL*AL+GHRR*AR & +2D0*GHLR*ALR)**2 IDLAM(LKNT,1)=IJ IDLAM(LKNT,2)=-IJ IDLAM(LKNT,3)=0 ENDIF IF(AXMI.GE.2D0*XMJR) THEN LKNT=LKNT+1 AL=SFMIX(IFL,3)**2 AR=SFMIX(IFL,4)**2 ALR=SFMIX(IFL,3)*SFMIX(IFL,4) XMJ=XMJR XMJ2=XMJ**2 XL=PYLAMF(XMI2,XMJ2,XMJ2) XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* & (GHLL*AL+GHRR*AR & +2D0*GHLR*ALR)**2 IDLAM(LKNT,1)=IJ+KSUSY1 IDLAM(LKNT,2)=-(IJ+KSUSY1) IDLAM(LKNT,3)=0 ENDIF 140 CONTINUE IF(AXMI.GE.XMJL+XMJR) THEN LKNT=LKNT+1 AL=SFMIX(IFL,1)*SFMIX(IFL,3) AR=SFMIX(IFL,2)*SFMIX(IFL,4) ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3) XMJ=XMJR XMJ2=XMJ**2 XL=PYLAMF(XMI2,XMJ2,XMJL**2) XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* & (GHLL*AL+GHRR*AR)**2 IDLAM(LKNT,1)=IJ IDLAM(LKNT,2)=-(IJ+KSUSY1) IDLAM(LKNT,3)=0 LKNT=LKNT+1 IDLAM(LKNT,1)=-IJ IDLAM(LKNT,2)=IJ+KSUSY1 IDLAM(LKNT,3)=0 XLAM(LKNT)=XLAM(LKNT-1) ENDIF ENDIF 150 CONTINUE 160 CONTINUE 170 CONTINUE GOTO 230 180 CONTINUE C...H+ -> CHI+_I + CHI0_J DO 200 IJ=1,4 XMJ=SMZ(IJ) AXMJ=ABS(XMJ) XMJ2=XMJ**2 DO 190 IK=1,2 XMK=SMW(IK) AXMK=ABS(XMK) XMK2=XMK**2 IF(AXMI.GE.AXMJ+AXMK) THEN LKNT=LKNT+1 GL=CBETA*(ZMIX(IJ,4)*VMIX(IK,1)+(ZMIX(IJ,2)+ZMIX(IJ,1)* & TANW)*VMIX(IK,2)/SR2) GR=SBETA*(ZMIX(IJ,3)*UMIX(IK,1)-(ZMIX(IJ,2)+ZMIX(IJ,1)* & TANW)*UMIX(IK,2)/SR2) XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GL,GR) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=KFCCHI(IK) IDLAM(LKNT,3)=0 ENDIF 190 CONTINUE 200 CONTINUE GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2) GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB) AL=0D0 AR=0D0 CF=3D0 C...H+ -> T_1 B_1~ XM1=PMAS(PYCOMP(KSUSY1+6),1) XM2=PMAS(PYCOMP(KSUSY1+5),1) IF(XMI.GE.XM1+XM2) THEN XL=PYLAMF(XMI2,XM1**2,XM2**2) LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2 IDLAM(LKNT,1)=KSUSY1+6 IDLAM(LKNT,2)=-(KSUSY1+5) IDLAM(LKNT,3)=0 ENDIF C...H+ -> T_2 B_1~ XM1=PMAS(PYCOMP(KSUSY2+6),1) XM2=PMAS(PYCOMP(KSUSY1+5),1) IF(XMI.GE.XM1+XM2) THEN XL=PYLAMF(XMI2,XM1**2,XM2**2) LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2 IDLAM(LKNT,1)=KSUSY2+6 IDLAM(LKNT,2)=-(KSUSY1+5) IDLAM(LKNT,3)=0 ENDIF C...H+ -> T_1 B_2~ XM1=PMAS(PYCOMP(KSUSY1+6),1) XM2=PMAS(PYCOMP(KSUSY2+5),1) IF(XMI.GE.XM1+XM2) THEN XL=PYLAMF(XMI2,XM1**2,XM2**2) LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2 IDLAM(LKNT,1)=KSUSY1+6 IDLAM(LKNT,2)=-(KSUSY2+5) IDLAM(LKNT,3)=0 ENDIF C...H+ -> T_2 B_2~ XM1=PMAS(PYCOMP(KSUSY2+6),1) XM2=PMAS(PYCOMP(KSUSY2+5),1) IF(XMI.GE.XM1+XM2) THEN XL=PYLAMF(XMI2,XM1**2,XM2**2) LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2 IDLAM(LKNT,1)=KSUSY2+6 IDLAM(LKNT,2)=-(KSUSY2+5) IDLAM(LKNT,3)=0 ENDIF C...H+ -> UL DL~ GL=-XMW/SR2*SIN(2D0*BETA) DO 210 IJ=1,3,2 XM1=PMAS(PYCOMP(KSUSY1+IJ),1) XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1) IF(XMI.GE.XM1+XM2) THEN XL=PYLAMF(XMI2,XM1**2,XM2**2) LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2 IDLAM(LKNT,1)=-(KSUSY1+IJ) IDLAM(LKNT,2)=KSUSY1+IJ+1 IDLAM(LKNT,3)=0 ENDIF 210 CONTINUE C...H+ -> EL~ NUL CF=1D0 DO 220 IJ=11,13,2 XM1=PMAS(PYCOMP(KSUSY1+IJ),1) XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1) IF(XMI.GE.XM1+XM2) THEN XL=PYLAMF(XMI2,XM1**2,XM2**2) LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2 IDLAM(LKNT,1)=-(KSUSY1+IJ) IDLAM(LKNT,2)=KSUSY1+IJ+1 IDLAM(LKNT,3)=0 ENDIF 220 CONTINUE C...H+ -> TAU1 NUTAUL XM1=PMAS(PYCOMP(KSUSY1+15),1) XM2=PMAS(PYCOMP(KSUSY1+16),1) IF(XMI.GE.XM1+XM2) THEN XL=PYLAMF(XMI2,XM1**2,XM2**2) LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,1)**2 IDLAM(LKNT,1)=-(KSUSY1+15) IDLAM(LKNT,2)= KSUSY1+16 IDLAM(LKNT,3)=0 ENDIF C...H+ -> TAU2 NUTAUL XM1=PMAS(PYCOMP(KSUSY2+15),1) XM2=PMAS(PYCOMP(KSUSY1+16),1) IF(XMI.GE.XM1+XM2) THEN XL=PYLAMF(XMI2,XM1**2,XM2**2) LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*(GL)**2*SFMIX(15,3)**2 IDLAM(LKNT,1)=-(KSUSY2+15) IDLAM(LKNT,2)= KSUSY1+16 IDLAM(LKNT,3)=0 ENDIF 230 CONTINUE IKNT=LKNT XLAM(0)=0D0 DO 240 I=1,IKNT IF(XLAM(I).LE.0D0) XLAM(I)=0D0 XLAM(0)=XLAM(0)+XLAM(I) 240 CONTINUE IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6 RETURN END C********************************************************************* C...PYH2XX C...Calculates the decay rate for a Higgs to an ino pair. FUNCTION PYH2XX(C1,XM1,XM2,XM3,GL,GR) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Local variables. DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR DOUBLE PRECISION XL,PYLAMF,C1 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3 XMI2=XM1**2 XMI3=ABS(XM1**3) XMJ2=XM2**2 XMK2=XM3**2 XL=PYLAMF(XMI2,XMJ2,XMK2) PYH2XX=C1/4D0/XMI3*SQRT(XL) &*((GL**2+GR**2)*(XMI2-XMJ2-XMK2)- &4D0*GL*GR*XM3*XM2) IF(PYH2XX.LT.0D0) THEN WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX ' WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GL,GR,XM1,XM2,XM3 STOP ENDIF RETURN END C********************************************************************* C...PYGAUS C...Integration by adaptive Gaussian quadrature. C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig. FUNCTION PYGAUS(F, A, B, EPS) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Local declarations. EXTERNAL F DOUBLE PRECISION W(12), X(12) DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/ DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/ DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/ DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/ DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/ DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/ DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/ DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/ DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/ DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/ DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/ DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/ C...The Gaussian quadrature algorithm. H = 0D0 IF(B .EQ. A) GO TO 140 CONST = 5D-3 / ABS(B-A) BB = A 100 CONTINUE AA = BB BB = B 110 CONTINUE C1 = 0.5D0*(BB+AA) C2 = 0.5D0*(BB-AA) S8 = 0D0 DO 120 I = 1, 4 U = C2*X(I) S8 = S8 + W(I) * (F(C1+U) + F(C1-U)) 120 CONTINUE S16 = 0D0 DO 130 I = 5, 12 U = C2*X(I) S16 = S16 + W(I) * (F(C1+U) + F(C1-U)) 130 CONTINUE S16 = C2*S16 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN H = H + S16 IF(BB .NE. B) GO TO 100 ELSE BB = C1 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GO TO 110 H = 0D0 CALL PYERRM(18,'(PYGAUS:) too high accuracy required') GO TO 140 ENDIF 140 CONTINUE PYGAUS = H RETURN END C********************************************************************* C...PYSIMP C...Simpson formula for an integral. FUNCTION PYSIMP(Y,X0,X1,N) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DOUBLE PRECISION Y,X0,X1,H,S DIMENSION Y(0:N) S=0D0 H=(X1-X0)/N DO 100 I=0,N-2,2 S=S+Y(I)+4D0*Y(I+1)+Y(I+2) 100 CONTINUE PYSIMP=S*H/3D0 RETURN END C********************************************************************* C...PYLAMF C...The standard lambda function. FUNCTION PYLAMF(X,Y,Z) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DOUBLE PRECISION PYLAMF,X,Y,Z PYLAMF=(X-(Y+Z))**2-4D0*Y*Z IF(PYLAMF.LT.0D0) PYLAMF=0D0 RETURN END C********************************************************************* C...PYTBDY C...Generates 3-body decays of gauginos. SUBROUTINE PYTBDY(XM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) 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(4000,2),BRAT(4000),KFDP(4000,5) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/ C...Local variables. DOUBLE PRECISION XM(5) DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3 DOUBLE PRECISION CPHI1,SPHI1 DOUBLE PRECISION S23DEL,EPS DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3) DOUBLE PRECISION F1,F2,X0,X1,X2,X3 DATA EPS/1D-6/ C...GENERATE S12 S12MIN=(XM(1)+XM(2))**2 S12MAX=(XM(5)-XM(3))**2 YJACO1=S12MAX-S12MIN C...FIND S12* AX=S12MIN CX=S12MAX BX=S12MIN+0.5D0*YJACO1 X0=AX X3=CX IF(ABS(CX-BX).GT.ABS(BX-AX))THEN X1=BX X2=BX+C*(CX-BX) ELSE X2=BX X1=BX-C*(BX-AX) ENDIF C...SOLVE FOR F1 AND F2 S23DF1=(X1-XM(2)**2-XM(1)**2)**2 &-(2D0*XM(1)*XM(2))**2 S23DF2=(X1-XM(3)**2-XM(5)**2)**2 &-(2D0*XM(3)*XM(5))**2 S23DF1=S23DF1*EPS S23DF2=S23DF2*EPS S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1) F1=-2D0*S23DEL/EPS S23DF1=(X2-XM(2)**2-XM(1)**2)**2 &-(2D0*XM(1)*XM(2))**2 S23DF2=(X2-XM(3)**2-XM(5)**2)**2 &-(2D0*XM(3)*XM(5))**2 S23DF1=S23DF1*EPS S23DF2=S23DF2*EPS S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2) F2=-2D0*S23DEL/EPS 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN IF(F2.LT.F1)THEN X0=X1 X1=X2 X2=R*X1+C*X3 F1=F2 S23DF1=(X2-XM(2)**2-XM(1)**2)**2 & -(2D0*XM(1)*XM(2))**2 S23DF2=(X2-XM(3)**2-XM(5)**2)**2 & -(2D0*XM(3)*XM(5))**2 S23DF1=S23DF1*EPS S23DF2=S23DF2*EPS S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X2) F2=-2D0*S23DEL/EPS ELSE X3=X2 X2=X1 X1=R*X2+C*X0 F2=F1 S23DF1=(X1-XM(2)**2-XM(1)**2)**2 & -(2D0*XM(1)*XM(2))**2 S23DF2=(X1-XM(3)**2-XM(5)**2)**2 & -(2D0*XM(3)*XM(5))**2 S23DF1=S23DF1*EPS S23DF2=S23DF2*EPS S23DEL=SQRT(S23DF1*S23DF2)/(2D0*X1) F1=-2D0*S23DEL/EPS ENDIF GOTO 100 ENDIF C...WE WANT THE MAXIMUM, NOT THE MINIMUM IF(F1.LT.F2)THEN GOLDEN=-F1 XMIN=X1 ELSE GOLDEN=-F2 XMIN=X2 ENDIF IKNT=0 110 S12=S12MIN+PYR(0)*YJACO1 IKNT=IKNT+1 C...GENERATE S23 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2) &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12) S23DF1=(S12-XM(2)**2-XM(1)**2)**2 &-(2D0*XM(1)*XM(2))**2 S23DF2=(S12-XM(3)**2-XM(5)**2)**2 &-(2D0*XM(3)*XM(5))**2 S23DF1=S23DF1*EPS S23DF2=S23DF2*EPS S23DEL=SQRT(S23DF1*S23DF2)/(2D0*S12) S23DEL=S23DEL/EPS S23MIN=S23AVE-S23DEL S23MAX=S23AVE+S23DEL YJACO2=S23MAX-S23MIN S23=S23MIN+PYR(0)*YJACO2 C...CHECK THE SAMPLING IF(IKNT.GT.100) THEN WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY ' GOTO 120 ENDIF IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 110 120 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5)) D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5)) D2=XM(5)-D1-D3 P1=SQRT(D1*D1-XM(1)**2) P2=SQRT(D2*D2-XM(2)**2) P3=SQRT(D3*D3-XM(3)**2) CTHE1=2D0*PYR(0)-1D0 ANG1=2D0*PYR(0)*PARU(1) CPHI1=COS(ANG1) SPHI1=SIN(ANG1) ARG=1D0-CTHE1**2 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0 STHE1=SQRT(ARG) P(N+1,1)=P1*STHE1*CPHI1 P(N+1,2)=P1*STHE1*SPHI1 P(N+1,3)=P1*CTHE1 P(N+1,4)=D1 C...GET CPHI3 ANG3=2D0*PYR(0)*PARU(1) CPHI3=COS(ANG3) SPHI3=SIN(ANG3) CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3 ARG=1D0-CTHE3**2 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0 STHE3=SQRT(ARG) P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1 &+P3*STHE3*SPHI3*SPHI1 &+P3*CTHE3*STHE1*CPHI1 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1 &-P3*STHE3*SPHI3*CPHI1 &+P3*CTHE3*STHE1*SPHI1 P(N+3,3)=P3*STHE3*CPHI3*STHE1 &+P3*CTHE3*CTHE1 P(N+3,4)=D3 DO 130 I=1,3 P(N+2,I)=-P(N+1,I)-P(N+3,I) 130 CONTINUE P(N+2,4)=D2 RETURN END C********************************************************************* C...PY1ENT C...Stores one parton/particle in commonblock PYJETS. SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Standard checks. MSTU(28)=0 IF(MSTU(12).GE.1) CALL PYLIST(0) IPA=MAX(1,IABS(IP)) IF(IPA.GT.MSTU(4)) CALL PYERRM(21, &'(PY1ENT:) writing outside PYJETS memory') KC=PYCOMP(KF) IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code') C...Find mass. Reset K, P and V vectors. PM=0D0 IF(MSTU(10).EQ.1) PM=P(IPA,5) IF(MSTU(10).GE.2) PM=PYMASS(KF) DO 100 J=1,5 K(IPA,J)=0 P(IPA,J)=0D0 V(IPA,J)=0D0 100 CONTINUE C...Store parton/particle in K and P vectors. K(IPA,1)=1 IF(IP.LT.0) K(IPA,1)=2 K(IPA,2)=KF P(IPA,5)=PM P(IPA,4)=MAX(PE,PM) PA=SQRT(P(IPA,4)**2-P(IPA,5)**2) P(IPA,1)=PA*SIN(THE)*COS(PHI) P(IPA,2)=PA*SIN(THE)*SIN(PHI) P(IPA,3)=PA*COS(THE) C...Set N. Optionally fragment/decay. N=IPA IF(IP.EQ.0) CALL PYEXEC RETURN END C********************************************************************* C...PY2ENT C...Stores two partons/particles in their CM frame, C...with the first along the +z axis. SUBROUTINE PY2ENT(IP,KF1,KF2,PECM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Standard checks. MSTU(28)=0 IF(MSTU(12).GE.1) CALL PYLIST(0) IPA=MAX(1,IABS(IP)) IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21, &'(PY2ENT:) writing outside PYJETS memory') KC1=PYCOMP(KF1) KC2=PYCOMP(KF2) IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12, &'(PY2ENT:) unknown flavour code') C...Find masses. Reset K, P and V vectors. PM1=0D0 IF(MSTU(10).EQ.1) PM1=P(IPA,5) IF(MSTU(10).GE.2) PM1=PYMASS(KF1) PM2=0D0 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5) IF(MSTU(10).GE.2) PM2=PYMASS(KF2) DO 110 I=IPA,IPA+1 DO 100 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 100 CONTINUE 110 CONTINUE C...Check flavours. KQ1=KCHG(KC1,2)*ISIGN(1,KF1) KQ2=KCHG(KC2,2)*ISIGN(1,KF2) IF(MSTU(19).EQ.1) THEN MSTU(19)=0 ELSE IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2, & '(PY2ENT:) unphysical flavour combination') ENDIF K(IPA,2)=KF1 K(IPA+1,2)=KF2 C...Store partons/particles in K vectors for normal case. IF(IP.GE.0) THEN K(IPA,1)=1 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2 K(IPA+1,1)=1 C...Store partons in K vectors for parton shower evolution. ELSE K(IPA,1)=3 K(IPA+1,1)=3 K(IPA,4)=MSTU(5)*(IPA+1) K(IPA,5)=K(IPA,4) K(IPA+1,4)=MSTU(5)*IPA K(IPA+1,5)=K(IPA+1,4) ENDIF C...Check kinematics and store partons/particles in P vectors. IF(PECM.LE.PM1+PM2) CALL PYERRM(13, &'(PY2ENT:) energy smaller than sum of masses') PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/ &(2D0*PECM) P(IPA,3)=PA P(IPA,4)=SQRT(PM1**2+PA**2) P(IPA,5)=PM1 P(IPA+1,3)=-PA P(IPA+1,4)=SQRT(PM2**2+PA**2) P(IPA+1,5)=PM2 C...Set N. Optionally fragment/decay. N=IPA+1 IF(IP.EQ.0) CALL PYEXEC RETURN END C********************************************************************* C...PY3ENT C...Stores three partons or particles in their CM frame, C...with the first along the +z axis and the third in the (x,z) C...plane with x > 0. SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Standard checks. MSTU(28)=0 IF(MSTU(12).GE.1) CALL PYLIST(0) IPA=MAX(1,IABS(IP)) IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21, &'(PY3ENT:) writing outside PYJETS memory') KC1=PYCOMP(KF1) KC2=PYCOMP(KF2) KC3=PYCOMP(KF3) IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12, &'(PY3ENT:) unknown flavour code') C...Find masses. Reset K, P and V vectors. PM1=0D0 IF(MSTU(10).EQ.1) PM1=P(IPA,5) IF(MSTU(10).GE.2) PM1=PYMASS(KF1) PM2=0D0 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5) IF(MSTU(10).GE.2) PM2=PYMASS(KF2) PM3=0D0 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5) IF(MSTU(10).GE.2) PM3=PYMASS(KF3) DO 110 I=IPA,IPA+2 DO 100 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 100 CONTINUE 110 CONTINUE C...Check flavours. KQ1=KCHG(KC1,2)*ISIGN(1,KF1) KQ2=KCHG(KC2,2)*ISIGN(1,KF2) KQ3=KCHG(KC3,2)*ISIGN(1,KF3) IF(MSTU(19).EQ.1) THEN MSTU(19)=0 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR. & KQ1+KQ3.EQ.4)) THEN ELSE CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination') ENDIF K(IPA,2)=KF1 K(IPA+1,2)=KF2 K(IPA+2,2)=KF3 C...Store partons/particles in K vectors for normal case. IF(IP.GE.0) THEN K(IPA,1)=1 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2 K(IPA+1,1)=1 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2 K(IPA+2,1)=1 C...Store partons in K vectors for parton shower evolution. ELSE K(IPA,1)=3 K(IPA+1,1)=3 K(IPA+2,1)=3 KCS=4 IF(KQ1.EQ.-1) KCS=5 K(IPA,KCS)=MSTU(5)*(IPA+1) K(IPA,9-KCS)=MSTU(5)*(IPA+2) K(IPA+1,KCS)=MSTU(5)*(IPA+2) K(IPA+1,9-KCS)=MSTU(5)*IPA K(IPA+2,KCS)=MSTU(5)*IPA K(IPA+2,9-KCS)=MSTU(5)*(IPA+1) ENDIF C...Check kinematics. MKERR=0 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR. &0.5D0*X3*PECM.LE.PM3) MKERR=1 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2)) PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2)) PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2)) CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2) CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3) IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1 CTHE3=MAX(-1D0,MIN(1D0,CTHE3)) IF(MKERR.NE.0) CALL PYERRM(13, &'(PY3ENT:) unphysical kinematical variable setup') C...Store partons/particles in P vectors. P(IPA,3)=PA1 P(IPA,4)=SQRT(PA1**2+PM1**2) P(IPA,5)=PM1 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2) P(IPA+2,3)=PA3*CTHE3 P(IPA+2,4)=SQRT(PA3**2+PM3**2) P(IPA+2,5)=PM3 P(IPA+1,1)=-P(IPA+2,1) P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3) P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2) P(IPA+1,5)=PM2 C...Set N. Optionally fragment/decay. N=IPA+2 IF(IP.EQ.0) CALL PYEXEC RETURN END C********************************************************************* C...PY4ENT C...Stores four partons or particles in their CM frame, with C...the first along the +z axis, the last in the xz plane with x > 0 C...and the second having y < 0 and y > 0 with equal probability. SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Standard checks. MSTU(28)=0 IF(MSTU(12).GE.1) CALL PYLIST(0) IPA=MAX(1,IABS(IP)) IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21, &'(PY4ENT:) writing outside PYJETS momory') KC1=PYCOMP(KF1) KC2=PYCOMP(KF2) KC3=PYCOMP(KF3) KC4=PYCOMP(KF4) IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12, &'(PY4ENT:) unknown flavour code') C...Find masses. Reset K, P and V vectors. PM1=0D0 IF(MSTU(10).EQ.1) PM1=P(IPA,5) IF(MSTU(10).GE.2) PM1=PYMASS(KF1) PM2=0D0 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5) IF(MSTU(10).GE.2) PM2=PYMASS(KF2) PM3=0D0 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5) IF(MSTU(10).GE.2) PM3=PYMASS(KF3) PM4=0D0 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5) IF(MSTU(10).GE.2) PM4=PYMASS(KF4) DO 110 I=IPA,IPA+3 DO 100 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 100 CONTINUE 110 CONTINUE C...Check flavours. KQ1=KCHG(KC1,2)*ISIGN(1,KF1) KQ2=KCHG(KC2,2)*ISIGN(1,KF2) KQ3=KCHG(KC3,2)*ISIGN(1,KF3) KQ4=KCHG(KC4,2)*ISIGN(1,KF4) IF(MSTU(19).EQ.1) THEN MSTU(19)=0 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR. & KQ1+KQ4.EQ.4)) THEN ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0) & THEN ELSE CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination') ENDIF K(IPA,2)=KF1 K(IPA+1,2)=KF2 K(IPA+2,2)=KF3 K(IPA+3,2)=KF4 C...Store partons/particles in K vectors for normal case. IF(IP.GE.0) THEN K(IPA,1)=1 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2 K(IPA+1,1)=1 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0)) & K(IPA+1,1)=2 K(IPA+2,1)=1 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2 K(IPA+3,1)=1 C...Store partons for parton shower evolution from q-g-g-qbar or C...g-g-g-g event. ELSEIF(KQ1+KQ2.NE.0) THEN K(IPA,1)=3 K(IPA+1,1)=3 K(IPA+2,1)=3 K(IPA+3,1)=3 KCS=4 IF(KQ1.EQ.-1) KCS=5 K(IPA,KCS)=MSTU(5)*(IPA+1) K(IPA,9-KCS)=MSTU(5)*(IPA+3) K(IPA+1,KCS)=MSTU(5)*(IPA+2) K(IPA+1,9-KCS)=MSTU(5)*IPA K(IPA+2,KCS)=MSTU(5)*(IPA+3) K(IPA+2,9-KCS)=MSTU(5)*(IPA+1) K(IPA+3,KCS)=MSTU(5)*IPA K(IPA+3,9-KCS)=MSTU(5)*(IPA+2) C...Store partons for parton shower evolution from q-qbar-q-qbar event. ELSE K(IPA,1)=3 K(IPA+1,1)=3 K(IPA+2,1)=3 K(IPA+3,1)=3 K(IPA,4)=MSTU(5)*(IPA+1) K(IPA,5)=K(IPA,4) K(IPA+1,4)=MSTU(5)*IPA K(IPA+1,5)=K(IPA+1,4) K(IPA+2,4)=MSTU(5)*(IPA+3) K(IPA+2,5)=K(IPA+2,4) K(IPA+3,4)=MSTU(5)*(IPA+2) K(IPA+3,5)=K(IPA+3,4) ENDIF C...Check kinematics. MKERR=0 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR. &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4) &MKERR=1 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2)) PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2)) PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2)) X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4) IF(ABS(CTHE4).GE.1.002D0) MKERR=1 CTHE4=MAX(-1D0,MIN(1D0,CTHE4)) STHE4=SQRT(1D0-CTHE4**2) CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2) IF(ABS(CTHE2).GE.1.002D0) MKERR=1 CTHE2=MAX(-1D0,MIN(1D0,CTHE2)) STHE2=SQRT(1D0-CTHE2**2) CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/ &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4) IF(ABS(CPHI2).GE.1.05D0) MKERR=1 CPHI2=MAX(-1D0,MIN(1D0,CPHI2)) IF(MKERR.EQ.1) CALL PYERRM(13, &'(PY4ENT:) unphysical kinematical variable setup') C...Store partons/particles in P vectors. P(IPA,3)=PA1 P(IPA,4)=SQRT(PA1**2+PM1**2) P(IPA,5)=PM1 P(IPA+3,1)=PA4*STHE4 P(IPA+3,3)=PA4*CTHE4 P(IPA+3,4)=SQRT(PA4**2+PM4**2) P(IPA+3,5)=PM4 P(IPA+1,1)=PA2*STHE2*CPHI2 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0) P(IPA+1,3)=PA2*CTHE2 P(IPA+1,4)=SQRT(PA2**2+PM2**2) P(IPA+1,5)=PM2 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1) P(IPA+2,2)=-P(IPA+1,2) P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3) P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2) P(IPA+2,5)=PM3 C...Set N. Optionally fragment/decay. N=IPA+3 IF(IP.EQ.0) CALL PYEXEC RETURN END C********************************************************************* C...PYJOIN C...Connects a sequence of partons with colour flow indices, C...as required for subsequent shower evolution (or other operations). SUBROUTINE PYJOIN(NJOIN,IJOIN) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local array. DIMENSION IJOIN(*) C...Check that partons are of right types to be connected. IF(NJOIN.LT.2) GOTO 120 KQSUM=0 DO 100 IJN=1,NJOIN I=IJOIN(IJN) IF(I.LE.0.OR.I.GT.N) GOTO 120 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120 KC=PYCOMP(K(I,2)) IF(KC.EQ.0) GOTO 120 KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) IF(KQ.EQ.0) GOTO 120 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120 IF(KQ.NE.2) KQSUM=KQSUM+KQ IF(IJN.EQ.1) KQS=KQ 100 CONTINUE IF(KQSUM.NE.0) GOTO 120 C...Connect the partons sequentially (closing for gluon loop). KCS=(9-KQS)/2 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0)) DO 110 IJN=1,NJOIN I=IJOIN(IJN) K(I,1)=3 IF(IJN.NE.1) IP=IJOIN(IJN-1) IF(IJN.EQ.1) IP=IJOIN(NJOIN) IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1) IF(IJN.EQ.NJOIN) IN=IJOIN(1) K(I,KCS)=MSTU(5)*IN K(I,9-KCS)=MSTU(5)*IP IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0 110 CONTINUE C...Error exit: no action taken. RETURN 120 CALL PYERRM(12, &'(PYJOIN:) given entries can not be joined by one string') RETURN END C********************************************************************* C...PYGIVE C...Sets values of commonblock variables. SUBROUTINE PYGIVE(CHIN) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) 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(4000,2),BRAT(4000),KFDP(4000,5) COMMON/PYDAT4/CHAF(500,2) CHARACTER CHAF*16 COMMON/PYDATR/MRPY(6),RRPY(100) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT6/PROC(0:500) CHARACTER PROC*28 COMMON/PYINT7/SIGT(0:6,0:6,0:5) COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6), &XPDIR(-6:6) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/, &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/, &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/ C...Local arrays and character variables. CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28, &CHNEW2*28,CHNAM*6,CHVAR(49)*6,CHALP(2)*26,CHIND*8,CHINI*10, &CHINR*16 DIMENSION MSVAR(49,8) C...For each variable to be translated give: name, C...integer/real/character, no. of indices, lower&upper index bounds. DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG', &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY', &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI', &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH', &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL', &'XPANH','XPBEH','XPDIR','IMSS','RMSS'/ DATA ((MSVAR(I,J),J=1,8),I=1,49)/ 1,7*0, 1,2,1,4000,1,5,2*0, &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0, &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0, &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0, &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,4000,1,2,2*0, &2,1,1,4000,4*0, 1,2,1,4000,1,5,2*0, 3,2,1,500,1,2,2*0, &1,1,1,6,4*0, 2,1,1,100,4*0, &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0, &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0, &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0, &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2, &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0, &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0, &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5, &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0, &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/ DATA CHALP/'abcdefghijklmnopqrstuvwxyz', &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ C...Length of character variable. Subdivide it into instructions. IF(MSTU(12).GE.1) CALL PYLIST(0) CHBIT=CHIN//' ' LBIT=101 100 LBIT=LBIT-1 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100 LTOT=0 DO 110 LCOM=1,LBIT IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110 LTOT=LTOT+1 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM) 110 CONTINUE LLOW=0 120 LHIG=LLOW+1 130 LHIG=LHIG+1 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130 LBIT=LHIG-LLOW-1 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1) C...Identify commonblock variable. LNAM=1 140 LNAM=LNAM+1 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND. &LNAM.LE.6) GOTO 140 CHNAM=CHBIT(1:LNAM-1)//' ' DO 160 LCOM=1,LNAM-1 DO 150 LALP=1,26 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)= & CHALP(2)(LALP:LALP) 150 CONTINUE 160 CONTINUE IVAR=0 DO 170 IV=1,49 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV 170 CONTINUE IF(IVAR.EQ.0) THEN CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM) LLOW=LHIG IF(LLOW.LT.LTOT) GOTO 120 RETURN ENDIF C...Identify any indices. I1=0 I2=0 I3=0 NINDX=0 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN LIND=LNAM 180 LIND=LIND+1 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 180 CHIND=' ' IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c') & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17)) & THEN CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1) READ(CHIND,'(I8)') KF I1=PYCOMP(KF) ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ. & 'c') THEN CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '// & CHNAM) LLOW=LHIG IF(LLOW.LT.LTOT) GOTO 120 RETURN ELSE CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1) READ(CHIND,'(I8)') I1 ENDIF LNAM=LIND IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1 NINDX=1 ENDIF IF(CHBIT(LNAM:LNAM).EQ.',') THEN LIND=LNAM 190 LIND=LIND+1 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190 CHIND=' ' CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1) READ(CHIND,'(I8)') I2 LNAM=LIND IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1 NINDX=2 ENDIF IF(CHBIT(LNAM:LNAM).EQ.',') THEN LIND=LNAM 200 LIND=LIND+1 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200 CHIND=' ' CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1) READ(CHIND,'(I8)') I3 LNAM=LIND+1 NINDX=3 ENDIF C...Check that indices allowed. IERR=0 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4))) &IERR=2 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6))) &IERR=3 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8))) &IERR=4 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5 IF(IERR.GE.1) THEN CALL PYERRM(18,'(PYGIVE:) unallowed indices for '// & CHBIT(1:LNAM-1)) LLOW=LHIG IF(LLOW.LT.LTOT) GOTO 120 RETURN ENDIF C...Save old value of variable. IF(IVAR.EQ.1) THEN IOLD=N ELSEIF(IVAR.EQ.2) THEN IOLD=K(I1,I2) ELSEIF(IVAR.EQ.3) THEN ROLD=P(I1,I2) ELSEIF(IVAR.EQ.4) THEN ROLD=V(I1,I2) ELSEIF(IVAR.EQ.5) THEN IOLD=MSTU(I1) ELSEIF(IVAR.EQ.6) THEN ROLD=PARU(I1) ELSEIF(IVAR.EQ.7) THEN IOLD=MSTJ(I1) ELSEIF(IVAR.EQ.8) THEN ROLD=PARJ(I1) ELSEIF(IVAR.EQ.9) THEN IOLD=KCHG(I1,I2) ELSEIF(IVAR.EQ.10) THEN ROLD=PMAS(I1,I2) ELSEIF(IVAR.EQ.11) THEN ROLD=PARF(I1) ELSEIF(IVAR.EQ.12) THEN ROLD=VCKM(I1,I2) ELSEIF(IVAR.EQ.13) THEN IOLD=MDCY(I1,I2) ELSEIF(IVAR.EQ.14) THEN IOLD=MDME(I1,I2) ELSEIF(IVAR.EQ.15) THEN ROLD=BRAT(I1) ELSEIF(IVAR.EQ.16) THEN IOLD=KFDP(I1,I2) ELSEIF(IVAR.EQ.17) THEN CHOLD=CHAF(I1,I2) ELSEIF(IVAR.EQ.18) THEN IOLD=MRPY(I1) ELSEIF(IVAR.EQ.19) THEN ROLD=RRPY(I1) ELSEIF(IVAR.EQ.20) THEN IOLD=MSEL ELSEIF(IVAR.EQ.21) THEN IOLD=MSUB(I1) ELSEIF(IVAR.EQ.22) THEN IOLD=KFIN(I1,I2) ELSEIF(IVAR.EQ.23) THEN ROLD=CKIN(I1) ELSEIF(IVAR.EQ.24) THEN IOLD=MSTP(I1) ELSEIF(IVAR.EQ.25) THEN ROLD=PARP(I1) ELSEIF(IVAR.EQ.26) THEN IOLD=MSTI(I1) ELSEIF(IVAR.EQ.27) THEN ROLD=PARI(I1) ELSEIF(IVAR.EQ.28) THEN IOLD=MINT(I1) ELSEIF(IVAR.EQ.29) THEN ROLD=VINT(I1) ELSEIF(IVAR.EQ.30) THEN IOLD=ISET(I1) ELSEIF(IVAR.EQ.31) THEN IOLD=KFPR(I1,I2) ELSEIF(IVAR.EQ.32) THEN ROLD=COEF(I1,I2) ELSEIF(IVAR.EQ.33) THEN IOLD=ICOL(I1,I2,I3) ELSEIF(IVAR.EQ.34) THEN ROLD=XSFX(I1,I2) ELSEIF(IVAR.EQ.35) THEN IOLD=ISIG(I1,I2) ELSEIF(IVAR.EQ.36) THEN ROLD=SIGH(I1) ELSEIF(IVAR.EQ.37) THEN IOLD=MWID(I1) ELSEIF(IVAR.EQ.38) THEN ROLD=WIDS(I1,I2) ELSEIF(IVAR.EQ.39) THEN IOLD=NGEN(I1,I2) ELSEIF(IVAR.EQ.40) THEN ROLD=XSEC(I1,I2) ELSEIF(IVAR.EQ.41) THEN CHOLD2=PROC(I1) ELSEIF(IVAR.EQ.42) THEN ROLD=SIGT(I1,I2,I3) ELSEIF(IVAR.EQ.43) THEN ROLD=XPVMD(I1) ELSEIF(IVAR.EQ.44) THEN ROLD=XPANL(I1) ELSEIF(IVAR.EQ.45) THEN ROLD=XPANH(I1) ELSEIF(IVAR.EQ.46) THEN ROLD=XPBEH(I1) ELSEIF(IVAR.EQ.47) THEN ROLD=XPDIR(I1) ELSEIF(IVAR.EQ.48) THEN IOLD=IMSS(I1) ELSEIF(IVAR.EQ.49) THEN ROLD=RMSS(I1) ENDIF C...Print current value of variable. Loop back. IF(LNAM.GE.LBIT) THEN CHBIT(LNAM:14)=' ' CHBIT(15:60)=' has the value ' IF(MSVAR(IVAR,1).EQ.1) THEN WRITE(CHBIT(51:60),'(I10)') IOLD ELSEIF(MSVAR(IVAR,1).EQ.2) THEN WRITE(CHBIT(47:60),'(F14.5)') ROLD ELSEIF(MSVAR(IVAR,1).EQ.3) THEN CHBIT(53:60)=CHOLD ELSE CHBIT(33:60)=CHOLD ENDIF IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60) LLOW=LHIG IF(LLOW.LT.LTOT) GOTO 120 RETURN ENDIF C...Read in new variable value. IF(MSVAR(IVAR,1).EQ.1) THEN CHINI=' ' CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT) READ(CHINI,'(I10)') INEW ELSEIF(MSVAR(IVAR,1).EQ.2) THEN CHINR=' ' CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT) READ(CHINR,*) RNEW ELSEIF(MSVAR(IVAR,1).EQ.3) THEN CHNEW=CHBIT(LNAM+1:LBIT)//' ' ELSE CHNEW2=CHBIT(LNAM+1:LBIT)//' ' ENDIF C...Store new variable value. IF(IVAR.EQ.1) THEN N=INEW ELSEIF(IVAR.EQ.2) THEN K(I1,I2)=INEW ELSEIF(IVAR.EQ.3) THEN P(I1,I2)=RNEW ELSEIF(IVAR.EQ.4) THEN V(I1,I2)=RNEW ELSEIF(IVAR.EQ.5) THEN MSTU(I1)=INEW ELSEIF(IVAR.EQ.6) THEN PARU(I1)=RNEW ELSEIF(IVAR.EQ.7) THEN MSTJ(I1)=INEW ELSEIF(IVAR.EQ.8) THEN PARJ(I1)=RNEW ELSEIF(IVAR.EQ.9) THEN KCHG(I1,I2)=INEW ELSEIF(IVAR.EQ.10) THEN PMAS(I1,I2)=RNEW ELSEIF(IVAR.EQ.11) THEN PARF(I1)=RNEW ELSEIF(IVAR.EQ.12) THEN VCKM(I1,I2)=RNEW ELSEIF(IVAR.EQ.13) THEN MDCY(I1,I2)=INEW ELSEIF(IVAR.EQ.14) THEN MDME(I1,I2)=INEW ELSEIF(IVAR.EQ.15) THEN BRAT(I1)=RNEW ELSEIF(IVAR.EQ.16) THEN KFDP(I1,I2)=INEW ELSEIF(IVAR.EQ.17) THEN CHAF(I1,I2)=CHNEW ELSEIF(IVAR.EQ.18) THEN MRPY(I1)=INEW ELSEIF(IVAR.EQ.19) THEN RRPY(I1)=RNEW ELSEIF(IVAR.EQ.20) THEN MSEL=INEW ELSEIF(IVAR.EQ.21) THEN MSUB(I1)=INEW ELSEIF(IVAR.EQ.22) THEN KFIN(I1,I2)=INEW ELSEIF(IVAR.EQ.23) THEN CKIN(I1)=RNEW ELSEIF(IVAR.EQ.24) THEN MSTP(I1)=INEW ELSEIF(IVAR.EQ.25) THEN PARP(I1)=RNEW ELSEIF(IVAR.EQ.26) THEN MSTI(I1)=INEW ELSEIF(IVAR.EQ.27) THEN PARI(I1)=RNEW ELSEIF(IVAR.EQ.28) THEN MINT(I1)=INEW ELSEIF(IVAR.EQ.29) THEN VINT(I1)=RNEW ELSEIF(IVAR.EQ.30) THEN ISET(I1)=INEW ELSEIF(IVAR.EQ.31) THEN KFPR(I1,I2)=INEW ELSEIF(IVAR.EQ.32) THEN COEF(I1,I2)=RNEW ELSEIF(IVAR.EQ.33) THEN ICOL(I1,I2,I3)=INEW ELSEIF(IVAR.EQ.34) THEN XSFX(I1,I2)=RNEW ELSEIF(IVAR.EQ.35) THEN ISIG(I1,I2)=INEW ELSEIF(IVAR.EQ.36) THEN SIGH(I1)=RNEW ELSEIF(IVAR.EQ.37) THEN MWID(I1)=INEW ELSEIF(IVAR.EQ.38) THEN WIDS(I1,I2)=RNEW ELSEIF(IVAR.EQ.39) THEN NGEN(I1,I2)=INEW ELSEIF(IVAR.EQ.40) THEN XSEC(I1,I2)=RNEW ELSEIF(IVAR.EQ.41) THEN PROC(I1)=CHNEW2 ELSEIF(IVAR.EQ.42) THEN SIGT(I1,I2,I3)=RNEW ELSEIF(IVAR.EQ.43) THEN XPVMD(I1)=RNEW ELSEIF(IVAR.EQ.44) THEN XPANL(I1)=RNEW ELSEIF(IVAR.EQ.45) THEN XPANH(I1)=RNEW ELSEIF(IVAR.EQ.46) THEN XPBEH(I1)=RNEW ELSEIF(IVAR.EQ.47) THEN XPDIR(I1)=RNEW ELSEIF(IVAR.EQ.48) THEN IMSS(I1)=INEW ELSEIF(IVAR.EQ.49) THEN RMSS(I1)=RNEW ENDIF C...Write old and new value. Loop back. CHBIT(LNAM:14)=' ' CHBIT(15:60)=' changed from to ' IF(MSVAR(IVAR,1).EQ.1) THEN WRITE(CHBIT(33:42),'(I10)') IOLD WRITE(CHBIT(51:60),'(I10)') INEW IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60) ELSEIF(MSVAR(IVAR,1).EQ.2) THEN WRITE(CHBIT(29:42),'(F14.5)') ROLD WRITE(CHBIT(47:60),'(F14.5)') RNEW IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60) ELSEIF(MSVAR(IVAR,1).EQ.3) THEN CHBIT(35:42)=CHOLD CHBIT(53:60)=CHNEW IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60) ELSE CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88) ENDIF LLOW=LHIG IF(LLOW.LT.LTOT) GOTO 120 C...Format statement for output on unit MSTU(11) (by default 6). 5000 FORMAT(5X,A60) 5100 FORMAT(5X,A88) RETURN END C********************************************************************* C...PYEXEC C...Administrates the fragmentation and decay chain. SUBROUTINE PYEXEC 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/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5) COMMON/PYINT4/MWID(500),WIDS(500,5) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT4/ C...Local array. DIMENSION PS(2,6),IJOIN(100) C...Initialize and reset. MSTU(24)=0 IF(MSTU(12).GE.1) CALL PYLIST(0) MSTU(31)=MSTU(31)+1 MSTU(1)=0 MSTU(2)=0 MSTU(3)=0 IF(MSTU(17).LE.0) MSTU(90)=0 MCONS=1 C...Sum up momentum, energy and charge for starting entries. NSAV=N DO 110 I=1,2 DO 100 J=1,6 PS(I,J)=0D0 100 CONTINUE 110 CONTINUE DO 130 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130 DO 120 J=1,4 PS(1,J)=PS(1,J)+P(I,J) 120 CONTINUE PS(1,6)=PS(1,6)+PYCHGE(K(I,2)) 130 CONTINUE PARU(21)=PS(1,4) C...Prepare system for subsequent fragmentation/decay. CALL PYPREP(0) C...Loop through jet fragmentation and particle decays. MBE=0 140 MBE=MBE+1 IP=0 150 IP=IP+1 KC=0 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2)) IF(KC.EQ.0) THEN C...Deal with any remaining undecayed resonance C...(normally the task of PYEVNT, so seldom used). ELSEIF(MWID(KC).NE.0) THEN IBEG=IP IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN IBEG=IP+1 160 IBEG=IBEG-1 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 160 IF(K(IBEG,1).NE.2) IBEG=IBEG+1 IEND=IP-1 170 IEND=IEND+1 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 170 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 170 NJOIN=0 DO 180 I=IBEG,IEND IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN NJOIN=NJOIN+1 IJOIN(NJOIN)=I ENDIF 180 CONTINUE ENDIF CALL PYRESD(IP) CALL PYPREP(IBEG) C...Particle decay if unstable and allowed. Save long-lived particle C...decays until second pass after Bose-Einstein effects. ELSEIF(KCHG(KC,2).EQ.0) THEN IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311)) & CALL PYDECY(IP) C...Decay products may develop a shower. IF(MSTJ(92).GT.0) THEN IP1=MSTJ(92) QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1, & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2)) CALL PYSHOW(IP1,IP1+1,QMAX) CALL PYPREP(IP1) MSTJ(92)=0 ELSEIF(MSTJ(92).LT.0) THEN IP1=-MSTJ(92) CALL PYSHOW(IP1,-3,P(IP,5)) CALL PYPREP(IP1) MSTJ(92)=0 ENDIF C...Jet fragmentation: string or independent fragmentation. ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN MFRAG=MSTJ(1) IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND. & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG) ENDIF ENDIF IF(MFRAG.EQ.1) CALL PYSTRF(IP) IF(MFRAG.EQ.2) CALL PYINDF(IP) IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0 ENDIF C...Loop back if enough space left in PYJETS and no error abort. IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN GOTO 150 ELSEIF(IP.LT.N) THEN CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS') ENDIF C...Include simple Bose-Einstein effect parametrization if desired. IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN CALL PYBOEI(NSAV) GOTO 140 ENDIF C...Check that momentum, energy and charge were conserved. DO 200 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 200 DO 190 J=1,4 PS(2,J)=PS(2,J)+P(I,J) 190 CONTINUE PS(2,6)=PS(2,6)+PYCHGE(K(I,2)) 200 CONTINUE PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)- &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4))) IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15, &'(PYEXEC:) four-momentum was not conserved') IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15, &'(PYEXEC:) charge was not conserved') RETURN END C********************************************************************* C...PYPREP C...Rearranges partons along strings. Allows small systems C...to collapse into one or two particles and checks flavours. SUBROUTINE PYPREP(IP) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(4000,2),BRAT(4000),KFDP(4000,5) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/ C...Local arrays. DIMENSION DPS(5),DPC(5),UE(3) C...Rearrange parton shower product listing along strings: begin loop. I1=N DO 130 MQGST=1,2 DO 120 I=MAX(1,IP),N IF(K(I,1).NE.3) GOTO 120 KC=PYCOMP(K(I,2)) IF(KC.EQ.0) GOTO 120 KQ=KCHG(KC,2) IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 120 C...Pick up loose string end. KCS=4 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5 IA=I NSTP=0 100 NSTP=NSTP+1 IF(NSTP.GT.4*N) THEN CALL PYERRM(14,'(PYPREP:) caught in infinite loop') RETURN ENDIF C...Copy undecayed parton. IF(K(IA,1).EQ.3) THEN IF(I1.GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS') RETURN ENDIF I1=I1+1 K(I1,1)=2 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1 K(I1,2)=K(IA,2) K(I1,3)=IA K(I1,4)=0 K(I1,5)=0 DO 110 J=1,5 P(I1,J)=P(IA,J) V(I1,J)=V(IA,J) 110 CONTINUE K(IA,1)=K(IA,1)+10 IF(K(I1,1).EQ.1) GOTO 120 ENDIF C...Go to next parton in colour space. IB=IA IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5)) & .NE.0) THEN IA=MOD(K(IB,KCS),MSTU(5)) K(IB,KCS)=K(IB,KCS)+MSTU(5)**2 MREV=0 ELSE IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5), & MSTU(5)).EQ.0) KCS=9-KCS IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5)) K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2 MREV=1 ENDIF IF(IA.LE.0.OR.IA.GT.N) THEN CALL PYERRM(12,'(PYPREP:) colour rearrangement failed') RETURN ENDIF IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5), & MSTU(5)).EQ.IB) THEN IF(MREV.EQ.1) KCS=9-KCS IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2 ELSE IF(MREV.EQ.0) KCS=9-KCS IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS K(IA,KCS)=K(IA,KCS)+MSTU(5)**2 ENDIF IF(IA.NE.I) GOTO 100 K(I1,1)=1 120 CONTINUE 130 CONTINUE N=I1 IF(MSTJ(14).LT.0) RETURN C...Find lowest-mass colour singlet jet system, OK if above threshold. IF(MSTJ(14).EQ.0) GOTO 320 NS=N 140 NSIN=N-NS PDM=1D0+PARJ(32) IC=0 DO 190 I=MAX(1,IP),NS IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN NSIN=NSIN+1 IC=I DO 150 J=1,4 DPS(J)=P(I,J) 150 CONTINUE MSTJ(93)=1 DPS(5)=PYMASS(K(I,2)) ELSEIF(K(I,1).EQ.2) THEN DO 160 J=1,4 DPS(J)=DPS(J)+P(I,J) 160 CONTINUE ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN DO 170 J=1,4 DPS(J)=DPS(J)+P(I,J) 170 CONTINUE MSTJ(93)=1 DPS(5)=DPS(5)+PYMASS(K(I,2)) PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))- & DPS(5) IF(PD.LT.PDM) THEN PDM=PD DO 180 J=1,5 DPC(J)=DPS(J) 180 CONTINUE IC1=IC IC2=I ENDIF IC=0 ELSE NSIN=NSIN+1 ENDIF 190 CONTINUE IF(PDM.GE.PARJ(32)) GOTO 320 C...Fill small-mass system as cluster. NSAV=N PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2)) K(N+1,1)=11 K(N+1,2)=91 K(N+1,3)=IC1 K(N+1,4)=N+2 K(N+1,5)=N+3 P(N+1,1)=DPC(1) P(N+1,2)=DPC(2) P(N+1,3)=DPC(3) P(N+1,4)=DPC(4) P(N+1,5)=PECM C...Form two particles from flavours of lowest-mass system, if feasible. K(N+2,1)=1 K(N+3,1)=1 IF(MSTU(16).NE.2) THEN K(N+2,3)=N+1 K(N+3,3)=N+1 ELSE K(N+2,3)=IC1 K(N+3,3)=IC2 ENDIF K(N+2,4)=0 K(N+3,4)=0 K(N+2,5)=0 K(N+3,5)=0 IF(IABS(K(IC1,2)).NE.21) THEN KC1=PYCOMP(K(IC1,2)) KC2=PYCOMP(K(IC2,2)) IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 320 KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2)) KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2)) IF(KQ1+KQ2.NE.0) GOTO 320 C.. Start with qq, if there is one. Only allow for rank 1 popcorn meson 200 K1=K(IC1,2) IF(IABS(K(IC2,2)).GT.10) K1=K(IC2,2) MSTU(125)=0 CALL PYDCYK(K1,0,KFLN,K(N+2,2)) CALL PYDCYK(K(IC1,2)+K(IC2,2)-K1,-KFLN,KFLDMP,K(N+3,2)) IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 200 ELSE IF(IABS(K(IC2,2)).NE.21) GOTO 320 C.. No room for popcorn mesons in closed string -> 2 hadrons. MSTU(125)=0 210 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP) CALL PYDCYK(KFLN,0,KFLM,K(N+2,2)) CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2)) IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 210 ENDIF P(N+2,5)=PYMASS(K(N+2,2)) P(N+3,5)=PYMASS(K(N+3,2)) IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM.AND.NSIN.EQ.1) GOTO 320 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) GOTO 260 C...Perform two-particle decay of jet system, if possible. IF(PECM.GE.0.02D0*DPC(4)) THEN PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2- & (P(N+2,5)-P(N+3,5))**2))/(2D0*PECM) UE(3)=2D0*PYR(0)-1D0 PHI=PARU(2)*PYR(0) UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI) UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI) DO 220 J=1,3 P(N+2,J)=PA*UE(J) P(N+3,J)=-PA*UE(J) 220 CONTINUE P(N+2,4)=SQRT(PA**2+P(N+2,5)**2) P(N+3,4)=SQRT(PA**2+P(N+3,5)**2) MSTU(33)=1 CALL PYROBO(N+2,N+3,0D0,0D0,DPC(1)/DPC(4),DPC(2)/DPC(4), & DPC(3)/DPC(4)) ELSE NP=0 DO 230 I=IC1,IC2 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2) NP=NP+1 230 CONTINUE HA=P(IC1,4)*P(IC2,4)-P(IC1,1)*P(IC2,1)-P(IC1,2)*P(IC2,2)- & P(IC1,3)*P(IC2,3) IF(NP.GE.3.OR.HA.LE.1.25D0*P(IC1,5)*P(IC2,5)) GOTO 260 HD1=0.5D0*(P(N+2,5)**2-P(IC1,5)**2) HD2=0.5D0*(P(N+3,5)**2-P(IC2,5)**2) HR=SQRT(MAX(0D0,((HA-HD1-HD2)**2-(P(N+2,5)*P(N+3,5))**2)/ & (HA**2-(P(IC1,5)*P(IC2,5))**2)))-1D0 HC=P(IC1,5)**2+2D0*HA+P(IC2,5)**2 HK1=((P(IC2,5)**2+HA)*HR+HD1-HD2)/HC HK2=((P(IC1,5)**2+HA)*HR+HD2-HD1)/HC DO 240 J=1,4 P(N+2,J)=(1D0+HK1)*P(IC1,J)-HK2*P(IC2,J) P(N+3,J)=(1D0+HK2)*P(IC2,J)-HK1*P(IC1,J) 240 CONTINUE ENDIF DO 250 J=1,4 V(N+1,J)=V(IC1,J) V(N+2,J)=V(IC1,J) V(N+3,J)=V(IC2,J) 250 CONTINUE V(N+1,5)=0D0 V(N+2,5)=0D0 V(N+3,5)=0D0 N=N+3 GOTO 300 C...Else form one particle from the flavours available, if possible. 260 K(N+1,5)=N+2 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN GOTO 320 ELSEIF(IABS(K(IC1,2)).NE.21) THEN CALL PYKFDI(K(IC1,2),K(IC2,2),KFLDMP,K(N+2,2)) ELSE KFLN=1+INT((2D0+PARJ(2))*PYR(0)) CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2)) ENDIF IF(K(N+2,2).EQ.0) GOTO 260 P(N+2,5)=PYMASS(K(N+2,2)) C...Find parton/particle which combines to largest extra mass. IR=0 HA=0D0 HSM=0D0 DO 280 MCOMB=1,3 IF(IR.NE.0) GOTO 280 DO 270 I=MAX(1,IP),N IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 270 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2)) IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 270 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 270 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100) & GOTO 270 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3) HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5) IF(HSR.GT.HSM) THEN IR=I HA=HCR HSM=HSR ENDIF 270 CONTINUE 280 CONTINUE C...Shuffle energy and momentum to put new particle on mass shell. IF(IR.NE.0) THEN HB=PECM**2+HA HC=P(N+2,5)**2+HA HD=P(IR,5)**2+HA HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/ & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD) HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB DO 290 J=1,4 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J) P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J) V(N+1,J)=V(IC1,J) V(N+2,J)=V(IC1,J) 290 CONTINUE V(N+1,5)=0D0 V(N+2,5)=0D0 N=N+2 ELSE CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster') RETURN ENDIF C...Mark collapsed system and store daughter pointers. Iterate. 300 DO 310 I=IC1,IC2 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.KCHG(PYCOMP(K(I,2)),2).NE.0) & THEN K(I,1)=K(I,1)+10 IF(MSTU(16).NE.2) THEN K(I,4)=NSAV+1 K(I,5)=NSAV+1 ELSE K(I,4)=NSAV+2 K(I,5)=N ENDIF ENDIF 310 CONTINUE IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140 C...Check flavours and invariant masses in parton systems. 320 NP=0 KFN=0 KQS=0 DO 330 J=1,5 DPS(J)=0D0 330 CONTINUE DO 360 I=MAX(1,IP),N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 360 KC=PYCOMP(K(I,2)) IF(KC.EQ.0) GOTO 360 KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) IF(KQ.EQ.0) GOTO 360 NP=NP+1 IF(KQ.NE.2) THEN KFN=KFN+1 KQS=KQS+KQ MSTJ(93)=1 DPS(5)=DPS(5)+PYMASS(K(I,2)) ENDIF DO 340 J=1,4 DPS(J)=DPS(J)+P(I,J) 340 CONTINUE IF(K(I,1).EQ.1) THEN IF(NP.NE.1.AND.(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0)) CALL & PYERRM(2,'(PYPREP:) unphysical flavour combination') IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT. & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3, & '(PYPREP:) too small mass in jet system') NP=0 KFN=0 KQS=0 DO 350 J=1,5 DPS(J)=0D0 350 CONTINUE ENDIF 360 CONTINUE RETURN END C********************************************************************* C...PYSTRF C...Handles the fragmentation of an arbitrary colour singlet C...jet system according to the Lund string fragmentation model. SUBROUTINE PYSTRF(IP) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local arrays. All MOPS variables ends with MO DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2), &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(3),PJU(5,5), &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8), &INMO(9),PM2QMO(2),XTMO(2) C...Function: four-product of two vectors. FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)- &DP(I,3)*DP(J,3) C...Reset counters. Identify parton system. MSTJ(91)=0 NSAV=N MSTU90=MSTU(90) NP=0 KQSUM=0 DO 100 J=1,5 DPS(J)=0D0 100 CONTINUE MJU(1)=0 MJU(2)=0 I=IP-1 110 I=I+1 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system') IF(MSTU(21).GE.1) RETURN ENDIF IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110 KC=PYCOMP(K(I,2)) IF(KC.EQ.0) GOTO 110 KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) IF(KQ.EQ.0) GOTO 110 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS') IF(MSTU(21).GE.1) RETURN ENDIF C...Take copy of partons to be considered. Check flavour sum. NP=NP+1 DO 120 J=1,5 K(N+NP,J)=K(I,J) P(N+NP,J)=P(I,J) IF(J.NE.4) DPS(J)=DPS(J)+P(I,J) 120 CONTINUE DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) K(N+NP,3)=I IF(KQ.NE.2) KQSUM=KQSUM+KQ IF(K(I,1).EQ.41) THEN KQSUM=KQSUM+2*KQ IF(KQSUM.EQ.KQ) MJU(1)=N+NP IF(KQSUM.NE.KQ) MJU(2)=N+NP ENDIF IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110 IF(KQSUM.NE.0) THEN CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination') IF(MSTU(21).GE.1) RETURN ENDIF C...Boost copied system to CM frame (for better numerical precision). IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN MBST=0 MSTU(33)=1 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4), & -DPS(3)/DPS(4)) ELSE MBST=1 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3))) DO 130 I=N+1,N+NP HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2 IF(P(I,3).GT.0D0) THEN HHPEZ=(P(I,4)+P(I,3))/HHBZ P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ) P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ) ELSE HHPEZ=(P(I,4)-P(I,3))*HHBZ P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ) P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ) ENDIF 130 CONTINUE ENDIF C...Search for very nearby partons that may be recombined. NTRYR=0 PARU12=PARU(12) PARU13=PARU(13) MJU(3)=MJU(1) MJU(4)=MJU(2) NR=NP 140 IF(NR.GE.3) THEN PDRMIN=2D0*PARU12 DO 150 I=N+1,N+NR IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150 I1=I+1 IF(I.EQ.N+NR) I1=N+1 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21) & GOTO 150 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21) & GOTO 150 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+ & P(I1,2)**2+P(I1,3)**2)) PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3) PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP)) IF(PDR.LT.PDRMIN) THEN IR=I PDRMIN=PDR ENDIF 150 CONTINUE C...Recombine very nearby partons to avoid machine precision problems. IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN DO 160 J=1,4 P(N+1,J)=P(N+1,J)+P(N+NR,J) 160 CONTINUE P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- & P(N+1,3)**2)) NR=NR-1 GOTO 140 ELSEIF(PDRMIN.LT.PARU12) THEN DO 170 J=1,4 P(IR,J)=P(IR,J)+P(IR+1,J) 170 CONTINUE P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2- & P(IR,3)**2)) DO 190 I=IR+1,N+NR-1 K(I,2)=K(I+1,2) DO 180 J=1,5 P(I,J)=P(I+1,J) 180 CONTINUE 190 CONTINUE IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2) NR=NR-1 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1 GOTO 140 ENDIF ENDIF NTRYR=NTRYR+1 C...Reset particle counter. Skip ahead if no junctions are present; C...this is usually the case! NRS=MAX(5*NR+11,NP) NTRY=0 200 NTRY=NTRY+1 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN PARU12=4D0*PARU12 PARU13=2D0*PARU13 GOTO 140 ELSEIF(NTRY.GT.100) THEN CALL PYERRM(14,'(PYSTRF:) caught in infinite loop') IF(MSTU(21).GE.1) RETURN ENDIF I=N+NRS MSTU(90)=MSTU90 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 580 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'// & ' junction strings not handled by MSTJ(12)>3 options') DO 570 JT=1,2 NJS(JT)=0 IF(MJU(JT).EQ.0) GOTO 570 JS=3-2*JT C...Find and sum up momentum on three sides of junction. Check flavours. DO 220 IU=1,3 IJU(IU)=0 DO 210 J=1,5 PJU(IU,J)=0D0 210 CONTINUE 220 CONTINUE IU=0 DO 240 I1=N+1+(JT-1)*(NR-1),N+NR+(JT-1)*(1-NR),JS IF(K(I1,2).NE.21.AND.IU.LE.2) THEN IU=IU+1 IJU(IU)=I1 ENDIF DO 230 J=1,4 PJU(IU,J)=PJU(IU,J)+P(I1,J) 230 CONTINUE 240 CONTINUE DO 250 IU=1,3 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2) 250 CONTINUE IF(K(IJU(3),2)/100.NE.10*K(IJU(1),2)+K(IJU(2),2).AND. & K(IJU(3),2)/100.NE.10*K(IJU(2),2)+K(IJU(1),2)) THEN CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination') IF(MSTU(21).GE.1) RETURN ENDIF C...Calculate (approximate) boost to rest frame of junction. T12=(PJU(1,1)*PJU(2,1)+PJU(1,2)*PJU(2,2)+PJU(1,3)*PJU(2,3))/ & (PJU(1,5)*PJU(2,5)) T13=(PJU(1,1)*PJU(3,1)+PJU(1,2)*PJU(3,2)+PJU(1,3)*PJU(3,3))/ & (PJU(1,5)*PJU(3,5)) T23=(PJU(2,1)*PJU(3,1)+PJU(2,2)*PJU(3,2)+PJU(2,3)*PJU(3,3))/ & (PJU(2,5)*PJU(3,5)) T11=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T13)/(1D0-T23)) T22=SQRT((2D0/3D0)*(1D0-T12)*(1D0-T23)/(1D0-T13)) TSQ=SQRT((2D0*T11*T22+T12-1D0)*(1D0+T12)) T1F=(TSQ-T22*(1D0+T12))/(1D0-T12**2) T2F=(TSQ-T11*(1D0+T12))/(1D0-T12**2) DO 260 J=1,3 TJU(J)=-(T1F*PJU(1,J)/PJU(1,5)+T2F*PJU(2,J)/PJU(2,5)) 260 CONTINUE TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2) DO 270 IU=1,3 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)- & TJU(3)*PJU(IU,3) 270 CONTINUE C...Put junction at rest if motion could give inconsistencies. IF(PJU(1,5)+PJU(2,5).GT.PJU(1,4)+PJU(2,4)) THEN DO 280 J=1,3 TJU(J)=0D0 280 CONTINUE TJU(4)=1D0 PJU(1,5)=PJU(1,4) PJU(2,5)=PJU(2,4) PJU(3,5)=PJU(3,4) ENDIF C...Start preparing for fragmentation of two strings from junction. ISTA=I DO 550 IU=1,2 NS=IJU(IU+1)-IJU(IU) C...Junction strings: find longitudinal string directions. DO 310 IS=1,NS IS1=IJU(IU)+IS-1 IS2=IJU(IU)+IS DO 290 J=1,5 DP(1,J)=0.5D0*P(IS1,J) IF(IS.EQ.1) DP(1,J)=P(IS1,J) DP(2,J)=0.5D0*P(IS2,J) IF(IS.EQ.NS) DP(2,J)=-PJU(IU,J) 290 CONTINUE IF(IS.EQ.NS) DP(2,4)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+ & PJU(IU,3)**2) IF(IS.EQ.NS) DP(2,5)=0D0 DP(3,5)=DFOUR(1,1) DP(4,5)=DFOUR(2,2) DHKC=DFOUR(1,2) IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) DP(3,5)=0D0 DP(4,5)=0D0 DHKC=DFOUR(1,2) ENDIF DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5)) DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0) DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0) IN1=N+NR+4*IS-3 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5)) DO 300 J=1,4 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J) P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J) 300 CONTINUE 310 CONTINUE C...Junction strings: initialize flavour, momentum and starting pos. ISAV=I MSTU91=MSTU(90) 320 NTRY=NTRY+1 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN PARU12=4D0*PARU12 PARU13=2D0*PARU13 GOTO 140 ELSEIF(NTRY.GT.100) THEN CALL PYERRM(14,'(PYSTRF:) caught in infinite loop') IF(MSTU(21).GE.1) RETURN ENDIF I=ISAV MSTU(90)=MSTU91 IRANKJ=0 IE(1)=K(N+1+(JT/2)*(NP-1),3) IN(4)=N+NR+1 IN(5)=IN(4)+1 IN(6)=N+NR+4*NS+1 DO 340 JQ=1,2 DO 330 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4 P(IN1,1)=2-JQ P(IN1,2)=JQ-1 P(IN1,3)=1D0 330 CONTINUE 340 CONTINUE KFL(1)=K(IJU(IU),2) PX(1)=0D0 PY(1)=0D0 GAM(1)=0D0 DO 350 J=1,5 PJU(IU+3,J)=0D0 350 CONTINUE C...Junction strings: find initial transverse directions. DO 360 J=1,4 DP(1,J)=P(IN(4),J) DP(2,J)=P(IN(4)+1,J) DP(3,J)=0D0 DP(4,J)=0D0 360 CONTINUE DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0 DHC12=DFOUR(1,2) DHCX1=DFOUR(3,1)/DHC12 DHCX2=DFOUR(3,2)/DHC12 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) DHCY1=DFOUR(4,1)/DHC12 DHCY2=DFOUR(4,2)/DHC12 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2) DO 370 J=1,4 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) P(IN(6),J)=DP(3,J) P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)- & DHCYX*DP(3,J)) 370 CONTINUE C...Junction strings: produce new particle, origin. 380 I=I+1 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS') IF(MSTU(21).GE.1) RETURN ENDIF IRANKJ=IRANKJ+1 K(I,1)=1 K(I,3)=IE(1) K(I,4)=0 K(I,5)=0 C...Junction strings: generate flavour, hadron, pT, z and Gamma. 390 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2)) IF(K(I,2).EQ.0) GOTO 320 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND. & IABS(KFL(3)).GT.10) THEN IF(PYR(0).GT.PARJ(19)) GOTO 390 ENDIF P(I,5)=PYMASS(K(I,2)) CALL PYPTDI(KFL(1),PX(3),PY(3)) PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z) IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND. & MSTU(90).LT.8) THEN MSTU(90)=MSTU(90)+1 MSTU(90+MSTU(90))=I PARU(90+MSTU(90))=Z ENDIF GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z) DO 400 J=1,3 IN(J)=IN(3+J) 400 CONTINUE C...Junction strings: stepping within or from 'low' string region easy. IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)* & P(IN(1),5)**2.GE.PR(1)) THEN P(IN(1)+2,4)=Z*P(IN(1)+2,3) P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2) DO 410 J=1,4 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J) 410 CONTINUE GOTO 500 ELSEIF(IN(1)+1.EQ.IN(2)) THEN P(IN(2)+2,4)=P(IN(2)+2,3) P(IN(2)+2,1)=1D0 IN(2)=IN(2)+4 IF(IN(2).GT.N+NR+4*NS) GOTO 320 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN P(IN(1)+2,4)=P(IN(1)+2,3) P(IN(1)+2,1)=0D0 IN(1)=IN(1)+4 ENDIF ENDIF C...Junction strings: find new transverse directions. 420 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR. & IN(1).GT.IN(2)) GOTO 320 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN DO 430 J=1,4 DP(1,J)=P(IN(1),J) DP(2,J)=P(IN(2),J) DP(3,J)=0D0 DP(4,J)=0D0 430 CONTINUE DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) DHC12=DFOUR(1,2) IF(DHC12.LE.1D-2) THEN P(IN(1)+2,4)=P(IN(1)+2,3) P(IN(1)+2,1)=0D0 IN(1)=IN(1)+4 GOTO 420 ENDIF IN(3)=N+NR+4*NS+5 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0 DHCX1=DFOUR(3,1)/DHC12 DHCX2=DFOUR(3,2)/DHC12 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) DHCY1=DFOUR(4,1)/DHC12 DHCY2=DFOUR(4,2)/DHC12 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2) DO 440 J=1,4 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) P(IN(3),J)=DP(3,J) P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)- & DHCYX*DP(3,J)) 440 CONTINUE C...Express pT with respect to new axes, if sensible. PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3))) PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1)) IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN PX(3)=PXP PY(3)=PYP ENDIF ENDIF C...Junction strings: sum up known four-momentum, coefficients for m2. DO 470 J=1,4 DHG(J)=0D0 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+ & PY(3)*P(IN(3)+1,J) DO 450 IN1=IN(4),IN(1)-4,4 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J) 450 CONTINUE DO 460 IN2=IN(5),IN(2)-4,4 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J) 460 CONTINUE 470 CONTINUE DHM(1)=FOUR(I,I) DHM(2)=2D0*FOUR(I,IN(1)) DHM(3)=2D0*FOUR(I,IN(2)) DHM(4)=2D0*FOUR(IN(1),IN(2)) C...Junction strings: find coefficients for Gamma expression. DO 490 IN2=IN(1)+1,IN(2),4 DO 480 IN1=IN(1),IN2-1,4 DHC=2D0*FOUR(IN1,IN2) DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC 480 CONTINUE 490 CONTINUE C...Junction strings: solve (m2, Gamma) equation system for energies. DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3) IF(ABS(DHS1).LT.1D-4) GOTO 320 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)* & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3) DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1)) P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/ & ABS(DHS1)-DHS2/DHS1) IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 320 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/ & (DHM(2)+DHM(4)*P(IN(2)+2,4)) C...Junction strings: step to new region if necessary. IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN P(IN(2)+2,4)=P(IN(2)+2,3) P(IN(2)+2,1)=1D0 IN(2)=IN(2)+4 IF(IN(2).GT.N+NR+4*NS) GOTO 320 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN P(IN(1)+2,4)=P(IN(1)+2,3) P(IN(1)+2,1)=0D0 IN(1)=IN(1)+4 ENDIF GOTO 420 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN P(IN(1)+2,4)=P(IN(1)+2,3) P(IN(1)+2,1)=0D0 IN(1)=IN(1)+JS GOTO 890 ENDIF C...Junction strings: particle four-momentum, remainder, loop back. 500 DO 510 J=1,4 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+ & P(IN(2)+2,4)*P(IN(2),J) PJU(IU+3,J)=PJU(IU+3,J)+P(I,J) 510 CONTINUE IF(P(I,4).LT.P(I,5)) GOTO 320 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)- & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3) IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN KFL(1)=-KFL(3) PX(1)=-PX(3) PY(1)=-PY(3) GAM(1)=GAM(3) IF(IN(3).NE.IN(6)) THEN DO 520 J=1,4 P(IN(6),J)=P(IN(3),J) P(IN(6)+1,J)=P(IN(3)+1,J) 520 CONTINUE ENDIF DO 530 JQ=1,2 IN(3+JQ)=IN(JQ) P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4) P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4) 530 CONTINUE GOTO 380 ENDIF C...Junction strings: save quantities left after each string. IF(IABS(KFL(1)).GT.10) GOTO 320 I=I-1 KFJH(IU)=KFL(1) DO 540 J=1,4 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J) 540 CONTINUE 550 CONTINUE C...Junction strings: put together to new effective string endpoint. NJS(JT)=I-ISTA KFJS(JT)=K(K(MJU(JT+2),3),2) KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1 IF(KFJH(1).EQ.KFJH(2)) KFLS=3 IF(ISTA.NE.I) KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)), & IABS(KFJH(2)))+100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+ & KFLS,KFJH(1)) DO 560 J=1,4 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J) PJS(JT+2,J)=PJU(4,J)+PJU(5,J) 560 CONTINUE PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2- & PJS(JT,3)**2)) 570 CONTINUE C...Open versus closed strings. Choose breakup region for latter. 580 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN NS=MJU(2)-MJU(1) NB=MJU(1)-N ELSEIF(MJU(1).NE.0) THEN NS=N+NR-MJU(1) NB=MJU(1)-N ELSEIF(MJU(2).NE.0) THEN NS=MJU(2)-N NB=1 ELSEIF(IABS(K(N+1,2)).NE.21) THEN NS=NR-1 NB=1 ELSE NS=NR+1 W2SUM=0D0 DO 590 IS=1,NR P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR)) W2SUM=W2SUM+P(N+NR+IS,1) 590 CONTINUE W2RAN=PYR(0)*W2SUM NB=0 600 NB=NB+1 W2SUM=W2SUM-P(N+NR+NB,1) IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 600 ENDIF C...Find longitudinal string directions (i.e. lightlike four-vectors). DO 630 IS=1,NS IS1=N+IS+NB-1-NR*((IS+NB-2)/NR) IS2=N+IS+NB-NR*((IS+NB-1)/NR) DO 610 J=1,5 DP(1,J)=P(IS1,J) IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J) IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J) DP(2,J)=P(IS2,J) IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J) IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J) 610 CONTINUE DP(3,5)=DFOUR(1,1) DP(4,5)=DFOUR(2,2) DHKC=DFOUR(1,2) IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN DP(3,5)=DP(1,5)**2 DP(4,5)=DP(2,5)**2 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2+DP(1,5)**2) DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2+DP(2,5)**2) DHKC=DFOUR(1,2) ENDIF DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5)) DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0) DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0) IN1=N+NR+4*IS-3 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5)) DO 620 J=1,4 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J) P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J) 620 CONTINUE 630 CONTINUE C...Begin initialization: sum up energy, set starting position. ISAV=I MSTU91=MSTU(90) 640 NTRY=NTRY+1 IF(NTRY.GT.100.AND.NTRYR.LE.4) THEN PARU12=4D0*PARU12 PARU13=2D0*PARU13 GOTO 140 ELSEIF(NTRY.GT.100) THEN CALL PYERRM(14,'(PYSTRF:) caught in infinite loop') IF(MSTU(21).GE.1) RETURN ENDIF I=ISAV MSTU(90)=MSTU91 DO 660 J=1,4 P(N+NRS,J)=0D0 DO 650 IS=1,NR P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J) 650 CONTINUE 660 CONTINUE DO 680 JT=1,2 IRANK(JT)=0 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT) IF(NS.GT.NR) IRANK(JT)=1 IE(JT)=K(N+1+(JT/2)*(NP-1),3) IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1) IN(3*JT+2)=IN(3*JT+1)+1 IN(3*JT+3)=N+NR+4*NS+2*JT-1 DO 670 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4 P(IN1,1)=2-JT P(IN1,2)=JT-1 P(IN1,3)=1D0 670 CONTINUE 680 CONTINUE C.. MOPS variables and switches NRVMO=0 XBMO=1D0 MSTU(121)=0 MSTU(122)=0 C...Initialize flavour and pT variables for open string. IF(NS.LT.NR) THEN PX(1)=0D0 PY(1)=0D0 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1)) PX(2)=-PX(1) PY(2)=-PY(1) DO 690 JT=1,2 KFL(JT)=K(IE(JT),2) IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT) MSTJ(93)=1 PMQ(JT)=PYMASS(KFL(JT)) GAM(JT)=0D0 690 CONTINUE C...Closed string: random initial breakup flavour, pT and vertex. ELSE KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0) IBMO=0 700 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP) C.. Closed string: first vertex diq attempt => enforced second C.. vertex diq IF(IABS(KFL(1)).GT.10)THEN IBMO=1 MSTU(121)=0 GOTO 700 ENDIF IF(IBMO.EQ.1) MSTU(121)=-1 KFL(2)=-KFL(1) CALL PYPTDI(KFL(1),PX(1),PY(1)) PX(2)=-PX(1) PY(2)=-PY(1) PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2) 710 CALL PYZDIS(KFL(1),KFL(2),PR3,Z) ZR=PR3/(Z*P(N+NR+1,5)**2) IF(ZR.GE.1D0) GOTO 710 DO 720 JT=1,2 MSTJ(93)=1 PMQ(JT)=PYMASS(KFL(JT)) GAM(JT)=PR3*(1D0-Z)/Z IN1=N+NR+3+4*(JT/2)*(NS-1) P(IN1,JT)=1D0-Z P(IN1,3-JT)=JT-1 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z P(IN1+1,JT)=ZR P(IN1+1,3-JT)=2-JT P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR 720 CONTINUE ENDIF C.. MOPS variables DO 730 JT=1,2 XTMO(JT)=1D0 PM2QMO(JT)=PMQ(JT)**2 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0 730 CONTINUE C...Find initial transverse directions (i.e. spacelike four-vectors). DO 770 JT=1,2 IF(JT.EQ.1.OR.NS.EQ.NR-1) THEN IN1=IN(3*JT+1) IN3=IN(3*JT+3) DO 740 J=1,4 DP(1,J)=P(IN1,J) DP(2,J)=P(IN1+1,J) DP(3,J)=0D0 DP(4,J)=0D0 740 CONTINUE DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0 DHC12=DFOUR(1,2) DHCX1=DFOUR(3,1)/DHC12 DHCX2=DFOUR(3,2)/DHC12 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) DHCY1=DFOUR(4,1)/DHC12 DHCY2=DFOUR(4,2)/DHC12 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2) DO 750 J=1,4 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) P(IN3,J)=DP(3,J) P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)- & DHCYX*DP(3,J)) 750 CONTINUE ELSE DO 760 J=1,4 P(IN3+2,J)=P(IN3,J) P(IN3+3,J)=P(IN3+1,J) 760 CONTINUE ENDIF 770 CONTINUE C...Remove energy used up in junction string fragmentation. IF(MJU(1)+MJU(2).GT.0) THEN DO 790 JT=1,2 IF(NJS(JT).EQ.0) GOTO 790 DO 780 J=1,4 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J) 780 CONTINUE 790 CONTINUE ENDIF C...Produce new particle: side, origin. 800 I=I+1 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS') IF(MSTU(21).GE.1) RETURN ENDIF C.. New side priority for popcorn systems IF(MSTU(121).LE.0)THEN JT=1.5D0+PYR(0) IF(IABS(KFL(3-JT)).GT.10) JT=3-JT IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT ENDIF JR=3-JT JS=3-2*JT IRANK(JT)=IRANK(JT)+1 K(I,1)=1 K(I,3)=IE(JT) K(I,4)=0 K(I,5)=0 C...Generate flavour, hadron and pT. 810 CONTINUE CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2)) IF(K(I,2).EQ.0) GOTO 640 MU90MO=MSTU(90) IF(MSTU(121).EQ.-1) GOTO 840 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND. &IABS(KFL(3)).GT.10) THEN IF(PYR(0).GT.PARJ(19)) GOTO 810 ENDIF P(I,5)=PYMASS(K(I,2)) CALL PYPTDI(KFL(JT),PX(3),PY(3)) PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2 C...Final hadrons for small invariant mass. MSTJ(93)=1 PMQ(3)=PYMASS(KFL(3)) PARJST=PARJ(33) IF(MSTJ(11).EQ.2) PARJST=PARJ(34) WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3) IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN= &WMIN-0.5D0*PARJ(36)*PMQ(3) WREM2=FOUR(N+NRS,N+NRS) IF(WREM2.LT.0.10D0) GOTO 640 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)), &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1010 C...Choose z, which gives Gamma. Shift z for heavy flavours. CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z) IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND. &MSTU(90).LT.8) THEN MSTU(90)=MSTU(90)+1 MSTU(90+MSTU(90))=I PARU(90+MSTU(90))=Z ENDIF KFL1A=IABS(KFL(1)) KFL2A=IABS(KFL(2)) IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10), &MOD(KFL2A/1000,10)).GE.4) THEN PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2))) Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2) PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1010 ENDIF GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z) C.. MOPS baryon model modification XTMO3=(1D0-Z)*XTMO(JT) IF(IABS(KFL(3)).LE.10) NRVMO=0 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN GTSTMO=1D0 PTSTMO=1D0 RTSTMO=PYR(0) IF(IABS(KFL(JT)).LE.10)THEN XBMO=MIN(XTMO3,1D0-(2D-10)) GBMO=GAM(3) PMMO=0D0 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT) GTSTMO=1D0-PARF(192)**PGMO ELSE IF(IRANK(JT).EQ.1) THEN GBMO=GAM(JT) PMMO=0D0 XBMO=1D0 ENDIF IF(XBMO.LT.1D0-(1D-10))THEN PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3) GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO) PGMO=PGNMO ENDIF IF(MSTJ(12).GE.5)THEN PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO)) PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3) PTSTMO=EXP((PMMO-PMNMO)*PARF(193)) PMMO=PMNMO ENDIF ENDIF C.. MOPS Accepting popcorn system hadron. IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN NRVMO=I-N-NR IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11, & '(PYSTRF:) no more memory left in PYJETS') IF(MSTU(21).GE.1) RETURN ENDIF IMO=I KFLMO=KFL(JT) PMQMO=PMQ(JT) PXMO=PX(JT) PYMO=PY(JT) GAMMO=GAM(JT) IRMO=IRANK(JT) XMO=XTMO(JT) DO 830 J=1,9 IF(J.LE.5) THEN DO 820 LINE=1,I-N-NR P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J) K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J) 820 CONTINUE ENDIF INMO(J)=IN(J) 830 CONTINUE ENDIF ELSE C..Reject popcorn system, flag=-1 if enforcing new one MSTU(121)=-1 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2 ENDIF ENDIF C..Lift restoring string outside MOPS block 840 IF(MSTU(121).LT.0) THEN IF(MSTU(121).EQ.-2) MSTU(121)=0 MSTU(90)=MU90MO NRVMO=0 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 810 I=IMO KFL(JT)=KFLMO PMQ(JT)=PMQMO PX(JT)=PXMO PY(JT)=PYMO GAM(JT)=GAMMO IRANK(JT)=IRMO XTMO(JT)=XMO DO 860 J=1,9 IF(J.LE.5) THEN DO 850 LINE=1,I-N-NR P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J) K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J) 850 CONTINUE ENDIF IN(J)=INMO(J) 860 CONTINUE GOTO 810 ENDIF XTMO(JT)=XTMO3 C.. MOPS end of modification DO 870 J=1,3 IN(J)=IN(3*JT+J) 870 CONTINUE C...Stepping within or from 'low' string region easy. IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)* &P(IN(1),5)**2.GE.PR(JT)) THEN P(IN(JT)+2,4)=Z*P(IN(JT)+2,3) P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2) DO 880 J=1,4 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J) 880 CONTINUE GOTO 970 ELSEIF(IN(1)+1.EQ.IN(2)) THEN P(IN(JR)+2,4)=P(IN(JR)+2,3) P(IN(JR)+2,JT)=1D0 IN(JR)=IN(JR)+4*JS IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN P(IN(JT)+2,4)=P(IN(JT)+2,3) P(IN(JT)+2,JT)=0D0 IN(JT)=IN(JT)+4*JS ENDIF ENDIF C...Find new transverse directions (i.e. spacelike string vectors). 890 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR. &IN(1).GT.IN(2)) GOTO 640 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN DO 900 J=1,4 DP(1,J)=P(IN(1),J) DP(2,J)=P(IN(2),J) DP(3,J)=0D0 DP(4,J)=0D0 900 CONTINUE DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) DHC12=DFOUR(1,2) IF(DHC12.LE.1D-2) THEN P(IN(JT)+2,4)=P(IN(JT)+2,3) P(IN(JT)+2,JT)=0D0 IN(JT)=IN(JT)+4*JS GOTO 890 ENDIF IN(3)=N+NR+4*NS+5 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0 DHCX1=DFOUR(3,1)/DHC12 DHCX2=DFOUR(3,2)/DHC12 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) DHCY1=DFOUR(4,1)/DHC12 DHCY2=DFOUR(4,2)/DHC12 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2) DO 910 J=1,4 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) P(IN(3),J)=DP(3,J) P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)- & DHCYX*DP(3,J)) 910 CONTINUE C...Express pT with respect to new axes, if sensible. PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)* & FOUR(IN(3*JT+3)+1,IN(3))) PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)* & FOUR(IN(3*JT+3)+1,IN(3)+1)) IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN PX(3)=PXP PY(3)=PYP ENDIF ENDIF C...Sum up known four-momentum. Gives coefficients for m2 expression. DO 940 J=1,4 DHG(J)=0D0 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+ & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J) DO 920 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J) 920 CONTINUE DO 930 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J) 930 CONTINUE 940 CONTINUE DHM(1)=FOUR(I,I) DHM(2)=2D0*FOUR(I,IN(1)) DHM(3)=2D0*FOUR(I,IN(2)) DHM(4)=2D0*FOUR(IN(1),IN(2)) C...Find coefficients for Gamma expression. DO 960 IN2=IN(1)+1,IN(2),4 DO 950 IN1=IN(1),IN2-1,4 DHC=2D0*FOUR(IN1,IN2) DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC 950 CONTINUE 960 CONTINUE C...Solve (m2, Gamma) equation system for energies taken. DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1) IF(ABS(DHS1).LT.1D-4) GOTO 640 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)* &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1) DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1)) P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/ &ABS(DHS1)-DHS2/DHS1) IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 640 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/ &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4)) C...Step to new region if necessary. IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN P(IN(JR)+2,4)=P(IN(JR)+2,3) P(IN(JR)+2,JT)=1D0 IN(JR)=IN(JR)+4*JS IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 640 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN P(IN(JT)+2,4)=P(IN(JT)+2,3) P(IN(JT)+2,JT)=0D0 IN(JT)=IN(JT)+4*JS ENDIF GOTO 890 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN P(IN(JT)+2,4)=P(IN(JT)+2,3) P(IN(JT)+2,JT)=0D0 IN(JT)=IN(JT)+4*JS GOTO 890 ENDIF C...Four-momentum of particle. Remaining quantities. Loop back. 970 DO 980 J=1,4 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J) P(N+NRS,J)=P(N+NRS,J)-P(I,J) 980 CONTINUE IF(P(I,4).LT.P(I,5)) GOTO 640 KFL(JT)=-KFL(3) PMQ(JT)=PMQ(3) PX(JT)=-PX(3) PY(JT)=-PY(3) GAM(JT)=GAM(3) IF(IN(3).NE.IN(3*JT+3)) THEN DO 990 J=1,4 P(IN(3*JT+3),J)=P(IN(3),J) P(IN(3*JT+3)+1,J)=P(IN(3)+1,J) 990 CONTINUE ENDIF DO 1000 JQ=1,2 IN(3*JT+JQ)=IN(JQ) P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4) P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4) 1000 CONTINUE GOTO 800 C...Final hadron: side, flavour, hadron, mass. 1010 I=I+1 K(I,1)=1 K(I,3)=IE(JR) K(I,4)=0 K(I,5)=0 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2)) IF(K(I,2).EQ.0) GOTO 640 P(I,5)=PYMASS(K(I,2)) PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2 C...Final two hadrons: find common setup of four-vectors. JQ=1 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.P(IN(7),3)* &P(IN(8),3)*FOUR(IN(7),IN(8))) JQ=2 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2)) DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ) PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ) PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS* & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2 ENDIF C...Solve kinematics for final two hadrons, if possible. WREM2=WREM2+(PX(1)+PX(2))**2+(PY(1)+PY(2))**2 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2) IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200 IF(FD.GE.1D0) GOTO 640 FA=WREM2+PR(JT)-PR(JR) IF(MSTJ(11).NE.2) PREV=0.5D0*EXP(MAX(-50D0,LOG(FD)*PARJ(38)* &(PR(1)+PR(2))**2)) IF(MSTJ(11).EQ.2) PREV=0.5D0*FD**PARJ(39) FB=SIGN(SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT))),JS*(PYR(0)-PREV)) KFL1A=IABS(KFL(1)) KFL2A=IABS(KFL(2)) IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10), &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2- &4D0*WREM2*PR(JT))),DBLE(JS)) DO 1020 J=1,4 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))* & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+ & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2 P(I,J)=P(N+NRS,J)-P(I-1,J) 1020 CONTINUE IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 640 C...Mark jets as fragmented and give daughter pointers. N=I-NRS+1 DO 1030 I=NSAV+1,NSAV+NP IM=K(I,3) K(IM,1)=K(IM,1)+10 IF(MSTU(16).NE.2) THEN K(IM,4)=NSAV+1 K(IM,5)=NSAV+1 ELSE K(IM,4)=NSAV+2 K(IM,5)=N ENDIF 1030 CONTINUE C...Document string system. Move up particles. NSAV=NSAV+1 K(NSAV,1)=11 K(NSAV,2)=92 K(NSAV,3)=IP K(NSAV,4)=NSAV+1 K(NSAV,5)=N DO 1040 J=1,4 P(NSAV,J)=DPS(J) V(NSAV,J)=V(IP,J) 1040 CONTINUE P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2)) V(NSAV,5)=0D0 DO 1060 I=NSAV+1,N DO 1050 J=1,5 K(I,J)=K(I+NRS-1,J) P(I,J)=P(I+NRS-1,J) V(I,J)=0D0 1050 CONTINUE 1060 CONTINUE MSTU91=MSTU(90) DO 1070 IZ=MSTU90+1,MSTU91 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N PARU9T(IZ)=PARU(90+IZ) 1070 CONTINUE MSTU(90)=MSTU90 C...Order particles in rank along the chain. Update mother pointer. DO 1090 I=NSAV+1,N DO 1080 J=1,5 K(I-NSAV+N,J)=K(I,J) P(I-NSAV+N,J)=P(I,J) 1080 CONTINUE 1090 CONTINUE I1=NSAV DO 1120 I=N+1,2*N-NSAV IF(K(I,3).NE.IE(1)) GOTO 1120 I1=I1+1 DO 1100 J=1,5 K(I1,J)=K(I,J) P(I1,J)=P(I,J) 1100 CONTINUE IF(MSTU(16).NE.2) K(I1,3)=NSAV DO 1110 IZ=MSTU90+1,MSTU91 IF(MSTU9T(IZ).EQ.I) THEN MSTU(90)=MSTU(90)+1 MSTU(90+MSTU(90))=I1 PARU(90+MSTU(90))=PARU9T(IZ) ENDIF 1110 CONTINUE 1120 CONTINUE DO 1150 I=2*N-NSAV,N+1,-1 IF(K(I,3).EQ.IE(1)) GOTO 1150 I1=I1+1 DO 1130 J=1,5 K(I1,J)=K(I,J) P(I1,J)=P(I,J) 1130 CONTINUE IF(MSTU(16).NE.2) K(I1,3)=NSAV DO 1140 IZ=MSTU90+1,MSTU91 IF(MSTU9T(IZ).EQ.I) THEN MSTU(90)=MSTU(90)+1 MSTU(90+MSTU(90))=I1 PARU(90+MSTU(90))=PARU9T(IZ) ENDIF 1140 CONTINUE 1150 CONTINUE C...Boost back particle system. Set production vertices. IF(MBST.EQ.0) THEN MSTU(33)=1 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4), & DPS(3)/DPS(4)) ELSE DO 1160 I=NSAV+1,N HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2 IF(P(I,3).GT.0D0) THEN HHPEZ=(P(I,4)+P(I,3))*HHBZ P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ) P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ) ELSE HHPEZ=(P(I,4)-P(I,3))/HHBZ P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ) P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ) ENDIF 1160 CONTINUE ENDIF DO 1180 I=NSAV+1,N DO 1170 J=1,4 V(I,J)=V(IP,J) 1170 CONTINUE 1180 CONTINUE RETURN END C********************************************************************* C...PYINDF C...Handles the fragmentation of a jet system (or a single C...jet) according to independent fragmentation models. SUBROUTINE PYINDF(IP) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local arrays. DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3), &KFLO(2),PXO(2),PYO(2),WO(2) C.. MOPS error message IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'// &' are not treated as expected in independent fragmentation') C...Reset counters. Identify parton system and take copy. Check flavour. NSAV=N MSTU90=MSTU(90) NJET=0 KQSUM=0 DO 100 J=1,5 DPS(J)=0D0 100 CONTINUE I=IP-1 110 I=I+1 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system') IF(MSTU(21).GE.1) RETURN ENDIF IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110 KC=PYCOMP(K(I,2)) IF(KC.EQ.0) GOTO 110 KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) IF(KQ.EQ.0) GOTO 110 NJET=NJET+1 IF(KQ.NE.2) KQSUM=KQSUM+KQ DO 120 J=1,5 K(NSAV+NJET,J)=K(I,J) P(NSAV+NJET,J)=P(I,J) DPS(J)=DPS(J)+P(I,J) 120 CONTINUE K(NSAV+NJET,3)=I IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND. &K(I+1,1).EQ.2)) GOTO 110 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN CALL PYERRM(12,'(PYINDF:) unphysical flavour combination') IF(MSTU(21).GE.1) RETURN ENDIF C...Boost copied system to CM frame. Find CM energy and sum flavours. IF(NJET.NE.1) THEN MSTU(33)=1 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4), & -DPS(2)/DPS(4),-DPS(3)/DPS(4)) ENDIF PECM=0D0 DO 130 J=1,3 NFI(J)=0 130 CONTINUE DO 140 I=NSAV+1,NSAV+NJET PECM=PECM+P(I,4) KFA=IABS(K(I,2)) IF(KFA.LE.3) THEN NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2)) ELSEIF(KFA.GT.1000) THEN KFLA=MOD(KFA/1000,10) KFLB=MOD(KFA/100,10) IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2)) IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2)) ENDIF 140 CONTINUE C...Loop over attempts made. Reset counters. NTRY=0 150 NTRY=NTRY+1 IF(NTRY.GT.200) THEN CALL PYERRM(14,'(PYINDF:) caught in infinite loop') IF(MSTU(21).GE.1) RETURN ENDIF N=NSAV+NJET MSTU(90)=MSTU90 DO 160 J=1,3 NFL(J)=NFI(J) IFET(J)=0 KFLF(J)=0 160 CONTINUE C...Loop over jets to be fragmented. DO 230 IP1=NSAV+1,NSAV+NJET MSTJ(91)=0 NSAV1=N MSTU91=MSTU(90) C...Initial flavour and momentum values. Jet along +z axis. KFLH=IABS(K(IP1,2)) IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10) KFLO(2)=0 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2) C...Initial values for quark or diquark jet. 170 IF(IABS(K(IP1,2)).NE.21) THEN NSTR=1 KFLO(1)=K(IP1,2) CALL PYPTDI(0,PXO(1),PYO(1)) WO(1)=WF C...Initial values for gluon treated like random quark jet. ELSEIF(MSTJ(2).LE.2) THEN NSTR=1 IF(MSTJ(2).EQ.2) MSTJ(91)=1 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0) CALL PYPTDI(0,PXO(1),PYO(1)) WO(1)=WF C...Initial values for gluon treated like quark-antiquark jet pair, C...sharing energy according to Altarelli-Parisi splitting function. ELSE NSTR=2 IF(MSTJ(2).EQ.4) MSTJ(91)=1 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0) KFLO(2)=-KFLO(1) CALL PYPTDI(0,PXO(1),PYO(1)) PXO(2)=-PXO(1) PYO(2)=-PYO(1) WO(1)=WF*PYR(0)**(1D0/3D0) WO(2)=WF-WO(1) ENDIF C...Initial values for rank, flavour, pT and W+. DO 220 ISTR=1,NSTR 180 I=N MSTU(90)=MSTU91 IRANK=0 KFL1=KFLO(ISTR) PX1=PXO(ISTR) PY1=PYO(ISTR) W=WO(ISTR) C...New hadron. Generate flavour and hadron species. 190 I=I+1 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS') IF(MSTU(21).GE.1) RETURN ENDIF IRANK=IRANK+1 K(I,1)=1 K(I,3)=IP1 K(I,4)=0 K(I,5)=0 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2)) IF(K(I,2).EQ.0) GOTO 180 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN IF(PYR(0).GT.PARJ(19)) GOTO 200 ENDIF C...Find hadron mass. Generate four-momentum. P(I,5)=PYMASS(K(I,2)) CALL PYPTDI(KFL1,PX2,PY2) P(I,1)=PX1+PX2 P(I,2)=PY1+PY2 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2 CALL PYZDIS(KFL1,KFL2,PR,Z) MZSAV=0 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN MZSAV=1 MSTU(90)=MSTU(90)+1 MSTU(90+MSTU(90))=I PARU(90+MSTU(90))=Z ENDIF P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W)) P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W)) IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND. & P(I,3).LE.0.001D0) THEN IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180 P(I,3)=0.0001D0 P(I,4)=SQRT(PR) Z=P(I,4)/W ENDIF C...Remaining flavour and momentum. KFL1=-KFL2 PX1=-PX2 PY1=-PY2 W=(1D0-Z)*W DO 210 J=1,5 V(I,J)=0D0 210 CONTINUE C...Check if pL acceptable. Go back for new hadron if enough energy. IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN I=I-1 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1 ENDIF IF(W.GT.PARJ(31)) GOTO 190 N=I 220 CONTINUE IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32) IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170 C...Rotate jet to new direction. THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2)) PHI=PYANGL(P(IP1,1),P(IP1,2)) MSTU(33)=1 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0) K(K(IP1,3),4)=NSAV1+1 K(K(IP1,3),5)=N C...End of jet generation loop. Skip conservation in some cases. 230 CONTINUE IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150 C...Subtract off produced hadron flavours, finished if zero. DO 240 I=NSAV+NJET+1,N KFA=IABS(K(I,2)) KFLA=MOD(KFA/1000,10) KFLB=MOD(KFA/100,10) KFLC=MOD(KFA/10,10) IF(KFLA.EQ.0) THEN IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB ELSE IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2)) IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2)) IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2)) ENDIF 240 CONTINUE NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3 IF(NREQ.EQ.0) GOTO 320 C...Take away flavour of low-momentum particles until enough freedom. NREM=0 250 IREM=0 P2MIN=PECM**2 DO 260 I=NSAV+NJET+1,N P2=P(I,1)**2+P(I,2)**2+P(I,3)**2 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2 260 CONTINUE IF(IREM.EQ.0) GOTO 150 K(IREM,1)=7 KFA=IABS(K(IREM,2)) KFLA=MOD(KFA/1000,10) KFLB=MOD(KFA/100,10) KFLC=MOD(KFA/10,10) IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8 IF(K(IREM,1).EQ.8) GOTO 250 IF(KFLA.EQ.0) THEN ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN ELSE IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2)) IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2)) IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2)) ENDIF NREM=NREM+1 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3 IF(NREQ.GT.NREM) GOTO 250 DO 270 I=NSAV+NJET+1,N IF(K(I,1).EQ.8) K(I,1)=1 270 CONTINUE C...Find combination of existing and new flavours for hadron. 280 NFET=2 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3 IF(NREQ.LT.NREM) NFET=1 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0 DO 290 J=1,NFET IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0) KFLF(J)=ISIGN(1,NFL(1)) IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2)) IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3)) 290 CONTINUE IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0)) &GOTO 280 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR. &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3) &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0)) IF(NFET.EQ.0) KFLF(2)=-KFLF(1) IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1)) IF(NFET.LE.2) KFLF(3)=0 IF(KFLF(3).NE.0) THEN KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+ & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1)) IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0) & KFLFC=KFLFC+ISIGN(2,KFLFC) ELSE KFLFC=KFLF(1) ENDIF CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF) IF(KF.EQ.0) GOTO 280 DO 300 J=1,MAX(2,NFET) NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J)) 300 CONTINUE C...Store hadron at random among free positions. NPOS=MIN(1+INT(PYR(0)*NREM),NREM) DO 310 I=NSAV+NJET+1,N IF(K(I,1).EQ.7) NPOS=NPOS-1 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310 K(I,1)=1 K(I,2)=KF P(I,5)=PYMASS(K(I,2)) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) 310 CONTINUE NREM=NREM-1 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3 IF(NREM.GT.0) GOTO 280 C...Compensate for missing momentum in global scheme (3 options). 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN DO 340 J=1,3 PSI(J)=0D0 DO 330 I=NSAV+NJET+1,N PSI(J)=PSI(J)+P(I,J) 330 CONTINUE 340 CONTINUE PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2 PWS=0D0 DO 350 I=NSAV+NJET+1,N IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4) IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+ & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4)) IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0 350 CONTINUE DO 370 I=NSAV+NJET+1,N IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4) IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+ & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4)) IF(MOD(MSTJ(3),5).EQ.3) PW=1D0 DO 360 J=1,3 P(I,J)=P(I,J)-PSI(J)*PW/PWS 360 CONTINUE P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) 370 CONTINUE C...Compensate for missing momentum withing each jet separately. ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN DO 390 I=N+1,N+NJET K(I,1)=0 DO 380 J=1,5 P(I,J)=0D0 380 CONTINUE 390 CONTINUE DO 410 I=NSAV+NJET+1,N IR1=K(I,3) IR2=N+IR1-NSAV K(IR2,1)=K(IR2,1)+1 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/ & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2) DO 400 J=1,3 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J) 400 CONTINUE P(IR2,4)=P(IR2,4)+P(I,4) P(IR2,5)=P(IR2,5)+PLS 410 CONTINUE PSS=0D0 DO 420 I=N+1,N+NJET IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0)) 420 CONTINUE DO 440 I=NSAV+NJET+1,N IR1=K(I,3) IR2=N+IR1-NSAV PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/ & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2) DO 430 J=1,3 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)* & PLS*P(IR1,J) 430 CONTINUE P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) 440 CONTINUE ENDIF C...Scale momenta for energy conservation. IF(MOD(MSTJ(3),5).NE.0) THEN PMS=0D0 PES=0D0 PQS=0D0 DO 450 I=NSAV+NJET+1,N PMS=PMS+P(I,5) PES=PES+P(I,4) PQS=PQS+P(I,5)**2/P(I,4) 450 CONTINUE IF(PMS.GE.PECM) GOTO 150 NECO=0 460 NECO=NECO+1 PFAC=(PECM-PQS)/(PES-PQS) PES=0D0 PQS=0D0 DO 480 I=NSAV+NJET+1,N DO 470 J=1,3 P(I,J)=PFAC*P(I,J) 470 CONTINUE P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) PES=PES+P(I,4) PQS=PQS+P(I,5)**2/P(I,4) 480 CONTINUE IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460 ENDIF C...Origin of produced particles and parton daughter pointers. 490 DO 500 I=NSAV+NJET+1,N IF(MSTU(16).NE.2) K(I,3)=NSAV+1 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3) 500 CONTINUE DO 510 I=NSAV+1,NSAV+NJET I1=K(I,3) K(I1,1)=K(I1,1)+10 IF(MSTU(16).NE.2) THEN K(I1,4)=NSAV+1 K(I1,5)=NSAV+1 ELSE K(I1,4)=K(I1,4)-NJET+1 K(I1,5)=K(I1,5)-NJET+1 IF(K(I1,5).LT.K(I1,4)) THEN K(I1,4)=0 K(I1,5)=0 ENDIF ENDIF 510 CONTINUE C...Document independent fragmentation system. Remove copy of jets. NSAV=NSAV+1 K(NSAV,1)=11 K(NSAV,2)=93 K(NSAV,3)=IP K(NSAV,4)=NSAV+1 K(NSAV,5)=N-NJET+1 DO 520 J=1,4 P(NSAV,J)=DPS(J) V(NSAV,J)=V(IP,J) 520 CONTINUE P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2)) V(NSAV,5)=0D0 DO 540 I=NSAV+NJET,N DO 530 J=1,5 K(I-NJET+1,J)=K(I,J) P(I-NJET+1,J)=P(I,J) V(I-NJET+1,J)=V(I,J) 530 CONTINUE 540 CONTINUE N=N-NJET+1 DO 550 IZ=MSTU90+1,MSTU(90) MSTU(90+IZ)=MSTU(90+IZ)-NJET+1 550 CONTINUE C...Boost back particle system. Set production vertices. IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4), &DPS(2)/DPS(4),DPS(3)/DPS(4)) DO 570 I=NSAV+1,N DO 560 J=1,4 V(I,J)=V(IP,J) 560 CONTINUE 570 CONTINUE RETURN END C********************************************************************* C...PYDECY C...Handles the decay of unstable particles. SUBROUTINE PYDECY(IP) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) 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(4000,2),BRAT(4000),KFDP(4000,5) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/ C...Local arrays. DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3), &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3) CHARACTER CIDC*4 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/ C...Functions: momentum in two-particle decays and four-product. PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A) FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) C...Initial values. NTRY=0 NSAV=N KFA=IABS(K(IP,2)) KFS=ISIGN(1,K(IP,2)) KC=PYCOMP(KFA) MSTJ(92)=0 C...Choose lifetime and determine decay vertex. IF(K(IP,1).EQ.5) THEN V(IP,5)=0D0 ELSEIF(K(IP,1).NE.4) THEN V(IP,5)=-PMAS(KC,4)*LOG(PYR(0)) ENDIF DO 100 J=1,4 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5) 100 CONTINUE C...Determine whether decay allowed or not. MOUT=0 IF(MSTJ(22).EQ.2) THEN IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1 ELSEIF(MSTJ(22).EQ.3) THEN IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1 ELSEIF(MSTJ(22).EQ.4) THEN IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1 ENDIF IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN K(IP,1)=4 RETURN ENDIF C...Interface to external tau decay library (for tau polarization). IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN C...Starting values for pointers and momenta. ITAU=IP DO 110 J=1,4 PTAU(J)=P(ITAU,J) PCMTAU(J)=P(ITAU,J) 110 CONTINUE C...Iterate to find position and code of mother of tau. IMTAU=ITAU 120 IMTAU=K(IMTAU,3) IF(IMTAU.EQ.0) THEN C...If no known origin then impossible to do anything further. KFORIG=0 IORIG=0 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN C...If tau -> tau + gamma then add gamma energy and loop. IF(K(K(IMTAU,4),2).EQ.22) THEN DO 130 J=1,4 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J) 130 CONTINUE ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN DO 140 J=1,4 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J) 140 CONTINUE ENDIF GOTO 120 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN C...If coming from weak decay of hadron then W is not stored in record, C...but can be reconstructed by adding neutrino momentum. KFORIG=-ISIGN(24,K(ITAU,2)) IORIG=0 DO 160 II=K(IMTAU,4),K(IMTAU,5) IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN DO 150 J=1,4 PCMTAU(J)=PCMTAU(J)+P(II,J) 150 CONTINUE ENDIF 160 CONTINUE ELSE C...If coming from resonance decay then find latest copy of this C...resonance (may not completely agree). KFORIG=K(IMTAU,2) IORIG=IMTAU DO 170 II=IMTAU+1,IP-1 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND. & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II 170 CONTINUE DO 180 J=1,4 PCMTAU(J)=P(IORIG,J) 180 CONTINUE ENDIF C...Boost tau to rest frame of production process (where known) C...and rotate it to sit along +z axis. DO 190 J=1,3 DBETAU(J)=PCMTAU(J)/PCMTAU(4) 190 CONTINUE IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1), & -DBETAU(2),-DBETAU(3)) PHITAU=PYANGL(P(ITAU,1),P(ITAU,2)) CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0) THETAU=PYANGL(P(ITAU,3),P(ITAU,1)) CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0) C...Call tau decay routine (if meaningful) and fill extra info. IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY) DO 200 II=NSAV+1,NSAV+NDECAY K(II,1)=1 K(II,3)=IP K(II,4)=0 K(II,5)=0 200 CONTINUE N=NSAV+NDECAY ENDIF C...Boost back decay tau and decay products. DO 210 J=1,4 P(ITAU,J)=PTAU(J) 210 CONTINUE IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0) IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1), & DBETAU(2),DBETAU(3)) C...Skip past ordinary tau decay treatment. MMAT=0 MBST=0 ND=0 GOTO 630 ENDIF ENDIF C...B-Bbar mixing: flip sign of meson appropriately. MMIX=0 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN XBBMIX=PARJ(76) IF(KFA.EQ.531) XBBMIX=PARJ(77) IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1 IF(MMIX.EQ.1) KFS=-KFS ENDIF C...Check existence of decay channels. Particle/antiparticle rules. KCA=KC IF(MDCY(KC,2).GT.0) THEN MDMDCY=MDME(MDCY(KC,2),2) IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY ENDIF IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN CALL PYERRM(9,'(PYDECY:) no decay channel defined') RETURN ENDIF IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS IF(KCHG(KC,3).EQ.0) THEN KFSP=1 KFSN=0 IF(PYR(0).GT.0.5D0) KFS=-KFS ELSEIF(KFS.GT.0) THEN KFSP=1 KFSN=0 ELSE KFSP=0 KFSN=1 ENDIF C...Sum branching ratios of allowed decay channels. 220 NOPE=0 BRSU=0D0 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND. & KFSN*MDME(IDL,1).NE.3) GOTO 230 IF(MDME(IDL,2).GT.100) GOTO 230 NOPE=NOPE+1 BRSU=BRSU+BRAT(IDL) 230 CONTINUE IF(NOPE.EQ.0) THEN CALL PYERRM(2,'(PYDECY:) all decay channels closed by user') RETURN ENDIF C...Select decay channel among allowed ones. 240 RBR=BRSU*PYR(0) IDL=MDCY(KCA,2)-1 250 IDL=IDL+1 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND. &KFSN*MDME(IDL,1).NE.3) THEN IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250 ELSEIF(MDME(IDL,2).GT.100) THEN IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250 ELSE IDC=IDL RBR=RBR-BRAT(IDL) IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250 ENDIF C...Start readout of decay channel: matrix element, reset counters. MMAT=MDME(IDC,2) 260 NTRY=NTRY+1 IF(MOD(NTRY,200).EQ.0) THEN WRITE(CIDC,'(I4)') IDC CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'// & CIDC) GOTO 240 ENDIF IF(NTRY.GT.1000) THEN CALL PYERRM(14,'(PYDECY:) caught in infinite loop') IF(MSTU(21).GE.1) RETURN ENDIF I=N NP=0 NQ=0 MBST=0 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1 DO 270 J=1,4 PV(1,J)=0D0 IF(MBST.EQ.0) PV(1,J)=P(IP,J) 270 CONTINUE IF(MBST.EQ.1) PV(1,4)=P(IP,5) PV(1,5)=P(IP,5) PS=0D0 PSQ=0D0 MREM=0 MHADDY=0 IF(KFA.GT.80) MHADDY=1 C.. Random flavour and popcorn system memory. IRNDMO=0 JTMO=0 MSTU(121)=0 MSTU(125)=10 C...Read out decay products. Convert to standard flavour code. JTMAX=5 IF(MDME(IDC+1,2).EQ.101) JTMAX=10 DO 280 JT=1,JTMAX IF(JT.LE.5) KP=KFDP(IDC,JT) IF(JT.GE.6) KP=KFDP(IDC+1,JT-5) IF(KP.EQ.0) GOTO 280 KPA=IABS(KP) KCP=PYCOMP(KPA) IF(KPA.GT.80) MHADDY=1 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN KFP=KP ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN KFP=KFS*KP ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN KFP=-KFS*MOD(KFA/10,10) ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN KFP=KFS*(100*MOD(KFA/10,100)+3) ELSEIF(KPA.EQ.81) THEN KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1) ELSEIF(KP.EQ.82) THEN CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP) IF(KFP.EQ.0) GOTO 260 KFP=-KFP IRNDMO=1 MSTJ(93)=1 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260 ELSEIF(KP.EQ.-82) THEN KFP=MSTU(124) ENDIF IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP) C...Add decay product to event record or to quark flavour list. KFPA=IABS(KFP) KQP=KCHG(KCP,2) IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN NQ=NQ+1 KFLO(NQ)=KFP C...set rndmflav popcorn system pointer IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ MSTJ(93)=2 PSQ=PSQ+PYMASS(KFLO(NQ)) ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND. & MOD(NQ,2).EQ.1) THEN NQ=NQ-1 PS=PS-P(I,5) K(I,1)=1 KFI=K(I,2) CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2)) IF(K(I,2).EQ.0) GOTO 260 MSTJ(93)=1 P(I,5)=PYMASS(K(I,2)) PS=PS+P(I,5) ELSE I=I+1 NP=NP+1 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1 K(I,1)=1+MOD(NQ,2) IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1 K(I,2)=KFP K(I,3)=IP K(I,4)=0 K(I,5)=0 P(I,5)=PYMASS(KFP) PS=PS+P(I,5) ENDIF 280 CONTINUE C...Check masses for resonance decays. IF(MHADDY.EQ.0) THEN IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240 ENDIF C...Choose decay multiplicity in phase space model. 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN PSP=PS CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0)) IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63) 300 NTRY=NTRY+1 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed. IF(IRNDMO.EQ.0) THEN MSTU(121)=0 JTMO=0 ELSEIF(IRNDMO.EQ.1) THEN IRNDMO=2 ELSE GOTO 260 ENDIF IF(NTRY.GT.1000) THEN CALL PYERRM(14,'(PYDECY:) caught in infinite loop') IF(MSTU(21).GE.1) RETURN ENDIF IF(MMAT.LE.20) THEN GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))* & SIN(PARU(2)*PYR(0)) ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300 ELSE ND=MMAT-20 ENDIF C.. Set maximum popcorn meson number. Test rndmflav popcorn size. MSTU(125)=ND-NQ/2 IF(MSTU(121).GT.MSTU(125)) GOTO 300 C...Form hadrons from flavour content. DO 310 JT=1,4 KFL1(JT)=KFLO(JT) 310 CONTINUE IF(ND.EQ.NP+NQ/2) GOTO 330 DO 320 I=N+NP+1,N+ND-NQ/2 C.. Stick to started popcorn system, else pick side at random JT=JTMO IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0)) CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2)) IF(K(I,2).EQ.0) GOTO 300 MSTU(125)=MSTU(125)-1 JTMO=0 IF(MSTU(121).GT.0) JTMO=JT KFL1(JT)=-KFL2 320 CONTINUE 330 JT=2 JT2=3 JT3=4 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))* & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3 IF(JT.EQ.3) JT2=2 IF(JT.EQ.4) JT3=2 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2)) IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2)) IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300 C...Check that sum of decay product masses not too large. PS=PSP DO 340 I=N+NP+1,N+ND K(I,1)=1 K(I,3)=IP K(I,4)=0 K(I,5)=0 P(I,5)=PYMASS(K(I,2)) PS=PS+P(I,5) 340 CONTINUE IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300 C...Rescale energy to subtract off spectator quark mass. ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44) & .AND.NP.GE.3) THEN PS=PS-P(N+NP,5) PQT=(P(N+NP,5)+PARJ(65))/PV(1,5) DO 350 J=1,5 P(N+NP,J)=PQT*PV(1,J) PV(1,J)=(1D0-PQT)*PV(1,J) 350 CONTINUE IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260 ND=NP-1 MREM=1 C...Fully specified final state: check mass broadening effects. ELSE IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260 ND=NP ENDIF C...Determine position of grandmother, number of sisters. NM=0 KFAS=0 MSGN=0 IF(MMAT.EQ.3) THEN IM=K(IP,3) IF(IM.LT.0.OR.IM.GE.IP) IM=0 IF(IM.NE.0) KFAM=IABS(K(IM,2)) IF(IM.NE.0) THEN DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N) IF(K(IL,3).EQ.IM) NM=NM+1 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL 360 CONTINUE IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR. & MOD(KFAM/1000,10).NE.0) NM=0 IF(NM.EQ.2) THEN KFAS=IABS(K(ISIS,2)) IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR. & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0 ENDIF ENDIF ENDIF C...Kinematics of one-particle decays. IF(ND.EQ.1) THEN DO 370 J=1,4 P(N+1,J)=P(IP,J) 370 CONTINUE GOTO 630 ENDIF C...Calculate maximum weight ND-particle decay. PV(ND,5)=P(N+ND,5) IF(ND.GE.3) THEN WTMAX=1D0/WTCOR(ND-2) PMAX=PV(1,5)-PS+P(N+ND,5) PMIN=0D0 DO 380 IL=ND-1,1,-1 PMAX=PMAX+P(N+IL,5) PMIN=PMIN+P(N+IL+1,5) WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5)) 380 CONTINUE ENDIF C...Find virtual gamma mass in Dalitz decay. 390 IF(ND.EQ.2) THEN ELSEIF(MMAT.EQ.2) THEN PMES=4D0*PMAS(11,1)**2 PMRHO2=PMAS(131,1)**2 PGRHO2=PMAS(131,2)**2 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0) WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))* & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/ & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2) IF(WT.LT.PYR(0)) GOTO 400 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST)) C...M-generator gives weight. If rejected, try again. ELSE 410 RORD(1)=1D0 DO 440 IL1=2,ND-1 RSAV=PYR(0) DO 420 IL2=IL1-1,1,-1 IF(RSAV.LE.RORD(IL2)) GOTO 430 RORD(IL2+1)=RORD(IL2) 420 CONTINUE 430 RORD(IL2+1)=RSAV 440 CONTINUE RORD(ND)=0D0 WT=1D0 DO 450 IL=ND-1,1,-1 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))* & (PV(1,5)-PS) WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5)) 450 CONTINUE IF(WT.LT.PYR(0)*WTMAX) GOTO 410 ENDIF C...Perform two-particle decays in respective CM frame. 460 DO 480 IL=1,ND-1 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5)) UE(3)=2D0*PYR(0)-1D0 PHI=PARU(2)*PYR(0) UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI) UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI) DO 470 J=1,3 P(N+IL,J)=PA*UE(J) PV(IL+1,J)=-PA*UE(J) 470 CONTINUE P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2) PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2) 480 CONTINUE C...Lorentz transform decay products to lab frame. DO 490 J=1,4 P(N+ND,J)=PV(ND,J) 490 CONTINUE DO 530 IL=ND-1,1,-1 DO 500 J=1,3 BE(J)=PV(IL,J)/PV(IL,4) 500 CONTINUE GA=PV(IL,4)/PV(IL,5) DO 520 I=N+IL,N+ND BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3) DO 510 J=1,3 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J) 510 CONTINUE P(I,4)=GA*(P(I,4)+BEP) 520 CONTINUE 530 CONTINUE C...Check that no infinite loop in matrix element weight. NTRY=NTRY+1 IF(NTRY.GT.800) GOTO 560 C...Matrix elements for omega and phi decays. IF(MMAT.EQ.1) THEN WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3) IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-. ELSEIF(MMAT.EQ.2) THEN FOUR12=FOUR(N+1,N+2) FOUR13=FOUR(N+1,N+3) WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+ & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2) IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar, C...V vector), of form cos**2(theta02) in V1 rest frame, and for C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02). ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN FOUR10=FOUR(IP,IM) FOUR12=FOUR(IP,N+1) FOUR02=FOUR(IM,N+1) PMS1=P(IP,5)**2 PMS0=P(IM,5)**2 PMS2=P(N+1,5)**2 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02- & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2) HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM) HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2) IF(HNUM.LT.PYR(0)*HDEN) GOTO 460 C...Matrix element for "onium" -> g + g + g or gamma + g + g. ELSEIF(MMAT.EQ.4) THEN HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+ & ((1D0-HX3)/(HX1*HX2))**2 IF(WT.LT.2D0*PYR(0)) GOTO 390 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2) & GOTO 390 C...Effective matrix element for nu spectrum in tau -> nu + hadrons. ELSEIF(MMAT.EQ.41) THEN HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5))) IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390 C...Matrix elements for weak decays (only semileptonic for c and b) ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) & .AND.ND.EQ.3) THEN IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3) IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3) IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN DO 550 J=1,4 P(N+NP+1,J)=0D0 DO 540 IS=N+3,N+NP P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J) 540 CONTINUE 550 CONTINUE IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1) IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1) IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390 ENDIF C...Scale back energy and reattach spectator. 560 IF(MREM.EQ.1) THEN DO 570 J=1,5 PV(1,J)=PV(1,J)/(1D0-PQT) 570 CONTINUE ND=ND+1 MREM=0 ENDIF C...Low invariant mass for system with spectator quark gives particle, C...not two jets. Readjust momenta accordingly. IF(MMAT.EQ.31.AND.ND.EQ.3) THEN MSTJ(93)=1 PM2=PYMASS(K(N+2,2)) MSTJ(93)=1 PM3=PYMASS(K(N+3,2)) IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE. & (PARJ(32)+PM2+PM3)**2) GOTO 630 K(N+2,1)=1 KFTEMP=K(N+2,2) CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2)) IF(K(N+2,2).EQ.0) GOTO 260 P(N+2,5)=PYMASS(K(N+2,2)) PS=P(N+1,5)+P(N+2,5) PV(2,5)=P(N+2,5) MMAT=0 ND=2 GOTO 460 ELSEIF(MMAT.EQ.44) THEN MSTJ(93)=1 PM3=PYMASS(K(N+3,2)) MSTJ(93)=1 PM4=PYMASS(K(N+4,2)) IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE. & (PARJ(32)+PM3+PM4)**2) GOTO 600 K(N+3,1)=1 KFTEMP=K(N+3,2) CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2)) IF(K(N+3,2).EQ.0) GOTO 260 P(N+3,5)=PYMASS(K(N+3,2)) DO 580 J=1,3 P(N+3,J)=P(N+3,J)+P(N+4,J) 580 CONTINUE P(N+3,4)=SQRT(P(N+3,1)**2+P(N+3,2)**2+P(N+3,3)**2+P(N+3,5)**2) HA=P(N+1,4)**2-P(N+2,4)**2 HB=HA-(P(N+1,5)**2-P(N+2,5)**2) HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+ & (P(N+1,3)-P(N+2,3))**2 HD=(PV(1,4)-P(N+3,4))**2 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2 HF=HD*HC-HB**2 HG=HD*HC-HA*HB HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF) DO 590 J=1,3 PCOR=HH*(P(N+1,J)-P(N+2,J)) P(N+1,J)=P(N+1,J)+PCOR P(N+2,J)=P(N+2,J)-PCOR 590 CONTINUE P(N+1,4)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2+P(N+1,5)**2) P(N+2,4)=SQRT(P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2+P(N+2,5)**2) ND=ND-1 ENDIF C...Check invariant mass of W jets. May give one particle or start over. 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) &.AND.IABS(K(N+1,2)).LT.10) THEN PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2))) MSTJ(93)=1 PM1=PYMASS(K(N+1,2)) MSTJ(93)=1 PM2=PYMASS(K(N+2,2)) IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610 KFLDUM=INT(1.5D0+PYR(0)) CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1) CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2) IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260 PSM=PYMASS(KF1)+PYMASS(KF2) IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610 IF(MMAT.EQ.48) GOTO 390 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260 K(N+1,1)=1 KFTEMP=K(N+1,2) CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2)) IF(K(N+1,2).EQ.0) GOTO 260 P(N+1,5)=PYMASS(K(N+1,2)) K(N+2,2)=K(N+3,2) P(N+2,5)=P(N+3,5) PS=P(N+1,5)+P(N+2,5) IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260 PV(2,5)=P(N+3,5) MMAT=0 ND=2 GOTO 460 ENDIF C...Phase space decay of partons from W decay. 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN KFLO(1)=K(N+1,2) KFLO(2)=K(N+2,2) K(N+1,1)=K(N+3,1) K(N+1,2)=K(N+3,2) DO 620 J=1,5 PV(1,J)=P(N+1,J)+P(N+2,J) P(N+1,J)=P(N+3,J) 620 CONTINUE PV(1,5)=PMR N=N+1 NP=0 NQ=2 PS=0D0 MSTJ(93)=2 PSQ=PYMASS(KFLO(1)) MSTJ(93)=2 PSQ=PSQ+PYMASS(KFLO(2)) MMAT=11 GOTO 290 ENDIF C...Boost back for rapidly moving particle. 630 N=N+ND IF(MBST.EQ.1) THEN DO 640 J=1,3 BE(J)=P(IP,J)/P(IP,4) 640 CONTINUE GA=P(IP,4)/P(IP,5) DO 660 I=NSAV+1,N BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3) DO 650 J=1,3 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J) 650 CONTINUE P(I,4)=GA*(P(I,4)+BEP) 660 CONTINUE ENDIF C...Fill in position of decay vertex. DO 680 I=NSAV+1,N DO 670 J=1,4 V(I,J)=VDCY(J) 670 CONTINUE V(I,5)=0D0 680 CONTINUE C...Set up for parton shower evolution from jets. IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN K(NSAV+1,1)=3 K(NSAV+2,1)=3 K(NSAV+3,1)=3 K(NSAV+1,4)=MSTU(5)*(NSAV+2) K(NSAV+1,5)=MSTU(5)*(NSAV+3) K(NSAV+2,4)=MSTU(5)*(NSAV+3) K(NSAV+2,5)=MSTU(5)*(NSAV+1) K(NSAV+3,4)=MSTU(5)*(NSAV+1) K(NSAV+3,5)=MSTU(5)*(NSAV+2) MSTJ(92)=-(NSAV+1) ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN K(NSAV+2,1)=3 K(NSAV+3,1)=3 K(NSAV+2,4)=MSTU(5)*(NSAV+3) K(NSAV+2,5)=MSTU(5)*(NSAV+3) K(NSAV+3,4)=MSTU(5)*(NSAV+2) K(NSAV+3,5)=MSTU(5)*(NSAV+2) MSTJ(92)=NSAV+2 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND. & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN K(NSAV+1,1)=3 K(NSAV+2,1)=3 K(NSAV+1,4)=MSTU(5)*(NSAV+2) K(NSAV+1,5)=MSTU(5)*(NSAV+2) K(NSAV+2,4)=MSTU(5)*(NSAV+1) K(NSAV+2,5)=MSTU(5)*(NSAV+1) MSTJ(92)=NSAV+1 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND. & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN MSTJ(92)=NSAV+1 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21) & THEN K(NSAV+1,1)=3 K(NSAV+2,1)=3 K(NSAV+3,1)=3 KCP=PYCOMP(K(NSAV+1,2)) KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2)) JCON=4 IF(KQP.LT.0) JCON=5 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2) K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1) K(NSAV+2,JCON)=MSTU(5)*(NSAV+3) K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2) MSTJ(92)=NSAV+1 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN K(NSAV+1,1)=3 K(NSAV+3,1)=3 K(NSAV+1,4)=MSTU(5)*(NSAV+3) K(NSAV+1,5)=MSTU(5)*(NSAV+3) K(NSAV+3,4)=MSTU(5)*(NSAV+1) K(NSAV+3,5)=MSTU(5)*(NSAV+1) MSTJ(92)=NSAV+1 ENDIF C...Mark decayed particle; special option for B-Bbar mixing. IF(K(IP,1).EQ.5) K(IP,1)=15 IF(K(IP,1).LE.10) K(IP,1)=11 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12 K(IP,4)=NSAV+1 K(IP,5)=N RETURN END C********************************************************************* C...PYDCYK C...Handles flavour production in the decay of unstable particles C...and small string clusters. SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C.. Call PYKFDI directly if no popcorn option is on IF(MSTJ(12).LT.2) THEN CALL PYKFDI(KFL1,KFL2,KFL3,KF) MSTU(124)=KFL3 RETURN ENDIF KFL3=0 KF=0 IF(KFL1.EQ.0) RETURN KF1A=IABS(KFL1) KF2A=IABS(KFL2) NSTO=130 NMAX=MIN(MSTU(125),10) C.. Identify rank 0 cluster qq IRANK=1 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0 IF(KF2A.GT.0)THEN C.. Join jets: Fails if store not empty IF(MSTU(121).GT.0) THEN MSTU(121)=0 RETURN ENDIF CALL PYKFDI(KFL1,KFL2,KFL3,KF) ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN C.. Pick popcorn meson from store, return same qq, decrease store KF=MSTU(NSTO+MSTU(121)) KFL3=-KFL1 MSTU(121)=MSTU(121)-1 ELSE C.. Generate new flavour. Then done if no diquark is generated 100 CALL PYKFDI(KFL1,0,KFL3,KF) IF(MSTU(121).EQ.-1) GOTO 100 MSTU(124)=KFL3 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN C.. Simple case if no dynamical popcorn suppressions are considered IF(MSTJ(12).LT.4) THEN IF(MSTU(121).EQ.0) RETURN NMES=1 KFPREV=-KFL3 CALL PYKFDI(KFPREV,0,KFL3,KFM) C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q IF(IABS(KFL3).LE.10)THEN KFL3=-KFPREV RETURN ENDIF GOTO 120 ENDIF C test output qq against fake Gamma, then return if no popcorn. GB=2D0 IF(IRANK.NE.0)THEN CALL PYZDIS(1,2103,5D0,Z) GB=3D0*(1D0-Z)/Z IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN MSTU(121)=0 GOTO 100 ENDIF ENDIF IF(MSTU(121).EQ.0) RETURN C..Set store size memory. Pick fake dynamical variables of qq. NMES=MSTU(121) CALL PYPTDI(1,PX3,PY3) X=1D0 POPM=0D0 G=GB POPG=GB C.. Pick next popcorn meson, test with fake dynamical variables 110 KFPREV=-KFL3 PX1=-PX3 PY1=-PY3 CALL PYKFDI(KFPREV,0,KFL3,KFM) IF(MSTU(121).EQ.-1) GOTO 100 CALL PYPTDI(KFL3,PX3,PY3) PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2 CALL PYZDIS(KFPREV,KFL3,PM,Z) G=(1D0-Z)*(G+PM/Z) X=(1D0-Z)*X PTST=1D0 GTST=1D0 RTST=PYR(0) IF(MSTJ(12).GT.4)THEN POPMN=SQRT((1D0-X)*(G/X-GB)) POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3) PTST=EXP((POPM-POPMN)*PARF(193)) POPM=POPMN ENDIF IF(IRANK.NE.0)THEN POPGN=X*GB GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG) POPG=POPGN ENDIF IF(RTST.GT.PTST*GTST)THEN MSTU(121)=0 IF(RTST.GT.PTST) MSTU(121)=-1 GOTO 100 ENDIF C.. Store meson 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM IF(MSTU(121).GT.0) GOTO 110 C.. Test accepted system size. If OK set global popcorn size variable. IF(NMES.GT.NMAX)THEN KF=0 KFL3=0 RETURN ENDIF MSTU(121)=NMES ENDIF RETURN END C******************************************************************** C...PYKFDI C...Generates a new flavour pair and combines off a hadron SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C...Local arrays. DIMENSION PD(7) IF(MSTU(123).EQ.0.AND.MSTJ(12).GT.0) CALL PYKFIN C...Default flavour values. Input consistency checks. KF1A=IABS(KFL1) KF2A=IABS(KFL2) KFL3=0 KF=0 IF(KF1A.EQ.0) RETURN IF(KF2A.NE.0)THEN IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN ENDIF C...Check if tabulated flavour probabilities are to be used. IF(MSTJ(15).EQ.1) THEN IF(MSTJ(12).GE.5) CALL PYERRM(29, & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' // & ' together with MSTJ(12)>=5 modification') KTAB1=-1 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A KFL1A=MOD(KF1A/1000,10) KFL1B=MOD(KF1A/100,10) KFL1S=MOD(KF1A,10) IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4) & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A KTAB2=0 IF(KF2A.NE.0) THEN KTAB2=-1 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A KFL2A=MOD(KF2A/1000,10) KFL2B=MOD(KF2A/100,10) KFL2S=MOD(KF2A,10) IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4) & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1 ENDIF IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140 ENDIF C.. Recognize rank 0 diquark case 100 IRANK=1 KFDIQ=MAX(KF1A,KF2A) IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0 C.. Join two flavours to meson or baryon. Test for popcorn. IF(KF2A.GT.0)THEN MBARY=0 IF(KFDIQ.GT.10) THEN IF(IRANK.EQ.0.AND.MSTJ(12).LT.5) & CALL PYNMES(KFDIQ) IF(MSTU(121).NE.0) RETURN MBARY=2 ENDIF KFQOLD=KF1A KFQVER=KF2A GOTO 130 ENDIF C.. Separate incoming flavours, curtain flavour consistency check KFIN=KFL1 KFQOLD=KF1A KFQPOP=KF1A/10000 IF(KF1A.GT.10)THEN KFIN=-KFL1 KFL1A=MOD(KF1A/1000,10) KFL1B=MOD(KF1A/100,10) IF(IRANK.EQ.0)THEN QAWT=1D0 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4) IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4) KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0)) ENDIF IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) RETURN KFQOLD=KFL1A+KFL1B-KFQPOP ENDIF C...Meson/baryon choice. Set number of mesons if starting a popcorn C...system. 110 MBARY=0 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN MBARY=1 CALL PYNMES(0) ENDIF ELSEIF(KF1A.GT.10)THEN MBARY=2 IF(IRANK.EQ.0) CALL PYNMES(KF1A) IF(MSTU(121).GT.0) MBARY=-1 ENDIF C..x->H+q: Choose single vertex quark. Jump to form hadron. IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN KFQVER=1+INT((2D0+PARJ(2))*PYR(0)) KFL3=ISIGN(KFQVER,-KFIN) GOTO 130 ENDIF C..x->H+qq: (IDW=proper PARF position for diquark weights) IDW=160 C.. q->B+qq: Get curtain quark, different weights for q->B+B and C.. q->B+M+... IF(MBARY.EQ.1)THEN IF(MSTU(121).EQ.0) IDW=150 SQWT=PARF(IDW+1) IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121) KFQPOP=1+INT((2D0+SQWT)*PYR(0)) C.. Shift to s-curtain parameters if needed IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN PARF(194)=PARF(138)*PARF(139) PARF(193)=PARJ(8)+PARJ(9) ENDIF ENDIF C.. x->H+qq: Get vertex quark IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN IDW=MSTU(122) MSTU(121)=MSTU(121)-1 IF(IDW.EQ.170) THEN IF(MSTU(121).EQ.0)THEN IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2) ELSE IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2) ENDIF ELSE IF(MSTU(121).EQ.0)THEN IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4) ELSE IPOS=3*5+5*4+MIN(KFQOLD-1,4) ENDIF ENDIF IPOS=200+30*IPOS+1 IMES=-1 RMES=PYR(0)*PARF(194) 120 IMES=IMES+1 RMES=RMES-PARF(IPOS+IMES) IF(IMES.EQ.30) THEN MSTU(121)=-1 KF=-111 RETURN ENDIF IF(RMES.GT.0D0) GOTO 120 KMUL=IMES/5 KFJ=2*KMUL+1 IF(KMUL.EQ.2) KFJ=10003 IF(KMUL.EQ.3) KFJ=10001 IF(KMUL.EQ.4) KFJ=20003 IF(KMUL.EQ.5) KFJ=5 IDIAG=0 KFQVER=MOD(IMES,5)+1 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1 IF(KFQVER.GT.3)THEN IDIAG=KFQVER-3 KFQVER=KFQOLD ENDIF ELSE IF(MBARY.EQ.-1) IDW=170 SQWT=PARF(IDW+2) IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3) IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0))) IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN KFQVER=KFQPOP IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP ENDIF ENDIF C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos KFLDS=3 IF(KFQPOP.NE.KFQVER)THEN SWT=PARF(IDW+7) IF(KFQVER.EQ.3) SWT=PARF(IDW+6) IF(KFQPOP.GE.3) SWT=PARF(IDW+5) IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1 ENDIF KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS & +10000*KFQPOP KFL3=ISIGN(KFDIQ,KFIN) C..x->M+y: flavour for meson. 130 IF(MBARY.LE.0)THEN KFLA=MAX(KFQOLD,KFQVER) KFLB=MIN(KFQOLD,KFQVER) KFS=ISIGN(1,KFL1) IF(KFLA.NE.KFQOLD) KFS=-KFS C... Form meson, with spin and flavour mixing for diagonal states. IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN IF(IDIAG.GT.0) KF=110*IDIAG+KFJ IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA RETURN ENDIF IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0)) IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0)) IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0)) IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN IF(PYR(0).LT.PARJ(14)) KMUL=2 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN RMUL=PYR(0) IF(RMUL.LT.PARJ(15)) KMUL=3 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5 ENDIF KFLS=3 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1 IF(KMUL.EQ.5) KFLS=5 IF(KFLA.NE.KFLB)THEN KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA ELSE RMIX=PYR(0) IMIX=2*KFLA+10*KMUL IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+ & INT(RMIX+PARF(IMIX)))+KFLS IF(KFLA.GE.4) KF=110*KFLA+KFLS ENDIF IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF) IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF) C..Optional extra suppression of eta and eta'. C..Allow shift to qq->B+q in old version (set IRANK to 0) IF(KF.EQ.221.OR.KF.EQ.331)THEN IF(PYR(0).GT.PARJ(25+KF/300))THEN IF(KF2A.GT.0) GOTO 130 IF(MSTJ(12).LT.4) IRANK=0 GOTO 110 ENDIF ENDIF MSTU(121)=0 C.. x->B+y: Flavour for baryon ELSE KFLA=KFQVER IF(KF1A.LE.10) KFLA=KFQOLD KFLB=MOD(KFDIQ/1000,10) KFLC=MOD(KFDIQ/100,10) KFLDS=MOD(KFDIQ,10) KFLD=MAX(KFLA,KFLB,KFLC) KFLF=MIN(KFLA,KFLB,KFLC) KFLE=KFLA+KFLB+KFLC-KFLD-KFLF C... SU(6) factors for formation of baryon. KBARY=3 KDMAX=5 KFLG=KFLB IF(KFLB.NE.KFLC)THEN KBARY=2*KFLDS-1 KDMAX=1+KFLDS/2 IF(KFLB.GT.2) KDMAX=KDMAX+2 ENDIF IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN KBARY=KBARY+1 KFLG=KFLA ENDIF SU6MAX=PARF(140+KDMAX) SU6DEC=PARJ(18) SU6S =PARF(146) IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN SU6MAX=1D0 SU6DEC=1D0 SU6S =1D0 ENDIF SU6OCT=PARF(60+KBARY) IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1) IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1) ELSE IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1) ENDIF SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY) C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected. IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN MSTU(121)=0 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1 GOTO 110 ENDIF C.. Form baryon. Distinguish Lambda- and Sigmalike baryons. KSIG=1 KFLS=2 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN KSIG=KFLDS/3 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0)) ENDIF KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1) IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1) ENDIF RETURN C...Use tabulated probabilities to select new flavour and hadron. 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN KT3L=1 KT3U=6 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN KT3L=1 KT3U=6 ELSEIF(KTAB2.EQ.0) THEN KT3L=1 KT3U=22 ELSE KT3L=KTAB2 KT3U=KTAB2 ENDIF RFL=0D0 DO 160 KTS=0,2 DO 150 KT3=KT3L,KT3U RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3) 150 CONTINUE 160 CONTINUE RFL=PYR(0)*RFL DO 180 KTS=0,2 KTABS=KTS DO 170 KT3=KT3L,KT3U KTAB3=KT3 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3) IF(RFL.LE.0D0) GOTO 190 170 CONTINUE 180 CONTINUE 190 CONTINUE C...Reconstruct flavour of produced quark/diquark. IF(KTAB3.LE.6) THEN KFL3A=KTAB3 KFL3B=0 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13)) ELSE KFL3A=1 IF(KTAB3.GE.8) KFL3A=2 IF(KTAB3.GE.11) KFL3A=3 IF(KTAB3.GE.16) KFL3A=4 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2 KFL3=1000*KFL3A+100*KFL3B+1 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3= & KFL3+2 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1)) ENDIF C...Reconstruct meson code. IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR. &KFL3B.NE.0)) THEN RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+ & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS)) KF=110+2*KTABS+1 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+ & 25*KTABS)) KF=330+2*KTABS+1 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN KFLA=MAX(KTAB1,KTAB3) KFLB=MIN(KTAB1,KTAB3) KFS=ISIGN(1,KFL1) IF(KFLA.NE.KF1A) KFS=-KFS KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN KFS=ISIGN(1,KFL1) IF(KFL1A.EQ.KFL3A) THEN KFLA=MAX(KFL1B,KFL3B) KFLB=MIN(KFL1B,KFL3B) IF(KFLA.NE.KFL1B) KFS=-KFS ELSEIF(KFL1A.EQ.KFL3B) THEN KFLA=KFL3A KFLB=KFL1B KFS=-KFS ELSEIF(KFL1B.EQ.KFL3A) THEN KFLA=KFL1A KFLB=KFL3B ELSEIF(KFL1B.EQ.KFL3B) THEN KFLA=MAX(KFL1A,KFL3A) KFLB=MIN(KFL1A,KFL3A) IF(KFLA.NE.KFL1A) KFS=-KFS ELSE CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq') GOTO 100 ENDIF KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA C...Reconstruct baryon code. ELSE IF(KTAB1.GE.7) THEN KFLA=KFL3A KFLB=KFL1A KFLC=KFL1B ELSE KFLA=KFL1A KFLB=KFL3A KFLC=KFL3B ENDIF KFLD=MAX(KFLA,KFLB,KFLC) KFLF=MIN(KFLA,KFLB,KFLC) KFLE=KFLA+KFLB+KFLC-KFLD-KFLF IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1) IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1) ENDIF C...Check that constructed flavour code is an allowed one. IF(KFL2.NE.0) KFL3=0 KC=PYCOMP(KF) IF(KC.EQ.0) THEN CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '// & 'failed') GOTO 100 ENDIF RETURN END C********************************************************************* C...PYNMES C...Generates number of popcorn mesons and stores some relevant C...parameters. SUBROUTINE PYNMES(KFDIQ) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ MSTU(121)=0 IF(MSTJ(12).LT.2) RETURN C..Old version: Get 1 or 0 popcorn mesons IF(MSTJ(12).LT.5)THEN POPWT=PARF(131) IF(KFDIQ.NE.0) THEN KFDIQA=IABS(KFDIQ) KFA=MOD(KFDIQA/1000,10) KFB=MOD(KFDIQA/100,10) KFS=MOD(KFDIQA,10) POPWT=PARF(132) IF(KFA.EQ.3) POPWT=PARF(133) IF(KFB.EQ.3) POPWT=PARF(134) IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4)) ENDIF MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0)) RETURN ENDIF C..New version: Store popcorn- or rank 0 diquark parameters MSTU(122)=170 PARF(193)=PARJ(8) PARF(194)=PARF(139) IF(KFDIQ.NE.0) THEN MSTU(122)=180 PARF(193)=PARJ(10) PARF(194)=PARF(140) ENDIF IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9, & '(PYNMES:) Neglecting too large popcorn possibility') RETURN ENDIF C..New version: Get number of popcorn mesons 100 RTST=PYR(0) MSTU(121)=-1 110 MSTU(121)=MSTU(121)+1 RTST=RTST/PARF(194) IF(RTST.LT.1D0) GOTO 110 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)).GT. & (2D0+PARF(135)*PARF(138)**MSTU(121))) GOTO 100 RETURN END C********************************************************************* C...PYKFIN C...Precalculates a set of diquark and popcorn weights. C.. (Results stored in order SU0,US0,SS1,UU1,SU1,US1,UD1) SUBROUTINE PYKFIN C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ DIMENSION SU6(12),SU6M(7) MSTU(123)=1 C..Curtain tunneling factor T(D,q)/T(ud0,u). IF(MSTJ(12).GE.5) THEN PMUD0=PYMASS(2101) PMUD1=PYMASS(2103)-PMUD0 PMUS0=PYMASS(3201)-PMUD0 PMUS1=PYMASS(3203)-PMUS0-PMUD0 PMSS1=PYMASS(3303)-PMUS0-PMUD0 PARF(151)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191)) PARF(152)=EXP(-PARJ(8)*PMUS0) PARF(153)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*PARF(151) PARF(154)=EXP(-PARJ(8)*PMUD1) PARF(155)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*PARF(151) PARF(156)=EXP(-PARJ(8)*PMUS1)*PARF(152) PARF(157)=PARF(154) ELSE PAR2M=SQRT(PARJ(2)) PAR3M=SQRT(PARJ(3)) PAR4M=SQRT(PARJ(4)) PARF(151)=PAR2M*PAR3M PARF(152)=PAR3M PARF(153)=PAR2M*PARJ(3)*PAR4M PARF(154)=PAR4M PARF(155)=PAR4M*PARF(151) PARF(156)=PAR4M*PARF(152) PARF(157)=PAR4M ENDIF C.. Total tunneling factor tau(D,q)=T*vertex*spin. PARF(161)=PARF(151) PARF(162)=PARJ(2)*PARF(152) PARF(163)=PARJ(2)*6D0*PARF(153) PARF(164)=6D0*PARF(154) PARF(165)=3D0*PARF(155) PARF(166)=PARJ(2)*3D0*PARF(156) PARF(167)=3D0*PARF(157) DO 100 I=1,7 PARF(150+I)=PARF(150+I)*PARF(160+I) 100 CONTINUE C..Modified SU(6) factors. PARF(146)=1D0 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0) IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9, & '(PYKFIN:) PARJ(18)<1 combined with 0 qgamma. IF(MCE.EQ.2) THEN Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0) IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390 K(IEP(1),5)=22 C...Select z value of branching: q -> qg, g -> gg, g -> qqbar. ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0) IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 390 K(IEP(1),5)=21 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*(0.5D0-ZC).LT.PYR(0)*FBR) THEN Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0) IF(PYR(0).GT.0.5D0) Z=1D0-Z IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 390 K(IEP(1),5)=21 ELSEIF(MSTJ(49).NE.1) THEN Z=ZC+(1D0-2D0*ZC)*PYR(0) IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 390 KFLB=1+INT(MSTJ(45)*PYR(0)) PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5) IF(PMQ.GE.1D0) GOTO 390 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5) IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT. & PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 390 K(IEP(1),5)=KFLB C...Ditto for scalar gluon model. ELSEIF(KFL(1).NE.21) THEN Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC)) K(IEP(1),5)=21 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN Z=ZC+(1D0-2D0*ZC)*PYR(0) K(IEP(1),5)=21 ELSE Z=ZC+(1D0-2D0*ZC)*PYR(0) KFLB=1+INT(MSTJ(45)*PYR(0)) PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5) IF(PMQ.GE.1D0) GOTO 390 K(IEP(1),5)=KFLB ENDIF IF(MCE.EQ.1.AND.MSTJ(44).GE.2) THEN IF(Z*(1D0-Z)*V(IEP(1),5).LT.PT2MIN) GOTO 390 IF(ALFM/LOG(V(IEP(1),5)*Z*(1D0-Z)/ALAMS).LT.PYR(0)) GOTO 390 ENDIF C...Check if z consistent with chosen m. IF(KFL(1).EQ.21) THEN KFLGD1=IABS(K(IEP(1),5)) KFLGD2=KFLGD1 ELSE KFLGD1=KFL(1) KFLGD2=IABS(K(IEP(1),5)) ENDIF IF(NEP.EQ.1) THEN PED=PS(4) ELSEIF(NEP.GE.3) THEN PED=P(IEP(1),4) ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5) ELSE IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM ENDIF IF(MOD(MSTJ(43),2).EQ.1) THEN IFLGD1=KFLGD1 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFL PMQTH3=0.5D0*PARJ(82) IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83) PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(IEP(1),5) PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(IEP(1),5) ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2- & 4D0*PMQ1*PMQ2))) ZH=1D0+PMQ1-PMQ2 ELSE ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2)) ZH=1D0 ENDIF ZL=0.5D0*(ZH-ZD) ZU=0.5D0*(ZH+ZD) IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 390 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL* &(1D0-ZU))) IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU)) C...Width suppression for q -> q + g. IF(MSTJ(40).NE.0.AND.KFL(1).NE.21) THEN IF(IGM.EQ.0) THEN EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5)) ELSE EGLU=PMED*(1D0-Z) ENDIF CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2) IF(MSTJ(40).EQ.1) THEN IF(CHI.LT.PYR(0)) GOTO 390 ELSEIF(MSTJ(40).EQ.2) THEN IF(1D0-CHI.LT.PYR(0)) GOTO 390 ENDIF ENDIF C...Three-jet matrix element correction. IF(IGM.EQ.0.AND.M3JC.EQ.1) THEN X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5)) X2=1D0-V(IEP(1),5)/V(NS+1,5) X3=(1D0-X1)+(1D0-X2) IF(MCE.EQ.2) THEN KI1=K(IPA(INUM),2) KI2=K(IPA(3-INUM),2) QF1=KCHG(IABS(KI1),1)*ISIGN(1,KI1)/3D0 QF2=KCHG(IABS(KI2),1)*ISIGN(1,KI2)/3D0 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+ & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2) WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2) ELSEIF(MSTJ(49).NE.1) THEN WSHOW=1D0+(1D0-X1)/X3*(X1/(2D0-X2))**2+ & (1D0-X2)/X3*(X2/(2D0-X1))**2 WME=X1**2+X2**2 IF(M3JCM.EQ.1) WME=WME-QME*X3-0.5D0*QME**2- & (0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/MAX(1D-7,1D0-X1)+ & (1D0-X1)/MAX(1D-7,1D0-X2)) ELSE WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2) WME=X3**2 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)* & PARJ(171) ENDIF IF(WME.LT.PYR(0)*WSHOW) GOTO 390 C...Impose angular ordering by rejection of nonordered emission. ELSEIF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2) THEN MAOM=1 ZM=V(IM,1) IF(IEP(1).EQ.N+2) ZM=1D0-V(IM,1) THE2ID=Z*(1D0-Z)*(ZM*P(IM,4))**2/V(IEP(1),5) IAOM=IM 420 IF(K(IAOM,5).EQ.22) THEN IAOM=K(IAOM,3) IF(K(IAOM,3).LE.NS) MAOM=0 IF(MAOM.EQ.1) GOTO 420 ENDIF IF(MAOM.EQ.1) THEN THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5) IF(THE2ID.LT.THE2IM) GOTO 390 ENDIF ENDIF C...Impose user-defined maximum angle at first branching. IF(MSTJ(48).EQ.1) THEN IF(NEP.EQ.1.AND.IM.EQ.NS) THEN THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5) IF(THE2ID.LT.1D0/PARJ(85)**2) GOTO 390 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5) IF(THE2ID.LT.1D0/PARJ(85)**2) GOTO 390 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5) IF(THE2ID.LT.1D0/PARJ(86)**2) GOTO 390 ENDIF ENDIF C...Impose angular constraint in first branching from interference C...with initial state partons. IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 390 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 390 ENDIF ENDIF C...End of inner veto algorithm. Check if only one leg evolved so far. 430 V(IEP(1),1)=Z ISL(1)=0 ISL(2)=0 IF(NEP.EQ.1) GOTO 460 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 330 DO 440 I=1,NEP IF(ITRY(I).EQ.0.AND.KFLD(I).LE.40) THEN IF(KSH(KFLD(I)).EQ.1) THEN IFLD=KFLD(I) IF(KFLD(I).GE.6.AND.KFLD(I).LE.8) IFLD=37+KFLD(I)+ & ISIGN(2,K(N+I,2)) IF(P(N+I,5).GE.PMTH(2,IFLD)) GOTO 330 ENDIF ENDIF 440 CONTINUE C...Check if chosen multiplet m1,m2,z1,z2 is physical. IF(NEP.EQ.3) THEN PA1S=(P(N+1,4)+P(N+1,5))*(P(N+1,4)-P(N+1,5)) PA2S=(P(N+2,4)+P(N+2,5))*(P(N+2,4)-P(N+2,5)) PA3S=(P(N+3,4)+P(N+3,5))*(P(N+3,4)-P(N+3,5)) PTS=0.25D0*(2D0*PA1S*PA2S+2D0*PA1S*PA3S+2D0*PA2S*PA3S- & PA1S**2-PA2S**2-PA3S**2)/PA1S IF(PTS.LE.0D0) GOTO 330 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN DO 450 I1=N+1,N+2 KFLDA=IABS(K(I1,2)) IF(KFLDA.GT.40) GOTO 450 IF(KSH(KFLDA).EQ.0) GOTO 450 IFLDA=KFLDA IF(KFLDA.GE.6.AND.KFLDA.LE.8) IFLDA=37+KFLDA+ & ISIGN(2,K(I1,2)) IF(P(I1,5).LT.PMTH(2,IFLDA)) GOTO 450 IF(KFLDA.EQ.21) THEN KFLGD1=IABS(K(I1,5)) KFLGD2=KFLGD1 ELSE KFLGD1=KFLDA KFLGD2=IABS(K(I1,5)) ENDIF I2=2*N+3-I1 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5) ELSE IF(I1.EQ.N+1) ZM=V(IM,1) IF(I1.EQ.N+2) ZM=1D0-V(IM,1) PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2- & 4D0*V(N+1,5)*V(N+2,5)) PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/V(IM,5) ENDIF IF(MOD(MSTJ(43),2).EQ.1) THEN PMQTH3=0.5D0*PARJ(82) IF(KFLGD2.EQ.22) PMQTH3=0.5D0*PARJ(83) IFLGD1=KFLGD1 IF(KFLGD1.GE.6.AND.KFLGD1.LE.8) IFLGD1=IFLDA PMQ1=(PMTH(1,IFLGD1)**2+PMQTH3**2)/V(I1,5) PMQ2=(PMTH(1,KFLGD2)**2+PMQTH3**2)/V(I1,5) ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2- & 4D0*PMQ1*PMQ2))) ZH=1D0+PMQ1-PMQ2 ELSE ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2)) ZH=1D0 ENDIF ZL=0.5D0*(ZH-ZD) ZU=0.5D0*(ZH+ZD) IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(1)=1 IF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU)) ISL(2)=1 IF(KFLDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20, & ZL*(1D0-ZU))) IF(KFLDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU)) 450 CONTINUE IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN ISL(3-ISLM)=0 ISLM=3-ISLM ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0) ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0) IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0 IF(ISL(1).EQ.1) ISL(2)=0 IF(ISL(1).EQ.0) ISLM=1 IF(ISL(2).EQ.0) ISLM=2 ENDIF IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 330 ENDIF IFLD1=KFLD(1) IF(KFLD(1).GE.6.AND.KFLD(1).LE.8) IFLD1=37+KFLD(1)+ &ISIGN(2,K(N+1,2)) IFLD2=KFLD(2) IF(KFLD(2).GE.6.AND.KFLD(2).LE.8) IFLD2=37+KFLD(2)+ &ISIGN(2,K(N+2,2)) IF(IGM.GT.0.AND.MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE. &PMTH(2,IFLD1).OR.P(N+2,5).GE.PMTH(2,IFLD2))) THEN PMQ1=V(N+1,5)/V(IM,5) PMQ2=V(N+2,5)/V(IM,5) ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2- & 4D0*PMQ1*PMQ2))) ZH=1D0+PMQ1-PMQ2 ZL=0.5D0*(ZH-ZD) ZU=0.5D0*(ZH+ZD) IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 330 ENDIF C...Accepted branch. Construct four-momentum for initial partons. 460 MAZIP=0 MAZIC=0 IF(NEP.EQ.1) THEN P(N+1,1)=0D0 P(N+1,2)=0D0 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)- & P(N+1,5)))) P(N+1,4)=P(IPA(1),4) V(N+1,2)=P(N+1,4) ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5) P(N+1,1)=0D0 P(N+1,2)=0D0 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5)))) P(N+1,4)=PED1 P(N+2,1)=0D0 P(N+2,2)=0D0 P(N+2,3)=-P(N+1,3) P(N+2,4)=P(IM,5)-PED1 V(N+1,2)=P(N+1,4) V(N+2,2)=P(N+2,4) ELSEIF(NEP.EQ.3) THEN P(N+1,1)=0D0 P(N+1,2)=0D0 P(N+1,3)=SQRT(MAX(0D0,PA1S)) P(N+2,1)=SQRT(PTS) P(N+2,2)=0D0 P(N+2,3)=0.5D0*(PA3S-PA2S-PA1S)/P(N+1,3) P(N+3,1)=-P(N+2,1) P(N+3,2)=0D0 P(N+3,3)=-(P(N+1,3)+P(N+2,3)) V(N+1,2)=P(N+1,4) V(N+2,2)=P(N+2,4) V(N+3,2)=P(N+3,4) C...Construct transverse momentum for ordinary branching in shower. ELSE ZM=V(IM,1) PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5)))) PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5) IF(PZM.LE.0D0) THEN PTS=0D0 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)- & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2 ELSE PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2 ENDIF PT=SQRT(MAX(0D0,PTS)) C...Find coefficient of azimuthal asymmetry due to gluon polarization. HAZIP=0D0 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21 & .AND.IAU.NE.0) THEN IF(K(IGM,3).NE.0) MAZIP=1 ZAU=V(IGM,1) IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1) IF(MAZIP.EQ.0) ZAU=0D0 IF(K(IGM,2).NE.21) THEN HAZIP=2D0*ZAU/(1D0+ZAU**2) ELSE HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2 ENDIF IF(K(N+1,2).NE.21) THEN HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM)) ELSE HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2 ENDIF ENDIF C...Find coefficient of azimuthal asymmetry due to soft gluon C...interference. HAZIC=0D0 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR. & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN IF(K(IGM,3).NE.0) MAZIC=N+1 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND. & ZM.GT.0.5D0) MAZIC=N+2 IF(K(IAU,2).EQ.22) MAZIC=0 ZS=ZM IF(MAZIC.EQ.N+2) ZS=1D0-ZM ZGM=V(IGM,1) IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1) IF(MAZIC.EQ.0) ZGM=1D0 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))* & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM)) HAZIC=MIN(0.95D0,HAZIC) ENDIF ENDIF C...Construct kinematics for ordinary branching in shower. 470 IF(NEP.EQ.2.AND.IGM.GT.0) THEN IF(MOD(MSTJ(43),2).EQ.1) THEN P(N+1,4)=PEM*V(IM,1) ELSE P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+ & SQRT(PMLS)*ZM)/V(IM,5) ENDIF PHI=PARU(2)*PYR(0) P(N+1,1)=PT*COS(PHI) P(N+1,2)=PT*SIN(PHI) IF(PZM.GT.0D0) THEN P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+ & 2D0*PEM*P(N+1,4))/PZM ELSE P(N+1,3)=0D0 ENDIF P(N+2,1)=-P(N+1,1) P(N+2,2)=-P(N+1,2) P(N+2,3)=PZM-P(N+1,3) P(N+2,4)=PEM-P(N+1,4) IF(MSTJ(43).LE.2) THEN V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5) V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5) ENDIF ENDIF C...Rotate and boost daughters. IF(IGM.GT.0) THEN IF(MSTJ(43).LE.2) THEN BEX=P(IGM,1)/P(IGM,4) BEY=P(IGM,2)/P(IGM,4) BEZ=P(IGM,3)/P(IGM,4) GA=P(IGM,4)/P(IGM,5) GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)- & P(IM,4)) ELSE BEX=0D0 BEY=0D0 BEZ=0D0 GA=1D0 GABEP=0D0 ENDIF THE=PYANGL(P(IM,3)+GABEP*BEZ,SQRT((P(IM,1)+GABEP*BEX)**2+ & (P(IM,2)+GABEP*BEY)**2)) PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY) DO 480 I=N+1,N+2 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+ & SIN(THE)*COS(PHI)*P(I,3) DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+ & SIN(THE)*SIN(PHI)*P(I,3) DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3) DP(4)=P(I,4) DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3) DGABP=GA*(GA*DBP/(1D0+GA)+DP(4)) P(I,1)=DP(1)+DGABP*BEX P(I,2)=DP(2)+DGABP*BEY P(I,3)=DP(3)+DGABP*BEZ P(I,4)=GA*(DP(4)+DBP) 480 CONTINUE ENDIF C...Weight with azimuthal distribution, if required. IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN DO 490 J=1,3 DPT(1,J)=P(IM,J) DPT(2,J)=P(IAU,J) DPT(3,J)=P(N+1,J) 490 CONTINUE DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3) DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3) DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2 DO 500 J=1,3 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/DPMM DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/DPMM 500 CONTINUE DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2) DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2) IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+ & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4)) IF(MAZIP.NE.0) THEN IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP))) & GOTO 470 ENDIF IF(MAZIC.NE.0) THEN IF(MAZIC.EQ.N+2) CAD=-CAD IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD) & .LT.PYR(0)) GOTO 470 ENDIF ENDIF ENDIF C...Azimuthal anisotropy due to interference with initial state partons. IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR. &K(N+2,2).EQ.21)) THEN III=IM-NS-1 IF(ISII(III).GE.1) THEN IAZIID=N+1 IF(K(N+1,2).NE.21) IAZIID=N+2 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND. & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2)) IF(III.EQ.2) THEIID=PARU(1)-THEIID PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2)) HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III))) CAD=COS(PHIIID-PHIIIS(III,ISII(III))) PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III))) IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD) & .LT.PYR(0)) GOTO 470 ENDIF ENDIF C...Continue loop over partons that may branch, until none left. IF(IGM.GE.0) K(IM,1)=14 N=N+NEP NEP=2 IF(N.GT.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS') IF(MSTU(21).GE.1) N=NS IF(MSTU(21).GE.1) RETURN ENDIF GOTO 270 C...Set information on imagined shower initiator. 510 IF(NPA.GE.2) THEN K(NS+1,1)=11 K(NS+1,2)=94 K(NS+1,3)=IP1 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2 K(NS+1,4)=NS+2 K(NS+1,5)=NS+1+NPA IIM=1 ELSE IIM=0 ENDIF C...Reconstruct string drawing information. DO 520 I=NS+1+IIM,N IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN K(I,1)=1 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND. & IABS(K(I,2)).LE.18) THEN K(I,1)=1 ELSEIF(K(I,1).LE.10) THEN K(I,4)=MSTU(5)*(K(I,4)/MSTU(5)) K(I,5)=MSTU(5)*(K(I,5)/MSTU(5)) ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN ID1=MOD(K(I,4),MSTU(5)) IF(K(I,2).GE.1.AND.K(I,2).LE.8) ID1=MOD(K(I,4),MSTU(5))+1 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2 K(ID1,4)=K(ID1,4)+MSTU(5)*I K(ID1,5)=K(ID1,5)+MSTU(5)*ID2 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1 K(ID2,5)=K(ID2,5)+MSTU(5)*I ELSE ID1=MOD(K(I,4),MSTU(5)) ID2=ID1+1 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1 IF(IABS(K(I,2)).LE.10.OR.K(ID1,1).GE.11) THEN K(ID1,4)=K(ID1,4)+MSTU(5)*I K(ID1,5)=K(ID1,5)+MSTU(5)*I ELSE K(ID1,4)=0 K(ID1,5)=0 ENDIF K(ID2,4)=0 K(ID2,5)=0 ENDIF 520 CONTINUE C...Transformation from CM frame. IF(NPA.GE.2) THEN BEX=PS(1)/PS(4) BEY=PS(2)/PS(4) BEZ=PS(3)/PS(4) GA=PS(4)/PS(5) GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3)) & /(1D0+GA)-P(IPA(1),4)) ELSE BEX=0D0 BEY=0D0 BEZ=0D0 GABEP=0D0 ENDIF THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1) &+GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2)) PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY) IF(NPA.EQ.3) THEN CHI=PYANGL(COS(THE)*COS(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(THE)* & SIN(PHI)*(P(IPA(2),2)+GABEP*BEY)-SIN(THE)*(P(IPA(2),3)+GABEP* & BEZ),-SIN(PHI)*(P(IPA(2),1)+GABEP*BEX)+COS(PHI)*(P(IPA(2),2)+ & GABEP*BEY)) MSTU(33)=1 CALL PYROBO(NS+1,N,0D0,CHI,0D0,0D0,0D0) ENDIF MSTU(33)=1 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ) C...Decay vertex of shower. DO 540 I=NS+1,N DO 530 J=1,5 V(I,J)=V(IP1,J) 530 CONTINUE 540 CONTINUE C...Delete trivial shower, else connect initiators. IF(N.EQ.NS+NPA+IIM) THEN N=NS ELSE DO 550 IP=1,NPA K(IPA(IP),1)=14 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP K(NS+IIM+IP,3)=IPA(IP) IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1 IF(K(NS+IIM+IP,1).NE.1) THEN K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4) K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5) ENDIF 550 CONTINUE ENDIF RETURN END C********************************************************************* C...PYBOEI C...Modifies an event so as to approximately take into account C...Bose-Einstein effects according to a simple phenomenological C...parametrization. SUBROUTINE PYBOEI(NSAV) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYJETS/,/PYDAT1/ C...Local arrays and data. DIMENSION DPS(4),KFBE(9),NBE(0:9),BEI(100) DATA KFBE/211,-211,111,321,-321,130,310,221,331/ C...Boost event to overall CM frame. Calculate CM energy. IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN DO 100 J=1,4 DPS(J)=0D0 100 CONTINUE DO 120 I=1,N KFA=IABS(K(I,2)) IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22) & .AND.K(I,3).GT.0) THEN KFMA=IABS(K(K(I,3),2)) IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1) ENDIF IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120 DO 110 J=1,4 DPS(J)=DPS(J)+P(I,J) 110 CONTINUE 120 CONTINUE CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4), &-DPS(3)/DPS(4)) PECM=0D0 DO 130 I=1,N IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4) 130 CONTINUE C...Reserve copy of particles by species at end of record. NBE(0)=N+MSTU(3) DO 160 IBE=1,MIN(9,MSTJ(52)) NBE(IBE)=NBE(IBE-1) DO 150 I=NSAV+1,N IF(K(I,2).NE.KFBE(IBE)) GOTO 150 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS') RETURN ENDIF NBE(IBE)=NBE(IBE)+1 K(NBE(IBE),1)=I DO 140 J=1,3 P(NBE(IBE),J)=0D0 140 CONTINUE 150 CONTINUE 160 CONTINUE IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 280 C...Tabulate integral for subsequent momentum shift. DO 220 IBE=1,MIN(9,MSTJ(52)) IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 180 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2)) & .LE.1) GOTO 180 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5), & NBE(7)-NBE(6)).LE.1) GOTO 180 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 180 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211) IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321) IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221) IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331) QDEL=0.1D0*MIN(PMHQ,PARJ(93)) IF(MSTJ(51).EQ.1) THEN NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL)) BEEX=EXP(0.5D0*QDEL/PARJ(93)) BERT=EXP(-QDEL/PARJ(93)) ELSE NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL)) ENDIF DO 170 IBIN=1,NBIN QBIN=QDEL*(IBIN-0.5D0) BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2) IF(MSTJ(51).EQ.1) THEN BEEX=BEEX*BERT BEI(IBIN)=BEI(IBIN)*BEEX ELSE BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2) ENDIF IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1) 170 CONTINUE C...Loop through particle pairs and find old relative momentum. 180 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)-1 I1=K(I1M,1) DO 200 I2M=I1M+1,NBE(IBE) I2=K(I2M,1) Q2OLD=MAX(0D0,(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2- & (P(I1,2)+ P(I2,2))**2-(P(I1,3)+P(I2,3))**2- & (P(I1,5)+P(I2,5))**2) QOLD=SQRT(Q2OLD) C...Calculate new relative momentum. IF(QOLD.LT.1D-3*QDEL) THEN GOTO 200 ELSEIF(QOLD.LE.QDEL) THEN QMOV=QOLD/3D0 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN RBIN=QOLD/QDEL IBIN=RBIN RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1) QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))* & SQRT(Q2OLD+PMHQ**2)/Q2OLD ELSE QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD ENDIF Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0) C...Calculate and save shift to be performed on three-momenta. HC1=(P(I1,4)+P(I2,4))**2-(Q2OLD-Q2NEW) HC2=(Q2OLD-Q2NEW)*(P(I1,4)-P(I2,4))**2 HA=0.5D0*(1D0-SQRT(HC1*Q2NEW/(HC1*Q2OLD-HC2))) DO 190 J=1,3 PD=HA*(P(I2,J)-P(I1,J)) P(I1M,J)=P(I1M,J)+PD P(I2M,J)=P(I2M,J)-PD 190 CONTINUE 200 CONTINUE 210 CONTINUE 220 CONTINUE C...Shift momenta and recalculate energies. DO 240 IM=NBE(0)+1,NBE(MIN(9,MSTJ(52))) I=K(IM,1) DO 230 J=1,3 P(I,J)=P(I,J)+P(IM,J) 230 CONTINUE P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) 240 CONTINUE C...Rescale all momenta for energy conservation. PES=0D0 PQS=0D0 DO 250 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 250 PES=PES+P(I,4) PQS=PQS+P(I,5)**2/P(I,4) 250 CONTINUE FAC=(PECM-PQS)/(PES-PQS) DO 270 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 270 DO 260 J=1,3 P(I,J)=FAC*P(I,J) 260 CONTINUE P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) 270 CONTINUE C...Boost back to correct reference frame. 280 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4)) DO 290 I=1,N IF(K(I,1).LT.0) K(I,1)=-K(I,1) 290 CONTINUE RETURN END C********************************************************************* C...PYMASS C...Gives the mass of a particle/parton. FUNCTION PYMASS(KF) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C...Reset variables. Compressed code. Special case for popcorn diquarks. PYMASS=0D0 KFA=IABS(KF) KC=PYCOMP(KF) IF(KC.EQ.0) THEN MSTJ(93)=0 RETURN ENDIF C...Guarantee use of constituent masses for internal checks. IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND. &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN PARF(106)=PMAS(6,1) PARF(107)=PMAS(7,1) PARF(108)=PMAS(8,1) IF(KFA.LE.10) THEN PYMASS=PARF(100+KFA) IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121)) ELSEIF(MSTJ(93).EQ.1) THEN PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10)) ELSE PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0) ENDIF C...Other masses can be read directly off table. ELSE PYMASS=PMAS(KC,1) ENDIF C...Optional mass broadening according to truncated Breit-Wigner C...(either in m or in m^2). IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)* & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2))) ELSE PM0=PYMASS PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/ & (PM0*PMAS(KC,2))) PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2))) PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+ & (PMUPP-PMLOW)*PYR(0)))) ENDIF ENDIF MSTJ(93)=0 RETURN END C********************************************************************* C...PYNAME C...Gives the particle/parton name as a character string. SUBROUTINE PYNAME(KF,CHAU) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT4/CHAF(500,2) CHARACTER CHAF*16 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/ C...Local character variable. CHARACTER CHAU*16 C...Read out code with distinction particle/antiparticle. CHAU=' ' KC=PYCOMP(KF) IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2) RETURN END C********************************************************************* C...PYCHGE C...Gives three times the charge for a particle/parton. FUNCTION PYCHGE(KF) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT2/ C...Read out charge and change sign for antiparticle. PYCHGE=0 KC=PYCOMP(KF) IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF) RETURN END C********************************************************************* C...PYCOMP C...Compress the standard KF codes for use in mass and decay arrays; C...also checks whether a given code actually is defined. FUNCTION PYCOMP(KF) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C...Local arrays and saved data. DIMENSION KFORD(100:500),KCORD(101:500) SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST C...Whenever necessary reorder codes for faster search. IF(MSTU(20).EQ.0) THEN NFORD=100 KFORD(100)=0 DO 120 I=101,500 KFA=KCHG(I,4) IF(KFA.LE.100) GOTO 120 NFORD=NFORD+1 DO 100 I1=NFORD-1,0,-1 IF(KFA.GE.KFORD(I1)) GOTO 110 KFORD(I1+1)=KFORD(I1) KCORD(I1+1)=KCORD(I1) 100 CONTINUE 110 KFORD(I1+1)=KFA KCORD(I1+1)=I 120 CONTINUE MSTU(20)=1 KFLAST=0 KCLAST=0 ENDIF C...Fast action if same code as in latest call. IF(KF.EQ.KFLAST) THEN PYCOMP=KCLAST RETURN ENDIF C...Starting values. Remove internal diquark flags. PYCOMP=0 KFA=IABS(KF) IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000) C...Simple cases: direct translation. IF(KFA.GT.KFORD(NFORD)) THEN ELSEIF(KFA.LE.100) THEN PYCOMP=KFA C...Else binary search. ELSE IMIN=100 IMAX=NFORD+1 130 IAVG=(IMIN+IMAX)/2 IF(KFORD(IAVG).GT.KFA) THEN IMAX=IAVG IF(IMAX.GT.IMIN+1) GOTO 130 ELSEIF(KFORD(IAVG).LT.KFA) THEN IMIN=IAVG IF(IMAX.GT.IMIN+1) GOTO 130 ELSE PYCOMP=KCORD(IAVG) ENDIF ENDIF C...Check if antiparticle allowed. IF(PYCOMP.NE.0.AND.KF.LT.0) THEN IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0 ENDIF C...Save codes for possible future fast action. KFLAST=KF KCLAST=PYCOMP RETURN END C********************************************************************* C...PYERRM C...Informs user of errors in program execution. SUBROUTINE PYERRM(MERR,CHMESS) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYJETS/,/PYDAT1/ C...Local character variable. CHARACTER CHMESS*(*) C...Write first few warnings, then be silent. IF(MERR.LE.10) THEN MSTU(27)=MSTU(27)+1 MSTU(28)=MERR IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000) & MERR,MSTU(31),CHMESS C...Write first few errors, then be silent or stop program. ELSEIF(MERR.LE.20) THEN MSTU(23)=MSTU(23)+1 MSTU(24)=MERR-10 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100) & MERR-10,MSTU(31),CHMESS IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS WRITE(MSTU(11),5200) IF(MERR.NE.17) CALL PYLIST(2) STOP ENDIF C...Stop program in case of irreparable error. ELSE WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS STOP ENDIF C...Formats for output. 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9, &' PYEXEC calls:'/5X,A) 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9, &' PYEXEC calls:'/5X,A) 5200 FORMAT(5X,'Execution will be stopped after listing of last ', &'event!') 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9, &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!') RETURN END C********************************************************************* C...PYALEM C...Calculates the running alpha_electromagnetic. FUNCTION PYALEM(Q2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Calculate real part of photon vacuum polarization. C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions. C...For hadrons use parametrization of H. Burkhardt et al. C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131. AEMPI=PARU(101)/(3D0*PARU(1)) IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN RPIGG=0D0 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN RPIGG=0D0 ELSEIF(MSTU(101).EQ.2) THEN RPIGG=1D0-PARU(101)/PARU(103) ELSEIF(Q2.LT.0.09D0) THEN RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2) ELSEIF(Q2.LT.9D0) THEN RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+ & 0.00238D0*LOG(1D0+3.927D0*Q2) ELSEIF(Q2.LT.1D4) THEN RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+ & 0.00299D0*LOG(1D0+Q2) ELSE RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+ & 0.00293D0*LOG(1D0+Q2) ENDIF C...Calculate running alpha_em. PYALEM=PARU(101)/(1D0-RPIGG) PARU(108)=PYALEM RETURN END C********************************************************************* C...PYALPS C...Gives the value of alpha_strong. FUNCTION PYALPS(Q2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C...Constant alpha_strong trivial. Pick artificial Lambda. IF(MSTU(111).LE.0) THEN PYALPS=PARU(111) MSTU(118)=MSTU(112) PARU(117)=0.2D0 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/ & ((33D0-2D0*MSTU(112))*PARU(111))) PARU(118)=PARU(111) RETURN ENDIF C...Find effective Q2, number of flavours and Lambda. Q2EFF=Q2 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114)) NF=MSTU(112) ALAM2=PARU(112)**2 100 IF(NF.GT.MAX(2,MSTU(113))) THEN Q2THR=PARU(113)*PMAS(NF,1)**2 IF(Q2EFF.LT.Q2THR) THEN NF=NF-1 ALAM2=ALAM2*(Q2THR/ALAM2)**(2D0/(33D0-2D0*NF)) GOTO 100 ENDIF ENDIF 110 IF(NF.LT.MIN(8,MSTU(114))) THEN Q2THR=PARU(113)*PMAS(NF+1,1)**2 IF(Q2EFF.GT.Q2THR) THEN NF=NF+1 ALAM2=ALAM2*(ALAM2/Q2THR)**(2D0/(33D0-2D0*NF)) GOTO 110 ENDIF ENDIF IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2 PARU(117)=SQRT(ALAM2) C...Evaluate first or second order alpha_strong. B0=(33D0-2D0*NF)/6D0 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2)) IF(MSTU(111).EQ.1) THEN PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)) ELSE B1=(153D0-19D0*NF)/6D0 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/ & (B0**2*ALGQ))) ENDIF MSTU(118)=NF PARU(118)=PYALPS RETURN END C********************************************************************* C...PYANGL C...Reconstructs an angle from given x and y coordinates. FUNCTION PYANGL(X,Y) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ PYANGL=0D0 R=SQRT(X**2+Y**2) IF(R.LT.1D-20) RETURN IF(ABS(X)/R.LT.0.8D0) THEN PYANGL=SIGN(ACOS(X/R),Y) ELSE PYANGL=ASIN(Y/R) IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN PYANGL=PARU(1)-PYANGL ELSEIF(X.LT.0D0) THEN PYANGL=-PARU(1)-PYANGL ENDIF ENDIF RETURN END C********************************************************************* C...PYR C...Generates random numbers uniformly distributed between C...0 and 1, excluding the endpoints. FUNCTION PYR(IDUMMY) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDATR/MRPY(6),RRPY(100) SAVE /PYDATR/ C...Equivalence between commonblock and local variables. EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)), &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)), &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100)) C...Initialize generation from given seed. IF(MRPY2.EQ.0) THEN IJ=MOD(MRPY1/30082,31329) KL=MOD(MRPY1,30082) I=MOD(IJ/177,177)+2 J=MOD(IJ,177)+2 K=MOD(KL/169,178)+1 L=MOD(KL,169) DO 110 II=1,97 S=0D0 T=0.5D0 DO 100 JJ=1,48 M=MOD(MOD(I*J,179)*K,179) I=J J=K K=M L=MOD(53*L+1,169) IF(MOD(L*M,64).GE.32) S=S+T T=0.5D0*T 100 CONTINUE RRPY(II)=S 110 CONTINUE TWOM24=1D0 DO 120 I24=1,24 TWOM24=0.5D0*TWOM24 120 CONTINUE RRPY98=362436D0*TWOM24 RRPY99=7654321D0*TWOM24 RRPY00=16777213D0*TWOM24 MRPY2=1 MRPY3=0 MRPY4=97 MRPY5=33 ENDIF C...Generate next random number. 130 RUNI=RRPY(MRPY4)-RRPY(MRPY5) IF(RUNI.LT.0D0) RUNI=RUNI+1D0 RRPY(MRPY4)=RUNI MRPY4=MRPY4-1 IF(MRPY4.EQ.0) MRPY4=97 MRPY5=MRPY5-1 IF(MRPY5.EQ.0) MRPY5=97 RRPY98=RRPY98-RRPY99 IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00 RUNI=RUNI-RRPY98 IF(RUNI.LT.0D0) RUNI=RUNI+1D0 IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130 C...Update counters. Random number to output. MRPY3=MRPY3+1 IF(MRPY3.EQ.1000000000) THEN MRPY2=MRPY2+1 MRPY3=0 ENDIF PYR=RUNI RETURN END C********************************************************************* C...PYRGET C...Dumps the state of the random number generator on a file C...for subsequent startup from this state onwards. SUBROUTINE PYRGET(LFN,MOVE) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDATR/MRPY(6),RRPY(100) SAVE /PYDATR/ C...Local character variable. CHARACTER CHERR*8 C...Backspace required number of records (or as many as there are). IF(MOVE.LT.0) THEN NBCK=MIN(MRPY(6),-MOVE) DO 100 IBCK=1,NBCK BACKSPACE(LFN,ERR=110,IOSTAT=IERR) 100 CONTINUE MRPY(6)=MRPY(6)-NBCK ENDIF C...Unformatted write on unit LFN. WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5), &(RRPY(I2),I2=1,100) MRPY(6)=MRPY(6)+1 RETURN C...Write error. 110 WRITE(CHERR,'(I8)') IERR CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='// &CHERR) RETURN END C********************************************************************* C...PYRSET C...Reads a state of the random number generator from a file C...for subsequent generation from this state onwards. SUBROUTINE PYRSET(LFN,MOVE) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDATR/MRPY(6),RRPY(100) SAVE /PYDATR/ C...Local character variable. CHARACTER CHERR*8 C...Backspace required number of records (or as many as there are). IF(MOVE.LT.0) THEN NBCK=MIN(MRPY(6),-MOVE) DO 100 IBCK=1,NBCK BACKSPACE(LFN,ERR=120,IOSTAT=IERR) 100 CONTINUE MRPY(6)=MRPY(6)-NBCK ENDIF C...Unformatted read from unit LFN. NFOR=1+MAX(0,MOVE) DO 110 IFOR=1,NFOR READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5), & (RRPY(I2),I2=1,100) 110 CONTINUE MRPY(6)=MRPY(6)+NFOR RETURN C...Write error. 120 WRITE(CHERR,'(I8)') IERR CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='// &CHERR) RETURN END C********************************************************************* C...PYROBO C...Performs rotations and boosts. SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYJETS/,/PYDAT1/ C...Local arrays. DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4) C...Find and check range of rotation/boost. IMIN=IMI IF(IMIN.LE.0) IMIN=1 IF(MSTU(1).GT.0) IMIN=MSTU(1) IMAX=IMA IF(IMAX.LE.0) IMAX=N IF(MSTU(2).GT.0) IMAX=MSTU(2) IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory') RETURN ENDIF C...Optional resetting of V (when not set before.) IF(MSTU(33).NE.0) THEN DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4)) DO 100 J=1,5 V(I,J)=0D0 100 CONTINUE 110 CONTINUE MSTU(33)=0 ENDIF C...Rotate, typically from z axis to direction (theta,phi). IF(THE**2+PHI**2.GT.1D-20) THEN ROT(1,1)=COS(THE)*COS(PHI) ROT(1,2)=-SIN(PHI) ROT(1,3)=SIN(THE)*COS(PHI) ROT(2,1)=COS(THE)*SIN(PHI) ROT(2,2)=COS(PHI) ROT(2,3)=SIN(THE)*SIN(PHI) ROT(3,1)=-SIN(THE) ROT(3,2)=0D0 ROT(3,3)=COS(THE) DO 140 I=IMIN,IMAX IF(K(I,1).LE.0) GOTO 140 DO 120 J=1,3 PR(J)=P(I,J) VR(J)=V(I,J) 120 CONTINUE DO 130 J=1,3 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3) V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3) 130 CONTINUE 140 CONTINUE ENDIF C...Boost, typically from rest to momentum/energy=beta. IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN DBX=BEX DBY=BEY DBZ=BEZ DB=SQRT(DBX**2+DBY**2+DBZ**2) EPS1=1D0-1D-12 IF(DB.GT.EPS1) THEN C...Rescale boost vector if too close to unity. CALL PYERRM(3,'(PYROBO:) boost vector too large') DBX=DBX*(EPS1/DB) DBY=DBY*(EPS1/DB) DBZ=DBZ*(EPS1/DB) DB=EPS1 ENDIF DGA=1D0/SQRT(1D0-DB**2) DO 160 I=IMIN,IMAX IF(K(I,1).LE.0) GOTO 160 DO 150 J=1,4 DP(J)=P(I,J) DV(J)=V(I,J) 150 CONTINUE DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3) DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4)) P(I,1)=DP(1)+DGABP*DBX P(I,2)=DP(2)+DGABP*DBY P(I,3)=DP(3)+DGABP*DBZ P(I,4)=DGA*(DP(4)+DBP) DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3) DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4)) V(I,1)=DV(1)+DGABV*DBX V(I,2)=DV(2)+DGABV*DBY V(I,3)=DV(3)+DGABV*DBZ V(I,4)=DGA*(DV(4)+DBV) 160 CONTINUE ENDIF RETURN END C********************************************************************* C...PYEDIT C...Performs global manipulations on the event record, in particular C...to exclude unstable or undetectable partons/particles. SUBROUTINE PYEDIT(MEDIT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local arrays. DIMENSION NS(2),PTS(2),PLS(2) C...Remove unwanted partons/particles. IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN IMAX=N IF(MSTU(2).GT.0) IMAX=MSTU(2) I1=MAX(1,MSTU(1))-1 DO 110 I=MAX(1,MSTU(1)),IMAX IF(K(I,1).EQ.0.OR.K(I,1).GT.20) GOTO 110 IF(MEDIT.EQ.1) THEN IF(K(I,1).GT.10) GOTO 110 ELSEIF(MEDIT.EQ.2) THEN IF(K(I,1).GT.10) GOTO 110 KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.KC.EQ.18) & GOTO 110 ELSEIF(MEDIT.EQ.3) THEN IF(K(I,1).GT.10) GOTO 110 KC=PYCOMP(K(I,2)) IF(KC.EQ.0) GOTO 110 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110 ELSEIF(MEDIT.EQ.5) THEN IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) GOTO 110 KC=PYCOMP(K(I,2)) IF(KC.EQ.0) GOTO 110 IF(K(I,1).GE.11.AND.KCHG(KC,2).EQ.0) GOTO 110 ENDIF C...Pack remaining partons/particles. Origin no longer known. I1=I1+1 DO 100 J=1,5 K(I1,J)=K(I,J) P(I1,J)=P(I,J) V(I1,J)=V(I,J) 100 CONTINUE K(I1,3)=0 110 CONTINUE IF(I1.LT.N) MSTU(3)=0 IF(I1.LT.N) MSTU(70)=0 N=I1 C...Selective removal of class of entries. New position of retained. ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN I1=0 DO 120 I=1,N K(I,3)=MOD(K(I,3),MSTU(5)) IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR. & K(I,1).EQ.15).AND.K(I,2).NE.94) GOTO 120 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR. & K(I,2).EQ.94)) GOTO 120 IF(MEDIT.EQ.15.AND.K(I,1).GE.21) GOTO 120 I1=I1+1 K(I,3)=K(I,3)+MSTU(5)*I1 120 CONTINUE C...Find new event history information and replace old. DO 140 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,3)/MSTU(5).EQ.0) & GOTO 140 ID=I 130 IM=MOD(K(ID,3),MSTU(5)) IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15).AND. & K(IM,2).NE.94) THEN ID=IM GOTO 130 ENDIF ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,2).EQ.94) THEN ID=IM GOTO 130 ENDIF ENDIF K(I,3)=MSTU(5)*(K(I,3)/MSTU(5)) IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5) IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)= & K(K(I,4),3)/MSTU(5) IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)= & K(K(I,5),3)/MSTU(5) ELSE KCM=MOD(K(I,4)/MSTU(5),MSTU(5)) IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5) KCD=MOD(K(I,4),MSTU(5)) IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5) K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD KCM=MOD(K(I,5)/MSTU(5),MSTU(5)) IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5) KCD=MOD(K(I,5),MSTU(5)) IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5) K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD ENDIF 140 CONTINUE C...Pack remaining entries. I1=0 MSTU90=MSTU(90) MSTU(90)=0 DO 170 I=1,N IF(K(I,3)/MSTU(5).EQ.0) GOTO 170 I1=I1+1 DO 150 J=1,5 K(I1,J)=K(I,J) P(I1,J)=P(I,J) V(I1,J)=V(I,J) 150 CONTINUE K(I1,3)=MOD(K(I1,3),MSTU(5)) DO 160 IZ=1,MSTU90 IF(I.EQ.MSTU(90+IZ)) THEN MSTU(90)=MSTU(90)+1 MSTU(90+MSTU(90))=I1 PARU(90+MSTU(90))=PARU(90+IZ) ENDIF 160 CONTINUE 170 CONTINUE IF(I1.LT.N) MSTU(3)=0 IF(I1.LT.N) MSTU(70)=0 N=I1 C...Fill in some missing daughter pointers (lost in colour flow). ELSEIF(MEDIT.EQ.16) THEN DO 220 I=1,N IF(K(I,1).LE.10.OR.K(I,1).GT.20) GOTO 220 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220 C...Find daughters who point to mother. DO 180 I1=I+1,N IF(K(I1,3).NE.I) THEN ELSEIF(K(I,4).EQ.0) THEN K(I,4)=I1 ELSE K(I,5)=I1 ENDIF 180 CONTINUE IF(K(I,5).EQ.0) K(I,5)=K(I,4) IF(K(I,4).NE.0) GOTO 220 C...Find daughters who point to documentation version of mother. IM=K(I,3) IF(IM.LE.0.OR.IM.GE.I) GOTO 220 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220 DO 190 I1=I+1,N IF(K(I1,3).NE.IM) THEN ELSEIF(K(I,4).EQ.0) THEN K(I,4)=I1 ELSE K(I,5)=I1 ENDIF 190 CONTINUE IF(K(I,5).EQ.0) K(I,5)=K(I,4) IF(K(I,4).NE.0) GOTO 220 C...Find daughters who point to documentation daughters who, C...in their turn, point to documentation mother. ID1=IM ID2=IM DO 200 I1=IM+1,I-1 IF(K(I1,3).EQ.IM.AND.K(I1,1).GT.20.AND.K(I1,1).LE.30) THEN ID2=I1 IF(ID1.EQ.IM) ID1=I1 ENDIF 200 CONTINUE DO 210 I1=I+1,N IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN ELSEIF(K(I,4).EQ.0) THEN K(I,4)=I1 ELSE K(I,5)=I1 ENDIF 210 CONTINUE IF(K(I,5).EQ.0) K(I,5)=K(I,4) 220 CONTINUE C...Save top entries at bottom of PYJETS commonblock. ELSEIF(MEDIT.EQ.21) THEN IF(2*N.GE.MSTU(4)) THEN CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS') RETURN ENDIF DO 240 I=1,N DO 230 J=1,5 K(MSTU(4)-I,J)=K(I,J) P(MSTU(4)-I,J)=P(I,J) V(MSTU(4)-I,J)=V(I,J) 230 CONTINUE 240 CONTINUE MSTU(32)=N C...Restore bottom entries of commonblock PYJETS to top. ELSEIF(MEDIT.EQ.22) THEN DO 260 I=1,MSTU(32) DO 250 J=1,5 K(I,J)=K(MSTU(4)-I,J) P(I,J)=P(MSTU(4)-I,J) V(I,J)=V(MSTU(4)-I,J) 250 CONTINUE 260 CONTINUE N=MSTU(32) C...Mark primary entries at top of commonblock PYJETS as untreated. ELSEIF(MEDIT.EQ.23) THEN I1=0 DO 270 I=1,N KH=K(I,3) IF(KH.GE.1) THEN IF(K(KH,1).GT.20) KH=0 ENDIF IF(KH.NE.0) GOTO 280 I1=I1+1 IF(K(I,1).GT.10.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10 270 CONTINUE 280 N=I1 C...Place largest axis along z axis and second largest in xy plane. ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1), & P(MSTU(61),2)),0D0,0D0,0D0) CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3), & P(MSTU(61),1)),0D0,0D0,0D0,0D0) CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1), & P(MSTU(61)+1,2)),0D0,0D0,0D0) IF(MEDIT.EQ.31) RETURN C...Rotate to put slim jet along +z axis. DO 290 IS=1,2 NS(IS)=0 PTS(IS)=0D0 PLS(IS)=0D0 290 CONTINUE DO 300 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18) GOTO 300 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)) & .EQ.0) GOTO 300 ENDIF IS=2D0-SIGN(0.5D0,P(I,3)) NS(IS)=NS(IS)+1 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2) 300 CONTINUE IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2) & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0) C...Rotate to put second largest jet into -z,+x quadrant. DO 310 I=1,N IF(P(I,3).GE.0D0) GOTO 310 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18) GOTO 310 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)) & .EQ.0) GOTO 310 ENDIF IS=2D0-SIGN(0.5D0,P(I,1)) PLS(IS)=PLS(IS)-P(I,3) 310 CONTINUE IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1), & 0D0,0D0,0D0) ENDIF RETURN END C********************************************************************* C...PYLIST C...Gives program heading, or lists an event, or particle C...data, or current parameter values. SUBROUTINE PYLIST(MLIST) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KEXCIT=4000000) 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(4000,2),BRAT(4000),KFDP(4000,5) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/ C...Local arrays, character variables and data. CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4 DIMENSION PS(6) DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/ C...Initialization printout: version number and date of last change. IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN CALL PYLOGO MSTU(12)=0 IF(MLIST.EQ.0) RETURN ENDIF C...List event data, including additional lines after N. IF(MLIST.GE.1.AND.MLIST.LE.3) THEN IF(MLIST.EQ.1) WRITE(MSTU(11),5100) IF(MLIST.EQ.2) WRITE(MSTU(11),5200) IF(MLIST.EQ.3) WRITE(MSTU(11),5300) LMX=12 IF(MLIST.GE.2) LMX=16 ISTR=0 IMAX=N IF(MSTU(2).GT.0) IMAX=MSTU(2) DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3))) IF((I.GT.IMAX.AND.I.LE.N).OR.K(I,1).LT.0) GOTO 120 C...Get particle name, pad it and check it is not too long. CALL PYNAME(K(I,2),CHAP) LEN=0 DO 100 LEM=1,16 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM 100 CONTINUE MDL=(K(I,1)+19)/10 LDL=0 IF(MDL.EQ.2.OR.MDL.GE.8) THEN CHAC=CHAP IF(LEN.GT.LMX) CHAC(LMX:LMX)='?' ELSE LDL=1 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2 IF(LEN.EQ.0) THEN CHAC=CHDL(MDL)(1:2*LDL)//' ' ELSE CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))// & CHDL(MDL)(LDL+1:2*LDL)//' ' IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?' ENDIF ENDIF C...Add information on string connection. IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12) & THEN KC=PYCOMP(K(I,2)) KCC=0 IF(KC.NE.0) KCC=KCHG(KC,2) IF(IABS(K(I,2)).EQ.39) THEN IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X' ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN ISTR=1 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A' ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I' ELSEIF(KCC.NE.0) THEN ISTR=0 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V' ENDIF ENDIF C...Write data for particle/jet. IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN WRITE(MSTU(11),5400) I,CHAC(1:12),(K(I,J1),J1=1,3), & (P(I,J2),J2=1,5) ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3), & (P(I,J2),J2=1,5) ELSEIF(MLIST.EQ.1) THEN WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3), & (P(I,J2),J2=1,5) ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR. & K(I,1).EQ.14)) THEN WRITE(MSTU(11),5700) I,CHAC,(K(I,J1),J1=1,3), & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000), & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000), & (P(I,J2),J2=1,5) ELSE WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,5), & (P(I,J2),J2=1,5) ENDIF IF(MLIST.EQ.3) WRITE(MSTU(11),5900) (V(I,J),J=1,5) C...Insert extra separator lines specified by user. IF(MSTU(70).GE.1) THEN ISEP=0 DO 110 J=1,MIN(10,MSTU(70)) IF(I.EQ.MSTU(70+J)) ISEP=1 110 CONTINUE IF(ISEP.EQ.1.AND.MLIST.EQ.1) WRITE(MSTU(11),6000) IF(ISEP.EQ.1.AND.MLIST.GE.2) WRITE(MSTU(11),6100) ENDIF 120 CONTINUE C...Sum of charges and momenta. DO 130 J=1,6 PS(J)=PYP(0,J) 130 CONTINUE IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN WRITE(MSTU(11),6200) PS(6),(PS(J),J=1,5) ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN WRITE(MSTU(11),6300) PS(6),(PS(J),J=1,5) ELSEIF(MLIST.EQ.1) THEN WRITE(MSTU(11),6400) PS(6),(PS(J),J=1,5) ELSE WRITE(MSTU(11),6500) PS(6),(PS(J),J=1,5) ENDIF C...Give simple list of KF codes defined in program. ELSEIF(MLIST.EQ.11) THEN WRITE(MSTU(11),6600) DO 140 KF=1,80 CALL PYNAME(KF,CHAP) CALL PYNAME(-KF,CHAN) IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN 140 CONTINUE DO 170 KFLS=1,3,2 DO 160 KFLA=1,5 DO 150 KFLB=1,KFLA-(3-KFLS)/2 KF=1000*KFLA+100*KFLB+KFLS CALL PYNAME(KF,CHAP) CALL PYNAME(-KF,CHAN) WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN 150 CONTINUE 160 CONTINUE 170 CONTINUE KF=130 CALL PYNAME(KF,CHAP) WRITE(MSTU(11),6700) KF,CHAP KF=310 CALL PYNAME(KF,CHAP) WRITE(MSTU(11),6700) KF,CHAP DO 200 KMUL=0,5 KFLS=3 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1 IF(KMUL.EQ.5) KFLS=5 KFLR=0 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1 IF(KMUL.EQ.4) KFLR=2 DO 190 KFLB=1,5 DO 180 KFLC=1,KFLB-1 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS CALL PYNAME(KF,CHAP) CALL PYNAME(-KF,CHAN) WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN 180 CONTINUE KF=10000*KFLR+110*KFLB+KFLS CALL PYNAME(KF,CHAP) WRITE(MSTU(11),6700) KF,CHAP 190 CONTINUE 200 CONTINUE KF=100443 CALL PYNAME(KF,CHAP) WRITE(MSTU(11),6700) KF,CHAP KF=100553 CALL PYNAME(KF,CHAP) WRITE(MSTU(11),6700) KF,CHAP DO 240 KFLSP=1,3 KFLS=2+2*(KFLSP/3) DO 230 KFLA=1,5 DO 220 KFLB=1,KFLA DO 210 KFLC=1,KFLB IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC)) & GOTO 210 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 210 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS CALL PYNAME(KF,CHAP) CALL PYNAME(-KF,CHAN) WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN 210 CONTINUE 220 CONTINUE 230 CONTINUE 240 CONTINUE DO 250 KF=KSUSY1+1,KSUSY1+40 CALL PYNAME(KF,CHAP) CALL PYNAME(-KF,CHAN) IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN 250 CONTINUE DO 260 KF=KSUSY2+1,KSUSY2+40 CALL PYNAME(KF,CHAP) CALL PYNAME(-KF,CHAN) IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN 260 CONTINUE DO 270 KF=KEXCIT+1,KEXCIT+40 CALL PYNAME(KF,CHAP) CALL PYNAME(-KF,CHAN) IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),6700) KF,CHAP IF(CHAN.NE.' ') WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN 270 CONTINUE C...List parton/particle data table. Check whether to be listed. ELSEIF(MLIST.EQ.12) THEN WRITE(MSTU(11),6800) DO 300 KC=1,MSTU(6) KF=KCHG(KC,4) IF(KF.EQ.0) GOTO 300 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2))) & GOTO 300 C...Find particle name and mass. Print information. CALL PYNAME(KF,CHAP) IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300 CALL PYNAME(-KF,CHAN) WRITE(MSTU(11),6900) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3), & (PMAS(KC,J2),J2=1,4),MDCY(KC,1) C...Particle decay: channel number, branching ratios, matrix element, C...decay products. DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 DO 280 J=1,5 CALL PYNAME(KFDP(IDC,J),CHAD(J)) 280 CONTINUE WRITE(MSTU(11),7000) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC), & (CHAD(J),J=1,5) 290 CONTINUE 300 CONTINUE C...List parameter value table. ELSEIF(MLIST.EQ.13) THEN WRITE(MSTU(11),7100) DO 310 I=1,200 WRITE(MSTU(11),7200) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I) 310 CONTINUE ENDIF C...Format statements for output on unit MSTU(11) (by default 6). 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS', &5X,'KF orig p_x p_y p_z E m'/) 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet', &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)', &' P(I,2) P(I,3) P(I,4) P(I,5)'/) 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j', &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)', &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X, &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/) 5400 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3) 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2) 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1) 5700 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5) 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5) 5900 FORMAT(66X,5(1X,F12.3)) 6000 FORMAT(1X,78('=')) 6100 FORMAT(1X,130('=')) 6200 FORMAT(19X,'sum:',F6.2,5X,5F9.3) 6300 FORMAT(19X,'sum:',F6.2,5X,5F9.2) 6400 FORMAT(19X,'sum:',F6.2,5X,5F9.1) 6500 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:', &5F13.5) 6600 FORMAT(///20X,'List of KF codes in program'/) 6700 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16) 6800 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X, &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X, &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off', &1X,'ME',3X,'Br.rat.',4X,'decay products') 6900 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5), &1X,1P,E13.5,3X,I2) 7000 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16) 7100 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)', &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)') 7200 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5) RETURN END C********************************************************************* C...PYLOGO C...Writes a logo for the program. SUBROUTINE PYLOGO C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Parameter for length of information block. PARAMETER (IREFER=17) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) SAVE /PYDAT1/,/PYPARS/ C...Local arrays and character variables. INTEGER IDATI(6) CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79, &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2 C...Data on months, logo, titles, and references. DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep', &'Oct','Nov','Dec'/ DATA (LOGO(J),J=1,19)/ &' *......* ', &' *:::!!:::::::::::* ', &' *::::::!!::::::::::::::* ', &' *::::::::!!::::::::::::::::* ', &' *:::::::::!!:::::::::::::::::* ', &' *:::::::::!!:::::::::::::::::* ', &' *::::::::!!::::::::::::::::*! ', &' *::::::!!::::::::::::::* !! ', &' !! *:::!!:::::::::::* !! ', &' !! !* -><- * !! ', &' !! !! !! ', &' !! !! !! ', &' !! !! ', &' !! ep !! ', &' !! !! ', &' !! pp !! ', &' !! e+e- !! ', &' !! !! ', &' !! '/ DATA (LOGO(J),J=20,38)/ &'Welcome to the Lund Monte Carlo!', &' ', &'PPP Y Y TTTTT H H III A ', &'P P Y Y T H H I A A ', &'PPP Y T HHHHH I AAAAA', &'P Y T H H I A A', &'P Y T H H III A A', &' ', &'This is PYTHIA version x.xxx ', &'Last date of change: xx xxx 199x', &' ', &'Now is xx xxx 199x at xx:xx:xx ', &' ', &'Disclaimer: this program comes ', &'without any guarantees. Beware ', &'of errors and use common sense ', &'when interpreting results. ', &' ', &'Copyright T. Sjostrand (1997) '/ DATA (REFER(J),J=1,18)/ &'An archive of program versions and d', &'ocumentation is found on the web: ', &'http://www.thep.lu.se/tf2/staff/torb', &'jorn/Pythia.html ', &' ', &' ', &'When you cite this program, currentl', &'y the official reference is ', &'T. Sjostrand, Computer Physics Commu', &'n. 82 (1994) 74. ', &'The supersymmetry extensions are des', &'cribed in ', &'S. Mrenna, Computer Physics Commun. ', &'101 (1997) 232 ', &'Also remember that the program, to a', &' large extent, represents original ', &'physics research. Other publications', &' of special relevance to your '/ DATA (REFER(J),J=19,2*IREFER)/ &'studies may therefore deserve separa', &'te mention. ', &' ', &' ', &'Main author: Torbjorn Sjostrand; Dep', &'artment of Theoretical Physics 2, ', &' Lund University, Solvegatan 14A, S', &'-223 62 Lund, Sweden; ', &' phone: + 46 - 46 - 222 48 16; e-ma', &'il: torbjorn@thep.lu.se ', &'SUSY author: Stephen Mrenna, Argonne', &' National Laboratory, ', &' 9700 South Cass Avenue, Argonne, I', &'L 60439, USA; ', &' phone: + 1 - 630 - 252 - 7615; e-m', &'ail: mrenna@hep.anl.gov '/ C...Check that PYDATA linked. IF(MSTP(183)/10.NE.199) THEN WRITE(MSTU(11),'(1X,A)') & 'Error: PYDATA has not been linked.' WRITE(MSTU(11),'(1X,A)') 'Execution stopped!' STOP C...Write current version number and current date+time. ELSE WRITE(VERS,'(I1)') MSTP(181) LOGO(28)(24:24)=VERS WRITE(SUBV,'(I3)') MSTP(182) LOGO(28)(26:28)=SUBV IF(MSTP(182).LT.100) LOGO(28)(26:26)='0' WRITE(DATE,'(I2)') MSTP(185) LOGO(29)(22:23)=DATE LOGO(29)(25:27)=MONTH(MSTP(184)) WRITE(YEAR,'(I4)') MSTP(183) LOGO(29)(29:32)=YEAR CALL PYTIME(IDATI) IF(IDATI(1).LE.0) THEN LOGO(31)=' ' ELSE WRITE(DATE,'(I2)') IDATI(3) LOGO(31)(8:9)=DATE LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2)))) WRITE(YEAR,'(I4)') IDATI(1) LOGO(31)(15:18)=YEAR WRITE(HOUR,'(I2)') IDATI(4) LOGO(31)(23:24)=HOUR WRITE(MINU,'(I2)') IDATI(5) LOGO(31)(26:27)=MINU IF(IDATI(5).LT.10) LOGO(31)(26:26)='0' WRITE(SECO,'(I2)') IDATI(6) LOGO(31)(29:30)=SECO IF(IDATI(6).LT.10) LOGO(31)(29:29)='0' ENDIF ENDIF C...Loop over lines in header. Define page feed and side borders. DO 100 ILIN=1,29+IREFER LINE=' ' IF(ILIN.EQ.1) THEN LINE(1:1)='1' ELSE LINE(2:3)='**' LINE(78:79)='**' ENDIF C...Separator lines and logos. IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN LINE(4:77)='***********************************************'// & '***************************' ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN LINE(6:37)=LOGO(ILIN-5) LINE(44:75)=LOGO(ILIN+14) ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN LINE(5:40)=REFER(2*ILIN-51) LINE(41:76)=REFER(2*ILIN-50) ENDIF C...Write lines to appropriate unit. WRITE(MSTU(11),'(A79)') LINE 100 CONTINUE RETURN END C********************************************************************* C...PYUPDA C...Facilitates the updating of particle and decay data C...by allowing it to be done in an external file. SUBROUTINE PYUPDA(MUPDA,LFN) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) 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(4000,2),BRAT(4000),KFDP(4000,5) COMMON/PYDAT4/CHAF(500,2) CHARACTER CHAF*16 COMMON/PYINT4/MWID(500),WIDS(500,5) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/ C...Local arrays, character variables and data. CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72, &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)', &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)', &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ', &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)', &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/ C...Write header if not yet done. IF(MSTU(12).GE.1) CALL PYLIST(0) C...Write information on file for editing. IF(MUPDA.EQ.1) THEN DO 110 KC=1,500 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2), & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4), & MWID(KC),MDCY(KC,1) DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC), & (KFDP(IDC,J),J=1,5) 100 CONTINUE 110 CONTINUE C...Read complete set of information from edited file or C...read partial set of new or updated information from edited file. ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN C...Reset counters. KCC=100 NDC=0 CHKF=' ' IF(MUPDA.EQ.2) THEN DO 120 I=1,MSTU(6) KCHG(I,4)=0 120 CONTINUE ELSE DO 130 KC=1,MSTU(6) IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1) 130 CONTINUE ENDIF C...Begin of loop: read new line; unknown whether particle or C...decay data. 140 READ(LFN,5200,END=190) CHINL C...Identify particle code and whether already defined (for MUPDA=3). IF(CHINL(2:10).NE.' ') THEN CHKF=CHINL(2:10) READ(CHKF,5300) KF IF(MUPDA.EQ.2) THEN IF(KF.LE.100) THEN KC=KF ELSE KCC=KCC+1 KC=KCC ENDIF ELSE KCREP=0 IF(KF.LE.100) THEN KCREP=KF ELSE DO 150 KCR=101,KCC IF(KCHG(KCR,4).EQ.KF) KCREP=KCR 150 CONTINUE ENDIF C...Remove duplicate old decay data. IF(KCREP.NE.0) THEN IDCREP=MDCY(KCREP,2) NDCREP=MDCY(KCREP,3) DO 160 I=1,KCC IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP 160 CONTINUE DO 180 I=IDCREP,NDC-NDCREP MDME(I,1)=MDME(I+NDCREP,1) MDME(I,2)=MDME(I+NDCREP,2) BRAT(I)=BRAT(I+NDCREP) DO 170 J=1,5 KFDP(I,J)=KFDP(I+NDCREP,J) 170 CONTINUE 180 CONTINUE NDC=NDC-NDCREP KC=KCREP ELSE KCC=KCC+1 KC=KCC ENDIF ENDIF C...Study line with particle data. IF(KC.GT.MSTU(6)) CALL PYERRM(27, & '(PYUPDA:) Particle arrays full by KF ='//CHKF) READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2), & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4), & MWID(KC),MDCY(KC,1) MDCY(KC,2)=0 MDCY(KC,3)=0 C...Study line with decay data. ELSE NDC=NDC+1 IF(NDC.GT.MSTU(7)) CALL PYERRM(27, & '(PYUPDA:) Decay data arrays full by KF ='//CHKF) IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC MDCY(KC,3)=MDCY(KC,3)+1 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC), & (KFDP(NDC,J),J=1,5) ENDIF C...End of loop; ensure that PYCOMP tables are updated. GOTO 140 190 CONTINUE MSTU(20)=0 C...Perform possible tests that new information is consistent. MSTJ24=MSTJ(24) MSTJ(24)=0 DO 220 KC=1,MSTU(6) KF=KCHG(KC,4) IF(KF.EQ.0) GOTO 220 WRITE(CHKF,5300) KF IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3), & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17, & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF) BRSUM=0D0 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 IF(MDME(IDC,2).GT.80) GOTO 210 KQ=KCHG(KC,1) PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64) MERR=0 DO 200 J=1,5 KP=KFDP(IDC,J) IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN IF(KP.EQ.81) KQ=0 ELSEIF(PYCOMP(KP).EQ.0) THEN MERR=3 ELSE KQ=KQ-PYCHGE(KP) PMS=PMS-PYMASS(KP) KPC=PYCOMP(KP) PMS=PMS-PMAS(KPC,1) IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2), & PMAS(KPC,3)) ENDIF 200 CONTINUE IF(KQ.NE.0) MERR=MAX(2,MERR) IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0) & MERR=MAX(1,MERR) IF(MERR.EQ.3) CALL PYERRM(17, & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF) IF(MERR.EQ.2) CALL PYERRM(17, & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF) IF(MERR.EQ.1) CALL PYERRM(7, & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF) BRSUM=BRSUM+BRAT(IDC) 210 CONTINUE WRITE(CHTMP,5500) BRSUM IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0) & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '// & CHTMP(9:16)//' for KF ='//CHKF) 220 CONTINUE MSTJ(24)=MSTJ24 C...Write DATA statements for inclusion in program. ELSEIF(MUPDA.EQ.4) THEN C...Find out how many codes and decay channels are actually used. KCC=0 NDC=0 DO 230 I=1,MSTU(6) IF(KCHG(I,4).NE.0) THEN KCC=I NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1) ENDIF 230 CONTINUE C...Initialize writing of DATA statements for inclusion in program. DO 300 IVAR=1,22 NDIM=MSTU(6) IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7) NLIN=1 CHLIN=' ' CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/' LLIN=35 CHOLD='START' C...Loop through variables for conversion to characters. DO 280 IDIM=1,NDIM IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1) IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2) IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3) IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4) IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1) IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2) IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3) IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4) IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1) IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2) IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3) IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1) IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2) IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM) IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1) IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2) IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3) IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4) IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5) IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1) IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2) IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM) C...Replace variables beyond what is properly defined. IF(IVAR.LE.4) THEN IF(IDIM.GT.KCC) CHTMP=' 0' ELSEIF(IVAR.LE.8) THEN IF(IDIM.GT.KCC) CHTMP=' 0.0' ELSEIF(IVAR.LE.11) THEN IF(IDIM.GT.KCC) CHTMP=' 0' ELSEIF(IVAR.LE.13) THEN IF(IDIM.GT.NDC) CHTMP=' 0' ELSEIF(IVAR.LE.14) THEN IF(IDIM.GT.NDC) CHTMP=' 0.0' ELSEIF(IVAR.LE.19) THEN IF(IDIM.GT.NDC) CHTMP=' 0' ELSEIF(IVAR.LE.21) THEN IF(IDIM.GT.KCC) CHTMP=' ' ELSE IF(IDIM.GT.KCC) CHTMP=' 0' ENDIF C...Length of variable, trailing decimal zeros, quotation marks. LLOW=1 LHIG=1 DO 240 LL=1,16 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL IF(CHTMP(LL:LL).NE.' ') LHIG=LL 240 CONTINUE CHNEW=CHTMP(LLOW:LHIG)//' ' LNEW=1+LHIG-LLOW IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN LNEW=LNEW+1 250 LNEW=LNEW-1 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1 IF(LNEW.EQ.0) THEN CHNEW(1:3)='0D0' LNEW=3 ELSE CHNEW(LNEW+1:LNEW+2)='D0' LNEW=LNEW+2 ENDIF ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN DO 260 LL=LNEW,1,-1 IF(CHNEW(LL:LL).EQ.'''') THEN CHTMP=CHNEW CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11) LNEW=LNEW+1 ENDIF 260 CONTINUE LNEW=MIN(14,LNEW) CHTMP=CHNEW CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//'''' LNEW=LNEW+2 ENDIF C...Form composite character string, often including repetition counter. IF(CHNEW.NE.CHOLD) THEN NRPT=1 CHOLD=CHNEW CHCOM=CHNEW LCOM=LNEW ELSE LRPT=LNEW+1 IF(NRPT.GE.2) LRPT=LNEW+3 IF(NRPT.GE.10) LRPT=LNEW+4 IF(NRPT.GE.100) LRPT=LNEW+5 IF(NRPT.GE.1000) LRPT=LNEW+6 LLIN=LLIN-LRPT NRPT=NRPT+1 WRITE(CHTMP,5400) NRPT LRPT=1 IF(NRPT.GE.10) LRPT=2 IF(NRPT.GE.100) LRPT=3 IF(NRPT.GE.1000) LRPT=4 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW) LCOM=LRPT+1+LNEW ENDIF C...Add characters to end of line, to new line (after storing old line), C...or to new block of lines (after writing old block). IF(LLIN+LCOM.LE.70) THEN CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//',' LLIN=LLIN+LCOM+1 ELSEIF(NLIN.LE.19) THEN CHLIN(LLIN+1:72)=' ' CHBLK(NLIN)=CHLIN NLIN=NLIN+1 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//',' LLIN=6+LCOM+1 ELSE CHLIN(LLIN:72)='/'//' ' CHBLK(NLIN)=CHLIN WRITE(CHTMP,5400) IDIM-NRPT CHBLK(1)(30:33)=CHTMP(13:16) DO 270 ILIN=1,NLIN WRITE(LFN,5700) CHBLK(ILIN) 270 CONTINUE NLIN=1 CHLIN=' ' CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)// & ',I= , )/'//CHCOM(1:LCOM)//',' WRITE(CHTMP,5400) IDIM-NRPT+1 CHLIN(25:28)=CHTMP(13:16) LLIN=35+LCOM+1 ENDIF 280 CONTINUE C...Write final block of lines. CHLIN(LLIN:72)='/'//' ' CHBLK(NLIN)=CHLIN WRITE(CHTMP,5400) NDIM CHBLK(1)(30:33)=CHTMP(13:16) DO 290 ILIN=1,NLIN WRITE(LFN,5700) CHBLK(ILIN) 290 CONTINUE 300 CONTINUE ENDIF C...Formats for reading and writing particle data. 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3) 5100 FORMAT(10X,2I5,F12.6,5I10) 5200 FORMAT(A120) 5300 FORMAT(I9) 5400 FORMAT(I16) 5500 FORMAT(F16.5) 5600 FORMAT(F16.6) 5700 FORMAT(A72) RETURN END C********************************************************************* C...PYK C...Provides various integer-valued event related data. FUNCTION PYK(I,J) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Default value. For I=0 number of entries, number of stable entries C...or 3 times total charge. PYK=0 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN ELSEIF(I.EQ.0.AND.J.EQ.1) THEN PYK=N ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN DO 100 I1=1,N IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+ & PYCHGE(K(I1,2)) 100 CONTINUE ELSEIF(I.EQ.0) THEN C...For I > 0 direct readout of K matrix or charge. ELSEIF(J.LE.5) THEN PYK=K(I,J) ELSEIF(J.EQ.6) THEN PYK=PYCHGE(K(I,2)) C...Status (existing/fragmented/decayed), parton/hadron separation. ELSEIF(J.LE.8) THEN IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1 IF(J.EQ.8) PYK=PYK*K(I,2) ELSEIF(J.LE.12) THEN KFA=IABS(K(I,2)) KC=PYCOMP(KFA) KQ=0 IF(KC.NE.0) KQ=KCHG(KC,2) IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2) IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2) IF(J.EQ.11) PYK=KC IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2)) C...Heaviest flavour in hadron/diquark. ELSEIF(J.EQ.13) THEN KFA=IABS(K(I,2)) PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10) IF(KFA.LT.10) PYK=KFA IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10) PYK=PYK*ISIGN(1,K(I,2)) C...Particle history: generation, ancestor, rank. ELSEIF(J.LE.15) THEN I2=I I1=I 110 PYK=PYK+1 I2=I1 I1=K(I1,3) IF(I1.GT.0.AND.K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110 IF(J.EQ.15) PYK=I2 ELSEIF(J.EQ.16) THEN KFA=IABS(K(I,2)) IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR. & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN I1=I 120 I2=I1 I1=K(I1,3) IF(I1.GT.0) THEN KFAM=IABS(K(I1,2)) ILP=1 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93) & ILP=0 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0 IF(ILP.EQ.1) GOTO 120 ENDIF IF(K(I1,1).EQ.12) THEN DO 130 I3=I1+1,I2 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92 & .AND.K(I3,2).NE.93) PYK=PYK+1 130 CONTINUE ELSE I3=I2 140 PYK=PYK+1 I3=I3+1 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140 ENDIF ENDIF C...Particle coming from collapsing jet system or not. ELSEIF(J.EQ.17) THEN I1=I 150 PYK=PYK+1 I3=I1 I1=K(I1,3) I0=MAX(1,I1) KC=PYCOMP(K(I0,2)) IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN IF(PYK.EQ.1) PYK=-1 IF(PYK.GT.1) PYK=0 RETURN ENDIF IF(KCHG(KC,2).EQ.0) GOTO 150 IF(K(I1,1).NE.12) PYK=0 IF(K(I1,1).NE.12) RETURN I2=I1 160 I2=I2+1 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160 K3M=K(I3-1,3) IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0 K3P=K(I3+1,3) IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0 C...Number of decay products. Colour flow. ELSEIF(J.EQ.18) THEN IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1) IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0 ELSEIF(J.LE.22) THEN IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5)) IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5)) IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5)) IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5)) ELSE ENDIF RETURN END C********************************************************************* C...PYP C...Provides various real-valued event related data. FUNCTION PYP(I,J) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local array. DIMENSION PSUM(4) C...Set default value. For I = 0 sum of momenta or charges, C...or invariant mass of system. PYP=0D0 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN ELSEIF(I.EQ.0.AND.J.LE.4) THEN DO 100 I1=1,N IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J) 100 CONTINUE ELSEIF(I.EQ.0.AND.J.EQ.5) THEN DO 120 J1=1,4 PSUM(J1)=0D0 DO 110 I1=1,N IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+ & P(I1,J1) 110 CONTINUE 120 CONTINUE PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2)) ELSEIF(I.EQ.0.AND.J.EQ.6) THEN DO 130 I1=1,N IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0 130 CONTINUE ELSEIF(I.EQ.0) THEN C...Direct readout of P matrix. ELSEIF(J.LE.5) THEN PYP=P(I,J) C...Charge, total momentum, transverse momentum, transverse mass. ELSEIF(J.LE.12) THEN IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP) C...Theta and phi angle in radians or degrees. ELSEIF(J.LE.16) THEN IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2)) IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2)) IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1) C...True rapidity, rapidity with pion mass, pseudorapidity. ELSEIF(J.LE.19) THEN PMR=0D0 IF(J.EQ.17) PMR=P(I,5) IF(J.EQ.18) PMR=PYMASS(211) PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2) PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR), & 1D20)),P(I,3)) C...Energy and momentum fractions (only to be used in CM frame). ELSEIF(J.LE.25) THEN IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21) IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21) IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21) IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21) IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21) IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21) ENDIF RETURN END C********************************************************************* C...PYSPHE C...Performs sphericity tensor analysis to give sphericity, C...aplanarity and the related event axes. SUBROUTINE PYSPHE(SPH,APL) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local arrays. DIMENSION SM(3,3),SV(3,3) C...Calculate matrix to be diagonalized. NP=0 DO 110 J1=1,3 DO 100 J2=J1,3 SM(J1,J2)=0D0 100 CONTINUE 110 CONTINUE PS=0D0 DO 140 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18) GOTO 140 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) & GOTO 140 ENDIF NP=NP+1 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) PWT=1D0 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT= & MAX(1D-10,PA)**(PARU(41)-2D0) DO 130 J1=1,3 DO 120 J2=J1,3 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2) 120 CONTINUE 130 CONTINUE PS=PS+PWT*PA**2 140 CONTINUE C...Very low multiplicities (0 or 1) not considered. IF(NP.LE.1) THEN CALL PYERRM(8,'(PYSPHE:) too few particles for analysis') SPH=-1D0 APL=-1D0 RETURN ENDIF DO 160 J1=1,3 DO 150 J2=J1,3 SM(J1,J2)=SM(J1,J2)/PS 150 CONTINUE 160 CONTINUE C...Find eigenvalues to matrix (third degree equation). SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)- &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+ &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+ &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0) P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP) P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP) P(N+2,4)=1D0-P(N+1,4)-P(N+3,4) IF(P(N+2,4).LT.1D-5) THEN CALL PYERRM(8,'(PYSPHE:) all particles back-to-back') SPH=-1D0 APL=-1D0 RETURN ENDIF C...Find first and last eigenvector by solving equation system. DO 240 I=1,3,2 DO 180 J1=1,3 SV(J1,J1)=SM(J1,J1)-P(N+I,4) DO 170 J2=J1+1,3 SV(J1,J2)=SM(J1,J2) SV(J2,J1)=SM(J1,J2) 170 CONTINUE 180 CONTINUE SMAX=0D0 DO 200 J1=1,3 DO 190 J2=1,3 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190 JA=J1 JB=J2 SMAX=ABS(SV(J1,J2)) 190 CONTINUE 200 CONTINUE SMAX=0D0 DO 220 J3=JA+1,JA+2 J1=J3-3*((J3-1)/3) RL=SV(J1,JB)/SV(JA,JB) DO 210 J2=1,3 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2) IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210 JC=J1 SMAX=ABS(SV(J1,J2)) 210 CONTINUE 220 CONTINUE JB1=JB+1-3*(JB/3) JB2=JB+2-3*((JB+1)/3) P(N+I,JB1)=-SV(JC,JB2) P(N+I,JB2)=SV(JC,JB1) P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/ & SV(JA,JB) PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2) SGN=(-1D0)**INT(PYR(0)+0.5D0) DO 230 J=1,3 P(N+I,J)=SGN*P(N+I,J)/PA 230 CONTINUE 240 CONTINUE C...Middle axis orthogonal to other two. Fill other codes. SGN=(-1D0)**INT(PYR(0)+0.5D0) P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2)) P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3)) P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1)) DO 260 I=1,3 K(N+I,1)=31 K(N+I,2)=95 K(N+I,3)=I K(N+I,4)=0 K(N+I,5)=0 P(N+I,5)=0D0 DO 250 J=1,5 V(I,J)=0D0 250 CONTINUE 260 CONTINUE C...Calculate sphericity and aplanarity. Select storing option. SPH=1.5D0*(P(N+2,4)+P(N+3,4)) APL=1.5D0*P(N+3,4) MSTU(61)=N+1 MSTU(62)=NP IF(MSTU(43).LE.1) MSTU(3)=3 IF(MSTU(43).GE.2) N=N+3 RETURN END C********************************************************************* C...PYTHRU C...Performs thrust analysis to give thrust, oblateness C...and the related event axes. SUBROUTINE PYTHRU(THR,OBL) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local arrays. DIMENSION TDI(3),TPR(3) C...Take copy of particles that are to be considered in thrust analysis. NP=0 PS=0D0 DO 100 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18) GOTO 100 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) & GOTO 100 ENDIF IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS') THR=-2D0 OBL=-2D0 RETURN ENDIF NP=NP+1 K(N+NP,1)=23 P(N+NP,1)=P(I,1) P(N+NP,2)=P(I,2) P(N+NP,3)=P(I,3) P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) P(N+NP,5)=1D0 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)= & P(N+NP,4)**(PARU(42)-1D0) PS=PS+P(N+NP,4)*P(N+NP,5) 100 CONTINUE C...Very low multiplicities (0 or 1) not considered. IF(NP.LE.1) THEN CALL PYERRM(8,'(PYTHRU:) too few particles for analysis') THR=-1D0 OBL=-1D0 RETURN ENDIF C...Loop over thrust and major. T axis along z direction in latter case. DO 320 ILD=1,2 IF(ILD.EQ.2) THEN K(N+NP+1,1)=31 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2)) MSTU(33)=1 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0) THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1)) CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0) ENDIF C...Find and order particles with highest p (pT for major). DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4 P(ILF,4)=0D0 110 CONTINUE DO 160 I=N+1,N+NP IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2) DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1 IF(P(I,4).LE.P(ILF,4)) GOTO 140 DO 120 J=1,5 P(ILF+1,J)=P(ILF,J) 120 CONTINUE 130 CONTINUE ILF=N+NP+3 140 DO 150 J=1,5 P(ILF+1,J)=P(I,J) 150 CONTINUE 160 CONTINUE C...Find and order initial axes with highest thrust (major). DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15 P(ILG,4)=0D0 170 CONTINUE NC=2**(MIN(MSTU(44),NP)-1) DO 250 ILC=1,NC DO 180 J=1,3 TDI(J)=0D0 180 CONTINUE DO 200 ILF=1,MIN(MSTU(44),NP) SGN=P(N+NP+ILF+3,5) IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN DO 190 J=1,4-ILD TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J) 190 CONTINUE 200 CONTINUE TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1 IF(TDS.LE.P(ILG,4)) GOTO 230 DO 210 J=1,4 P(ILG+1,J)=P(ILG,J) 210 CONTINUE 220 CONTINUE ILG=N+NP+MSTU(44)+4 230 DO 240 J=1,3 P(ILG+1,J)=TDI(J) 240 CONTINUE P(ILG+1,4)=TDS 250 CONTINUE C...Iterate direction of axis until stable maximum. P(N+NP+ILD,4)=0D0 ILG=0 260 ILG=ILG+1 THP=0D0 270 THPS=THP DO 280 J=1,3 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J) IF(THP.GT.1D-10) TDI(J)=TPR(J) TPR(J)=0D0 280 CONTINUE DO 300 I=N+1,N+NP SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3)) DO 290 J=1,4-ILD TPR(J)=TPR(J)+SGN*P(I,J) 290 CONTINUE 300 CONTINUE THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS IF(THP.GE.THPS+PARU(48)) GOTO 270 C...Save good axis. Try new initial axis until a number of tries agree. IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN IAGR=0 SGN=(-1D0)**INT(PYR(0)+0.5D0) DO 310 J=1,3 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP) 310 CONTINUE P(N+NP+ILD,4)=THP P(N+NP+ILD,5)=0D0 ENDIF IAGR=IAGR+1 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260 320 CONTINUE C...Find minor axis and value by orthogonality. SGN=(-1D0)**INT(PYR(0)+0.5D0) P(N+NP+3,1)=-SGN*P(N+NP+2,2) P(N+NP+3,2)=SGN*P(N+NP+2,1) P(N+NP+3,3)=0D0 THP=0D0 DO 330 I=N+1,N+NP THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2)) 330 CONTINUE P(N+NP+3,4)=THP/PS P(N+NP+3,5)=0D0 C...Fill axis information. Rotate back to original coordinate system. DO 350 ILD=1,3 K(N+ILD,1)=31 K(N+ILD,2)=96 K(N+ILD,3)=ILD K(N+ILD,4)=0 K(N+ILD,5)=0 DO 340 J=1,5 P(N+ILD,J)=P(N+NP+ILD,J) V(N+ILD,J)=0D0 340 CONTINUE 350 CONTINUE CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0) C...Calculate thrust and oblateness. Select storing option. THR=P(N+1,4) OBL=P(N+2,4)-P(N+3,4) MSTU(61)=N+1 MSTU(62)=NP IF(MSTU(43).LE.1) MSTU(3)=3 IF(MSTU(43).GE.2) N=N+3 RETURN END C********************************************************************* C...PYCLUS C...Subdivides the particle content of an event into jets/clusters. SUBROUTINE PYCLUS(NJET) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local arrays and saved variables. DIMENSION PS(5) SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM C...Functions: distance measure in pT, (pseudo)mass or Durham pT. R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)- &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)* &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5))) R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+ &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5))) C...If first time, reset. If reentering, skip preliminaries. IF(MSTU(48).LE.0) THEN NP=0 DO 100 J=1,5 PS(J)=0D0 100 CONTINUE PSS=0D0 PIMASS=PMAS(PYCOMP(211),1) ELSE NJET=NSAV IF(MSTU(43).GE.2) N=N-NJET DO 110 I=N+1,N+NJET P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) 110 CONTINUE IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN R2ACC=PARU(44)**2 ELSE R2ACC=PARU(45)*PS(5)**2 ENDIF NLOOP=0 GOTO 300 ENDIF C...Find which particles are to be considered in cluster search. DO 140 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18) GOTO 140 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) & GOTO 140 ENDIF IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS') NJET=-1 RETURN ENDIF C...Take copy of these particles, with space left for jets later on. NP=NP+1 K(N+NP,3)=I DO 120 J=1,5 P(N+NP,J)=P(I,J) 120 CONTINUE IF(MSTU(42).EQ.0) P(N+NP,5)=0D0 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) DO 130 J=1,4 PS(J)=PS(J)+P(N+NP,J) 130 CONTINUE PSS=PSS+P(N+NP,5) 140 CONTINUE DO 160 I=N+1,N+NP K(I+NP,3)=K(I,3) DO 150 J=1,5 P(I+NP,J)=P(I,J) 150 CONTINUE 160 CONTINUE PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2)) C...Very low multiplicities not considered. IF(NP.LT.MSTU(47)) THEN CALL PYERRM(8,'(PYCLUS:) too few particles for analysis') NJET=-1 RETURN ENDIF C...Find precluster configuration. If too few jets, make harder cuts. NLOOP=0 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN R2ACC=PARU(44)**2 ELSE R2ACC=PARU(45)*PS(5)**2 ENDIF RINIT=1.25D0*PARU(43) IF(NP.LE.MSTU(47)+2) RINIT=0D0 170 RINIT=0.8D0*RINIT NPRE=0 NREM=NP DO 180 I=N+NP+1,N+2*NP K(I,4)=0 180 CONTINUE C...Sum up small momentum region. Jet if enough absolute momentum. IF(MSTU(46).LE.2) THEN DO 190 J=1,4 P(N+1,J)=0D0 190 CONTINUE DO 210 I=N+NP+1,N+2*NP IF(P(I,5).GT.2D0*RINIT) GOTO 210 NREM=NREM-1 K(I,4)=1 DO 200 J=1,4 P(N+1,J)=P(N+1,J)+P(I,J) 200 CONTINUE 210 CONTINUE P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2) IF(P(N+1,5).GT.2D0*RINIT) NPRE=1 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170 IF(NREM.EQ.0) GOTO 170 ENDIF C...Find fastest remaining particle. 220 NPRE=NPRE+1 PMAX=0D0 DO 230 I=N+NP+1,N+2*NP IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230 IMAX=I PMAX=P(I,5) 230 CONTINUE DO 240 J=1,5 P(N+NPRE,J)=P(IMAX,J) 240 CONTINUE NREM=NREM-1 K(IMAX,4)=NPRE C...Sum up precluster around it according to pT separation. IF(MSTU(46).LE.2) THEN DO 260 I=N+NP+1,N+2*NP IF(K(I,4).NE.0) GOTO 260 R2=R2T(I,IMAX) IF(R2.GT.RINIT**2) GOTO 260 NREM=NREM-1 K(I,4)=NPRE DO 250 J=1,4 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J) 250 CONTINUE 260 CONTINUE P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2) C...Sum up precluster around it according to mass or C...Durham pT separation. ELSE 270 IMIN=0 R2MIN=RINIT**2 DO 280 I=N+NP+1,N+2*NP IF(K(I,4).NE.0) GOTO 280 IF(MSTU(46).LE.4) THEN R2=R2M(I,N+NPRE) ELSE R2=R2D(I,N+NPRE) ENDIF IF(R2.GE.R2MIN) GOTO 280 IMIN=I R2MIN=R2 280 CONTINUE IF(IMIN.NE.0) THEN DO 290 J=1,4 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J) 290 CONTINUE P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2) NREM=NREM-1 K(IMIN,4)=NPRE GOTO 270 ENDIF ENDIF C...Check if more preclusters to be found. Start over if too few. IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170 IF(NREM.GT.0) GOTO 220 NJET=NPRE C...Reassign all particles to nearest jet. Sum up new jet momenta. 300 TSAV=0D0 PSJT=0D0 310 IF(MSTU(46).LE.1) THEN DO 330 I=N+1,N+NJET DO 320 J=1,4 V(I,J)=0D0 320 CONTINUE 330 CONTINUE DO 360 I=N+NP+1,N+2*NP R2MIN=PSS**2 DO 340 IJET=N+1,N+NJET IF(P(IJET,5).LT.RINIT) GOTO 340 R2=R2T(I,IJET) IF(R2.GE.R2MIN) GOTO 340 IMIN=IJET R2MIN=R2 340 CONTINUE K(I,4)=IMIN-N DO 350 J=1,4 V(IMIN,J)=V(IMIN,J)+P(I,J) 350 CONTINUE 360 CONTINUE PSJT=0D0 DO 380 I=N+1,N+NJET DO 370 J=1,4 P(I,J)=V(I,J) 370 CONTINUE P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) PSJT=PSJT+P(I,5) 380 CONTINUE ENDIF C...Find two closest jets. R2MIN=2D0*MAX(R2ACC,PS(5)**2) DO 400 ITRY1=N+1,N+NJET-1 DO 390 ITRY2=ITRY1+1,N+NJET IF(MSTU(46).LE.2) THEN R2=R2T(ITRY1,ITRY2) ELSEIF(MSTU(46).LE.4) THEN R2=R2M(ITRY1,ITRY2) ELSE R2=R2D(ITRY1,ITRY2) ENDIF IF(R2.GE.R2MIN) GOTO 390 IMIN1=ITRY1 IMIN2=ITRY2 R2MIN=R2 390 CONTINUE 400 CONTINUE C...If allowed, join two closest jets and start over. IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN IREC=MIN(IMIN1,IMIN2) IDEL=MAX(IMIN1,IMIN2) DO 410 J=1,4 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J) 410 CONTINUE P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2) DO 430 I=IDEL+1,N+NJET DO 420 J=1,5 P(I-1,J)=P(I,J) 420 CONTINUE 430 CONTINUE IF(MSTU(46).GE.2) THEN DO 440 I=N+NP+1,N+2*NP IORI=N+K(I,4) IF(IORI.EQ.IDEL) K(I,4)=IREC-N IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1 440 CONTINUE ENDIF NJET=NJET-1 GOTO 300 C...Divide up broad jet if empty cluster in list of final ones. ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN DO 450 I=N+1,N+NJET K(I,5)=0 450 CONTINUE DO 460 I=N+NP+1,N+2*NP K(N+K(I,4),5)=K(N+K(I,4),5)+1 460 CONTINUE IEMP=0 DO 470 I=N+1,N+NJET IF(K(I,5).EQ.0) IEMP=I 470 CONTINUE IF(IEMP.NE.0) THEN NLOOP=NLOOP+1 ISPL=0 R2MAX=0D0 DO 480 I=N+NP+1,N+2*NP IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480 IJET=N+K(I,4) R2=R2T(I,IJET) IF(R2.LE.R2MAX) GOTO 480 ISPL=I R2MAX=R2 480 CONTINUE IF(ISPL.NE.0) THEN IJET=N+K(ISPL,4) DO 490 J=1,4 P(IEMP,J)=P(ISPL,J) P(IJET,J)=P(IJET,J)-P(ISPL,J) 490 CONTINUE P(IEMP,5)=P(ISPL,5) P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2) IF(NLOOP.LE.2) GOTO 300 ENDIF ENDIF ENDIF C...If generalized thrust has not yet converged, continue iteration. IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48)) &THEN TSAV=PSJT/PSS GOTO 310 ENDIF C...Reorder jets according to energy. DO 510 I=N+1,N+NJET DO 500 J=1,5 V(I,J)=P(I,J) 500 CONTINUE 510 CONTINUE DO 540 INEW=N+1,N+NJET PEMAX=0D0 DO 520 ITRY=N+1,N+NJET IF(V(ITRY,4).LE.PEMAX) GOTO 520 IMAX=ITRY PEMAX=V(ITRY,4) 520 CONTINUE K(INEW,1)=31 K(INEW,2)=97 K(INEW,3)=INEW-N K(INEW,4)=0 DO 530 J=1,5 P(INEW,J)=V(IMAX,J) 530 CONTINUE V(IMAX,4)=-1D0 K(IMAX,5)=INEW 540 CONTINUE C...Clean up particle-jet assignments and jet information. DO 550 I=N+NP+1,N+2*NP IORI=K(N+K(I,4),5) K(I,4)=IORI-N IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N K(IORI,4)=K(IORI,4)+1 550 CONTINUE IEMP=0 PSJT=0D0 DO 570 I=N+1,N+NJET K(I,5)=0 PSJT=PSJT+P(I,5) P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0)) DO 560 J=1,5 V(I,J)=0D0 560 CONTINUE IF(K(I,4).EQ.0) IEMP=I 570 CONTINUE C...Select storing option. Output variables. Check for failure. MSTU(61)=N+1 MSTU(62)=NP MSTU(63)=NPRE PARU(61)=PS(5) PARU(62)=PSJT/PSS PARU(63)=SQRT(R2MIN) IF(NJET.LE.1) PARU(63)=0D0 IF(IEMP.NE.0) THEN CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested') NJET=-1 ENDIF IF(MSTU(43).LE.1) MSTU(3)=NJET IF(MSTU(43).GE.2) N=N+NJET NSAV=NJET RETURN END C********************************************************************* C...PYCELL C...Provides a simple way of jet finding in eta-phi-ET coordinates, C...as used for calorimeters at hadron colliders. SUBROUTINE PYCELL(NJET) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) 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...Loop over all particles. Find cell that was hit by given particle. PTLRAT=1D0/SINH(PARU(51))**2 NP=0 NC=N DO 110 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18) GOTO 110 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) & GOTO 110 ENDIF NP=NP+1 PT=SQRT(P(I,1)**2+P(I,2)**2) ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3)) IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0* & (ETA/PARU(51)+1D0)))) PHI=PYANGL(P(I,1),P(I,2)) IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0* & (PHI/PARU(1)+1D0)))) IETPH=MSTU(52)*IETA+IPHI C...Add to cell already hit, or book new cell. DO 100 IC=N+1,NC IF(IETPH.EQ.K(IC,3)) THEN K(IC,4)=K(IC,4)+1 P(IC,5)=P(IC,5)+PT GOTO 110 ENDIF 100 CONTINUE IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS') NJET=-2 RETURN ENDIF NC=NC+1 K(NC,3)=IETPH K(NC,4)=1 K(NC,5)=2 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51)) P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52)) P(NC,5)=PT 110 CONTINUE C...Smear true bin content by calorimeter resolution. IF(MSTU(53).GE.1) THEN DO 130 IC=N+1,NC PEI=P(IC,5) IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1)) 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)* & COS(PARU(2)*PYR(0)) IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120 P(IC,5)=PEF IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1)) 130 CONTINUE ENDIF C...Remove cells below threshold. IF(PARU(58).GT.0D0) THEN NCC=NC NC=N DO 140 IC=N+1,NCC IF(P(IC,5).GT.PARU(58)) THEN NC=NC+1 K(NC,3)=K(IC,3) K(NC,4)=K(IC,4) K(NC,5)=K(IC,5) P(NC,1)=P(IC,1) P(NC,2)=P(IC,2) P(NC,5)=P(IC,5) ENDIF 140 CONTINUE ENDIF C...Find initiator cell: the one with highest pT of not yet used ones. NJ=NC 150 ETMAX=0D0 DO 160 IC=N+1,NC IF(K(IC,5).NE.2) GOTO 160 IF(P(IC,5).LE.ETMAX) GOTO 160 ICMAX=IC ETA=P(IC,1) PHI=P(IC,2) ETMAX=P(IC,5) 160 CONTINUE IF(ETMAX.LT.PARU(52)) GOTO 220 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS') NJET=-2 RETURN ENDIF K(ICMAX,5)=1 NJ=NJ+1 K(NJ,4)=0 K(NJ,5)=1 P(NJ,1)=ETA P(NJ,2)=PHI P(NJ,3)=0D0 P(NJ,4)=0D0 P(NJ,5)=0D0 C...Sum up unused cells within required distance of initiator. DO 170 IC=N+1,NC IF(K(IC,5).EQ.0) GOTO 170 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170 DPHIA=ABS(P(IC,2)-PHI) IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170 PHIC=P(IC,2) IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI) IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170 K(IC,5)=-K(IC,5) K(NJ,4)=K(NJ,4)+K(IC,4) P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1) P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC P(NJ,5)=P(NJ,5)+P(IC,5) 170 CONTINUE C...Reject cluster below minimum ET, else accept. IF(P(NJ,5).LT.PARU(53)) THEN NJ=NJ-1 DO 180 IC=N+1,NC IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5) 180 CONTINUE ELSEIF(MSTU(54).LE.2) THEN P(NJ,3)=P(NJ,3)/P(NJ,5) P(NJ,4)=P(NJ,4)/P(NJ,5) IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2), & P(NJ,4)) DO 190 IC=N+1,NC IF(K(IC,5).LT.0) K(IC,5)=0 190 CONTINUE ELSE DO 200 J=1,4 P(NJ,J)=0D0 200 CONTINUE DO 210 IC=N+1,NC IF(K(IC,5).GE.0) GOTO 210 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2)) P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2)) P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1)) P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1)) K(IC,5)=0 210 CONTINUE ENDIF GOTO 150 C...Arrange clusters in falling ET sequence. 220 DO 250 I=1,NJ-NC ETMAX=0D0 DO 230 IJ=NC+1,NJ IF(K(IJ,5).EQ.0) GOTO 230 IF(P(IJ,5).LT.ETMAX) GOTO 230 IJMAX=IJ ETMAX=P(IJ,5) 230 CONTINUE K(IJMAX,5)=0 K(N+I,1)=31 K(N+I,2)=98 K(N+I,3)=I K(N+I,4)=K(IJMAX,4) K(N+I,5)=0 DO 240 J=1,5 P(N+I,J)=P(IJMAX,J) V(N+I,J)=0D0 240 CONTINUE 250 CONTINUE NJET=NJ-NC C...Convert to massless or massive four-vectors. IF(MSTU(54).EQ.2) THEN DO 260 I=N+1,N+NJET ETA=P(I,3) P(I,1)=P(I,5)*COS(P(I,4)) P(I,2)=P(I,5)*SIN(P(I,4)) P(I,3)=P(I,5)*SINH(ETA) P(I,4)=P(I,5)*COSH(ETA) P(I,5)=0D0 260 CONTINUE ELSEIF(MSTU(54).GE.3) THEN DO 270 I=N+1,N+NJET P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2)) 270 CONTINUE ENDIF C...Information about storage. MSTU(61)=N+1 MSTU(62)=NP MSTU(63)=NC-N IF(MSTU(43).LE.1) MSTU(3)=NJET IF(MSTU(43).GE.2) N=N+NJET RETURN END C********************************************************************* C...PYJMAS C...Determines, approximately, the two jet masses that minimize C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler. SUBROUTINE PYJMAS(PMH,PML) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local arrays. DIMENSION SM(3,3),SAX(3),PS(3,5) C...Reset. NP=0 DO 120 J1=1,3 DO 100 J2=J1,3 SM(J1,J2)=0D0 100 CONTINUE DO 110 J2=1,4 PS(J1,J2)=0D0 110 CONTINUE 120 CONTINUE PSS=0D0 PIMASS=PMAS(PYCOMP(211),1) C...Take copy of particles that are to be considered in mass analysis. DO 170 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18) GOTO 170 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) & GOTO 170 ENDIF IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS') PMH=-2D0 PML=-2D0 RETURN ENDIF NP=NP+1 DO 130 J=1,5 P(N+NP,J)=P(I,J) 130 CONTINUE IF(MSTU(42).EQ.0) P(N+NP,5)=0D0 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) C...Fill information in sphericity tensor and total momentum vector. DO 150 J1=1,3 DO 140 J2=J1,3 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2) 140 CONTINUE 150 CONTINUE PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2) DO 160 J=1,4 PS(3,J)=PS(3,J)+P(N+NP,J) 160 CONTINUE 170 CONTINUE C...Very low multiplicities (0 or 1) not considered. IF(NP.LE.1) THEN CALL PYERRM(8,'(PYJMAS:) too few particles for analysis') PMH=-1D0 PML=-1D0 RETURN ENDIF PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2- &PS(3,3)**2)) C...Find largest eigenvalue to matrix (third degree equation). DO 190 J1=1,3 DO 180 J2=J1,3 SM(J1,J2)=SM(J1,J2)/PSS 180 CONTINUE 190 CONTINUE SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)- &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+ &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+ &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0) SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP) C...Find largest eigenvector by solving equation system. DO 210 J1=1,3 SM(J1,J1)=SM(J1,J1)-SMA DO 200 J2=J1+1,3 SM(J2,J1)=SM(J1,J2) 200 CONTINUE 210 CONTINUE SMAX=0D0 DO 230 J1=1,3 DO 220 J2=1,3 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220 JA=J1 JB=J2 SMAX=ABS(SM(J1,J2)) 220 CONTINUE 230 CONTINUE SMAX=0D0 DO 250 J3=JA+1,JA+2 J1=J3-3*((J3-1)/3) RL=SM(J1,JB)/SM(JA,JB) DO 240 J2=1,3 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2) IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240 JC=J1 SMAX=ABS(SM(J1,J2)) 240 CONTINUE 250 CONTINUE JB1=JB+1-3*(JB/3) JB2=JB+2-3*((JB+1)/3) SAX(JB1)=-SM(JC,JB2) SAX(JB2)=SM(JC,JB1) SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB) C...Divide particles into two initial clusters by hemisphere. DO 270 I=N+1,N+NP PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3) IS=1 IF(PSAX.LT.0D0) IS=2 K(I,3)=IS DO 260 J=1,4 PS(IS,J)=PS(IS,J)+P(I,J) 260 CONTINUE 270 CONTINUE PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+ &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2) C...Reassign one particle at a time; find maximum decrease of m^2 sum. 280 PMD=0D0 IM=0 DO 290 J=1,4 PS(3,J)=PS(1,J)-PS(2,J) 290 CONTINUE DO 300 I=N+1,N+NP PPS=P(I,4)*PS(3,4)-P(I,1)*PS(3,1)-P(I,2)*PS(3,2)-P(I,3)*PS(3,3) IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS) IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS) IF(PMDI.LT.PMD) THEN PMD=PMDI IM=I ENDIF 300 CONTINUE C...Loop back if significant reduction in sum of m^2. IF(PMD.LT.-PARU(48)*PMS) THEN PMS=PMS+PMD IS=K(IM,3) DO 310 J=1,4 PS(IS,J)=PS(IS,J)-P(IM,J) PS(3-IS,J)=PS(3-IS,J)+P(IM,J) 310 CONTINUE K(IM,3)=3-IS GOTO 280 ENDIF C...Final masses and output. MSTU(61)=N+1 MSTU(62)=NP PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)) PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)) PMH=MAX(PS(1,5),PS(2,5)) PML=MIN(PS(1,5),PS(2,5)) RETURN END C********************************************************************* C...PYFOWO C...Calculates the first few Fox-Wolfram moments. SUBROUTINE PYFOWO(H10,H20,H30,H40) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) 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...Copy momenta for particles and calculate H0. NP=0 H0=0D0 HD=0D0 DO 110 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18) GOTO 110 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) & GOTO 110 ENDIF IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS') H10=-1D0 H20=-1D0 H30=-1D0 H40=-1D0 RETURN ENDIF NP=NP+1 DO 100 J=1,3 P(N+NP,J)=P(I,J) 100 CONTINUE P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) H0=H0+P(N+NP,4) HD=HD+P(N+NP,4)**2 110 CONTINUE H0=H0**2 C...Very low multiplicities (0 or 1) not considered. IF(NP.LE.1) THEN CALL PYERRM(8,'(PYFOWO:) too few particles for analysis') H10=-1D0 H20=-1D0 H30=-1D0 H40=-1D0 RETURN ENDIF C...Calculate H1 - H4. H10=0D0 H20=0D0 H30=0D0 H40=0D0 DO 130 I1=N+1,N+NP DO 120 I2=I1+1,N+NP CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/ & (P(I1,4)*P(I2,4)) H10=H10+P(I1,4)*P(I2,4)*CTHE H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0) H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE) H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+ & 0.375D0) 120 CONTINUE 130 CONTINUE C...Calculate H1/H0 - H4/H0. Output. MSTU(61)=N+1 MSTU(62)=NP H10=(HD+2D0*H10)/H0 H20=(HD+2D0*H20)/H0 H30=(HD+2D0*H30)/H0 H40=(HD+2D0*H40)/H0 RETURN END C********************************************************************* C...PYTABU C...Evaluates various properties of an event, with statistics C...accumulated during the course of the run and C...printed at the end. SUBROUTINE PYTABU(MTABU) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) 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(4000,2),BRAT(4000),KFDP(4000,5) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/ C...Local arrays, character variables, saved variables and data. DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4), &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4), &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25), &KFDM(8),KFDC(200,0:8),NPDC(200) SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS, &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA, &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/, &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/, &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/, &NEVDC/0/,NKFDC/0/,NREDC/0/ C...Reset statistics on initial parton state. IF(MTABU.EQ.10) THEN NEVIS=0 NKFIS=0 C...Identify and order flavour content of initial state. ELSEIF(MTABU.EQ.11) THEN NEVIS=NEVIS+1 KFM1=2*IABS(MSTU(161)) IF(MSTU(161).GT.0) KFM1=KFM1-1 KFM2=2*IABS(MSTU(162)) IF(MSTU(162).GT.0) KFM2=KFM2-1 KFMN=MIN(KFM1,KFM2) KFMX=MAX(KFM1,KFM2) DO 100 I=1,NKFIS IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN IKFIS=-I GOTO 110 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND. & KFMX.LT.KFIS(I,2))) THEN IKFIS=I GOTO 110 ENDIF 100 CONTINUE IKFIS=NKFIS+1 110 IF(IKFIS.LT.0) THEN IKFIS=-IKFIS ELSE IF(NKFIS.GE.100) RETURN DO 130 I=NKFIS,IKFIS,-1 KFIS(I+1,1)=KFIS(I,1) KFIS(I+1,2)=KFIS(I,2) DO 120 J=0,10 NPIS(I+1,J)=NPIS(I,J) 120 CONTINUE 130 CONTINUE NKFIS=NKFIS+1 KFIS(IKFIS,1)=KFMN KFIS(IKFIS,2)=KFMX DO 140 J=0,10 NPIS(IKFIS,J)=0 140 CONTINUE ENDIF NPIS(IKFIS,0)=NPIS(IKFIS,0)+1 C...Count number of partons in initial state. NP=0 DO 160 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0) & THEN ELSE IM=I 150 IM=K(IM,3) IF(IM.LE.0.OR.IM.GT.N) THEN NP=NP+1 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN NP=NP+1 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10) & .NE.0) THEN ELSE GOTO 150 ENDIF ENDIF 160 CONTINUE NPCO=MAX(NP,1) IF(NP.GE.6) NPCO=6 IF(NP.GE.8) NPCO=7 IF(NP.GE.11) NPCO=8 IF(NP.GE.16) NPCO=9 IF(NP.GE.26) NPCO=10 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1 MSTU(62)=NP C...Write statistics on initial parton state. ELSEIF(MTABU.EQ.12) THEN FAC=1D0/MAX(1,NEVIS) WRITE(MSTU(11),5000) NEVIS DO 170 I=1,NKFIS KFMN=KFIS(I,1) IF(KFMN.EQ.0) KFMN=KFIS(I,2) KFM1=(KFMN+1)/2 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1 CALL PYNAME(KFM1,CHAU) CHIS(1)=CHAU(1:12) IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?' KFMX=KFIS(I,2) IF(KFIS(I,1).EQ.0) KFMX=0 KFM2=(KFMX+1)/2 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2 CALL PYNAME(KFM2,CHAU) CHIS(2)=CHAU(1:12) IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?' WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0), & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10) 170 CONTINUE C...Copy statistics on initial parton state into /PYJETS/. ELSEIF(MTABU.EQ.13) THEN FAC=1D0/MAX(1,NEVIS) DO 190 I=1,NKFIS KFMN=KFIS(I,1) IF(KFMN.EQ.0) KFMN=KFIS(I,2) KFM1=(KFMN+1)/2 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1 KFMX=KFIS(I,2) IF(KFIS(I,1).EQ.0) KFMX=0 KFM2=(KFMX+1)/2 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2 K(I,1)=32 K(I,2)=99 K(I,3)=KFM1 K(I,4)=KFM2 K(I,5)=NPIS(I,0) DO 180 J=1,5 P(I,J)=FAC*NPIS(I,J) V(I,J)=FAC*NPIS(I,J+5) 180 CONTINUE 190 CONTINUE N=NKFIS DO 200 J=1,5 K(N+1,J)=0 P(N+1,J)=0D0 V(N+1,J)=0D0 200 CONTINUE K(N+1,1)=32 K(N+1,2)=99 K(N+1,5)=NEVIS MSTU(3)=1 C...Reset statistics on number of particles/partons. ELSEIF(MTABU.EQ.20) THEN NEVFS=0 NPRFS=0 NFIFS=0 NCHFS=0 NKFFS=0 C...Identify whether particle/parton is primary or not. ELSEIF(MTABU.EQ.21) THEN NEVFS=NEVFS+1 MSTU(62)=0 DO 260 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260 MSTU(62)=MSTU(62)+1 KC=PYCOMP(K(I,2)) MPRI=0 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN MPRI=1 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN MPRI=1 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN MPRI=1 ELSEIF(KC.EQ.0) THEN ELSEIF(K(K(I,3),1).EQ.13) THEN IM=K(K(I,3),3) IF(IM.LE.0.OR.IM.GT.N) THEN MPRI=1 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN MPRI=1 ENDIF ELSEIF(KCHG(KC,2).EQ.0) THEN KCM=PYCOMP(K(K(I,3),2)) IF(KCM.NE.0) THEN IF(KCHG(KCM,2).NE.0) MPRI=1 ENDIF ENDIF IF(KC.NE.0.AND.MPRI.EQ.1) THEN IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1 ENDIF IF(K(I,1).LE.10) THEN NFIFS=NFIFS+1 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1 ENDIF C...Fill statistics on number of particles/partons in event. KFA=IABS(K(I,2)) KFS=3-ISIGN(1,K(I,2))-MPRI DO 210 IP=1,NKFFS IF(KFA.EQ.KFFS(IP)) THEN IKFFS=-IP GOTO 220 ELSEIF(KFA.LT.KFFS(IP)) THEN IKFFS=IP GOTO 220 ENDIF 210 CONTINUE IKFFS=NKFFS+1 220 IF(IKFFS.LT.0) THEN IKFFS=-IKFFS ELSE IF(NKFFS.GE.400) RETURN DO 240 IP=NKFFS,IKFFS,-1 KFFS(IP+1)=KFFS(IP) DO 230 J=1,4 NPFS(IP+1,J)=NPFS(IP,J) 230 CONTINUE 240 CONTINUE NKFFS=NKFFS+1 KFFS(IKFFS)=KFA DO 250 J=1,4 NPFS(IKFFS,J)=0 250 CONTINUE ENDIF NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1 260 CONTINUE C...Write statistics on particle/parton composition of events. ELSEIF(MTABU.EQ.22) THEN FAC=1D0/MAX(1,NEVFS) WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS DO 270 I=1,NKFFS CALL PYNAME(KFFS(I),CHAU) KC=PYCOMP(KFFS(I)) MDCYF=0 IF(KC.NE.0) MDCYF=MDCY(KC,1) WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4), & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)) 270 CONTINUE C...Copy particle/parton composition information into /PYJETS/. ELSEIF(MTABU.EQ.23) THEN FAC=1D0/MAX(1,NEVFS) DO 290 I=1,NKFFS K(I,1)=32 K(I,2)=99 K(I,3)=KFFS(I) K(I,4)=0 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4) DO 280 J=1,4 P(I,J)=FAC*NPFS(I,J) V(I,J)=0D0 280 CONTINUE P(I,5)=FAC*K(I,5) V(I,5)=0D0 290 CONTINUE N=NKFFS DO 300 J=1,5 K(N+1,J)=0 P(N+1,J)=0D0 V(N+1,J)=0D0 300 CONTINUE K(N+1,1)=32 K(N+1,2)=99 K(N+1,5)=NEVFS P(N+1,1)=FAC*NPRFS P(N+1,2)=FAC*NFIFS P(N+1,3)=FAC*NCHFS MSTU(3)=1 C...Reset factorial moments statistics. ELSEIF(MTABU.EQ.30) THEN NEVFM=0 NMUFM=0 DO 330 IM=1,3 DO 320 IB=1,10 DO 310 IP=1,4 FM1FM(IM,IB,IP)=0D0 FM2FM(IM,IB,IP)=0D0 310 CONTINUE 320 CONTINUE 330 CONTINUE C...Find particles to include, with (pion,pseudo)rapidity and azimuth. ELSEIF(MTABU.EQ.31) THEN NEVFM=NEVFM+1 NLOW=N+MSTU(3) NUPP=NLOW DO 410 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18) GOTO 410 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND. & PYCHGE(K(I,2)).EQ.0) GOTO 410 ENDIF PMR=0D0 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211) IF(MSTU(42).GE.2) PMR=P(I,5) PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2) YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR), & 1D20)),P(I,3)) IF(ABS(YETA).GT.PARU(57)) GOTO 410 PHI=PYANGL(P(I,1),P(I,2)) IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57)) IYETA=MAX(0,MIN(511,IYETA)) IPHI=512D0*(PHI+PARU(1))/PARU(2) IPHI=MAX(0,MIN(511,IPHI)) IYEP=0 DO 340 IB=0,9 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2)) 340 CONTINUE C...Order particles in (pseudo)rapidity and/or azimuth. IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS') RETURN ENDIF NUPP=NUPP+1 IF(NUPP.EQ.NLOW+1) THEN K(NUPP,1)=IYETA K(NUPP,2)=IPHI K(NUPP,3)=IYEP ELSE DO 350 I1=NUPP-1,NLOW+1,-1 IF(IYETA.GE.K(I1,1)) GOTO 360 K(I1+1,1)=K(I1,1) 350 CONTINUE 360 K(I1+1,1)=IYETA DO 370 I1=NUPP-1,NLOW+1,-1 IF(IPHI.GE.K(I1,2)) GOTO 380 K(I1+1,2)=K(I1,2) 370 CONTINUE 380 K(I1+1,2)=IPHI DO 390 I1=NUPP-1,NLOW+1,-1 IF(IYEP.GE.K(I1,3)) GOTO 400 K(I1+1,3)=K(I1,3) 390 CONTINUE 400 K(I1+1,3)=IYEP ENDIF 410 CONTINUE K(NUPP+1,1)=2**10 K(NUPP+1,2)=2**10 K(NUPP+1,3)=4**10 C...Calculate sum of factorial moments in event. DO 480 IM=1,3 DO 430 IB=1,10 DO 420 IP=1,4 FEVFM(IB,IP)=0D0 420 CONTINUE 430 CONTINUE DO 450 IB=1,10 IF(IM.LE.2) IBIN=2**(10-IB) IF(IM.EQ.3) IBIN=4**(10-IB) IAGR=K(NLOW+1,IM)/IBIN NAGR=1 DO 440 I=NLOW+2,NUPP+1 ICUT=K(I,IM)/IBIN IF(ICUT.EQ.IAGR) THEN NAGR=NAGR+1 ELSE IF(NAGR.EQ.1) THEN ELSEIF(NAGR.EQ.2) THEN FEVFM(IB,1)=FEVFM(IB,1)+2D0 ELSEIF(NAGR.EQ.3) THEN FEVFM(IB,1)=FEVFM(IB,1)+6D0 FEVFM(IB,2)=FEVFM(IB,2)+6D0 ELSEIF(NAGR.EQ.4) THEN FEVFM(IB,1)=FEVFM(IB,1)+12D0 FEVFM(IB,2)=FEVFM(IB,2)+24D0 FEVFM(IB,3)=FEVFM(IB,3)+24D0 ELSE FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0) FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0) FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)* & (NAGR-3D0) FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)* & (NAGR-3D0)*(NAGR-4D0) ENDIF IAGR=ICUT NAGR=1 ENDIF 440 CONTINUE 450 CONTINUE C...Add results to total statistics. DO 470 IB=10,1,-1 DO 460 IP=1,4 IF(FEVFM(1,IP).LT.0.5D0) THEN FEVFM(IB,IP)=0D0 ELSEIF(IM.LE.2) THEN FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP) ELSE FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP) ENDIF FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP) FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2 460 CONTINUE 470 CONTINUE 480 CONTINUE NMUFM=NMUFM+(NUPP-NLOW) MSTU(62)=NUPP-NLOW C...Write accumulated statistics on factorial moments. ELSEIF(MTABU.EQ.32) THEN FAC=1D0/MAX(1,NEVFM) IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta' IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi' IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y ' DO 510 IM=1,3 WRITE(MSTU(11),5500) DO 500 IB=1,10 BYETA=2D0*PARU(57) IF(IM.NE.2) BYETA=BYETA/2**(IB-1) BPHI=PARU(2) IF(IM.NE.1) BPHI=BPHI/2**(IB-1) IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1)) IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1)) DO 490 IP=1,4 FMOMA(IP)=FAC*FM1FM(IM,IB,IP) FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)- & FMOMA(IP)**2))) 490 CONTINUE WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP), & IP=1,4) 500 CONTINUE 510 CONTINUE C...Copy statistics on factorial moments into /PYJETS/. ELSEIF(MTABU.EQ.33) THEN FAC=1D0/MAX(1,NEVFM) DO 540 IM=1,3 DO 530 IB=1,10 I=10*(IM-1)+IB K(I,1)=32 K(I,2)=99 K(I,3)=1 IF(IM.NE.2) K(I,3)=2**(IB-1) K(I,4)=1 IF(IM.NE.1) K(I,4)=2**(IB-1) K(I,5)=0 P(I,1)=2D0*PARU(57)/K(I,3) V(I,1)=PARU(2)/K(I,4) DO 520 IP=1,4 P(I,IP+1)=FAC*FM1FM(IM,IB,IP) V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)- & P(I,IP+1)**2))) 520 CONTINUE 530 CONTINUE 540 CONTINUE N=30 DO 550 J=1,5 K(N+1,J)=0 P(N+1,J)=0D0 V(N+1,J)=0D0 550 CONTINUE K(N+1,1)=32 K(N+1,2)=99 K(N+1,5)=NEVFM MSTU(3)=1 C...Reset statistics on Energy-Energy Correlation. ELSEIF(MTABU.EQ.40) THEN NEVEE=0 DO 560 J=1,25 FE1EC(J)=0D0 FE2EC(J)=0D0 FE1EC(51-J)=0D0 FE2EC(51-J)=0D0 FE1EA(J)=0D0 FE2EA(J)=0D0 560 CONTINUE C...Find particles to include, with proper assumed mass. ELSEIF(MTABU.EQ.41) THEN NEVEE=NEVEE+1 NLOW=N+MSTU(3) NUPP=NLOW ECM=0D0 DO 570 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570 IF(MSTU(41).GE.2) THEN KC=PYCOMP(K(I,2)) IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. & KC.EQ.18) GOTO 570 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND. & PYCHGE(K(I,2)).EQ.0) GOTO 570 ENDIF PMR=0D0 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211) IF(MSTU(42).GE.2) PMR=P(I,5) IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS') RETURN ENDIF NUPP=NUPP+1 P(NUPP,1)=P(I,1) P(NUPP,2)=P(I,2) P(NUPP,3)=P(I,3) P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)) ECM=ECM+P(NUPP,4) 570 CONTINUE IF(NUPP.EQ.NLOW) RETURN C...Analyze Energy-Energy Correlation in event. FAC=(2D0/ECM**2)*50D0/PARU(1) DO 580 J=1,50 FEVEE(J)=0D0 580 CONTINUE DO 600 I1=NLOW+2,NUPP DO 590 I2=NLOW+1,I1-1 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/ & (P(I1,5)*P(I2,5)) THE=ACOS(MAX(-1D0,MIN(1D0,CTHE))) ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1)))) FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4) 590 CONTINUE 600 CONTINUE DO 610 J=1,25 FE1EC(J)=FE1EC(J)+FEVEE(J) FE2EC(J)=FE2EC(J)+FEVEE(J)**2 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J) FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J)) FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2 610 CONTINUE MSTU(62)=NUPP-NLOW C...Write statistics on Energy-Energy Correlation. ELSEIF(MTABU.EQ.42) THEN FAC=1D0/MAX(1,NEVEE) WRITE(MSTU(11),5700) NEVEE DO 620 J=1,25 FEEC1=FAC*FE1EC(J) FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2))) FEEC2=FAC*FE1EC(51-J) FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2))) FEECA=FAC*FE1EA(J) FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2))) WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1, & FEEC2,FEES2,FEECA,FEESA 620 CONTINUE C...Copy statistics on Energy-Energy Correlation into /PYJETS/. ELSEIF(MTABU.EQ.43) THEN FAC=1D0/MAX(1,NEVEE) DO 630 I=1,25 K(I,1)=32 K(I,2)=99 K(I,3)=0 K(I,4)=0 K(I,5)=0 P(I,1)=FAC*FE1EC(I) V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2))) P(I,2)=FAC*FE1EC(51-I) V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2))) P(I,3)=FAC*FE1EA(I) V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2))) P(I,4)=PARU(1)*(I-1)/50D0 P(I,5)=PARU(1)*I/50D0 V(I,4)=3.6D0*(I-1) V(I,5)=3.6D0*I 630 CONTINUE N=25 DO 640 J=1,5 K(N+1,J)=0 P(N+1,J)=0D0 V(N+1,J)=0D0 640 CONTINUE K(N+1,1)=32 K(N+1,2)=99 K(N+1,5)=NEVEE MSTU(3)=1 C...Reset statistics on decay channels. ELSEIF(MTABU.EQ.50) THEN NEVDC=0 NKFDC=0 NREDC=0 C...Identify and order flavour content of final state. ELSEIF(MTABU.EQ.51) THEN NEVDC=NEVDC+1 NDS=0 DO 670 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670 NDS=NDS+1 IF(NDS.GT.8) THEN NREDC=NREDC+1 RETURN ENDIF KFM=2*IABS(K(I,2)) IF(K(I,2).LT.0) KFM=KFM-1 DO 650 IDS=NDS-1,1,-1 IIN=IDS+1 IF(KFM.LT.KFDM(IDS)) GOTO 660 KFDM(IDS+1)=KFDM(IDS) 650 CONTINUE IIN=1 660 KFDM(IIN)=KFM 670 CONTINUE C...Find whether old or new final state. DO 690 IDC=1,NKFDC IF(NDS.LT.KFDC(IDC,0)) THEN IKFDC=IDC GOTO 700 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN DO 680 I=1,NDS IF(KFDM(I).LT.KFDC(IDC,I)) THEN IKFDC=IDC GOTO 700 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN GOTO 690 ENDIF 680 CONTINUE IKFDC=-IDC GOTO 700 ENDIF 690 CONTINUE IKFDC=NKFDC+1 700 IF(IKFDC.LT.0) THEN IKFDC=-IKFDC ELSEIF(NKFDC.GE.200) THEN NREDC=NREDC+1 RETURN ELSE DO 720 IDC=NKFDC,IKFDC,-1 NPDC(IDC+1)=NPDC(IDC) DO 710 I=0,8 KFDC(IDC+1,I)=KFDC(IDC,I) 710 CONTINUE 720 CONTINUE NKFDC=NKFDC+1 KFDC(IKFDC,0)=NDS DO 730 I=1,NDS KFDC(IKFDC,I)=KFDM(I) 730 CONTINUE NPDC(IKFDC)=0 ENDIF NPDC(IKFDC)=NPDC(IKFDC)+1 C...Write statistics on decay channels. ELSEIF(MTABU.EQ.52) THEN FAC=1D0/MAX(1,NEVDC) WRITE(MSTU(11),5900) NEVDC DO 750 IDC=1,NKFDC DO 740 I=1,KFDC(IDC,0) KFM=KFDC(IDC,I) KF=(KFM+1)/2 IF(2*KF.NE.KFM) KF=-KF CALL PYNAME(KF,CHAU) CHDC(I)=CHAU(1:12) IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?' 740 CONTINUE WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0)) 750 CONTINUE IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC C...Copy statistics on decay channels into /PYJETS/. ELSEIF(MTABU.EQ.53) THEN FAC=1D0/MAX(1,NEVDC) DO 780 IDC=1,NKFDC K(IDC,1)=32 K(IDC,2)=99 K(IDC,3)=0 K(IDC,4)=0 K(IDC,5)=KFDC(IDC,0) DO 760 J=1,5 P(IDC,J)=0D0 V(IDC,J)=0D0 760 CONTINUE DO 770 I=1,KFDC(IDC,0) KFM=KFDC(IDC,I) KF=(KFM+1)/2 IF(2*KF.NE.KFM) KF=-KF IF(I.LE.5) P(IDC,I)=KF IF(I.GE.6) V(IDC,I-5)=KF 770 CONTINUE V(IDC,5)=FAC*NPDC(IDC) 780 CONTINUE N=NKFDC DO 790 J=1,5 K(N+1,J)=0 P(N+1,J)=0D0 V(N+1,J)=0D0 790 CONTINUE K(N+1,1)=32 K(N+1,2)=99 K(N+1,5)=NEVDC V(N+1,5)=FAC*NREDC MSTU(3)=1 ENDIF C...Format statements for output on unit MSTU(11) (default 6). 5000 FORMAT(///20X,'Event statistics - initial state'/ &20X,'based on an analysis of ',I6,' events'// &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ', &'according to fragmenting system multiplicity'/ &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5', &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/) 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4) 5200 FORMAT(///20X,'Event statistics - final state'/ &20X,'based on an analysis of ',I7,' events'// &5X,'Mean primary multiplicity =',F10.4/ &5X,'Mean final multiplicity =',F10.4/ &5X,'Mean charged multiplicity =',F10.4// &5X,'Number of particles produced per event (directly and via ', &'decays/branchings)'/ &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles', &8X,'Total'/35X,'prim seco prim seco'/) 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6)) 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/ &20X,'based on an analysis of ',I6,' events'// &3X,'delta-',A3,' delta-phi /bin',10X,'',18X,'', &18X,'',18X,''/35X,4(' value error ')) 5500 FORMAT(10X) 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4)) 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/ &20X,'based on an analysis of ',I6,' events'// &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X, &'EECA(theta)'/2X,'in degrees ',3(' value error')/) 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4)) 5900 FORMAT(///20X,'Decay channel analysis - final state'/ &20X,'based on an analysis of ',I6,' events'// &2X,'Probability',10X,'Complete final state'/) 6000 FORMAT(2X,F9.5,5X,8(A12,1X)) 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ', &'or table overflow)') RETURN END C********************************************************************* C...PYEEVT C...Handles the generation of an e+e- annihilation jet event. SUBROUTINE PYEEVT(KFL,ECM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Check input parameters. IF(MSTU(12).GE.1) CALL PYLIST(0) IF(KFL.LT.0.OR.KFL.GT.8) THEN CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code') IF(MSTU(21).GE.1) RETURN ENDIF IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL)) IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1) IF(ECM.LT.ECMMIN) THEN CALL PYERRM(16,'(PYEEVT:) called with too small CM energy') IF(MSTU(21).GE.1) RETURN ENDIF C...Check consistency of MSTJ options set. IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN CALL PYERRM(6, & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1') MSTJ(110)=1 ENDIF IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN CALL PYERRM(6, & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0') MSTJ(111)=0 ENDIF C...Initialize alpha_strong and total cross-section. MSTU(111)=MSTJ(108) IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1)) &MSTU(111)=1 PARU(112)=PARJ(121) IF(MSTU(111).EQ.2) PARU(112)=PARJ(122) IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE. &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM, &XTOT) IF(MSTJ(116).GE.3) MSTJ(116)=1 PARJ(171)=0D0 C...Add initial e+e- to event record (documentation only). NTRY=0 100 NTRY=NTRY+1 IF(NTRY.GT.100) THEN CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop') RETURN ENDIF MSTU(24)=0 NC=0 IF(MSTJ(115).GE.2) THEN NC=NC+2 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0) K(NC-1,1)=21 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0) K(NC,1)=21 ENDIF C...Radiative photon (in initial state). MK=0 ECMC=ECM IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK, &THEK,PHIK,ALPK) IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK)) IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN NC=NC+1 CALL PY1ENT(NC,22,PAK,THEK,PHIK) K(NC,3)=MIN(MSTJ(115)/2,1) ENDIF C...Virtual exchange boson (gamma or Z0). IF(MSTJ(115).GE.3) THEN NC=NC+1 KF=22 IF(MSTJ(102).EQ.2) KF=23 MSTU10=MSTU(10) MSTU(10)=1 P(NC,5)=ECMC CALL PY1ENT(NC,KF,ECMC,0D0,0D0) K(NC,1)=21 K(NC,3)=1 MSTU(10)=MSTU10 ENDIF C...Choice of flavour and jet configuration. CALL PYXKFL(KFL,ECM,ECMC,KFLC) IF(KFLC.EQ.0) GOTO 100 CALL PYXJET(ECMC,NJET,CUT) KFLN=21 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4, &X12,X14) IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3) IF(NJET.EQ.2) MSTJ(120)=1 C...Fill jet configuration and origin. IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC) IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC, &ECMC) IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3) IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN, &-KFLC,ECMC,X1,X2,X4,X12,X14) IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN, &-KFLC,ECMC,X1,X2,X4,X12,X14) IF(MSTU(24).NE.0) GOTO 100 DO 110 IP=NC+1,N K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1) 110 CONTINUE C...Angular orientation according to matrix element. IF(MSTJ(106).EQ.1) THEN CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI) CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0) CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0) ENDIF C...Rotation and boost from radiative photon. IF(MK.EQ.1) THEN DBEK=-PAK/(ECM-PAK) NMIN=NC+1-MSTJ(115)/3 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0) CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK)) CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0) ENDIF C...Generate parton shower. Rearrange along strings and check. IF(MSTJ(101).EQ.5) THEN CALL PYSHOW(N-1,N,ECMC) MSTJ14=MSTJ(14) IF(MSTJ(105).EQ.-1) MSTJ(14)=-1 IF(MSTJ(105).GE.0) MSTU(28)=0 CALL PYPREP(0) MSTJ(14)=MSTJ14 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100 ENDIF C...Fragmentation/decay generation. Information for PYTABU. IF(MSTJ(105).EQ.1) CALL PYEXEC MSTU(161)=KFLC MSTU(162)=-KFLC RETURN END C********************************************************************* C...PYXTEE C...Calculates total cross-section, including initial state C...radiation effects. SUBROUTINE PYXTEE(KFL,ECM,XTOT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C...Status, (optimized) Q^2 scale, alpha_strong. PARJ(151)=ECM MSTJ(119)=10*MSTJ(102)+KFL IF(MSTJ(111).EQ.0) THEN Q2R=ECM**2 ELSEIF(MSTU(111).EQ.0) THEN PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/ & ((33D0-2D0*MSTU(112))*PARU(111))))) Q2R=PARJ(168)*ECM**2 ELSE PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM, & (2D0*PARU(112)/ECM)**2)) Q2R=PARJ(168)*ECM**2 ENDIF ALSPI=PYALPS(Q2R)/PARU(1) C...QCD corrections factor in R. IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN RQCD=1D0 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN RQCD=1D0+ALSPI ELSEIF(MSTJ(109).EQ.0) THEN RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0* & LOG(PARJ(168))*ALSPI**2) ELSEIF(IABS(MSTJ(101)).EQ.1) THEN RQCD=1D0+(3D0/4D0)*ALSPI ELSE RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2 ENDIF C...Calculate Z0 width if default value not acceptable. IF(MSTJ(102).GE.3) THEN RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+ & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2) DO 100 KFLC=5,6 VQ=1D0 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0- & (2D0*PYMASS(KFLC)/ ECM)**2)) IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3) 100 CONTINUE PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)* & (1D0-PARU(102))) ENDIF C...Calculate propagator and related constants for QFD case. POLL=1D0-PARJ(131)*PARJ(132) IF(MSTJ(102).GE.2) THEN SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102))) SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2) SFI=SFW*(1D0-(PARJ(123)/ECM)**2) VE=4D0*PARU(102)-1D0 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131)) SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131))) HF1I=SFI*SF1I HF1W=SFW*SF1W ENDIF C...Loop over different flavours: charge, velocity. RTOT=0D0 RQQ=0D0 RQV=0D0 RVA=0D0 DO 110 KFLC=1,MAX(MSTJ(104),KFL) IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110 MSTJ(93)=1 PMQ=PYMASS(KFLC) IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110 QF=KCHG(KFLC,1)/3D0 VQ=1D0 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2) C...Calculate R and sum of charges for QED or QFD case. RQQ=RQQ+3D0*QF**2*POLL IF(MSTJ(102).LE.1) THEN RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL ELSE VF=SIGN(1D0,QF)-4D0*QF*PARU(102) RQV=RQV-6D0*QF*VF*SF1I RVA=RVA+3D0*(VF**2+1D0)*SF1W RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL- & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W) ENDIF 110 CONTINUE RSUM=RQQ IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA C...Calculate cross-section, including QCD corrections. PARJ(141)=RQQ PARJ(142)=RTOT PARJ(143)=RTOT*RQCD PARJ(144)=PARJ(143) PARJ(145)=PARJ(141)*86.8D0/ECM**2 PARJ(146)=PARJ(142)*86.8D0/ECM**2 PARJ(147)=PARJ(143)*86.8D0/ECM**2 PARJ(148)=PARJ(147) PARJ(157)=RSUM*RQCD PARJ(158)=0D0 PARJ(159)=0D0 XTOT=PARJ(147) IF(MSTJ(107).LE.0) RETURN C...Virtual cross-section. XKL=PARJ(135) XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2) ALE=2D0*LOG(ECM/PYMASS(11))-1D0 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+ &1.526D0*LOG(ECM**2/0.932D0) C...Soft and hard radiative cross-section in QED case. IF(MSTJ(102).LE.1) THEN SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL) SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL)) C...Soft and hard radiative cross-section in QFD case. ELSE SZM=1D0-(PARJ(123)/ECM)**2 SZW=PARJ(123)*PARJ(124)/ECM**2 PARJ(161)=-RQQ/RSUM PARJ(162)=-(RQQ+RQV+RVA)/RSUM PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2- & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM) SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/ & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+ & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+ & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW))) SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/ & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)* & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+ & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW))) ENDIF C...Total cross-section and fraction of hard photon events. PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH) PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD PARJ(144)=PARJ(157) PARJ(148)=PARJ(144)*86.8D0/ECM**2 XTOT=PARJ(148) RETURN END C********************************************************************* C...PYRADK C...Generates initial state photon radiation. SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Function: cumulative hard photon spectrum in QFD case. FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+ &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW) C...Determine whether radiative photon or not. MK=0 PAK=0D0 IF(PARJ(160).LT.PYR(0)) RETURN MK=1 C...Photon energy range. Find photon momentum in QED case. XKL=PARJ(135) XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2) IF(MSTJ(102).LE.1) THEN 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0)) IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100 C...Ditto in QFD case, by numerical inversion of integrated spectrum. ELSE SZM=1D0-(PARJ(123)/ECM)**2 SZW=PARJ(123)*PARJ(124)/ECM**2 FXKL=FXK(XKL) FXKU=FXK(XKU) FXKD=1D-4*(FXKU-FXKL) FXKR=FXKL+PYR(0)*(FXKU-FXKL) NXK=0 110 NXK=NXK+1 XK=0.5D0*(XKL+XKU) FXKV=FXK(XK) IF(FXKV.GT.FXKR) THEN XKU=XK FXKU=FXKV ELSE XKL=XK FXKL=FXKV ENDIF IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL) ENDIF PAK=0.5D0*ECM*XK C...Photon polar and azimuthal angle. PME=2D0*(PYMASS(11)/ECM)**2 120 CTHM=PME*(2D0/PME)**PYR(0) IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME, &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120 CTHE=1D0-CTHM IF(PYR(0).GT.0.5D0) CTHE=-CTHE STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM))) THEK=PYANGL(CTHE,STHE) PHIK=PARU(2)*PYR(0) C...Rotation angle for hadronic system. SGN=1D0 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT. &PYR(0)) SGN=-1D0 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/ &(2D0-XK*(1D0-SGN*CTHE))) RETURN END C********************************************************************* C...PYXKFL C...Selects flavour for produced qqbar pair. SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C...Calculate maximum weight in QED or QFD case. IF(MSTJ(102).LE.1) THEN RFMAX=4D0/9D0 ELSE POLL=1D0-PARJ(131)*PARJ(132) SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102))) SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2) SFI=SFW*(1D0-(PARJ(123)/ECMC)**2) VE=4D0*PARU(102)-1D0 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131)) HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131))) RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+ & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0* & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+ & 1D0)*HF1W) ENDIF C...Choose flavour. Gives charge and velocity. NTRY=0 100 NTRY=NTRY+1 IF(NTRY.GT.100) THEN CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop') KFLC=0 RETURN ENDIF KFLC=KFL IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0)) MSTJ(93)=1 PMQ=PYMASS(KFLC) IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100 QF=KCHG(KFLC,1)/3D0 VQ=1D0 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2)) C...Calculate weight in QED or QFD case. IF(MSTJ(102).LE.1) THEN RF=QF**2 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2 ELSE VF=SIGN(1D0,QF)-4D0*QF*PARU(102) RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+ & VQ**3*HF1W IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV) ENDIF C...Weighting or new event (radiative photon). Cross-section update. IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100 PARJ(158)=PARJ(158)+1D0 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158) PARJ(148)=PARJ(144)*86.8D0/ECM**2 RETURN END C********************************************************************* C...PYXJET C...Selects number of jets in matrix element approach. SUBROUTINE PYXJET(ECM,NJET,CUT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Local array and data. DIMENSION ZHUT(5) DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/ C...Trivial result for two-jets only, including parton shower. IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN CUT=0D0 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R. ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN CF=4D0/3D0 IF(MSTJ(109).EQ.2) CF=1D0 IF(MSTJ(111).EQ.0) THEN Q2=ECM**2 Q2R=ECM**2 ELSEIF(MSTU(111).EQ.0) THEN PARJ(169)=MIN(1D0,PARJ(129)) Q2=PARJ(169)*ECM**2 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/ & ((33D0-2D0*MSTU(112))*PARU(111))))) Q2R=PARJ(168)*ECM**2 ELSE PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2)) Q2=PARJ(169)*ECM**2 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM, & (2D0*PARU(112)/ECM)**2)) Q2R=PARJ(168)*ECM**2 ENDIF C...alpha_strong for R and R itself. ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1) IF(IABS(MSTJ(101)).EQ.1) THEN RQCD=1D0+ALSPI ELSEIF(MSTJ(109).EQ.0) THEN RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+ & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2) ELSE RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2 ENDIF C...alpha_strong for jet rate. Initial value for y cut. ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1) CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2) IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0)) & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0) IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT)) C...Parametrization of first order three-jet cross-section. 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN PARJ(152)=0D0 ELSE PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))* & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)* & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0* & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2)) & PARJ(152)=0D0 ENDIF C...Parametrization of second order three-jet cross-section. IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR. & CUT.GE.0.25D0) THEN PARJ(153)=0D0 ELSEIF(MSTJ(110).LE.1) THEN CT=LOG(1D0/CUT-2D0) PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2- & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD C...Interpolation in second/first order ratio for Zhu parametrization. ELSEIF(MSTJ(110).EQ.2) THEN IZA=0 DO 110 IY=1,5 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY 110 CONTINUE IF(IZA.NE.0) THEN ZHURAT=ZHUT(IZA) ELSE IZ=100D0*CUT ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ)) ENDIF PARJ(153)=ALSPI*PARJ(152)*ZHURAT ENDIF C...Shift in second order three-jet cross-section with optimized Q^2. IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+ & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152) C...Parametrization of second order four-jet cross-section. IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN PARJ(154)=0D0 ELSE CT=LOG(1D0/CUT-5D0) IF(CUT.LE.0.018D0) THEN XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+ & 0.4059D0*CT**2) XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2) IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ ELSE XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+ & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3) XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+ & 0.002093D0*CT**3) IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ ENDIF PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD PARJ(155)=XQQQQ/(XQQGG+XQQQQ) ENDIF C...If negative three-jet rate, change y' optimization parameter. IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND. & PARJ(169).LT.0.99D0) THEN PARJ(169)=MIN(1D0,1.2D0*PARJ(169)) Q2=PARJ(169)*ECM**2 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1) GOTO 100 ENDIF C...If too high cross-section, use harder cuts, or fail. IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND. & PARJ(169).LT.0.99D0) THEN PARJ(169)=MIN(1D0,1.2D0*PARJ(169)) Q2=PARJ(169)*ECM**2 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1) GOTO 100 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN CALL PYERRM(26, & '(PYXJET:) no allowed y cut value for Zhu parametrization') ENDIF CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+ & PARJ(154))**(-1D0/3D0) IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT)) GOTO 100 ENDIF C...Scalar gluon (first order only). ELSE ALSPI=PYALPS(ECM**2)/PARU(1) CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI)) PARJ(152)=0D0 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)* & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0)) PARJ(153)=0D0 PARJ(154)=0D0 ENDIF C...Select number of jets. PARJ(150)=CUT IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN NJET=2 ELSEIF(MSTJ(101).LE.0) THEN NJET=MIN(4,2-MSTJ(101)) ELSE RNJ=PYR(0) NJET=2 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3 IF(PARJ(154).GT.RNJ) NJET=4 ENDIF RETURN END C********************************************************************* C...PYX3JT C...Selects the kinematical variables of three-jet events. SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Local array. DIMENSION ZHUP(5,12) C...Coefficients of Zhu second order parametrization. DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/ &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0, &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0, &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0, &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0, &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0, &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0, &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0, &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0, &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0, &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/ C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick). DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+ &X**7/49D0 C...Event type. Mass effect factors and other common constants. MSTJ(120)=2 MSTJ(121)=0 PMQ=PYMASS(KFL) QME=(2D0*PMQ/ECM)**2 IF(MSTJ(109).NE.1) THEN CUTL=LOG(CUT) CUTD=LOG(1D0/CUT-2D0) IF(MSTJ(109).EQ.0) THEN CF=4D0/3D0 CN=3D0 TR=2D0 WTMX=MIN(20D0,37D0-6D0*CUTD) IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT) ELSE CF=1D0 CN=0D0 TR=12D0 WTMX=0D0 ENDIF C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight. ALS2PI=PARU(118)/PARU(2) WTOPT=0D0 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0* & LOG(PARJ(169))*ALS2PI WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX) C...Choose three-jet events in allowed region. 100 NJET=3 110 Y13L=CUTL+CUTD*PYR(0) Y23L=CUTL+CUTD*PYR(0) Y13=EXP(Y13L) Y23=EXP(Y23L) Y12=1D0-Y13-Y23 IF(Y12.LE.CUT) GOTO 110 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110 C...Second order corrections. IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN Y12L=LOG(Y12) Y13M=LOG(1D0-Y13) Y23M=LOG(1D0-Y23) Y12M=LOG(1D0-Y12) IF(Y13.LE.0.5D0) Y13I=DILOG(Y13) IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13) IF(Y23.LE.0.5D0) Y23I=DILOG(Y23) IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23) IF(Y12.LE.0.5D0) Y12I=DILOG(Y12) IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12) WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23) WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+ & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+ & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2- & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+ & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+ & TR*(2D0*CUTL/3D0-10D0/9D0)+ & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+ & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/ & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+ & Y13*Y23)/(Y12+Y13)**2)/WT1+ & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)* & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L* & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)* & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/ & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))- & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1- & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I) IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2) ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN C...Second order corrections; Zhu parametrization of ERT. ZX=(Y23-Y13)**2 ZY=1D0-Y12 IZA=0 DO 120 IY=1,5 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY 120 CONTINUE IF(IZA.NE.0) THEN IZ=IZA WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+ & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+ & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY ELSE IZ=100D0*CUT WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+ & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+ & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY IZ=IZ+1 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+ & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+ & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ) ENDIF IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2) ENDIF C...Impose mass cuts (gives two jets). For fixed jet number new try. X1=1D0-Y23 X2=1D0-Y13 X3=1D0-Y12 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+ & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+ & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100 C...Scalar gluon model (first order only, no mass effects). ELSE 130 NJET=3 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2)) IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0) X1=1D0-0.5D0*(X3+YD) X2=1D0-0.5D0*(X3-YD) IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2 IF(MSTJ(102).GE.2) THEN IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT. & X3**2*PYR(0)) NJET=2 ENDIF IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130 ENDIF RETURN END C********************************************************************* C...PYX4JT C...Selects the kinematical variables of four-jet events. SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Local arrays. DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4) C...Common constants. Colour factors for QCD and Abelian gluon theory. PMQ=PYMASS(KFL) QME=(2D0*PMQ/ECM)**2 CT=LOG(1D0/CUT-5D0) IF(MSTJ(109).EQ.0) THEN CF=4D0/3D0 CN=3D0 TR=2.5D0 ELSE CF=1D0 CN=0D0 TR=15D0 ENDIF C...Choice of process (qqbargg or qqbarqqbar). 100 NJET=4 IT=1 IF(PARJ(155).GT.PYR(0)) IT=2 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2 IF(IT.EQ.1) WTMX=0.7D0/CUT**2 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2 ID=1 C...Sample the five kinematical variables (for qqgg preweighted in y34). 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0) Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0) IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0)) IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0) IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110 VT=PYR(0) CP=COS(PARU(1)*PYR(0)) Y14=(Y134-Y34)*VT Y13=Y134-Y14-Y34 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34)) Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)* &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB)) Y23=Y234-Y34-Y24 Y12=1D0-Y134-Y23-Y24 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110 Y123=Y12+Y13+Y23 Y124=Y12+Y14+Y24 C...Calculate matrix elements for qqgg or qqqq process. IC=0 WTTOT=0D0 120 IC=IC+1 IF(IT.EQ.1) THEN WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+ & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24- & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12* & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+ & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/ & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24- & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/ & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24) WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12* & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14* & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+ & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24) WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+ & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+ & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24- & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23- & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+ & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+ & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+ & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24- & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+ & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+ & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2- & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34) WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+ & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34- & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+ & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+ & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+ & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/ & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34- & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+ & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24- & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14- & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2- & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34- & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34- & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23- & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14- & Y12*Y13**2)/(4D0*Y34**2*Y134**2) WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+ & CN*WTC(IC))/8D0 ELSE WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12* & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2* & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12* & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14* & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+ & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+ & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24* & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24- & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123) WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13* & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23* & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13* & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+ & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+ & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134* & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14* & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124) WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0 ENDIF C...Permutations of momenta in matrix element. Weighting. 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN YSAV=Y13 Y13=Y14 Y14=YSAV YSAV=Y23 Y23=Y24 Y24=YSAV YSAV=Y123 Y123=Y124 Y124=YSAV ENDIF IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN YSAV=Y13 Y13=Y23 Y23=YSAV YSAV=Y14 Y14=Y24 Y24=YSAV YSAV=Y134 Y134=Y234 Y234=YSAV ENDIF IF(IC.LE.3) GOTO 120 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110 IC=5 C...qqgg events: string configuration and event type. IF(IT.EQ.1) THEN IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+ & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT) IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+ & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2 IF(ID.EQ.2) GOTO 130 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT) IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2 IF(ID.EQ.2) GOTO 130 ENDIF MSTJ(120)=3 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+ & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4 KFLN=21 C...Mass cuts. Kinematical variables out. IF(Y12.LE.CUT+QME) NJET=2 IF(NJET.EQ.2) GOTO 150 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12)) X1=1D0-(1D0-Q12)*Y234-Q12*Y134 X4=1D0-(1D0-Q12)*Y134-Q12*Y234 X2=1D0-Y124 X12=(1D0-Q12)*Y13+Q12*Y23 X14=Y12-0.5D0*QME IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2 C...qqbarqqbar events: string configuration, choose new flavour. ELSE IF(ID.EQ.1) THEN WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4)) IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2 IF(WTR.LT.WTD(3)+WTD(4)) ID=3 IF(WTR.LT.WTD(4)) ID=4 IF(ID.GE.2) GOTO 130 ENDIF MSTJ(120)=5 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT) 140 KFLN=1+INT(5D0*PYR(0)) IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140 IF(KFLN.GT.MSTJ(104)) NJET=2 PMQN=PYMASS(KFLN) QMEN=(2D0*PMQN/ECM)**2 C...Mass cuts. Kinematical variables out. IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2 IF(NJET.EQ.2) GOTO 150 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24)) Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13)) X1=1D0-(1D0-Q24)*Y123-Q24*Y134 X4=1D0-(1D0-Q24)*Y134-Q24*Y123 X2=1D0-(1D0-Q13)*Y234-Q13*Y124 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+ & Q13*Y23) X14=Y24-0.5D0*QME X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+ & Q13*Y14) IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE. & (PARJ(127)+PMQ+PMQN)**2) NJET=2 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2 ENDIF 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100 RETURN END C********************************************************************* C...PYXDIF C...Gives the angular orientation of events. SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Charge. Factors depending on polarization for QED case. QF=KCHG(KFL,1)/3D0 POLL=1D0-PARJ(131)*PARJ(132) POLD=PARJ(132)-PARJ(131) IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN HF1=POLL HF2=0D0 HF3=PARJ(133)**2 HF4=0D0 C...Factors depending on flavour, energy and polarization for QFD case. ELSE SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102))) SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2) SFI=SFW*(1D0-(PARJ(123)/ECM)**2) AE=-1D0 VE=4D0*PARU(102)-1D0 AF=SIGN(1D0,QF) VF=AF-4D0*QF*PARU(102) HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+ & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD) HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2* & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD) HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)* & SFW*SFF**2*(VE**2-AE**2)) HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)* & SFF*AE ENDIF C...Mass factor. Differential cross-sections for two-jet events. SQ2=SQRT(2D0) QME=0D0 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND. &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2 IF(NJET.EQ.2) THEN SIGU=4D0*SQRT(1D0-QME) SIGL=2D0*QME*SQRT(1D0-QME) SIGT=0D0 SIGI=0D0 SIGA=0D0 SIGP=4D0 C...Kinematical variables. Reduce four-jet event to three-jet one. ELSE IF(NJET.EQ.3) THEN X1=2D0*P(NC+1,4)/ECM X2=2D0*P(NC+3,4)/ECM ELSE ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+ & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2) X1=2D0*P(NC+1,4)/ECMR X2=2D0*P(NC+4,4)/ECMR ENDIF C...Differential cross-sections for three-jet (or reduced four-jet). XQ=(1D0-X1)/(1D0-X2) CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME)) ST12=SQRT(1D0-CT12**2) IF(MSTJ(109).NE.1) THEN SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)- & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+ & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2- & X2)*XQ SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+ & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2 SIGA=X2**2*ST12/SQ2 SIGP=2D0*(X1**2-X2**2*CT12) C...Differential cross-sect for scalar gluons (no mass effects). ELSE X3=2D0-X1-X2 XT=X2*ST12 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2)) SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+ & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1) SIGL=(1D0-PARJ(171))*0.5D0*XT**2+ & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+ & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1) SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+ & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2))) SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3) SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1 ENDIF ENDIF C...Upper bounds for differential cross-section. HF1A=ABS(HF1) HF2A=ABS(HF2) HF3A=ABS(HF3) HF4A=ABS(HF4) SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)* &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2* &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+ &2D0*HF2A*ABS(SIGP) C...Generate angular orientation according to differential cross-sect. 100 CHI=PARU(2)*PYR(0) CTHE=2D0*PYR(0)-1D0 PHI=PARU(2)*PYR(0) CCHI=COS(CHI) SCHI=SIN(CHI) C2CHI=COS(2D0*CHI) S2CHI=SIN(2D0*CHI) THE=ACOS(CTHE) STHE=SIN(THE) C2PHI=COS(2D0*(PHI-PARJ(134))) S2PHI=SIN(2D0*(PHI-PARJ(134))) SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+ &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+ &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI* &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)* &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI- &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+ &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100 RETURN END C********************************************************************* C...PYONIA C...Generates Upsilon and toponium decays into three gluons C...or two gluons and a photon. SUBROUTINE PYONIA(KFL,ECM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Printout. Check input parameters. IF(MSTU(12).GE.1) CALL PYLIST(0) IF(KFL.LT.0.OR.KFL.GT.8) THEN CALL PYERRM(16,'(PYONIA:) called with unknown flavour code') IF(MSTU(21).GE.1) RETURN ENDIF IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN CALL PYERRM(16,'(PYONIA:) called with too small CM energy') IF(MSTU(21).GE.1) RETURN ENDIF C...Initial e+e- and onium state (optional). NC=0 IF(MSTJ(115).GE.2) THEN NC=NC+2 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0) K(NC-1,1)=21 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0) K(NC,1)=21 ENDIF KFLC=IABS(KFL) IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN NC=NC+1 KF=110*KFLC+3 MSTU10=MSTU(10) MSTU(10)=1 P(NC,5)=ECM CALL PY1ENT(NC,KF,ECM,0D0,0D0) K(NC,1)=21 K(NC,3)=1 MSTU(10)=MSTU10 ENDIF C...Choose x1 and x2 according to matrix element. NTRY=0 100 X1=PYR(0) X2=PYR(0) X3=2D0-X1-X2 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+ &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100 NTRY=NTRY+1 NJET=3 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3) IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3) C...Photon-gluon-gluon events. Small system modifications. Jet origin. MSTU(111)=MSTJ(108) IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1)) &MSTU(111)=1 PARU(112)=PARJ(121) IF(MSTU(111).EQ.2) PARU(112)=PARJ(122) QF=0D0 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2) MK=0 ECMC=ECM IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125))) & NJET=2 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM) IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM) ELSE MK=1 ECMC=SQRT(1D0-X1)*ECM IF(ECMC.LT.2D0*PARJ(127)) GOTO 100 K(NC+1,1)=1 K(NC+1,2)=22 K(NC+1,4)=0 K(NC+1,5)=0 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3) IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3) IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2) IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2) NJET=2 IF(ECMC.LT.4D0*PARJ(127)) THEN MSTU10=MSTU(10) MSTU(10)=1 P(NC+2,5)=ECMC CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0) MSTU(10)=MSTU10 NJET=0 ENDIF ENDIF DO 110 IP=NC+1,N K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1) 110 CONTINUE C...Differential cross-sections. Upper limit for cross-section. IF(MSTJ(106).EQ.1) THEN SQ2=SQRT(2D0) HF1=1D0-PARJ(131)*PARJ(132) HF3=PARJ(133)**2 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3) ST13=SQRT(1D0-CT13**2) SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL SIGT=0.5D0*SIGL SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+ & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI) C...Angular orientation of event. 120 CHI=PARU(2)*PYR(0) CTHE=2D0*PYR(0)-1D0 PHI=PARU(2)*PYR(0) CCHI=COS(CHI) SCHI=SIN(CHI) C2CHI=COS(2D0*CHI) S2CHI=SIN(2D0*CHI) THE=ACOS(CTHE) STHE=SIN(THE) C2PHI=COS(2D0*(PHI-PARJ(134))) S2PHI=SIN(2D0*(PHI-PARJ(134))) SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1- & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)* & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT- & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE* & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0) CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0) ENDIF C...Generate parton shower. Rearrange along strings and check. IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN CALL PYSHOW(NC+MK+1,-NJET,ECMC) MSTJ14=MSTJ(14) IF(MSTJ(105).EQ.-1) MSTJ(14)=-1 IF(MSTJ(105).GE.0) MSTU(28)=0 CALL PYPREP(0) MSTJ(14)=MSTJ14 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100 ENDIF C...Generate fragmentation. Information for PYTABU: IF(MSTJ(105).EQ.1) CALL PYEXEC MSTU(161)=110*KFLC+3 MSTU(162)=0 RETURN END C********************************************************************* C...PYBOOK C...Books a histogram. SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU) C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) C...Commonblock. COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYBINS/ C...Local character variables. CHARACTER TITLE*(*), TITFX*60 C...Check that input is sensible. Find initial address in memory. IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28, &'(PYBOOK:) not allowed histogram number') IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28, &'(PYBOOK:) not allowed number of bins') IF(XL.GE.XU) CALL PYERRM(28, &'(PYBOOK:) x limits in wrong order') INDX(ID)=IHIST(4) IHIST(4)=IHIST(4)+28+NX IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28, &'(PYBOOK:) out of histogram space') IS=INDX(ID) C...Store histogram size and reset contents. BIN(IS+1)=NX BIN(IS+2)=XL BIN(IS+3)=XU BIN(IS+4)=(XU-XL)/NX CALL PYNULL(ID) C...Store title by conversion to integer to double precision. TITFX=TITLE//' ' DO 100 IT=1,20 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+ & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT)) 100 CONTINUE RETURN END C********************************************************************* C...PYFILL C...Fills entry in histogram. SUBROUTINE PYFILL(ID,X,W) C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) C...Commonblock. COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYBINS/ C...Find initial address in memory. Increase number of entries. IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28, &'(PYFILL:) not allowed histogram number') IS=INDX(ID) IF(IS.EQ.0) CALL PYERRM(28, &'(PYFILL:) filling unbooked histogram') BIN(IS+5)=BIN(IS+5)+1D0 C...Find bin in x, including under/overflow, and fill. IF(X.LT.BIN(IS+2)) THEN BIN(IS+6)=BIN(IS+6)+W ELSEIF(X.GE.BIN(IS+3)) THEN BIN(IS+8)=BIN(IS+8)+W ELSE BIN(IS+7)=BIN(IS+7)+W IX=(X-BIN(IS+2))/BIN(IS+4) IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX)) BIN(IS+9+IX)=BIN(IS+9+IX)+W ENDIF RETURN END C********************************************************************* C...PYFACT C...Multiplies histogram contents by factor. SUBROUTINE PYFACT(ID,F) C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) C...Commonblock. COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYBINS/ C...Find initial address in memory. Multiply all contents bins. IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28, &'(PYFACT:) not allowed histogram number') IS=INDX(ID) IF(IS.EQ.0) CALL PYERRM(28, &'(PYFACT:) scaling unbooked histogram') DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1)) BIN(IX)=F*BIN(IX) 100 CONTINUE RETURN END C********************************************************************* C...PYOPER C...Performs operations between histograms. SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2) C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) C...Commonblock. COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYBINS/ C...Character variable. CHARACTER OPER*(*) C...Find initial addresses in memory, and histogram size. IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28, &'(PYFACT:) not allowed histogram number') IS1=INDX(ID1) IS2=INDX(MIN(IHIST(1),MAX(1,ID2))) IS3=INDX(MIN(IHIST(1),MAX(1,ID3))) NX=NINT(BIN(IS3+1)) IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1)) C...Update info on number of histogram entries. IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5) ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN BIN(IS3+5)=BIN(IS1+5) ENDIF C...Operations on pair of histograms: addition, subtraction, C...multiplication, division. IF(OPER.EQ.'+') THEN DO 100 IX=6,8+NX BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX) 100 CONTINUE ELSEIF(OPER.EQ.'-') THEN DO 110 IX=6,8+NX BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX) 110 CONTINUE ELSEIF(OPER.EQ.'*') THEN DO 120 IX=6,8+NX BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX) 120 CONTINUE ELSEIF(OPER.EQ.'/') THEN DO 130 IX=6,8+NX FA2=F2*BIN(IS2+IX) IF(ABS(FA2).LE.1D-20) THEN BIN(IS3+IX)=0D0 ELSE BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2 ENDIF 130 CONTINUE C...Operations on single histogram: multiplication+addition, C...square root+addition, logarithm+addition. ELSEIF(OPER.EQ.'A') THEN DO 140 IX=6,8+NX BIN(IS3+IX)=F1*BIN(IS1+IX)+F2 140 CONTINUE ELSEIF(OPER.EQ.'S') THEN DO 150 IX=6,8+NX BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2 150 CONTINUE ELSEIF(OPER.EQ.'L') THEN ZMIN=1D20 DO 160 IX=9,8+NX IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20) & ZMIN=0.8D0*BIN(IS1+IX) 160 CONTINUE DO 170 IX=6,8+NX BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2 170 CONTINUE C...Operation on two or three histograms: average and C...standard deviation. ELSEIF(OPER.EQ.'M') THEN DO 180 IX=6,8+NX IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN BIN(IS2+IX)=0D0 ELSE BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX) ENDIF IF(ID3.NE.0) THEN IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN BIN(IS3+IX)=0D0 ELSE BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)- & BIN(IS2+IX)**2)) ENDIF ENDIF BIN(IS1+IX)=F1*BIN(IS1+IX) 180 CONTINUE ENDIF RETURN END C********************************************************************* C...PYHIST C...Prints and resets all histograms. SUBROUTINE PYHIST C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) C...Commonblock. COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYBINS/ C...Loop over histograms, print and reset used ones. DO 100 ID=1,IHIST(1) IS=INDX(ID) IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN CALL PYPLOT(ID) CALL PYNULL(ID) ENDIF 100 CONTINUE RETURN END C********************************************************************* C...PYPLOT C...Prints a histogram (but does not reset it). SUBROUTINE PYPLOT(ID) C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYDAT1/,/PYBINS/ C...Local arrays and character variables. DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10) CHARACTER TITLE*60, OUT*100, CHA(0:11)*1 C...Steps in histogram scale. Character sequence. DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/ DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/ C...Find initial address in memory; skip if empty histogram. IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN IS=INDX(ID) IF(IS.EQ.0) RETURN IF(NINT(BIN(IS+5)).LE.0) THEN WRITE(MSTU(11),5000) ID RETURN ENDIF C...Number of histogram lines and x bins. LIN=IHIST(3)-18 NX=NINT(BIN(IS+1)) C...Extract title by conversion from double precision via integer. DO 100 IT=1,20 IEQ=NINT(BIN(IS+8+NX+IT)) TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256) & //CHAR(MOD(IEQ,256)) 100 CONTINUE C...Find time; print title. CALL PYTIME(IDATI) IF(IDATI(1).GT.0) THEN WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5) ELSE WRITE(MSTU(11),5200) ID, TITLE ENDIF C...Find minimum and maximum bin content. YMIN=BIN(IS+9) YMAX=BIN(IS+9) DO 110 IX=IS+10,IS+8+NX IF(BIN(IX).LT.YMIN) YMIN=BIN(IX) IF(BIN(IX).GT.YMAX) YMAX=BIN(IX) 110 CONTINUE C...Determine scale and step size for y axis. IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1 DELY=DYAC(1) DO 120 IDEL=1,9 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1) 120 CONTINUE DY=DELY*10D0**IPOT C...Convert bin contents to integer form; fractional fill in top row. DO 130 IX=1,NX CTA=ABS(BIN(IS+8+IX))/DY IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX)) IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0))) 130 CONTINUE IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN) IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX) C...Print histogram row by row. DO 150 IR=IRMA,IRMI,-1 IF(IR.EQ.0) GOTO 150 OUT=' ' DO 140 IX=1,NX IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX)) IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10) 140 CONTINUE WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT 150 CONTINUE C...Print sign and value of bin contents. IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10 OUT=' ' DO 160 IX=1,NX IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11) IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX))) 160 CONTINUE WRITE(MSTU(11),5400) OUT DO 180 IR=4,1,-1 DO 170 IX=1,NX OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1)) 170 CONTINUE WRITE(MSTU(11),5500) IPOT+IR-4, OUT 180 CONTINUE C...Print sign and value of lower bin edge. IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+ & 10.0001D0)-10 OUT=' ' DO 190 IX=1,NX IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3)) & OUT(IX:IX)=CHA(11) IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4))) 190 CONTINUE WRITE(MSTU(11),5600) OUT DO 210 IR=3,1,-1 DO 200 IX=1,NX OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1)) 200 CONTINUE WRITE(MSTU(11),5500) IPOT+IR-3, OUT 210 CONTINUE ENDIF C...Calculate and print statistics. CSUM=0D0 CXSUM=0D0 CXXSUM=0D0 DO 220 IX=1,NX CTA=ABS(BIN(IS+8+IX)) X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4) CSUM=CSUM+CTA CXSUM=CXSUM+CTA*X CXXSUM=CXXSUM+CTA*X**2 220 CONTINUE XMEAN=CXSUM/MAX(CSUM,1D-20) XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2)) WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6), &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3) C...Formats for output. 5000 FORMAT(/5X,'Histogram no',I5,' : no entries') 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X, &I2,':',I2/) 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/) 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100) 5400 FORMAT(/8X,'Contents',3X,A100) 5500 FORMAT(9X,'*10**',I2,3X,A100) 5600 FORMAT(/8X,'Low edge',3X,A100) 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow =' &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X, &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4) RETURN END C********************************************************************* C...PYNULL C...Resets bin contents of a histogram. SUBROUTINE PYNULL(ID) C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) C...Commonblock. COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYBINS/ IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN IS=INDX(ID) IF(IS.EQ.0) RETURN DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1)) BIN(IX)=0D0 100 CONTINUE RETURN END C********************************************************************* C...PYDUMP C...Dumps histogram contents on file for reading by other program. C...Can also read back own dump. SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI) C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) C...Commonblock. COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYBINS/ C...Local arrays and character variables. DIMENSION IHI(*),ISS(100),VAL(5) CHARACTER TITLE*60,FORMAT*13 C...Dump all histograms that have been booked, C...including titles and ranges, one after the other. IF(MDUMP.EQ.1) THEN C...Loop over histograms and find which are wanted and booked. IF(NHI.LE.0) THEN NW=IHIST(1) ELSE NW=NHI ENDIF DO 130 IW=1,NW IF(NHI.EQ.0) THEN ID=IW ELSE ID=IHI(IW) ENDIF IS=INDX(ID) IF(IS.NE.0) THEN C...Write title, histogram size, filling statistics. NX=NINT(BIN(IS+1)) DO 100 IT=1,20 IEQ=NINT(BIN(IS+8+NX+IT)) TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)// & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256)) 100 CONTINUE WRITE(LFN,5100) ID,TITLE WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3) WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7), & BIN(IS+8) C...Write histogram contents, in groups of five. DO 120 IXG=1,(NX+4)/5 DO 110 IXV=1,5 IX=5*IXG+IXV-5 IF(IX.LE.NX) THEN VAL(IXV)=BIN(IS+8+IX) ELSE VAL(IXV)=0D0 ENDIF 110 CONTINUE WRITE(LFN,5400) (VAL(IXV),IXV=1,5) 120 CONTINUE C...Go to next histogram; finish. ELSEIF(NHI.GT.0) THEN CALL PYERRM(8,'(PYDUMP:) unknown histogram number') ENDIF 130 CONTINUE C...Read back in histograms dumped MDUMP=1. ELSEIF(MDUMP.EQ.2) THEN C...Read histogram number, title and range, and book. 140 READ(LFN,5100,END=170) ID,TITLE READ(LFN,5200) NX,XL,XU CALL PYBOOK(ID,TITLE,NX,XL,XU) IS=INDX(ID) C...Read filling statistics. READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8) BIN(IS+5)=DBLE(NENTRY) C...Read histogram contents, in groups of five. DO 160 IXG=1,(NX+4)/5 READ(LFN,5400) (VAL(IXV),IXV=1,5) DO 150 IXV=1,5 IX=5*IXG+IXV-5 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV) 150 CONTINUE 160 CONTINUE C...Go to next histogram; finish. GOTO 140 170 CONTINUE C...Write histogram contents in column format, C...convenient e.g. for GNUPLOT input. ELSEIF(MDUMP.EQ.3) THEN C...Find addresses to wanted histograms. NSS=0 IF(NHI.LE.0) THEN NW=IHIST(1) ELSE NW=NHI ENDIF DO 180 IW=1,NW IF(NHI.EQ.0) THEN ID=IW ELSE ID=IHI(IW) ENDIF IS=INDX(ID) IF(IS.NE.0.AND.NSS.LT.100) THEN NSS=NSS+1 ISS(NSS)=IS ELSEIF(NSS.GE.100) THEN CALL PYERRM(8,'(PYDUMP:) too many histograms requested') ELSEIF(NHI.GT.0) THEN CALL PYERRM(8,'(PYDUMP:) unknown histogram number') ENDIF 180 CONTINUE C...Check that they have common number of x bins. Fix format. NX=NINT(BIN(ISS(1)+1)) DO 190 IW=2,NSS IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN CALL PYERRM(8,'(PYDUMP:) different number of bins') RETURN ENDIF 190 CONTINUE FORMAT='(1P,000E12.4)' WRITE(FORMAT(5:7),'(I3)') NSS+1 C...Write histogram contents; first column x values. DO 200 IX=1,NX X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4) WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS) 200 CONTINUE ENDIF C...Formats for output. 5100 FORMAT(I5,5X,A60) 5200 FORMAT(I5,1P,2D12.4) 5300 FORMAT(I12,1P,3D12.4) 5400 FORMAT(1P,5D12.4) RETURN END C********************************************************************* C...PYKCUT C...Dummy routine, which the user can replace in order to make cuts on C...the kinematics on the parton level before the matrix elements are C...evaluated and the event is generated. The cross-section estimates C...will automatically take these cuts into account, so the given C...values are for the allowed phase space region only. MCUT=0 means C...that the event has passed the cuts, MCUT=1 that it has failed. SUBROUTINE PYKCUT(MCUT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYDAT1/,/PYINT1/,/PYINT2/ C...Set default value (accepting event) for MCUT. MCUT=0 C...Read out subprocess number. ISUB=MINT(1) ISTSB=ISET(ISUB) C...Read out tau, y*, cos(theta), tau' (where defined, else =0). TAU=VINT(21) YST=VINT(22) CTH=0D0 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23) TAUP=0D0 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26) C...Calculate x_1, x_2, x_F. IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN X1=SQRT(TAU)*EXP(YST) X2=SQRT(TAU)*EXP(-YST) ELSE X1=SQRT(TAUP)*EXP(YST) X2=SQRT(TAUP)*EXP(-YST) ENDIF XF=X1-X2 C...Calculate shat, that, uhat, p_T^2. SHAT=TAU*VINT(2) SQM3=VINT(63) SQM4=VINT(64) RM3=SQM3/SHAT RM4=SQM4/SHAT BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) RPTS=4D0*VINT(71)**2/SHAT BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS)) RM34=2D0*RM3*RM4 RSQM=1D0+RM34 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L) THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH) UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH) PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2)) C...Decisions by user to be put here. C...Stop program if this routine is ever called. C...You should not copy these lines to your own routine. WRITE(MSTU(11),5000) IF(PYR(0).LT.10D0) STOP C...Format for error printout. 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ', &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/ &1X,'Execution stopped!') RETURN END C********************************************************************* C...PYEVWT C...Dummy routine, which the user can replace in order to multiply the C...standard PYTHIA differential cross-section by a process- and C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds C...to generation of weighted events, with weight 1/WTXS, while for C...MSTP(142)=2 it corresponds to a modification of the underlying C...physics. SUBROUTINE PYEVWT(WTXS) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYDAT1/,/PYINT1/,/PYINT2/ C...Set default weight for WTXS. WTXS=1D0 C...Read out subprocess number. ISUB=MINT(1) ISTSB=ISET(ISUB) C...Read out tau, y*, cos(theta), tau' (where defined, else =0). TAU=VINT(21) YST=VINT(22) CTH=0D0 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23) TAUP=0D0 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26) C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2. X1=VINT(41) X2=VINT(42) XF=X1-X2 SHAT=VINT(44) THAT=VINT(45) UHAT=VINT(46) PT2=VINT(48) C...Modifications by user to be put here. C...Stop program if this routine is ever called. C...You should not copy these lines to your own routine. WRITE(MSTU(11),5000) IF(PYR(0).LT.10D0) STOP C...Format for error printout. 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ', &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/ &1X,'Execution stopped!') RETURN END C********************************************************************* C...PYUPIN C...Dummy copy of routine to be called by user to set up a user-defined C...process. SUBROUTINE PYUPIN(ISUB,TITLE,SIGMAX) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT6/PROC(0:500) CHARACTER PROC*28 SAVE /PYDAT1/,/PYINT2/,/PYINT6/ C...Local character variable. CHARACTER*(*) TITLE C...Check that subprocess number free. IF(ISUB.LT.1.OR.ISUB.GT.500.OR.ISET(ISUB).GE.0) THEN WRITE(MSTU(11),5000) ISUB STOP ENDIF C...Fill information on new process. ISET(ISUB)=11 COEF(ISUB,1)=SIGMAX PROC(ISUB)=TITLE//' ' C...Format for error output. 5000 FORMAT(1X,'Error: user-defined subprocess code ',I4, &' not allowed.'//1X,'Execution stopped!') RETURN END C********************************************************************* C...PYUPEV C...Dummy routine, to be replaced by user. When called from PYTHIA C...the subprocess number ISUB will be given, and PYUPEV is supposed C...to generate an event of this type, to be stored in the PYUPPR C...commonblock. SIGEV gives the differential cross-section associated C...with the event, i.e. the acceptance probability of the event is C...taken to be SIGEV/SIGMAX, where SIGMAX was given in the PYUPIN C...call. SUBROUTINE PYUPEV(ISUB,SIGEV) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYUPPR/NUP,KUP(20,7),NFUP,IFUP(10,2),PUP(20,5),Q2UP(0:10) SAVE /PYDAT1/,/PYUPPR/ C...Stop program if this routine is ever called. C...You should not copy these lines to your own routine. WRITE(MSTU(11),5000) IF(PYR(0).LT.10D0) STOP SIGEV=ISUB C...Format for error printout. 5000 FORMAT(1X,'Error: you did not link your PYUPEV routine ', &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/ &1X,'Execution stopped!') RETURN END C********************************************************************* C...PDFSET C...Dummy routine, to be removed when PDFLIB is to be linked. SUBROUTINE PDFSET(PARM,VALUE) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Local arrays and character variables. CHARACTER*20 PARM(20) DOUBLE PRECISION VALUE(20) C...Stop program if this routine is ever called. WRITE(MSTU(11),5000) IF(PYR(0).LT.10D0) STOP PARM(20)=PARM(1) VALUE(20)=VALUE(1) C...Format for error printout. 5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/ &1X,'Dummy routine PDFSET in PYTHIA file called instead.'/ &1X,'Execution stopped!') RETURN END C********************************************************************* C...STRUCTM C...Dummy routine, to be removed when PDFLIB is to be linked. SUBROUTINE STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Local variables DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU C...Stop program if this routine is ever called. WRITE(MSTU(11),5000) IF(PYR(0).LT.10D0) STOP UPV=XX+QQ DNV=XX+2D0*QQ USEA=XX+3D0*QQ DSEA=XX+4D0*QQ STR=XX+5D0*QQ CHM=XX+6D0*QQ BOT=XX+7D0*QQ TOP=XX+8D0*QQ GLU=XX+9D0*QQ C...Format for error printout. 5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/ &1X,'Dummy routine STRUCTM in PYTHIA file called instead.'/ &1X,'Execution stopped!') RETURN END C********************************************************************* C...PYTAUD C...Dummy routine, to be replaced by user, to handle the decay of a C...polarized tau lepton. C...Input: C...ITAU is the position where the decaying tau is stored in /PYJETS/. C...IORIG is the position where the mother of the tau is stored; C... is 0 when the mother is not stored. C...KFORIG is the flavour of the mother of the tau; C... is 0 when the mother is not known. C...Note that IORIG=0 does not necessarily imply KFORIG=0; C... e.g. in B hadron semileptonic decays the W propagator C... is not explicitly stored but the W code is still unambiguous. C...Output: C...NDECAY is the number of decay products in the current tau decay. C...These decay products should be added to the /PYJETS/ common block, C...in positions N+1 through N+NDECAY. For each product I you must C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2), C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically. SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYJETS/,/PYDAT1/ C...Stop program if this routine is ever called. C...You should not copy these lines to your own routine. NDECAY=ITAU+IORIG+KFORIG WRITE(MSTU(11),5000) IF(PYR(0).LT.10D0) STOP C...Format for error printout. 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ', &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/ &1X,'Execution stopped!') RETURN END C********************************************************************* C...PYTIME C...Finds current date and time. C...Since this task is not standardized in Fortran 77, the routine C...is dummy, to be replaced by the user. Examples are given for C...the Fortran 90 routine and DEC Fortran 77, and what to do if C...you do not have access to suitable routines. SUBROUTINE PYTIME(IDATI) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP CHARACTER*8 ATIME C...Local array. INTEGER IDATI(6),IDTEMP(3) C...Example 0: if you do not have suitable routines. DO 100 J=1,6 IDATI(J)=0 100 CONTINUE C...Example 1: Fortran 90 routine. C INTEGER IVAL(8) C CALL DATE_AND_TIME(VALUES=IVAL) C IDATI(1)=IVAL(1) C IDATI(2)=IVAL(2) C IDATI(3)=IVAL(3) C IDATI(4)=IVAL(5) C IDATI(5)=IVAL(6) C IDATI(6)=IVAL(7) C...Example 2: DEC Fortran 77. C CALL IDATE(IMON,IDAY,IYEAR) C IDATI(1)=1900+IYEAR C IDATI(2)=IMON C IDATI(3)=IDAY C CALL ITIME(IHOUR,IMIN,ISEC) C IDATI(4)=IHOUR C IDATI(5)=IMIN C IDATI(6)=ISEC C...Example 3: DEC Fortran C CALL IDATE(IMON,IDAY,IYEAR) C IDATI(1)=1900+IYEAR C IDATI(2)=IMON C IDATI(3)=IDAY C CALL TIME(ATIME) C IHOUR=0 C IMIN=0 C ISEC=0 C READ(ATIME(1:2),'(I2)') IHOUR C READ(ATIME(4:5),'(I2)') IMIN C READ(ATIME(7:8),'(I2)') ISEC C IDATI(4)=IHOUR C IDATI(5)=IMIN C IDATI(6)=ISEC C...Example 4: GNU LINUX libU77. C CALL IDATE(IDTEMP) C IDATI(1)=IDTEMP(3) C IDATI(2)=IDTEMP(2) C IDATI(3)=IDTEMP(1) C CALL ITIME(IDTEMP) C IDATI(4)=IDTEMP(1) C IDATI(5)=IDTEMP(2) C IDATI(6)=IDTEMP(3) RETURN END