C********************************************************************* C********************************************************************* C* ** C* August 2001 ** C* ** C* The Lund Monte Carlo ** C* ** C* PYTHIA version 6.2 ** C* ** C* Torbjorn Sjostrand ** C* Department of Theoretical Physics ** 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 and Technicolor parts by ** C* Stephen Mrenna ** C* Physics Department, UC Davis ** C* One Shields Avenue, Davis, CA 95616, USA ** C* phone + 1 - 530 - 752 - 2661 ** C* E-mail mrenna@physics.ucdavis.edu ** C* ** C* PYTHIA 7 efforts coordinated by ** C* Leif Lonnblad ** C* Department of Theoretical Physics ** C* Lund University ** C* Solvegatan 14A, S-223 62 Lund, Sweden ** C* phone +46 - 46 - 222 77 80 ** C* E-mail leif@thep.lu.se ** C* ** C* Several parts are written by Hans-Uno Bengtsson ** C* PYSHOW is written together with Mats Bengtsson ** C* PYMAEL is written by Emanuel Norrbin ** C* advanced popcorn baryon production written by Patrik Eden ** C* code for virtual photons mainly written by Christer Friberg ** C* code for low-mass strings mainly written by Emanuel Norrbin ** C* Bose-Einstein code mainly written by Leif Lonnblad ** C* Lepton number violation code by Peter Skands ** C* CTEQ parton distributions are by the CTEQ collaboration ** C* GRV 94 parton distributions are by Glueck, Reya and Vogt ** C* SaS photon parton distributions together with Gerhard Schuler ** C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt ** C* MSSM Higgs mass calculation code by M. Carena, ** C* J.R. Espinosa, M. Quiros and C.E.M. Wagner ** C* PYGAUS adapted from CERN library (K.S. Kolbig) ** C* ** C* The latest program version and documentation is found on WWW ** C* http://www.thep.lu.se/~torbjorn/Pythia.html ** C* ** C* Copyright Torbjorn Sjostrand, Lund 2001 ** 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 PYGAGA to handle lepton -> lepton + gamma branchings * C S PYRAND to select subprocess and kinematics for event * C S PYSCAT to set up kinematics and colour flow of event * C S PYSSPA to simulate initial state spacelike showers * C S PYMEMX auxiliary to PYSSPA for ME correction maximum * C S PYMEWT auxiliary to PYSSPA for matrix element correction * C S PYADSH to administrate sequential final-state 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 PYDISG to set up kinematics, remnant and showers for DIS * C S PYDOCU to compute cross-sections and handle documentation * C S PYFRAM to perform boosts between different frames * C S PYWIDT to calculate full and partial widths of resonances * C S PYOFSH to calculate partial width into off-shell channels * C S PYRECO to handle colour reconnection in W+W- events * C S PYKLIM to calculate borders of allowed kinematical region * C S PYKMAP to construct value of kinematical variable * C S PYSIGH to calculate differential cross-sections * C S 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 proton parton distributions * C S PYGRVM to evaluate the GRV 94M proton parton distributions * C S PYGRVD to evaluate the GRV 94D proton parton distributions * C F PYGRVV auxiliary to the PYGRV* routines * C F PYGRVW auxiliary to the PYGRV* routines * C F PYGRVS auxiliary to the PYGRV* routines * C F PYCT5L to evaluate the CTEQ 5L proton parton distributions * C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions * C S PYPDPO to evaluate old proton parton distributions * C F PYHFTH to evaluate threshold factor for heavy flavour * C S PYSPLI to find flavours left in hadron when one removed * C F PYGAMM to evaluate ordinary Gamma function Gamma(x) * C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) * C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) * C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) * C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H * C * 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 PYRGHM auxiliary to PYPOLE * C S PYGFXX auxiliary to PYRGHM * C F PYFINT auxiliary to PYPOLE * C F PYFISB auxiliary to PYFINT * C S PYSFDC to calculate sfermion decay partial widths * C S PYGLUI to calculate gluino decay partial widths * C S PYTBBN to calculate 3-body decay of gluino to neutralino * C S PYTBBC to calculate 3-body decay of gluino to chargino * C S PYNJDC to calculate neutralino decay partial widths * C S PYCJDC to calculate chargino decay partial widths * C F PYXXZ6 auxiliary for ino 3-body decays * C F PYXXGA auxiliary for ino -> ino + gamma decay * C F PYX2XG auxiliary for ino -> ino + gauge boson decay * C F PYX2XH auxiliary for ino -> ino + Higgs decay * C S PYHEXT to calculate non-SM Higgs decay partial widths * C F PYH2XX auxiliary for H -> ino + ino decay * C F PYGAUS to perform Gaussian integration * C F PYSIMP to perform Simpson integration * C F PYLAMF to evaluate the lambda kinematics function * C S PYTBDY to perform 3-body decay of gauginos * C S PYTECM to calculate techni_rho/omega masses * C S PYEICG to calculate eigenvalues of a 4*4 complex matrix * C S PYCMQR auxiliary to PYEICG * C S PYCMQ2 auxiliary to PYEICG * C S PYCDIV auxiliary to PYCMQR * C S PYCSRT auxiliary to PYCMQR * C S PYTHAG auxiliary to PYCMQR * C S PYCBAL auxiliary to PYEICG * C S PYCBA2 auxiliary to PYEICG * C S PYCRTH auxiliary to PYEICG * C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 * C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 * C S PYWIDX to calculate decay widths from within PYWIDT * C S PYRVSF to calculate R-violating sfermion decay widths * C S PYRVNE to calculate R-violating neutralino decay widths * C S PYRVCH to calculate R-violating chargino decay widths * C F PYRVSB auxiliary to PYRVSF * C S PYRVGW to calculate R-Violating 3-body widths * C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. * C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.* C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. * C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. * C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. * C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. * C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. * C F PYRVR auxiliary to PYRVG1, Breit-Wigner * C F PYRVS auxiliary to PYRVG2 & PYRVG4 * C * C S PY1ENT to fill one entry (= parton or particle) * C S PY2ENT to fill two entries * C S PY3ENT to fill three entries * C S PY4ENT to fill four entries * C S PY2FRM to interface to generic two-fermion generator * C S PY4FRM to interface to generic four-fermion generator * C S PY6FRM to interface to generic six-fermion generator * C S PY4JET to generate a shower from a given 4-parton config * C S PY4JTW to evaluate the weight od a shower history for above * C S PY4JTS to set up the parton configuration for above * C S PYJOIN to connect entries with colour flow information * C S PYGIVE to fill (or query) commonblock variables * C S PYEXEC to administrate fragmentation and decay chain * C S PYPREP to rearrange showered partons along strings * C S PYSTRF to do string fragmentation of jet system * C S 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 F PYMAEL auxiliary to PYSHOW, with gluon emission ME's * C S PYBOEI to include Bose-Einstein effects (crudely) * C S PYBESQ auxiliary to PYBOEI * C F PYMASS to give the mass of a particle or parton * C F PYMRUN to give the running MSbar mass of a quark * C S PYNAME to give the name of a particle or parton * C F PYCHGE to give three times the electric charge * C F PYCOMP to compress standard KF flavour code to internal KC * C S PYERRM to write error messages and abort faulty run * C F PYALEM to give the alpha_electromagnetic value * C F PYALPS to give the alpha_strong value * C F PYANGL to give the angle from known x and y components * C F PYR to provide a random number generator * C S PYRGET to save the state of the random number generator * C S PYRSET to set the state of the random number generator * C S PYROBO to rotate and/or boost an event * C S PYEDIT to remove unwanted entries from record * C S PYLIST to list event record or particle data * C S PYLOGO to write a logo * C S PYUPDA to update particle data * C F PYK to provide integer-valued event information * C F PYP to provide real-valued event information * C S PYSPHE to perform sphericity analysis * C S PYTHRU to perform thrust analysis * C S PYCLUS to perform three-dimensional cluster analysis * C S PYCELL to perform cluster analysis in (eta, phi, E_T) * C S PYJMAS to give high and low jet mass of event * C S PYFOWO to give Fox-Wolfram moments * C S PYTABU to analyze events, with tabular output * C * C S PYEEVT to administrate the generation of an e+e- event * C S PYXTEE to give the total cross-section at given CM energy * C S PYRADK to generate initial state photon radiation * C S PYXKFL to select flavour of primary qqbar pair * C S PYXJET to select (matrix element) jet multiplicity * C S PYX3JT to select kinematics of three-jet event * C S PYX4JT to select kinematics of four-jet event * C S PYXDIF to select angular orientation of event * C S PYONIA to perform generation of onium decay to gluons * C * C S PYBOOK to book a histogram * C S PYFILL to fill an entry in a histogram * C S PYFACT to multiply histogram contents by a factor * C S PYOPER to perform operations between histograms * C S PYHIST to print and reset all histograms * C S PYPLOT to print a single histogram * C S PYNULL to reset contents of a single histogram * C S PYDUMP to dump histogram contents onto a file * C * C S PYKCUT dummy routine for user kinematical cuts * C S PYEVWT dummy routine for weighting events * C S UPINIT dummy routine to initialize user processes * C S UPEVNT dummy routine to generate a user process event * C S PDFSET dummy routine to be removed when using PDFLIB * C S STRUCTM dummy routine to be removed when using PDFLIB * C S STRUCTP dummy routine to be removed when using PDFLIB * C S PYTAUD dummy routine for interface to tau decay libraries * C S PYTIME dummy routine for giving date and time * C * C********************************************************************* C...PYDATA C...Default values for switches and parameters, C...and particle, decay and process data. BLOCK DATA PYDATA C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYDAT4/CHAF(500,2) CHARACTER CHAF*16 COMMON/PYDATR/MRPY(6),RRPY(100) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT6/PROC(0:500) CHARACTER PROC*28 COMMON/PYINT7/SIGT(0:6,0:6,0:5) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/, &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/, &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYBINS/ C...PYDAT1, containing status codes and most parameters. DATA MSTU/ & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2, 1 6, 1, 1, 0, 0, 1, 0, 0, 0, 0, 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0, 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0, 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0, 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7 30*0, 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0, & 80*0/ DATA (PARU(I),I=1,100)/ & 3.141592653589793D0, 6.283185307179586D0, & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0, 1 0.001D0, 0.09D0, 0.01D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0, 4 0D0, 0D0, 0.0001D0, 0D0, 0D0, 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0, 6 40*0D0/ DATA (PARU(I),I=101,200)/ & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5, & 0D0, 0D0, 0D0, 0D0, 0D0, 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0, 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0, 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 5 1.0D0, 0D0, 0D0, 0D0, 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, 2, 2, 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, 2, 0, 0, 1, 0, 0, 0, 6 40*0, & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2, 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 2 80*0/ DATA PARJ/ & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0, & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0, 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0, 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0, 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,0D0, 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0, 0D0, 0D0,0D0, 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0, 5 0D0, 0D0, 0D0, 1.0D0, 0D0, 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0, 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0, 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4, 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0, 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0, 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0, 4 10*0D0, 5 10*0D0, 6 10*0D0, 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0, 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0, 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0, 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0, 9 5*0D0/ C...PYDAT2, with particle data and flavour treatment parameters. DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0, &-3,0,-3,6*0,3,9*0,3,2*0,3,4*0,-1,41*0,2,-1,20*0,3*3,7*0,3*3,3*0, &3*3,3*0,3*3,6*0,3*3,3*0,3*3,4*0,-2,-3,2*1,2*0,4,2*3,6,2*-2,2*-3, &0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,3,2*1,2*0, &2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,3,2*-2, &2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,-3,2*0, &2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,3*0,3,2*0,3,0,3,0,3, &2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,2,-1, &2,-1,2,-3,0,-3,0,-3,2*0,3,3*0,3,8*0,-1,2,-3,6*0,3,2*6,0,3,4*0,3, &139*0/ DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1, &2*0,-1,3*0,2*-1,3*0,2*-1,4*0,-1,5*0,2*-1,4*0,2*-1,5*0,2*-1,6*0, &-1,7*0,2*-1,5*0,2*-1,6*0,2*-1,7*0,2*-1,8*0,-1,56*0,6*1,6*0,2,7*0, &6*1,9*0,2,3*0,2,0,5*2,2*1,156*0/ DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0, &2*1,39*0,1,0,2*1,20*0,3*1,4*0,6*1,3*0,9*1,3*0,12*1,4*0,100*1,2*0, &2*1,2*0,4*1,2*0,6*1,2*0,8*1,3*0,1,0,2*1,0,3*1,0,4*1,3*0,12*1,3*0, &1,2*0,1,0,12*1,0,1,3*0,1,8*0,4*1,5*0,3*1,0,1,3*0,2*1,139*0/ DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36, &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57, &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78, &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99, &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315, &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441, &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553, &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101, &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314, &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214, &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412, &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142, &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322, &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442, &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111, &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331, &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511, &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113, &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/ DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443, &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011, &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023, &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003, &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015, &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223, &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001, &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023, &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440, &9902110,9902210,139*0/ DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0, &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0, &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0, &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0, &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0, &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0, &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0, &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0, &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0, &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0, &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0, &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0, &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0, &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0, &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0, &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0, &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0, &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0, &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0, &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/ DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0, &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0, &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0, &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0, &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0, &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0, &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0, &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0, &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0, &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0, &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0, &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0, &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,139*0D0/ DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0, &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0, &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0, &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0, &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0, &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0, &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0, &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0, &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0, &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0, &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0, &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0, &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0, &0.02911D0,0.01741D0,0.04536D0,0.09511D0,0.8686D0,0.62395D0, &0.19192D0,123.27638D0,0.02296D0,0.18886D0,23.26819D0,2.86306D0, &0D0,3.45903D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0, &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0, &7*0D0,139*0D0/ DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0, &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0, &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0, &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0, &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0, &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0, &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0, &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0, &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0, &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0, &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0, &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0, &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0, &0.29108D0,0.17412D0,0.45362D0,0.95114D0,8.68604D0,6.23946D0, &1.91923D0,450D0,0.22959D0,1.88863D0,232.68185D0,28.63059D0,0D0, &34.59032D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0, &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0, &8.80013D0,7*0D0,139*0D0/ DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0, &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0, &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0, &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0, &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0, &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0, &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0, &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,112*0D0,139*0D0/ DATA PARF/ & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0, 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0, 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0, 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0, 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0, 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0, 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0, 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0, 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 9 0.0099D0, 0.0056D0, 0.199D0, 1.35D0, 4.5D0, 165D0, 4*0D0, & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0, 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 3 60*0D0, 4 0.2D0, 0.5D0, 8*0D0, 5 1800*0D0/ DATA ((VCKM(I,J),J=1,4),I=1,4)/ & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0, & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0, & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0, & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/ C...PYDAT3, with particle decay parameters and data. DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0, &4*1,3*0,2*1,40*0,3*1,16*0,3*1,2*0,9*1,0,32*1,2*0,1,3*0,1,2*0,2*1, &2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,5*1,2*0,6*1,0,7*1,2*0,5*1,2*0, &6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,1,0,26*1,146*0/ DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82, &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420, &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581, &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736, &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945, &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0, &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077, &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173, &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201, &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256, &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299, &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407, &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471, &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506, &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543, &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592, &1631,1652,1691,1712,1751,1775,1806,1832,1864,1890,1922,1948,2009, &2160,2406,2615,2877,3155,0,3388,3431,3456,3499,3524,3567,3592,0, &3628,0,3664,0,3700,3708,3716,3724,3727,3751,3777,3801,3807,3814, &3821,3828,3834,3840,3849,3853,3857,3860,3862,3883,3905,3927,3949/ DATA (MDCY(I,2),I= 352, 500)/3964,3976,3983,146*0/ DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3, &2*0,9,12,16,20,79,6*0,22,0,23,86,83,27,3*0,9,1,40*0,1,4,9,16*0,2, &5,2*9,2*2,7,8,6,9,2*2,3,10,6,3,11,6,11,6,63,3,8,61,2,8,33,2,4,1, &3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,2*0,1,3*0,3,2*0,3,1,2*0,2, &3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,2*1,76,4,2*0,4*1,4,2*0,1,2,1,2,4,1, &0,7*4,2*0,2*1,17,2*9,2*0,4*1,2*9,2*0,4*1,9,1,9,2*0,8*9,0,9*9,4*1, &5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,9*2,11,14,39,21,39,21, &39,24,31,26,32,26,32,26,61,151,246,209,262,278,233,0,43,25,43,25, &43,25,36,0,36,0,36,0,3*8,3,24,26,24,6,3*7,2*6,9,2*4,3,2,21,3*22, &15,12,2*7,146*0/ DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1, &7*1,-1,1,7*-1,8*1,2*-1,8*1,2*-1,73*1,-1,2*1,-1,5*1,0,2*-1,6*1,0, &2*-1,3*1,-1,6*1,2*-1,6*1,2*-1,3*1,-1,3*1,-1,3*1,5*-1,3*1,-1,6*1, &2*-1,3*1,-1,5*1,62*-1,6*1,2*-1,6*1,8*-1,3*1,-1,3*1,-1,3*1,5*-1, &3*1,4*-1,6*1,2*-1,3*1,-1,12*1,62*-1,6*1,2*-1,3*1,-1,9*1,62*-1, &3*1,-1,3*1,-1,1,18*-1,4*1,2*-1,2*1,-1,1225*1,2*-1,248*1,2*-1, &1725*1,2*-1,6*1,2*-1,9*1,-1,3*1,-1,3*1,5*-1,3*1,-1,14*1,2*-1,6*1, &2*-1,67*1,2*-1,6*1,2*-1,4*1,-1,107*1,4011*0/ DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102, &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41, &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53, &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0, &18*53,6*32,4*0,12,2*42,2*11,9*42,0,2,3,15*0,4*42,5*0,3,12*0,2, &3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,3*0,1,11*0,22*42,41*0, &2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,6*0,12,2*0,12,0,12, &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42, &19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,4*32,2*4,0,32,45*0, &14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,2*42,2*11,0,2*42, &2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11, &2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,9*42,0,162*42,50*0,2*12, &17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,4*32,2*4,5*0,2108*53,4*32, &3*0,6*32,3*0,4*32,3*0,4*32,8*0,8*32,14*0,16*32,12*0,8*32,8*0, &46*32,3*53,12*0,8*32,13*0,66*51,6*32,9*0,9*32,4028*0/ DATA (BRAT(I) ,I= 1, 346)/43*0D0,0.00003D0,0.001765D0, &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0, &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0, &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0, &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0, &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0, &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0, &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0, &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0, &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0, &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0, &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0, &0.108087D0,0D0,0.000001D0,0D0,0.000349D0,0.048707D0,0.768308D0, &4*0D0,0.000227D0,0.064048D0,0D0,0.040621D0,0.002043D0,0.000615D0, &0.006981D0,0.068099D0,62*0D0,0.145835D0,0.113276D0,0.145835D0, &0.113271D0,0.145781D0,0.049002D0,2*0D0,0.032025D0,0.063642D0, &0.032025D0,0.063642D0,0.032022D0,0.063642D0,8*0D0,0.251225D0, &0.0129D0,0.000006D0,0D0,0.0129D0,0.250764D0,0.00038D0,0D0, &0.000008D0,0.000465D0,0.215418D0,5*0D0,2*0.085312D0,0.08531D0, &7*0D0,0.000049D0,0.000774D0,5*0D0,0.000074D0,0D0,0.000417D0/ DATA (BRAT(I) ,I= 347, 651)/0.000015D0,0.000061D0,0.30671D0, &0.689011D0,0D0,0.002889D0,69*0D0,0.000001D0,0.000121D0, &0.001924D0,4*0D0,0.000001D0,0.000184D0,0D0,0.003106D0,0.000015D0, &0.000003D0,2*0D0,0.994646D0,66*0D0,0.000021D0,0.090135D0,2*0D0, &0.000013D0,0.003714D0,0D0,0.906117D0,18*0D0,3*0.215119D0, &0.214724D0,2*0D0,0.06996D0,0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0, &0.08D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0, &0.005D0,0.988D0,0.012D0,0.998739D0,0.00079D0,0.00038D0, &0.000046D0,0.000045D0,2*0.34725D0,0.144D0,0.104D0,0.0245D0, &2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,0.1256D0,2*0.1939D0, &2*0.1359D0,0.002D0,0.001D0,0.0006D0,0.999877D0,0.000123D0, &0.99955D0,0.00045D0,2*0.34725D0,0.144D0,0.104D0,0.049D0,0.0028D0, &0.0057D0,0.3923D0,0.321D0,0.2317D0,0.0478D0,0.0049D0,0.0013D0, &0.0003D0,0.0007D0,0.89D0,0.08693D0,0.0221D0,0.00083D0, &2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,0.023D0,2*0.0115D0, &0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,0.665D0,0.333D0, &0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,0.043D0,0.059D0, &2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,0.0173D0,0.0482D0, &0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,0.166D0,0.168D0,0.084D0, &0.086D0,0.043D0,0.059D0,2*0.029D0,2*0.002D0,0.437D0,0.208D0/ DATA (BRAT(I) ,I= 652, 823)/0.302D0,0.0302D0,0.0212D0,0.0016D0, &0.48947D0,0.34D0,3*0.043D0,0.027D0,0.0126D0,0.0013D0,0.0003D0, &0.00025D0,0.00008D0,0.444D0,2*0.222D0,0.104D0,2*0.004D0,0.07D0, &0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.07D0,0.065D0,2*0.005D0, &2*0.011D0,5*0.001D0,0.026D0,0.019D0,0.066D0,0.041D0,0.045D0, &0.076D0,0.0073D0,2*0.0047D0,0.026D0,0.001D0,0.0006D0,0.0066D0, &0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,0.006D0,0.005D0,0.012D0, &0.0057D0,0.067D0,0.008D0,0.0022D0,0.027D0,0.004D0,0.019D0, &0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,0.022D0,0.087D0,0.001D0, &0.0019D0,0.0015D0,0.0028D0,0.683D0,0.306D0,0.011D0,0.3D0,0.15D0, &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.034D0,0.027D0, &2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,0.027D0,2*0.002D0, &2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,0.062D0,3*0.021D0, &0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,0.0109D0,0.0041D0, &0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,2*0.0016D0,0.0018D0, &0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,0.0034D0,0.0036D0, &0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,0.022D0,0.0077D0, &0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,0.0511D0,0.017D0, &0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,0.16D0,0.08D0, &0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,2*0.005D0/ DATA (BRAT(I) ,I= 824, 991)/2*0.02D0,0.03D0,2*0.005D0,0.015D0, &0.037D0,0.028D0,0.079D0,0.095D0,0.052D0,0.0078D0,4*0.001D0, &0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,0.0952D0, &0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,0.8797D0, &0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0, &0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0, &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0, &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0, &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0, &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0, &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0, &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0, &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0, &0.0008D0,0.0014D0,0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0, &0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0, &0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0, &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0, &0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0, &0.0135D0,0.025D0,2*0.0002D0,0.0007D0,2*0.0004D0,0.0014D0,0.001D0, &0.0009D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0/ DATA (BRAT(I) ,I= 992,1183)/1D0,2*0.3D0,2*0.2D0,0.047D0,0.122D0, &0.006D0,0.012D0,0.035D0,0.012D0,0.035D0,0.003D0,0.007D0,0.15D0, &0.037D0,0.008D0,0.002D0,0.05D0,0.015D0,0.003D0,0.001D0,0.014D0, &0.042D0,0.014D0,0.042D0,0.24D0,0.065D0,0.012D0,0.003D0,0.001D0, &0.002D0,0.001D0,0.002D0,0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0, &0.0252D0,0.0248D0,0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0, &0.7743D0,0.029D0,0.22D0,0.78D0,1D0,0.331D0,0.663D0,0.006D0, &0.663D0,0.331D0,0.006D0,1D0,0.999D0,0.001D0,0.88D0,2*0.06D0, &0.639D0,0.358D0,0.002D0,0.001D0,1D0,0.88D0,2*0.06D0,0.516D0, &0.483D0,0.001D0,0.88D0,2*0.06D0,0.9988D0,0.0001D0,0.0006D0, &0.0004D0,0.0001D0,0.667D0,0.333D0,0.9954D0,0.0011D0,0.0035D0, &0.333D0,0.667D0,0.676D0,0.234D0,0.085D0,0.005D0,2*1D0,0.018D0, &2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.018D0,2*0.005D0,0.003D0, &0.002D0,2*0.006D0,0.0066D0,0.025D0,0.016D0,0.0088D0,2*0.005D0, &0.0058D0,0.005D0,0.0055D0,4*0.004D0,2*0.002D0,2*0.004D0,0.003D0, &0.002D0,2*0.003D0,3*0.002D0,2*0.001D0,0.002D0,2*0.001D0, &2*0.002D0,0.0013D0,0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0, &2*0.002D0,2*0.001D0,2*0.002D0,2*0.001D0,0.2432D0,0.057D0, &2*0.035D0,0.15D0,2*0.075D0,0.03D0,2*0.015D0,2*0.08D0,0.76D0, &0.08D0,4*1D0,2*0.08D0,0.76D0,0.08D0,1D0,2*0.5D0,1D0,2*0.5D0/ DATA (BRAT(I) ,I=1184,1377)/2*0.08D0,0.76D0,0.08D0,1D0,2*0.08D0, &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0, &0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0, &0.04D0,0.0077D0,0.02D0,0.0235D0,0.0285D0,0.0435D0,0.0011D0, &0.0022D0,0.0044D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0, &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0, &2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0, &4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0, &0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0, &0.005D0,4*1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,1D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0/ DATA (BRAT(I) ,I=1378,1580)/0.015D0,0.005D0,2*0.105D0,0.04D0, &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0, &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0, &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0, &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0, &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0, &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0, &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0, &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,0.52D0,0.26D0, &0.11D0,2*0.055D0,0.333D0,0.334D0,0.333D0,0.667D0,0.333D0,0.28D0, &0.14D0,0.313D0,0.157D0,0.11D0,0.667D0,0.333D0,0.28D0,0.14D0, &0.313D0,0.157D0,0.11D0,0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0, &4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0, &0.333D0,4*0.5D0,0.007D0,0.993D0,1D0,0.667D0,0.333D0,0.667D0, &0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0, &1D0,4*0.5D0,3*0.146D0,3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0, &0.667D0,0.333D0,0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0, &0.333D0,2*0.5D0,0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0, &4*0.5D0,0.35D0,0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0, &0.027D0,0.001D0,0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0/ DATA (BRAT(I) ,I=1581,3853)/0.008D0,0.024D0,0.008D0,0.024D0, &0.425D0,0.02D0,0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2108*0D0, &0.017431D0,0.054048D0,0.857694D0,2*0D0,0.00025D0,0.070578D0,0D0, &0.022748D0,0.026576D0,0.359486D0,0.561581D0,2*0D0,0.000104D0, &0.029504D0,0.011185D0,0.034681D0,0.550354D0,2*0D0,0.00016D0, &0.045287D0,0.358333D0,0.445781D0,0D0,0.554219D0,0.144051D0, &2*0.351902D0,0D0,0.082107D0,0.029566D0,0.001511D0,0.000726D0, &0.004518D0,0.006522D0,0.004518D0,0.006522D0,0.004513D0,3*0D0, &0.002908D0,0.000973D0,0.002908D0,0.000973D0,0.002908D0, &0.000973D0,2*0D0,0.143982D0,0.489888D0,0.1951D0,0D0,0.114302D0, &0.008426D0,0.014868D0,0.000763D0,2*0D0,0.000763D0,0.01484D0, &0.000003D0,2*0D0,0.000027D0,0.001945D0,5*0D0,3*0.00503D0,0D0, &0.133776D0,0.003284D0,0.37169D0,0.006838D0,2*0.030954D0, &0.00163D0,0D0,0.047224D0,0.073737D0,0.047224D0,0.073732D0, &0.047179D0,3*0D0,0.034761D0,0.009166D0,0.034761D0,0.009166D0, &0.034759D0,0.009166D0,2*0D0,4*0.009069D0,0.510147D0,0.453576D0, &6*0D0,1D0,6*0D0,1D0,4*0.001128D0,0.571047D0,0.382288D0, &0.042153D0,4*0.016597D0,0.93361D0,0D0,4*0.016597D0,0.93361D0,0D0, &4*0.05515D0,0.34469D0,0D0,0.228998D0,0.164208D0,0.041503D0, &0.850973D0,0.005411D0,0.045025D0,0.098591D0,0.849898D0/ DATA (BRAT(I) ,I=3854,3984)/0.021617D0,0.030018D0,0.098466D0, &0.294448D0,0.10945D0,0.596102D0,0.389906D0,0.610094D0,3*0.0633D0, &0.063299D0,0.063295D0,0.056281D0,2*0D0,6*0.020495D0,2*0D0, &0.327919D0,0.04099D0,0.045236D0,0.090112D0,0D0,0.19874D0, &0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0, &0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0, &0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0, &0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0, &0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0, &0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0, &0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0, &0.010236D0,0.198928D0,0.000149D0,0.000006D0,0.000368D0, &0.080733D0,0.199344D0,0.010234D0,0.000003D0,0.010236D0, &0.198928D0,0.000149D0,0.000006D0,0.000368D0,0.080733D0,4*0D0, &0.184738D0,0.104588D0,0.184738D0,0.104587D0,0.184731D0,0.09582D0, &0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0, &0.015602D0,0.022902D0,0.008429D0,0.015602D0,0.28959D0,0.01487D0, &0.000008D0,0.01487D0,0.289061D0,0.000492D0,0.000009D0,0.000536D0, &0.27911D0,2*0.037151D0,0.03715D0,0.090266D0,2*0.001805D0, &0.090266D0,0.001805D0,0.812263D0,0.00179D0,0.090428D0,0.001809D0/ DATA (BRAT(I) ,I=3985,8000)/0.001808D0,0.090428D0,0.001808D0, &0.81372D0,0D0,4011*0D0/ DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25, &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23, &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22, &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12, &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25, &-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2, &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13, &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022, &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001, &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002, &1000003,2000003,1000003,-1000003,1000004,2000004,1000004, &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006, &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012, &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013, &1000014,2000014,1000014,-1000014,1000015,2000015,1000015, &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12, &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13, &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24, &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024, &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/ DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003, &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005, &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006, &1000011,2000011,1000011,-1000011,1000012,2000012,1000012, &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014, &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016, &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23, &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024, &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002, &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004, &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005, &1000006,2000006,1000006,-1000006,1000011,2000011,1000011, &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013, &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015, &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3, &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035, &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011, &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2, &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221, &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/ DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331, &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211, &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313, &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313, &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111, &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311, &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223, &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211, &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421, &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311, &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311, &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311, &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11, &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321, &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82, &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443, &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12, &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2, &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16, &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/ DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14, &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521, &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212, &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222, &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322, &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13, &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322, &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214, &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2, &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13, &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12, &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2, &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2, &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16, &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16, &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2, &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2, &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12, &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16, &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/ DATA (KFDP(I,1),I=1403,1708)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2, &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12, &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221, &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313, &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313, &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443, &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513, &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113, &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413, &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443, &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555, &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035, &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11, &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,1000039,1000024, &1000037,1000022,1000023,1000025,1000035,1000001,2000001,1000001, &2000001,1000021,3*-11,3*-13,3*-15,1000039,-1000024,-1000037, &1000022,1000023,1000025,1000035,1000004,2000004,1000004,2000004, &1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16, &15,16,15,16,15,1000039,1000024,1000037,1000022,1000023,1000025, &1000035,1000003,2000003,1000003,2000003,1000021,3*-11,3*-13/ DATA (KFDP(I,1),I=1709,1966)/3*-15,1000039,-1000024,-1000037, &1000022,1000023,1000025,1000035,1000006,2000006,1000006,2000006, &1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16, &15,16,15,16,15,1000039,1000024,1000037,1000022,1000023,1000025, &1000035,1000005,2000005,1000005,2000005,1000021,1000022,1000016, &-1000015,3*-11,3*-13,3*-15,1000039,-1000024,-1000037,1000022, &1000023,1000025,1000035,1000012,2000012,1000012,2*12,2*14,2*16, &3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,1000037,1000022, &1000023,1000025,1000035,1000011,2000011,1000011,2000011,3*-13, &3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,1000022,1000023, &1000025,1000035,1000014,2000014,1000014,2000014,2*12,2*14,2*16, &3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,1000037,1000022, &1000023,1000025,1000035,1000013,2000013,1000013,2000013,3*-11, &3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,1000022,1000023, &1000025,1000035,1000016,2000016,1000016,2000016,2*12,2*14,2*16, &3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,1000037,1000022, &1000023,1000025,1000035,1000015,2000015,1000015,2000015,3*-11, &3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,2000001,-2000001, &1000002,-1000002,2000002,-2000002,1000003,-1000003,2000003, &-2000003,1000004,-1000004,2000004,-2000004,1000005,-1000005/ DATA (KFDP(I,1),I=1967,2235)/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,5*1000039,4,1,-12,12,-12,12, &-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14, &-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11, &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12, &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13, &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14, &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15, &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16, &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,5*1000039, &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024, &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037, &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037, &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037, &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002, &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004, &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005, &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011/ DATA (KFDP(I,1),I=2236,2523)/-2000011,1000012,-1000012,2000012, &-2000012,1000013,-1000013,2000013,-2000013,1000014,-1000014, &2000014,-2000014,1000015,-1000015,2000015,-2000015,1000016, &-1000016,2000016,-2000016,5*1000021,-12,12,-12,12,-12,12,-12,12, &-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,-16,16, &-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,-11,11, &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12, &-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,-13,13, &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14, &-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,-15,15, &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16, &-15,15,-16,16,-15,15,-16,16,-15,15,2*1000039,6*1000022,6*1000023, &6*1000025,6*1000035,1000022,1000023,1000025,1000035,1000002, &2000002,-1000001,-2000001,1000004,2000004,-1000003,-2000003, &1000006,2000006,-1000005,-2000005,1000012,2000012,-1000011, &-2000011,1000014,2000014,-1000013,-2000013,1000016,2000016, &-1000015,-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12, &12,-11,-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13, &-14,14,-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15, &-16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12/ DATA (KFDP(I,1),I=2524,2794)/2*-11,12,-12,2*-11,12,-12,2*-11,12, &-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14, &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14, &-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16, &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16, &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, &2000003,-2000003,1000004,-1000004,2000004,-2000004,1000005, &-1000005,2000005,-2000005,1000006,-1000006,2000006,-2000006, &1000011,-1000011,2000011,-2000011,1000012,-1000012,2000012, &-2000012,1000013,-1000013,2000013,-2000013,1000014,-1000014, &2000014,-2000014,1000015,-1000015,2000015,-2000015,1000016, &-1000016,2000016,-2000016,5*1000021,-12,12,-12,12,-12,12,-12,12, &-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,-16,16, &-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,-11,11, &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12/ DATA (KFDP(I,1),I=2795,3070)/-11,11,-12,12,-11,11,-12,12,-11,11, &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14, &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13, &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16, &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15, &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,-12,12,-12,12,-12,12, &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14, &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12, &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11/ DATA (KFDP(I,1),I=3071,3398)/-12,12,-11,11,-12,12,-11,11,-12,12, &-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13, &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14, &-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15, &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16, &-15,15,2*1000039,15*1000024,6*1000022,6*1000023,6*1000025, &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002, &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006, &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011, &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015, &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11, &-12,12,-11,-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14, &-13,-14,14,-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16, &16,-15,-16,16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11, &12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11, &12,-12,2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13, &14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13, &14,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15, &16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,1000039, &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000001/ DATA (KFDP(I,1),I=3399,3676)/1000002,2000002,1000002,2000002, &1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16, &15,16,15,16,15,1000039,1000024,1000037,1000022,1000023,1000025, &1000035,4*1000002,1000001,2000001,1000001,2000001,1000021,3*-11, &3*-13,3*-15,1000039,-1000024,-1000037,1000022,1000023,1000025, &1000035,4*1000003,1000004,2000004,1000004,2000004,1000021,3*-12, &3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,15,16, &15,1000039,1000024,1000037,1000022,1000023,1000025,1000035, &4*1000004,1000003,2000003,1000003,2000003,1000021,3*-11,3*-13, &3*-15,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035, &4*1000005,1000006,2000006,1000006,2000006,1000021,3*-12,3*-14, &3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15, &1000039,1000024,1000037,1000022,1000023,1000025,1000035, &4*1000006,1000005,2000005,1000005,2000005,1000021,3*-11,3*-13, &3*-15,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035, &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14, &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023, &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12, &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037, &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016/ DATA (KFDP(I,1),I=3677,8000)/1000016,2000016,2*12,2*14,2*16, &3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,6,11,13,15,21,2*4,2,4,24,-11, &-13,-15,3,4,5,6,11,13,15,21,5,6,21,2*24,2*3000211,2*22,2*23,1,2, &3,4,5,6,7,8,11,12,13,14,15,16,17,18,2*24,3*3000211,24,4*-1,4*-3, &4*-5,4*-7,-11,-13,-15,-17,22,23,22,23,24,3000211,24,3000211,1,2, &3,4,5,6,7,8,11,12,13,14,15,16,17,18,1,2,3,4,5,6,1,2,3,4,5,6,21,1, &2,3,4,5,6,21,1,2,3,4,5,6,21,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6, &21,3100111,3200111,21,22,23,-24,21,22,23,24,22,23,-24,23,24,1,2, &3,4,5,6,7,8,11,12,13,14,15,16,17,18,21,22,23,24,0,9*11,9*-11, &2*11,2*-11,9*13,9*-13,2*13,2*-13,9*15,9*-15,2*15,2*-15,1,2,3,4,5, &6,11,12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11, &-13,-15,3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,4011*0/ DATA (KFDP(I,2),I= 1, 339)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4, &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,6*1000006,3*7, &2,4,6,8,7,4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14, &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321, &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211, &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211, &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21, &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8, &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8, &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23, &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023, &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001, &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003, &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005, &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011, &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013, &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015, &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6, &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8, &2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,25,-1,-2,-3,-4,-5,-6/ DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23, &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025, &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024, &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002, &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005, &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011, &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013, &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015, &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6, &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022, &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035, &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001, &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004, &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006, &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012, &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014, &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016, &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037, &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005, &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/ DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1, &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211, &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111, &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111, &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111, &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14, &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223, &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22, &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213, &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213, &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211, &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213, &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310, &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111, &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113, &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82, &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213, &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22, &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213, &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/ DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111, &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431, &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22, &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3, &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21, &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211, &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211, &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111, &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211, &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211, &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213, &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203, &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22, &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1, &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13, &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3, &4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,11,13,15,1,4,3,4,1,3,11, &13,15,1,4,3,4,1,3,4*22,11,13,15,1,4,3,4,1,3,22,11,13,15,1,4,3,4, &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1, &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3/ DATA (KFDP(I,2),I=1353,1822)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3, &4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4, &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1, &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3, &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113, &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310, &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311, &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311, &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211, &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311, &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111, &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13, &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5, &1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,2,2*1,4*2,2*24, &2*37,2,1,3,5,1,3,5,1,3,5,3,2*4,4*3,2*-24,2*-37,3,1,3,5,1,3,5,1,3, &5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,4,2*3,4*4,2*24,2*37,4,1,3, &5,1,3,5,1,3,2*5,2*6,4*5,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4, &5,6,1,2,3,4,5,6,1,2,3,4,5,2*6,2*5,4*6,2*24,2*37,6,4,-15,16,1,3,5, &1,3,5,1,3,5,11,2*12,4*11,2*-24,-37,13,15,11,15,11,13,11,13,15,11, &13,15,1,3,5,1,3,5,1,3,5,12,2*11,4*12,2*24,2*37,11,13,15,11,13,15/ DATA (KFDP(I,2),I=1823,2288)/1,3,5,1,3,5,1,3,5,13,2*14,4*13, &2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,5,1,3,5,1,3, &5,14,2*13,4*14,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,15, &2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,5, &1,3,5,1,3,5,16,2*15,4*16,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5, &1,3,5,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6, &-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,-1,3,-3,5, &-5,1,-1,3,-3,5,-5,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,-15, &15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11, &11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1, &-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6, &-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5, &-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4, &-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,22,23,25,35,36, &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13, &15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37, &-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6, &6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15, &-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15, &15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11/ DATA (KFDP(I,2),I=2289,2743)/11,-11,11,-13,13,-13,13,-13,13,-1,1, &-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6, &-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3, &-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2, &-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5, &-6,6,24,37,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13, &-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6, &2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14, &-13,-15,16,2*-15,16,2*-15,16,-15,6*-11,-15,16,2*-15,16,2*-15,16, &-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3, &-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2, &-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5, &6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4, &-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,22, &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11, &13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,1, &-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1, &-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11, &-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,14,-15,15,-15,15, &-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15/ DATA (KFDP(I,2),I=2744,3191)/15,-11,11,-11,11,-11,11,-15,15,-15, &15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1, &1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6, &6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3, &3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2, &2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,22, &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11, &13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5, &2,4,25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11, &13,-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3, &-3,3,-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12, &-13,13,-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2, &4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11, &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13, &-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5, &-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4, &-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1, &-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6, &-5,5,-6,6,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/ DATA (KFDP(I,2),I=3192,3692)/-13,-15,-1,-3,4*37,2*-1,2*2,2*-3, &2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1,-3,-13,14,2*-13, &14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,-11,12,2*-11,12, &2*-11,12,-11,-15,16,2*-15,16,2*-15,16,-15,-11,12,2*-11,12,2*-11, &12,-11,-13,14,2*-13,14,2*-13,14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2, &-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5, &-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4, &-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1, &2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6, &-5,6,-5,-6,-5,6,1,2*2,4*1,23,25,35,36,2*-24,2*-37,2*1,3,5,1,3,5, &1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,2,2*1,4*2,23,25,35,36, &2*24,2*37,2,1,3,5,1,3,5,1,3,5,3,2*4,4*3,23,25,35,36,2*-24,2*-37, &3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,4,2*3, &4*4,23,25,35,36,2*24,2*37,4,1,3,5,1,3,5,1,3,2*5,2*6,4*5,23,25,35, &36,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3, &4,5,2*6,2*5,4*6,23,25,35,36,2*24,2*37,6,1,3,5,1,3,5,1,3,5,11, &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11, &13,15,1,3,5,1,3,5,1,3,5,13,2*14,4*13,23,25,35,36,2*-24,2*-37,13, &15,11,15,11,13,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,15,2*16,4*15, &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3/ DATA (KFDP(I,2),I=3693,8000)/5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13, &-15,21,-1,-3,2*-5,5,12,14,16,-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21, &-24,-3000211,-24,-3000211,3000111,3000221,3000111,3000221,-1,-2, &-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,23,3000111,23, &3000111,22,3000221,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18, &2*3000111,2*3000221,-3000211,2*-24,-3000211,-1,-2,-3,-4,-5,-6,-7, &-8,-11,-12,-13,-14,-15,-16,-17,-18,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4, &-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4, &-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11, &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18, &21,22,23,-24,0,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-13,2*15,3*-1,3*-3, &3*-5,3*1,3*3,3*5,2*-11,2*15,3*-1,3*-3,3*-5,3*1,3*3,3*5,2*-11, &2*13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16, &9900016,2,4,6,2,4,6,2,4,6,9900012,9900014,9900016,-11,-13,-15, &-13,2*-15,24,-11,-13,-15,-13,2*-15,9900024,4011*0/ DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130, &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221, &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130, &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211, &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111, &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221, &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331, &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0, &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211, &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311, &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310, &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0, &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0, &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413, &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211, &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423, &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211, &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433, &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443, &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/ DATA (KFDP(I,3),I=1022,2197)/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,175*0,2*5,207*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,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15, &-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15, &-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1, &3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3, &3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3, &5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5, &5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,7*0,-11,-13,-15,-12,-14,-16, &-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14/ DATA (KFDP(I,3),I=2198,2789)/14,-16,16,-2,2,-4,4,52*0,-1,-3,-5, &-2,-4,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15, &-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15, &-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5, &1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1, &1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1, &3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3, &3,-3,5,-5,5,-5,3*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0, &12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14, &-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,14,-13,13,16,-15,15, &12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,2*4,3,-3,2*6,5,-5, &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1, &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3, &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5, &2*2,1,-1,2*4,3,-3,2*6,5,-5,7*0,-11,-13,-15,-12,-14,-16,-1,-3,-5, &-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14, &14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1, &-3,-5,-2,-4,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13, &-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13, &-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5/ DATA (KFDP(I,3),I=2790,3335)/-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5, &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1, &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1, &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,7*0,-11,-13, &-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3, &-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12, &-14,14,-16,16,-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0, &-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11, &13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11, &13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3, &5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5, &5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5, &1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1, &1,-1,3,-3,3,-3,5,-5,5,-5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2, &-4,4*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4, &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16, &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15, &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15, &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1, &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3/ DATA (KFDP(I,3),I=3336,8000)/2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5, &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1, &2*4,3,-3,2*6,5,-5,324*0,-5,170*0,2,4,6,2,4,6,2,4,6,-2,-4,-6,-2, &-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4,6,2,4,6,-2,-4,-6,-2, &-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4,6,2,4,6,-2,-4,-6,-2, &-4,-6,-2,-4,-6,2*9900012,2*9900014,4052*0/ DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211, &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113, &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0, &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111, &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111, &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321, &-311,20*0,-3,43*0,6*1,39*0,6*2,42*0,6*3,14*0,8*4,4*0,4*-5,4*0, &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81, &4*0,4*81,6*0,4*81,0,28*81,13*0,6*2101,18*81,4*0,18*81,4*0,9*81,0, &162*81,31*0,-211,111,6516*0/ DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0, &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211, &3*111,-211,111,7193*0/ C...PYDAT4, with particle names (character strings). DATA (CHAF(I,1),I= 1, 202)/'d','u','s','c','b','t','b''','t''', &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-', &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0', &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ', &'specflav','rndmflav','phasespa','c-hadron','b-hadron',4*' ', &'system','cluster','string','indep.','CMshower','SPHEaxis', &'THRUaxis','CLUSjet','CELLjet','table',' ','reggeon','pi0', &'rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega','f_2', &'K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi', &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+', &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+', &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b', &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0', &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-', &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+', &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0', &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1', &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0', &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0', &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/ DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+', &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0', &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+', &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-', &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0', &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0', &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-', &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-', &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+', &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1', &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c', &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+', &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1', &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0', &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L', &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL', &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+', &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R', &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR', &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/ DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc', &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc', &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*', &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++', &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di', &'n_diffr0','p_diffr+',139*' '/ DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar', &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar', &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ', &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar', &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ', &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-', &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-', &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0', &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar', &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar', &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+', &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0', &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+', &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar', &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar', &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--', &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0', &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0', &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--', &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/ DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+', &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar', &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-', &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar', &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+', &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0', &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba', &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar', &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+', &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0', &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0', &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0', &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-', &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ', &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ', &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar', &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+', &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ', &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar', &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/ DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+', &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar', &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ', &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',139*' '/ C...PYDATR, with initial values for the random number generator. DATA MRPY/19780503,0,0,97,33,0/ C...Default values for allowed processes and kinematics constraints. DATA MSEL/1/ DATA MSUB/500*0/ DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0, &5*1,5*0,6*1,4*0,4*1,16*0,16*0,4*1,4*0,6*1,5*0,5*1,0,5*1,5*0, &6*1,4*0,4*1,16*0/ DATA CKIN/ & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0, & 1.0D0, -10D0, 10D0, -40D0, 40D0, 1 -40D0, 40D0, -40D0, 40D0, -40D0, 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0, 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0, 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0, 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0, 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0, 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0, 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0, 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0, 5 -1.0D0, 0D0, 0D0, 0D0, 0D0, 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0, 6 -1D0, 0D0, -1D0, 0D0, -1D0, 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0, 7 0.99D0, 2D0, -1D0, 0D0, 0D0, 8 120*0D0/ C...Default values for main switches and parameters. Reset information. DATA (MSTP(I),I=1,100)/ & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0, 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3, 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1, 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0, 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0, 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7, 6 2, 3, 2, 2, 1, 5, 2, 1, 0, 0, 7 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8 1, 1, 100, 0, 0, 2, 0, 0, 0, 0, 9 1, 3, 1, 3, 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, 100, 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, 203, 2001, 11, 13, 0, 0, 0, 0, 0, 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ DATA (PARP(I),I=1,100)/ & 0.25D0, 10D0, 8*0D0, 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0, 2 10*0D0, 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,2.0D0,0.70D0,0.006D0,0D0, 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0, 5 10*0D0, 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 1.0D0,1D-3,2*0D0, 7 4.0D0, 0.25D0, 8*0D0, 8 1.90D0, 1.90D0, 0.5D0, 0.2D0, 0.33D0, 8 0.66D0, 0.7D0, 0.5D0, 1000D0, 0.16D0, 9 1.0D0,0.40D0,5.0D0,1.0D0,0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/ DATA (PARP(I),I=101,200)/ & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0, 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0, 2 1.0D0, 0.4D0, 8*0D0, 3 0.01D0, 5*0D0, 200D0, 200D0, 0.333D0, 0.05D0, 4 0.33333D0, 82D0, 1.33333D0, 4D0, 1D0, 4 1D0, .0182D0, 1D0, 0D0, 1.33333D0, 5 0D0, 0D0, 0D0, 0D0, 0.3651480D0, 200D0, 0D0, 0D0, 0D0, 0D0, 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0, 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0, 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0, 8 0.3D0, 0.64D0, 9 0.64D0, 5.0D0, 8*0D0/ DATA MSTI/200*0/ DATA PARI/200*0D0/ DATA MINT/400*0/ DATA VINT/400*0D0/ C...Constants for the generation of the various processes. DATA (ISET(I),I=1,100)/ & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2, 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2, 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2, 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1, 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1, 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2, 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2, 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2, 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/ DATA (ISET(I),I=101,200)/ & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2, 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2, 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2, 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2, 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2, 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2, 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2, 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2, 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/ DATA (ISET(I),I=201,300)/ & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2, 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2, 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2, 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1, 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/ DATA (ISET(I),I=301,500)/ & 2, 39*-2, 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1, 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2, 7 2, 2, 2, 2, 2, 2, 2, -1, -1, -1, 8 10*-2, 9 1, 1, 2, 2, 2, 5*-2, & 100*-2/ DATA ((KFPR(I,J),J=1,2),I=1,50)/ & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0, & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0, 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23, 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24, 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24, 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23, 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23, 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23, 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23, 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/ DATA ((KFPR(I,J),J=1,2),I=51,100)/ 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0, 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24, 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22, 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211, 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0, 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ DATA ((KFPR(I,J),J=1,2),I=101,150)/ & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0, & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25, 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22, 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0, 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0, 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0, 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0, 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/ DATA ((KFPR(I,J),J=1,2),I=151,200)/ 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0, 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0, 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0, 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0, 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0, 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0, 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35, 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36, 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0, 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ DATA ((KFPR(I,J),J=1,2),I=201,250)/ & 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, 4 1000021, 1000024, 1000021, 1000037, 1000021, 4 1000021, 1000021, 1000021, 0, 0, 4 1000002, 1000022, 2000002, 1000022, 1000002, 4 1000023, 2000002, 1000023, 1000002, 1000025/ DATA ((KFPR(I,J),J=1,2),I=251,300)/ 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, 8 1000005, 1000002, 2000005, 2000002, 1000005, 8 2000002, 1000005, 1000002, 2000005, 2000002, 8 1000005, 2000002, 1000005, 1000005, 2000005, 8 2000005, 1000005, 1000005, 2000005, 2000005, 9 1000005, 1000005, 2000005, 2000005, 1000005, 9 2000005, 1000005, 1000021, 2000005, 1000021, 9 1000005, 2000005, 37, 25, 37, 9 35, 36, 25, 36, 35/ DATA ((KFPR(I,J),J=1,2),I=301,500)/ & 37, 37, 78*0, 4 9900041, 0, 9900042, 0, 9900041, 4 11, 9900042, 11, 9900041, 13, 4 9900042, 13, 9900041, 15, 9900042, 4 15, 9900041, 9900041, 9900042, 9900042, 5 9900041, 0, 9900042, 0, 9900023, 5 0, 9900024, 0, 0, 0, 5 0, 0, 0, 0, 0, 5 0, 0, 0, 0, 0, 6 24, 24, 24, 3000211, 3000211, 6 3000211, 22, 3000111, 22, 3000221, 6 23, 3000111, 23, 3000221, 24, 6 3000211, 0, 0, 24, 23, 7 24, 3000111, 3000211, 23, 3000211, 7 3000111, 22, 3000211, 23, 3000211, 7 24, 3000111, 24, 3000221, 0, 7 0, 0, 0, 0, 0, 8 20*0, 9 5000039, 0, 5000039, 0, 21, 9 5000039, 0, 5000039, 21, 5000039, 9 10*0, & 200*0/ DATA COEF/10000*0D0/ DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/ &4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2, &3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2, &3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1, &3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0, &4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3, &2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2, &4,0,0,0,4,0,1,3,0,0,3,0,2,4,3,0,3,4,0,0,1,0,0,1,0,0,3,4,2,0,0,2, &3,0,0,0,1,0,0,0,0,0,3,0,2,0,0,0,2,0,3,1,2,0,0,0,3,2,1,0,1,0,0,0, &4,4,3,3,2,2,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ C...Treatment of resonances. DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1, &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,146*0/ C...Character constants: name of processes. DATA PROC(0)/ 'All included subprocesses '/ DATA (PROC(I),I=1,20)/ &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ', &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ', &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ', &' ', 'W+ + W- -> h0 ', &' ', 'f + f'' -> f + f'' (QFD) ', 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ', 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ', 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ', 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ', 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/ DATA (PROC(I),I=21,40)/ 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ', 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ', 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ', 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ', 2'f + g -> f + gamma ', 'f + g -> f + Z0 ', 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ', 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ', 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ', 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ', 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/ DATA (PROC(I),I=41,60)/ 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ', 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ', 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ', 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ', 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ', 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ', 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ', 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ', 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ', 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/ DATA (PROC(I),I=61,80)/ 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ', 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ', 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ', 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ', 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ', 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ', 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ', 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ', 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ', 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/ DATA (PROC(I),I=81,100)/ 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ', 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ', 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ', 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ', 8'g + g -> chi_2c + g ', ' ', 9'Elastic scattering ', 'Single diffractive (XB) ', 9'Single diffractive (AX) ', 'Double diffractive ', 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ', 9' ', ' ', 9'q + gamma* -> q ', ' '/ DATA (PROC(I),I=101,120)/ &'g + g -> gamma*/Z0 ', 'g + g -> h0 ', &'gamma + gamma -> h0 ', 'g + g -> chi_0c ', &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ', &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma', &' ', 'f + fbar -> gamma + h0 ', 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ', 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ', 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ', 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ', 1' ', ' '/ DATA (PROC(I),I=121,140)/ 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ', 2'f + f'' -> f + f'' + h0 ', 2'f + f'' -> f" + f"'' + h0 ', 2' ', ' ', 2' ', ' ', 2' ', ' ', 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ', 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ', 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ', 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ', 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/ DATA (PROC(I),I=141,160)/ 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ', 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ', 4'q + l -> LQ ', 'e + gamma -> e* ', 4'd + g -> d* ', 'u + g -> u* ', 4'g + g -> eta_tc ', ' ', 5'f + fbar -> H0 ', 'g + g -> H0 ', 5'gamma + gamma -> H0 ', ' ', 5' ', 'f + fbar -> A0 ', 5'g + g -> A0 ', 'gamma + gamma -> A0 ', 5' ', ' '/ DATA (PROC(I),I=161,180)/ 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ', 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ', 6'f + fbar -> f'' + fbar'' (g/Z)', 6'f +fbar'' -> f" + fbar"'' (W) ', 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ', 6'q + qbar -> e + e* ', ' ', 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ', 7'f + f'' -> f + f'' + H0 ', 7'f + f'' -> f" + f"'' + H0 ', 7' ', 'f + fbar -> Z0 + A0 ', 7'f + fbar'' -> W+/- + A0 ', 7'f + f'' -> f + f'' + A0 ', 7'f + f'' -> f" + f"'' + A0 ', 7' '/ DATA (PROC(I),I=181,200)/ 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ', 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ', 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ', 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ', 8'q + g -> q + A0 ', 'g + g -> g + A0 ', 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ', 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ', 9'f+fbar'' -> f"+fbar"'' (ETC)',' ', 9' ', ' ', 9' ', ' '/ DATA (PROC(I),I=201,220)/ &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ', &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar', &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar', &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar', &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ', 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar', 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar', 1' ', 'f + fbar -> ~chi1 + ~chi1 ', 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ', 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/ DATA (PROC(I),I=221,240)/ 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ', 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ', 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ', 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ', 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1', 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1', 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2', 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2', 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ', 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/ DATA (PROC(I),I=241,260)/ 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ', 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ', 4' ', 'qj + g -> ~qj_L + ~chi1 ', 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ', 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ', 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ', 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ', 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ', 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ', 5'qj + g -> ~qj_R + ~g ', ' '/ DATA (PROC(I),I=261,300)/ 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ', 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ', 6'g + g -> ~t_2 + ~t_2bar ', ' ', 6' ', ' ', 6' ', ' ', 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ', 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar', 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar', 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar', 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ', 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ', 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar', 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar', 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ', 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ', 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ', 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ', 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ', 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ', 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/ DATA (PROC(I),I=301,340)/ &'f + fbar -> H+ + H- ', 39*' '/ DATA (PROC(I),I=341,380)/ 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ', 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ', 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ', 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+', 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ', 5'f + f -> f'' + f'' + H_L++/-- ', 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ', 5'f + fbar'' -> W_R+/- ',5*' ', 6' ', 'f + fbar -> W_L+ W_L- ', 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ', 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ', 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ', 6'f + fbar -> W+/- pi_T-/+ ', ' ', 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ', 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ', 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ', 7'f + fbar'' -> W+/- pi_T0 ', 7'f + fbar'' -> W+/- pi_T0'' ', 7' ',' ', 7' '/ DATA (PROC(I),I=381,500)/ 8 10* ' ', 9'f + fbar -> G* ','g + g -> G* ', 9'q + qbar -> g + G* ','q + g -> q + G* ', 9'g + g -> g + G* ',' ', & 104*' '/ 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,0D0,24D17,0D0, 3 69*0D0/ C...Initial values for R-violating SUSY couplings. C...Should not be changed here. See PYMSIN. DATA RVLAM/27*0D0/ DATA RVLAMP/27*0D0/ DATA RVLAMB/27*0D0/ C...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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/ C...Local arrays. DIMENSION PSUM(5),PINI(6),PFIN(6) C...Save defaults for values that are changed. MSTJ1=MSTJ(1) MSTJ3=MSTJ(3) MSTJ11=MSTJ(11) MSTJ42=MSTJ(42) MSTJ43=MSTJ(43) MSTJ44=MSTJ(44) PARJ17=PARJ(17) PARJ22=PARJ(22) PARJ43=PARJ(43) PARJ54=PARJ(54) MST101=MSTJ(101) MST104=MSTJ(104) MST105=MSTJ(105) MST107=MSTJ(107) MST116=MSTJ(116) C...First part: loop over simple events to be generated. IF(MTEST.GE.1) CALL PYTABU(20) NERR=0 DO 180 IEV=1,500 C...Reset parameter values. Switch on some nonstandard features. MSTJ(1)=1 MSTJ(3)=0 MSTJ(11)=1 MSTJ(42)=2 MSTJ(43)=4 MSTJ(44)=2 PARJ(17)=0.1D0 PARJ(22)=1.5D0 PARJ(43)=1D0 PARJ(54)=-0.05D0 MSTJ(101)=5 MSTJ(104)=5 MSTJ(105)=0 MSTJ(107)=1 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3 C...Ten events each for some single jets configurations. IF(IEV.LE.50) THEN ITY=(IEV+9)/10 MSTJ(3)=-1 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0) IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0) IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0) IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0) IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0) C...Ten events each for some simple jet systems; string fragmentation. ELSEIF(IEV.LE.130) THEN ITY=(IEV-41)/10 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0) IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0) IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0) IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0) IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0) IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0) IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0) IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0, & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) C...Seventy events with independent fragmentation and momentum cons. ELSEIF(IEV.LE.200) THEN ITY=1+(IEV-131)/16 MSTJ(2)=1+MOD(IEV-131,4) MSTJ(3)=1+MOD((IEV-131)/4,4) IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0) IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0) IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0, & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0, & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) C...A hundred events with random jets (check invariant mass). ELSEIF(IEV.LE.300) THEN 100 DO 110 J=1,5 PSUM(J)=0D0 110 CONTINUE NJET=2D0+6D0*PYR(0) DO 130 I=1,NJET KFL=21 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0)) IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0)) EJET=5D0+20D0*PYR(0) THETA=ACOS(2D0*PYR(0)-1D0) PHI=6.2832D0*PYR(0) IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI) IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI) IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL) DO 120 J=1,4 PSUM(J)=PSUM(J)+P(I,J) 120 CONTINUE 130 CONTINUE IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT. & (PSUM(5)+PARJ(32))**2) GOTO 100 C...Fifty e+e- continuum events with matrix elements. ELSEIF(IEV.LE.350) THEN MSTJ(101)=2 CALL PYEEVT(0,40D0) C...Fifty e+e- continuum event with varying shower options. ELSEIF(IEV.LE.400) THEN MSTJ(42)=1+MOD(IEV,2) MSTJ(43)=1+MOD(IEV/2,4) MSTJ(44)=MOD(IEV/8,3) CALL PYEEVT(0,90D0) C...Fifty e+e- continuum events with coherent shower. ELSEIF(IEV.LE.450) THEN CALL PYEEVT(0,500D0) C...Fifty Upsilon decays to ggg or gammagg with coherent shower. ELSE CALL PYONIA(5,9.46D0) ENDIF C...Generate event. Find total momentum, energy and charge. DO 140 J=1,4 PINI(J)=PYP(0,J) 140 CONTINUE PINI(6)=PYP(0,6) CALL PYEXEC DO 150 J=1,4 PFIN(J)=PYP(0,J) 150 CONTINUE PFIN(6)=PYP(0,6) C...Check conservation of energy, momentum and charge; C...usually exact, but only approximate for single jets. MERR=0 IF(IEV.LE.50) THEN IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0) & MERR=MERR+1 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3) IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1 ELSE DO 160 J=1,4 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1 160 CONTINUE IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1 ENDIF IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6), & (PFIN(J),J=1,4),PFIN(6) C...Check that all KF codes are known ones, and that partons/particles C...satisfy energy-momentum-mass relation. Store particle statistics. DO 170 I=1,N IF(K(I,1).GT.20) GOTO 170 IF(PYCOMP(K(I,2)).EQ.0) THEN WRITE(MSTU(11),5100) I MERR=MERR+1 ENDIF PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0) & THEN WRITE(MSTU(11),5200) I MERR=MERR+1 ENDIF 170 CONTINUE IF(MTEST.GE.1) CALL PYTABU(21) C...List all erroneous events and some normal ones. IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN IF(MERR.GE.1) WRITE(MSTU(11),6400) CALL PYLIST(2) ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN CALL PYLIST(1) ENDIF C...Stop execution if too many errors. IF(MERR.NE.0) NERR=NERR+1 IF(NERR.GE.10) THEN WRITE(MSTU(11),6300) CALL PYLIST(1) STOP ENDIF 180 CONTINUE C...Summarize result of run. IF(MTEST.GE.1) CALL PYTABU(22) C...Reset commonblock variables changed during run. MSTJ(1)=MSTJ1 MSTJ(3)=MSTJ3 MSTJ(11)=MSTJ11 MSTJ(42)=MSTJ42 MSTJ(43)=MSTJ43 MSTJ(44)=MSTJ44 PARJ(17)=PARJ17 PARJ(22)=PARJ22 PARJ(43)=PARJ43 PARJ(54)=PARJ54 MSTJ(101)=MST101 MSTJ(104)=MST104 MSTJ(105)=MST105 MSTJ(107)=MST107 MSTJ(116)=MST116 C...Second part: complete events of various kinds. C...Common initial values. Loop over initiating conditions. MSTP(122)=MAX(0,MIN(2,MTEST)) MDCY(PYCOMP(111),1)=0 DO 230 IPROC=1,8 C...Reset process type, kinematics cuts, and the flags used. MSEL=0 DO 190 ISUB=1,500 MSUB(ISUB)=0 190 CONTINUE CKIN(1)=2D0 CKIN(3)=0D0 MSTP(2)=1 MSTP(11)=0 MSTP(33)=0 MSTP(81)=1 MSTP(82)=1 MSTP(111)=1 MSTP(131)=0 MSTP(133)=0 PARP(131)=0.01D0 C...Prompt photon production at fixed target. IF(IPROC.EQ.1) THEN PZSUM=300D0 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212) PQSUM=2D0 MSEL=10 CKIN(3)=5D0 CALL PYINIT('FIXT','pi+','p',PZSUM) C...QCD processes at ISR energies. ELSEIF(IPROC.EQ.2) THEN PESUM=63D0 PZSUM=0D0 PQSUM=2D0 MSEL=1 CKIN(3)=5D0 CALL PYINIT('CMS','p','p',PESUM) C...W production + multiple interactions at CERN Collider. ELSEIF(IPROC.EQ.3) THEN PESUM=630D0 PZSUM=0D0 PQSUM=0D0 MSEL=12 CKIN(1)=20D0 MSTP(82)=4 MSTP(2)=2 MSTP(33)=3 CALL PYINIT('CMS','p','pbar',PESUM) C...W/Z gauge boson pairs + pileup events at the Tevatron. ELSEIF(IPROC.EQ.4) THEN PESUM=1800D0 PZSUM=0D0 PQSUM=0D0 MSUB(22)=1 MSUB(23)=1 MSUB(25)=1 CKIN(1)=200D0 MSTP(111)=0 MSTP(131)=1 MSTP(133)=2 PARP(131)=0.04D0 CALL PYINIT('CMS','p','pbar',PESUM) C...Higgs production at LHC. ELSEIF(IPROC.EQ.5) THEN PESUM=15400D0 PZSUM=0D0 PQSUM=2D0 MSUB(3)=1 MSUB(102)=1 MSUB(123)=1 MSUB(124)=1 PMAS(25,1)=300D0 CKIN(1)=200D0 MSTP(81)=0 MSTP(111)=0 CALL PYINIT('CMS','p','p',PESUM) C...Z' production at SSC. ELSEIF(IPROC.EQ.6) THEN PESUM=40000D0 PZSUM=0D0 PQSUM=2D0 MSEL=21 PMAS(32,1)=600D0 CKIN(1)=400D0 MSTP(81)=0 MSTP(111)=0 CALL PYINIT('CMS','p','p',PESUM) C...W pair production at 1 TeV e+e- collider. ELSEIF(IPROC.EQ.7) THEN PESUM=1000D0 PZSUM=0D0 PQSUM=0D0 MSUB(25)=1 MSUB(69)=1 MSTP(11)=1 CALL PYINIT('CMS','e+','e-',PESUM) C...Deep inelastic scattering at a LEP+LHC ep collider. ELSEIF(IPROC.EQ.8) THEN P(1,1)=0D0 P(1,2)=0D0 P(1,3)=8000D0 P(2,1)=0D0 P(2,2)=0D0 P(2,3)=-80D0 PESUM=8080D0 PZSUM=7920D0 PQSUM=0D0 MSUB(10)=1 CKIN(3)=50D0 MSTP(111)=0 CALL PYINIT('3MOM','p','e-',PESUM) ENDIF C...Generate 20 events of each required type. DO 220 IEV=1,20 CALL PYEVNT PESUMM=PESUM IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM C...Check conservation of energy/momentum/flavour. PINI(1)=0D0 PINI(2)=0D0 PINI(3)=PZSUM PINI(4)=PESUMM PINI(6)=PQSUM DO 200 J=1,4 PFIN(J)=PYP(0,J) 200 CONTINUE PFIN(6)=PYP(0,6) MERR=0 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3)) DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2)) DEVQ=ABS(PFIN(6)-PINI(6)) IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR. & DEVQ.GT.0.1D0) MERR=1 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6), & (PFIN(J),J=1,4),PFIN(6) C...Check that all KF codes are known ones, and that partons/particles C...satisfy energy-momentum-mass relation. DO 210 I=1,N IF(K(I,1).GT.20) GOTO 210 IF(PYCOMP(K(I,2)).EQ.0) THEN WRITE(MSTU(11),5100) I MERR=MERR+1 ENDIF PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2* & SIGN(1D0,P(I,5)) IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2) & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN WRITE(MSTU(11),5200) I MERR=MERR+1 ENDIF 210 CONTINUE C...Listing of erroneous events, and first event of each type. IF(MERR.GE.1) NERR=NERR+1 IF(NERR.GE.10) THEN WRITE(MSTU(11),6300) CALL PYLIST(1) STOP ENDIF IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN IF(MERR.GE.1) WRITE(MSTU(11),6400) CALL PYLIST(1) ENDIF 220 CONTINUE C...List statistics for each process type. IF(MTEST.GE.1) CALL PYSTAT(1) 230 CONTINUE C...Summarize result of run. IF(NERR.EQ.0) WRITE(MSTU(11),6500) IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR C...Format statements for output. 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ', &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X, &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X, &4(1X,F12.5),1X,F8.2) 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code') 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ', &'kinematics') 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ', &'wrong.'/5X,'Execution will be stopped after listing of event.') 6400 FORMAT(5X,'Faulty event follows:') 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.') 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/ &5X,'This should not have happened!') RETURN END C********************************************************************* C...PYHEPC C...Converts PYTHIA event record contents to or from C...the standard event record commonblock. SUBROUTINE PYHEPC(MCONV) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...HEPEVT commonblock. PARAMETER (NMXHEP=4000) COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) DOUBLE PRECISION PHEP,VHEP SAVE /HEPEVT/ C...Conversion from PYTHIA to standard, the easy part. IF(MCONV.EQ.1) THEN NEVHEP=0 IF(N.GT.NMXHEP) CALL PYERRM(8, & '(PYHEPC:) no more space in /HEPEVT/') NHEP=MIN(N,NMXHEP) DO 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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYDAT4/CHAF(500,2) CHARACTER CHAF*16 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/, &/PYINT1/,/PYINT2/,/PYINT5/ C...Local arrays and character variables. DIMENSION ALAMIN(20),NFIN(20) CHARACTER*(*) FRAME,BEAM,TARGET CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6 C...Interface to PDFLIB. COMMON/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.. DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0, &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/, &NFIN/20*4/ DATA CHLH/'lepton','hadron'/ C...Reset MINT and VINT arrays. Write headers. MSTI(53)=0 DO 100 J=1,400 MINT(J)=0 VINT(J)=0D0 100 CONTINUE IF(MSTU(12).GE.1) CALL PYLIST(0) IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) C...Call user process initialization routine. IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN MSEL=0 CALL UPINIT MSEL=0 ENDIF C...Maximum 4 generations; set maximum number of allowed flavours. MSTP(1)=MIN(4,MSTP(1)) MSTU(114)=MIN(MSTU(114),2*MSTP(1)) MSTP(58)=MIN(MSTP(58),2*MSTP(1)) C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton. DO 120 I=-20,20 VINT(180+I)=0D0 IA=IABS(I) IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN DO 110 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110 IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)= & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2) 110 CONTINUE ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN VINT(180+I)=1D0 ENDIF 120 CONTINUE C...Initialize parton distributions: PDFLIB. IF(MSTP(52).EQ.2) THEN PARM(1)='NPTYPE' VALUE(1)=1 PARM(2)='NGROUP' VALUE(2)=MSTP(51)/1000 PARM(3)='NSET' VALUE(3)=MOD(MSTP(51),1000) PARM(4)='TMAS' VALUE(4)=PMAS(6,1) C.... ALICE CALL PDFSET_ALICE(PARM,VALUE) MINT(93)=1000000+MSTP(51) ENDIF C...Choose Lambda value to use in alpha-strong. MSTU(111)=MSTP(2) IF(MSTP(3).GE.2) THEN ALAM=0.2D0 NF=4 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN ALAM=ALAMIN(MSTP(51)) NF=NFIN(MSTP(51)) ELSEIF(MSTP(52).EQ.2) THEN ALAM=QCDL4 NF=4 ENDIF PARP(1)=ALAM PARP(61)=ALAM PARP(72)=ALAM PARU(112)=ALAM MSTU(112)=NF IF(MSTP(3).EQ.3) PARJ(81)=ALAM ENDIF C...Initialize the SUSY generation: couplings, masses, C...decay modes, branching ratios, and so on. CALL PYMSIN C...Initialize widths and partial widths for resonances. CALL PYINRE C...Set Z0 mass and width for e+e- routines. PARJ(123)=PMAS(23,1) PARJ(124)=PMAS(23,2) C...Identify beam and target particles and frame of process. CHFRAM=FRAME//' ' CHBEAM=BEAM//' ' CHTARG=TARGET//' ' CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN) IF(MINT(65).EQ.1) GOTO 170 C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives. C...For e-gamma allow 2 alternatives. MINT(121)=1 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13 ENDIF MINT(123)=MSTP(14) IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR. &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN IF(MSTP(14).EQ.11) MINT(123)=0 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6 IF(MSTP(14).EQ.15) MINT(123)=2 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7 IF(MSTP(14).EQ.19) MINT(123)=3 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN IF(MSTP(14).EQ.21) MINT(123)=0 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4 IF(MSTP(14).EQ.24) MINT(123)=1 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9 ENDIF C...Set up kinematics of process. CALL PYINKI(0) C...Set up kinematics for photons inside leptons. IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA) C...Precalculate flavour selection weights. CALL PYKFIN C...Loop over gamma-p or gamma-gamma alternatives. CKIN3=CKIN(3) MSAV48=0 DO 160 IGA=1,MINT(121) CKIN(3)=CKIN3 MINT(122)=IGA C...Select partonic subprocesses to be included in the simulation. CALL PYINPR MINT(101)=1 MINT(102)=1 MINT(103)=MINT(11) MINT(104)=MINT(12) C...Count number of subprocesses on. MINT(48)=0 DO 130 ISUB=1,500 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND. & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN MSUB(ISUB)=0 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND. & MSUB(ISUB).EQ.1) THEN WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42)) STOP ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN WRITE(MSTU(11),5300) ISUB STOP ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN WRITE(MSTU(11),5400) ISUB STOP ELSEIF(MSUB(ISUB).EQ.1) THEN MINT(48)=MINT(48)+1 ENDIF 130 CONTINUE C...Stop or raise warning flag if no subprocesses on. IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN IF(MSTP(127).NE.1) THEN WRITE(MSTU(11),5500) STOP ELSE WRITE(MSTU(11),5700) MSTI(53)=1 ENDIF ENDIF MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94) MSAV48=MSAV48+MINT(48) C...Reset variables for cross-section calculation. DO 150 I=0,500 DO 140 J=1,3 NGEN(I,J)=0 XSEC(I,J)=0D0 140 CONTINUE 150 CONTINUE C...Find parametrized total cross-sections. CALL PYXTOT VINT(318)=VINT(317) C...Maxima of differential cross-sections. IF(MSTP(121).LE.1) CALL PYMAXI C...Initialize possibility of pileup events. IF(MINT(121).GT.1) MSTP(131)=0 IF(MSTP(131).NE.0) CALL PYPILE(1) C...Initialize multiple interactions with variable impact parameter. IF(MINT(50).EQ.1.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. IF(MSAV48.EQ.0) THEN IF(MSTP(127).NE.1) THEN WRITE(MSTU(11),5500) STOP ELSE WRITE(MSTU(11),5700) MSTI(53)=1 ENDIF ENDIF 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600) C...Formats for initialization information. 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ', &'routines',1X,17('*')) 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6, &'-',A6,' interactions.'/1X,'Execution stopped!') 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/ &1X,'Execution stopped!') 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/ &1X,'Execution stopped!') 5500 FORMAT(1X,'Error: no subprocess switched on.'/ &1X,'Execution stopped.') 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X, &22('*')) 5700 FORMAT(1X,'Error: no subprocess switched on.'/ &1X,'Execution will stop if you try to generate events.') RETURN END C********************************************************************* C...PYEVNT C...Administers the generation of a high-pT event via calls to C...a number of subroutines. SUBROUTINE PYEVNT C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/, &/PYINT2/,/PYINT4/,/PYINT5/ C...Local array. DIMENSION VTX(4) C...Stop if no subprocesses on. IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN WRITE(MSTU(11),5100) STOP ENDIF C...Initial values for some counters. N=0 MINT(5)=MINT(5)+1 MINT(7)=0 MINT(8)=0 MINT(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 250 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 260 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 240 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN C...Hard scattering (including low-pT): C...reconstruct kinematics and colour flow of hard scattering. MINT31=MINT(31) 110 MINT(31)=MINT31 MINT(51)=0 CALL PYSCAT IF(MINT(51).EQ.1) GOTO 100 IPU1=MINT(84)+1 IPU2=MINT(84)+2 IF(ISUB.EQ.95) GOTO 120 C...Showering of initial state partons (optional). NFIN=N ALAMSV=PARJ(81) PARJ(81)=PARP(72) IF(MSTP(61).GE.1.AND.MINT(47).GE.2) CALL PYSSPA(IPU1,IPU2) PARJ(81)=ALAMSV IF(MINT(51).EQ.1) GOTO 100 C...Showering of final state partons (optional). ALAMSV=PARJ(81) PARJ(81)=PARP(72) IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10) & THEN IPU3=MINT(84)+3 IPU4=MINT(84)+4 IF(ISET(ISUB).EQ.5) IPU4=-3 QMAX=VINT(55) IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55) CALL PYSHOW(IPU3,IPU4,QMAX) ELSEIF(ISET(ISUB).EQ.11) THEN CALL PYADSH(NFIN) ENDIF PARJ(81)=ALAMSV C...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. 120 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 ELSEIF(ISUB.NE.99) THEN C...Diffractive and elastic scattering. CALL PYDIFF ELSE C...DIS scattering (photon flux external). CALL PYDISG IF(MINT(51).EQ.1) GOTO 100 ENDIF C...Check that no odd resonance left undecayed. IF(MSTP(111).GE.1) THEN NFIX=N DO 130 I=MINT(84)+1,NFIX IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND. & K(I,2).NE.22) THEN KCA=PYCOMP(K(I,2)) IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN CALL PYRESD(I) IF(MINT(51).EQ.1) GOTO 100 ENDIF ENDIF 130 CONTINUE ENDIF C...Boost hadronic subsystem to overall rest frame. C..(Only relevant when photon inside lepton beam.) IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA) C...Recalculate energies from momenta and masses (if desired). IF(MSTP(113).GE.1) THEN DO 140 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) 140 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 170 I=MINT(84)+1,N IF(K(I,2).EQ.94) THEN DO 160 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 150 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 150 CONTINUE IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3) ENDIF ENDIF 160 CONTINUE ENDIF 170 CONTINUE CALL PYEDIT(12) CALL PYEDIT(14) IF(MSTP(125).EQ.0) CALL PYEDIT(15) IF(MSTP(125).EQ.0) MINT(4)=0 DO 190 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 180 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 180 CONTINUE ENDIF 190 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 200 J=1,4 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))* & SIN(PARU(2)*PYR(0)) 200 CONTINUE DO 220 I=MINT(83)+1,N DO 210 J=1,4 V(I,J)=V(I,J)+VTX(J) 210 CONTINUE 220 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 230 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) 230 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. 240 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) 250 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. 260 CALL PYFRAM(MSTP(124)) MSTU(70)=MSTU70 PARU(21)=VINT(1) C...Error messages 5100 FORMAT(1X,'Error: no subprocess switched on.'/ &1X,'Execution stopped.') RETURN END C*********************************************************************** C...PYSTAT C...Prints out information about cross-sections, decay widths, branching C...ratios, kinematical limits, status codes and parameter values. SUBROUTINE PYSTAT(MSTAT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) PARAMETER (EPS=1D-3) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT6/PROC(0:500) CHARACTER PROC*28, CHTMP*16 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/ C...Local arrays, character variables and data. DIMENSION WDTP(0:300),WDTE(0:300,0:5),NMODES(0:20),PBRAT(10) CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16, &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28, &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28 CHARACTER*24 CHD0, CHDC(10) CHARACTER*6 DNAME(3) DATA PROGA/ &'VMD/hadron * VMD ','VMD/hadron * direct ', &'VMD/hadron * anomalous ','direct * direct ', &'direct * anomalous ','anomalous * anomalous '/ DATA DISGA/'e * VMD','e * anomalous'/ DATA PROGG9/ &'direct * direct ','direct * VMD ', &'direct * anomalous ','VMD * direct ', &'VMD * VMD ','VMD * anomalous ', &'anomalous * direct ','anomalous * VMD ', &'anomalous * anomalous ','DIS * VMD ', &'DIS * anomalous ','VMD * DIS ', &'anomalous * DIS '/ DATA PROGG4/ &'direct * direct ','direct * resolved ', &'resolved * direct ','resolved * resolved '/ DATA PROGG2/ &'direct * hadron ','resolved * hadron '/ DATA PROGP4/ &'VMD * hadron ','direct * hadron ', &'anomalous * hadron ','DIS * hadron '/ DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/, &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ', &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ', &' y*_small ',' eta*_large ',' eta*_small ', &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ', &' x_2 ',' x_F ',' cos(theta_hard) ', &'m''_hard (GeV/c^2) ',' tau ',' y* ', &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ', &' tau'' '/ DATA DNAME /'q ','lepton','nu '/ C...Cross-sections. IF(MSTAT.LE.1) THEN IF(MINT(121).GT.1) CALL PYSAVE(5,0) WRITE(MSTU(11),5000) WRITE(MSTU(11),5100) WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3) DO 100 I=1,500 IF(MSUB(I).NE.1) GOTO 100 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3) 100 CONTINUE IF(MINT(121).GT.1) THEN WRITE(MSTU(11),5300) DO 110 IGA=1,MINT(121) CALL PYSAVE(3,IGA) IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1), & XSEC(0,3) ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1), & XSEC(0,3) ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1), & XSEC(0,3) ELSEIF(MINT(121).EQ.4) THEN WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1), & XSEC(0,3) ELSEIF(MINT(121).EQ.2) THEN WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1), & XSEC(0,3) ELSE WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1), & XSEC(0,3) ENDIF 110 CONTINUE CALL PYSAVE(5,0) ENDIF WRITE(MSTU(11),5400) 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) ELSEIF(MSTAT.EQ.7) THEN WRITE (MSTU(11),8000) NMODES(0)=0 NMODES(10)=0 NMODES(9)=0 DO 290 ILR=1,2 DO 280 KFSM=1,16 KFSUSY=ILR*KSUSY1+KFSM NRVDC=0 C...SDOWN DECAYS IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN NRVDC=2 DO 190 I=1,NRVDC PBRAT(I)=0D0 NMODES(I)=0 190 CONTINUE CALL PYNAME(KFSUSY,CHTMP) CHD0=CHTMP//' ' CHDC(1)=DNAME(3) // ' + ' // DNAME(1) CHDC(2)=DNAME(2) // ' + ' // DNAME(1) KC=PYCOMP(KFSUSY) DO 200 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 ID1=IABS(KFDP(IDC,1)) ID2=IABS(KFDP(IDC,2)) IF (KFDP(IDC,3).EQ.0) THEN IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN PBRAT(1)=PBRAT(1)+BRAT(IDC) NMODES(1)=NMODES(1)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN PBRAT(2)=PBRAT(2)+BRAT(IDC) NMODES(2)=NMODES(2)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ENDIF ENDIF 200 CONTINUE ENDIF C...SUP DECAYS IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN NRVDC=1 DO 210 I=1,NRVDC NMODES(I)=0 PBRAT(I)=0D0 210 CONTINUE CALL PYNAME(KFSUSY,CHTMP) CHD0=CHTMP//' ' CHDC(1)=DNAME(2) // ' + ' // DNAME(1) KC=PYCOMP(KFSUSY) DO 220 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 ID1=IABS(KFDP(IDC,1)) ID2=IABS(KFDP(IDC,2)) IF (KFDP(IDC,3).EQ.0) THEN IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN PBRAT(1)=PBRAT(1)+BRAT(IDC) NMODES(1)=NMODES(1)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ENDIF ENDIF 220 CONTINUE ENDIF C...SLEPTON DECAYS IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN NRVDC=2 DO 230 I=1,NRVDC PBRAT(I)=0D0 NMODES(I)=0 230 CONTINUE CALL PYNAME(KFSUSY,CHTMP) CHD0=CHTMP//' ' CHDC(1)=DNAME(3) // ' + ' // DNAME(2) CHDC(2)=DNAME(1) // ' + ' // DNAME(1) KC=PYCOMP(KFSUSY) DO 240 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 ID1=IABS(KFDP(IDC,1)) ID2=IABS(KFDP(IDC,2)) IF (KFDP(IDC,3).EQ.0) THEN IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN PBRAT(1)=PBRAT(1)+BRAT(IDC) NMODES(1)=NMODES(1)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ENDIF IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN PBRAT(2)=PBRAT(2)+BRAT(IDC) NMODES(2)=NMODES(2)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ENDIF ENDIF 240 CONTINUE ENDIF C...SNEUTRINO DECAYS IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1) & THEN NRVDC=2 DO 250 I=1,NRVDC PBRAT(I)=0D0 NMODES(I)=0 250 CONTINUE CALL PYNAME(KFSUSY,CHTMP) CHD0=CHTMP//' ' CHDC(1)=DNAME(2) // ' + ' // DNAME(2) CHDC(2)=DNAME(1) // ' + ' // DNAME(1) KC=PYCOMP(KFSUSY) DO 260 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 ID1=IABS(KFDP(IDC,1)) ID2=IABS(KFDP(IDC,2)) IF (KFDP(IDC,3).EQ.0) THEN IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN PBRAT(1)=PBRAT(1)+BRAT(IDC) NMODES(1)=NMODES(1)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ENDIF IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN NMODES(2)=NMODES(2)+1 PBRAT(2)=PBRAT(2)+BRAT(IDC) IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ENDIF ENDIF 260 CONTINUE ENDIF IF (NRVDC.NE.0) THEN DO 270 I=1,NRVDC WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I) NMODES(0)=NMODES(0)+NMODES(I) 270 CONTINUE ENDIF 280 CONTINUE 290 CONTINUE DO 350 KFSM=22,37 KFSUSY=KSUSY1+KFSM NRVDC=0 C...NEUTRALINO DECAYS IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN NRVDC=3 DO 300 I=1,NRVDC PBRAT(I)=0D0 NMODES(I)=0 300 CONTINUE CALL PYNAME(KFSUSY,CHTMP) CHD0=CHTMP//' ' CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2) CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1) CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1) KC=PYCOMP(KFSUSY) DO 310 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 ID1=IABS(KFDP(IDC,1)) ID2=IABS(KFDP(IDC,2)) ID3=IABS(KFDP(IDC,3)) IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR & .ID3.EQ.13.OR.ID3.EQ.15)) THEN PBRAT(1)=PBRAT(1)+BRAT(IDC) NMODES(1)=NMODES(1)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN PBRAT(2)=PBRAT(2)+BRAT(IDC) NMODES(2)=NMODES(2)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN PBRAT(3)=PBRAT(3)+BRAT(IDC) NMODES(3)=NMODES(3)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ENDIF 310 CONTINUE ENDIF C...CHARGINO DECAYS IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN NRVDC=4 DO 320 I=1,NRVDC PBRAT(I)=0D0 NMODES(I)=0 320 CONTINUE CALL PYNAME(KFSUSY,CHTMP) CHD0=CHTMP//' ' CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2) CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2) CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1) CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1) KC=PYCOMP(KFSUSY) DO 330 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 ID1=IABS(KFDP(IDC,1)) ID2=IABS(KFDP(IDC,2)) ID3=IABS(KFDP(IDC,3)) IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR & .ID3.EQ.14.OR.ID3.EQ.16)) THEN PBRAT(1)=PBRAT(1)+BRAT(IDC) NMODES(1)=NMODES(1)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN PBRAT(1)=PBRAT(1)+BRAT(IDC) NMODES(1)=NMODES(1)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN PBRAT(2)=PBRAT(2)+BRAT(IDC) NMODES(2)=NMODES(2)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN PBRAT(3)=PBRAT(3)+BRAT(IDC) NMODES(3)=NMODES(3)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN PBRAT(3)=PBRAT(3)+BRAT(IDC) NMODES(3)=NMODES(3)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN PBRAT(4)=PBRAT(4)+BRAT(IDC) NMODES(4)=NMODES(4)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN PBRAT(4)=PBRAT(4)+BRAT(IDC) NMODES(4)=NMODES(4)+1 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 ENDIF 330 CONTINUE ENDIF IF (NRVDC.NE.0) THEN DO 340 I=1,NRVDC WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I) NMODES(0)=NMODES(0)+NMODES(I) 340 CONTINUE ENDIF 350 CONTINUE WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9) IF (IMSS(51).GE.1.OR.IMSS(52).GE.1) THEN WRITE (MSTU(11),8500) DO 380 IRV=1,3 DO 370 JRV=1,3 DO 360 KRV=1,3 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV) & ,RVLAMP(IRV,JRV,KRV), 0D0 360 CONTINUE 370 CONTINUE 380 CONTINUE WRITE (MSTU(11),8600) ENDIF ENDIF C...Formats for printouts. 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ', &'Events and Cross-sections',1X,9('*')) 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X, &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X, &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'), &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X, &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X, &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X, &'I',12X,'I') 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P, &D10.3,1X,'I') 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/ &1X,'I',34X,'I',28X,'I',12X,'I') 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')// &1X,'********* Fraction of events that fail fragmentation ', &'cuts =',1X,F8.5,' *********'/) 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ', &'Ratios',1X,27('*')) 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/ &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X, &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X, &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/ &1X,98('=')) 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X, &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X, &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I') 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X, &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X, &1P,D10.3,0P,1X,'I') 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X, &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X, &1P,D10.3,0P,1X,'I') 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('=')) 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/', &'Particles at Hard Interaction',1X,7('*')) 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X, &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X, &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X, &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X, &78('=')/1X,'I',38X,'I',37X,'I') 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I') 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('=')) 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ', &'Kinematical Variables',1X,12('*')) 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I') 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P, &16X,'I') 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A, &1X,'<',1X,1P,D10.3,0P,16X,'I') 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I') 7000 FORMAT(1X,'I',76X,'I'/1X,78('=')) 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ', &'Parameter Values',1X,12('*')) 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X, &'PARP(I)'/) 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3) 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes', &1X,13('*')) 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X, &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X, &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I') 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I') 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('=')) 8000 FORMAT(1X/ 1X/ & 17X,'Sums over R-Violating branching ratios',1X/ 1X & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X & ,'Mother --> Sum over final state flavours',4X,'I',2X & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I' & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I') 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/ & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I' & /1X,70('=')) 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X, & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I') 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I') 8500 FORMAT(1X/ 1X/ & 1X,'R-Violating couplings',1X/ 1X / & 1X,55('=')/ & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X & ,'I',15X,'I',15X,'I',15X,'I') 8600 FORMAT(1X,55('=')) 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I') RETURN END C********************************************************************* C...PYINRE C...Calculates full and effective widths of gauge bosons, stores C...masses and widths, rescales coefficients to be used for C...resonance production generation. SUBROUTINE PYINRE C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYDAT4/CHAF(500,2) CHARACTER CHAF*16 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT6/PROC(0:500) CHARACTER PROC*28 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/, &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/ C...Local arrays and data. DIMENSION WDTP(0:300),WDTE(0:300,0:5),WDTPM(0:300), &WDTEM(0:300,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)) IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41) DO 170 J=1,MDCY(KC,3) IDC=J+MDCY(KC,2)-1 BRAT(IDC)=0D0 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0) 170 CONTINUE ENDIF 180 CONTINUE C...Flavours of leptoquark: redefine charge and name. KFLQQ=KFDP(MDCY(42,2),1) KFLQL=KFDP(MDCY(42,2),2) KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+ &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL) LL=1 IF(IABS(KFLQL).EQ.13) LL=2 IF(IABS(KFLQL).EQ.15) LL=3 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)// &CHAF(IABS(KFLQL),1)(1:LL)//' ' CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar ' C...Special cases in treatment of gamma*/Z0: redefine process name. IF(MSTP(43).EQ.1) THEN PROC(1)='f + fbar -> gamma*' PROC(15)='f + fbar -> g + gamma*' PROC(19)='f + fbar -> gamma + gamma*' PROC(30)='f + g -> f + gamma*' PROC(35)='f + gamma -> f + gamma*' ELSEIF(MSTP(43).EQ.2) THEN PROC(1)='f + fbar -> Z0' PROC(15)='f + fbar -> g + Z0' PROC(19)='f + fbar -> gamma + Z0' PROC(30)='f + g -> f + Z0' PROC(35)='f + gamma -> f + Z0' ELSEIF(MSTP(43).EQ.3) THEN PROC(1)='f + fbar -> gamma*/Z0' PROC(15)='f + fbar -> g + gamma*/Z0' PROC(19)='f + fbar -> gamma + gamma*/Z0' PROC(30)='f + g -> f + gamma*/Z0' PROC(35)='f + gamma -> f + gamma*/Z0' ENDIF C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name. IF(MSTP(44).EQ.1) THEN PROC(141)='f + fbar -> gamma*' ELSEIF(MSTP(44).EQ.2) THEN PROC(141)='f + fbar -> Z0' ELSEIF(MSTP(44).EQ.3) THEN PROC(141)='f + fbar -> Z''0' ELSEIF(MSTP(44).EQ.4) THEN PROC(141)='f + fbar -> gamma*/Z0' ELSEIF(MSTP(44).EQ.5) THEN PROC(141)='f + fbar -> gamma*/Z''0' ELSEIF(MSTP(44).EQ.6) THEN PROC(141)='f + fbar -> Z0/Z''0' ELSEIF(MSTP(44).EQ.7) THEN PROC(141)='f + fbar -> gamma*/Z0/Z''0' ENDIF C...Special cases in treatment of WW -> WW: redefine process name. IF(MSTP(45).EQ.1) THEN PROC(77)='W+ + W+ -> W+ + W+' ELSEIF(MSTP(45).EQ.2) THEN PROC(77)='W+ + W- -> W+ + W-' ELSEIF(MSTP(45).EQ.3) THEN PROC(77)='W+/- + W+/- -> W+/- + W+/-' ENDIF C...Format for error information. 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ', &'combination'/1X,'Execution stopped!') RETURN END C********************************************************************* C...PYINBM C...Identifies the two incoming particles and the choice of frame. SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...User process initialization commonblock. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) SAVE /HEPRUP/ C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/ C...Local arrays, character variables and data. CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26, &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16 DIMENSION LEN(3),KCDE(39),PM(2) DATA CHALP/'abcdefghijklmnopqrstuvwxyz', &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ DATA CHCDE/ 'e- ','e+ ','nu_e ', &'nu_ebar ','mu- ','mu+ ','nu_mu ', &'nu_mubar ','tau- ','tau+ ','nu_tau ', &'nu_taubar ','pi+ ','pi- ','n0 ', &'nbar0 ','p+ ','pbar- ','gamma ', &'lambda0 ','sigma- ','sigma0 ','sigma+ ', &'xi- ','xi0 ','omega- ','pi0 ', &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ', &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ', &'k+ ','k- ','ks0 ','kl0 '/ DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16, &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222, &3312,3322,3334,111,110,990,6*22,321,-321,310,130/ C...Store initial energy. Default frame. VINT(290)=WIN MINT(111)=0 C...Special user process initialization; convert to normal input. IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN MINT(111)=11 CALL PYNAME(IDBMUP(1),CHNAME) CHBEAM=CHNAME(1:12) CALL PYNAME(IDBMUP(2),CHNAME) CHTARG=CHNAME(1:12) ENDIF C...Convert character variables to lowercase and find their length. CHCOM(1)=CHFRAM CHCOM(2)=CHBEAM CHCOM(3)=CHTARG DO 130 I=1,3 LEN(I)=12 DO 110 LL=12,1,-1 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1 DO 100 LA=1,26 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)= & CHALP(1)(LA:LA) 100 CONTINUE 110 CONTINUE CHIDNT(I)=CHCOM(I) C...Fix up bar, underscore and charge in particle name (if needed). DO 120 LL=1,10 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN CHTEMP=CHIDNT(I) CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' ' ENDIF 120 CONTINUE IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN CHTEMP=CHIDNT(I) CHIDNT(I)='nu_'//CHTEMP(3:7) ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN CHIDNT(I)(1:3)='n0 ' ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN CHIDNT(I)(1:5)='nbar0' ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN CHIDNT(I)(1:3)='p+ ' ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR. & CHIDNT(I)(1:2).EQ.'p-') THEN CHIDNT(I)(1:5)='pbar-' ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN CHIDNT(I)(7:7)='0' ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN CHIDNT(I)(1:7)='reggeon' ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN CHIDNT(I)(1:7)='pomeron' ENDIF 130 CONTINUE C...Identify free initialization. IF(CHCOM(1)(1:2).EQ.'no') THEN MINT(65)=1 RETURN ENDIF C...Identify incoming beam and target particles. DO 160 I=1,2 DO 140 J=1,39 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J) 140 CONTINUE PM(I)=PYMASS(MINT(10+I)) VINT(2+I)=PM(I) MINT(140+I)=0 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN CHTEMP=CHIDNT(I+1)(7:12)//' ' DO 150 J=1,12 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J) 150 CONTINUE PM(I)=PYMASS(MINT(140+I)) VINT(302+I)=PM(I) ENDIF 160 CONTINUE IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2)) IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3)) IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) STOP C...Identify choice of frame and input energies. CHINIT=' ' C...Events defined in the CM frame. IF(CHCOM(1)(1:2).EQ.'cm') THEN MINT(111)=1 S=WIN**2 IF(MSTP(122).GE.1) THEN IF(CHCOM(2)(1:1).NE.'e') THEN LOFFS=(31-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' collider'//' ' ELSE LOFFS=(30-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' collider'//' ' ENDIF WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),5300) WIN ENDIF C...Events defined in fixed target frame. ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN MINT(111)=2 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2) IF(MSTP(122).GE.1) THEN LOFFS=(29-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' fixed target'//' ' WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),5400) WIN WRITE(MSTU(11),5500) SQRT(S) ENDIF C...Frame defined by user three-vectors. ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN MINT(111)=3 P(1,5)=PM(1) P(2,5)=PM(2) P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2) P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2) S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2- & (P(1,3)+P(2,3))**2 IF(MSTP(122).GE.1) THEN LOFFS=(22-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' user configuration'//' ' WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),5600) WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4) WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4) WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) ENDIF C...Frame defined by user four-vectors. ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN MINT(111)=4 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1) PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2) S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2- & (P(1,3)+P(2,3))**2 IF(MSTP(122).GE.1) THEN LOFFS=(22-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' user configuration'//' ' WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),5600) WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4) WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4) WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) ENDIF C...Frame defined by user five-vectors. ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN MINT(111)=5 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2- & (P(1,3)+P(2,3))**2 IF(MSTP(122).GE.1) THEN LOFFS=(22-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' user configuration'//' ' WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),5600) WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4) WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4) WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) ENDIF C...Frame defined by HEPRUP common block. ELSEIF(MINT(111).EQ.11) THEN S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))- & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2 IF(MSTP(122).GE.1) THEN LOFFS=(22-(LEN(2)+LEN(3)))/2 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// & ' user configuration'//' ' WRITE(MSTU(11),5200) CHINIT WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2) WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) ENDIF C...Unknown frame. Error for too low CM energy. ELSE WRITE(MSTU(11),5800) CHFRAM(1:LEN(1)) STOP ENDIF IF(S.LT.PARP(2)**2) THEN WRITE(MSTU(11),5900) SQRT(S) STOP ENDIF C...Formats for initialization and error information. 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/ &1X,'Execution stopped!') 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/ &1X,'Execution stopped!') 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I') 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy', &19X,'I'/1X,'I',76X,'I'/1X,78('=')) 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I') 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X, &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('=')) 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X, &'pz (GeV/c)',6X,'E (GeV)',9X,'I') 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I') 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/ &1X,'Execution stopped!') 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ', &'generation.'/1X,'Execution stopped!') 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X, &'GeV beam energies',13X,'I') RETURN END C********************************************************************* C...PYINKI C...Sets up kinematics, including rotations and boosts to/from CM frame. SUBROUTINE PYINKI(MODKI) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...User process initialization commonblock. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) SAVE /HEPRUP/ C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/ C...Set initial flavour state. N=2 DO 100 I=1,2 K(I,1)=1 K(I,2)=MINT(10+I) IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I) 100 CONTINUE C...Reset boost. Do kinematics for various cases. DO 110 J=6,10 VINT(J)=0D0 110 CONTINUE C...Set up kinematics for events defined in CM frame. IF(MINT(111).EQ.1) THEN WIN=VINT(290) IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290) S=WIN**2 P(1,5)=VINT(3) P(2,5)=VINT(4) IF(MINT(141).NE.0) P(1,5)=VINT(303) IF(MINT(142).NE.0) P(2,5)=VINT(304) P(1,1)=0D0 P(1,2)=0D0 P(2,1)=0D0 P(2,2)=0D0 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/ & (4D0*S)) P(2,3)=-P(1,3) P(1,4)=SQRT(P(1,3)**2+P(1,5)**2) P(2,4)=SQRT(P(2,3)**2+P(2,5)**2) C...Set up kinematics for fixed target events. ELSEIF(MINT(111).EQ.2) THEN WIN=VINT(290) IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290) P(1,5)=VINT(3) P(2,5)=VINT(4) IF(MINT(141).NE.0) P(1,5)=VINT(303) IF(MINT(142).NE.0) P(2,5)=VINT(304) P(1,1)=0D0 P(1,2)=0D0 P(2,1)=0D0 P(2,2)=0D0 P(1,3)=WIN P(1,4)=SQRT(P(1,3)**2+P(1,5)**2) P(2,3)=0D0 P(2,4)=P(2,5) S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4) VINT(10)=P(1,3)/(P(1,4)+P(2,4)) CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10)) C...Set up kinematics for events in user-defined frame. ELSEIF(MINT(111).EQ.3) THEN P(1,5)=VINT(3) P(2,5)=VINT(4) IF(MINT(141).NE.0) P(1,5)=VINT(303) IF(MINT(142).NE.0) P(2,5)=VINT(304) P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2) P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2) DO 120 J=1,3 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4)) 120 CONTINUE CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) VINT(7)=PYANGL(P(1,1),P(1,2)) CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) VINT(6)=PYANGL(P(1,3),P(1,1)) CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3)) C...Set up kinematics for events with user-defined four-vectors. ELSEIF(MINT(111).EQ.4) THEN PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1) PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2) DO 130 J=1,3 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4)) 130 CONTINUE CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) VINT(7)=PYANGL(P(1,1),P(1,2)) CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) VINT(6)=PYANGL(P(1,3),P(1,1)) CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) S=(P(1,4)+P(2,4))**2 C...Set up kinematics for events with user-defined five-vectors. ELSEIF(MINT(111).EQ.5) THEN DO 140 J=1,3 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4)) 140 CONTINUE CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) VINT(7)=PYANGL(P(1,1),P(1,2)) CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) VINT(6)=PYANGL(P(1,3),P(1,1)) CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) S=(P(1,4)+P(2,4))**2 C...Set up kinematics for events with external user processes. ELSEIF(MINT(111).EQ.11) THEN P(1,5)=VINT(3) P(2,5)=VINT(4) IF(MINT(141).NE.0) P(1,5)=VINT(303) IF(MINT(142).NE.0) P(2,5)=VINT(304) P(1,1)=0D0 P(1,2)=0D0 P(2,1)=0D0 P(2,2)=0D0 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2)) P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2)) P(1,4)=EBMUP(1) P(2,4)=EBMUP(2) VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4)) CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10)) S=(P(1,4)+P(2,4))**2 ENDIF C...Return or error for too low CM energy. IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN IF(MSTP(172).LE.1) THEN CALL PYERRM(23, & '(PYINKI:) too low invariant mass in this event') ELSE MSTI(61)=1 RETURN ENDIF ENDIF C...Save information on incoming particles. VINT(1)=SQRT(S) VINT(2)=S IF(MINT(111).GE.4) THEN IF(MINT(141).EQ.0) THEN VINT(3)=P(1,5) IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2 ELSE VINT(303)=P(1,5) ENDIF IF(MINT(142).EQ.0) THEN VINT(4)=P(2,5) IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2 ELSE VINT(304)=P(2,5) ENDIF ENDIF VINT(5)=P(1,3) IF(MODKI.EQ.0) VINT(289)=S DO 150 J=1,5 V(1,J)=0D0 V(2,J)=0D0 VINT(290+J)=P(1,J) VINT(295+J)=P(2,J) 150 CONTINUE C...Store pT cut-off and related constants to be used in generation. IF(MODKI.EQ.0) VINT(285)=CKIN(3) IF(MSTP(82).LE.1) THEN PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90) ELSE PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) ENDIF VINT(149)=4D0*PTMN**2/S VINT(154)=PTMN RETURN END C********************************************************************* C...PYINPR C...Selects partonic subprocesses to be included in the simulation. SUBROUTINE PYINPR C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...User process initialization commonblock. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) SAVE /HEPRUP/ C...Commonblocks and character variables. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT6/PROC(0:500) CHARACTER PROC*28 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/, &/PYINT6/ CHARACTER CHIPR*10 C...Reset processes to be included. IF(MSEL.NE.0) THEN DO 100 I=1,500 MSUB(I)=0 100 CONTINUE ENDIF C...Set running pTmin scale. IF(MSTP(82).LE.1) THEN PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90) ELSE PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) ENDIF C...Begin by assuming incoming photon to enter subprocess. IF(MINT(11).EQ.22) MINT(15)=22 IF(MINT(12).EQ.22) MINT(16)=22 C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous. IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN MSUB(10)=1 MINT(123)=MINT(122)+1 C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30 C...allow mixture. C...Here also set a few parameters otherwise normally not touched. ELSEIF(MINT(121).GT.1) THEN C...Parton distributions dampened at small Q2; go to low energies, C...alpha_s <1; no minimum pT cut-off a priori. IF(MSTP(18).EQ.2) THEN MSTP(57)=3 PARP(2)=2D0 PARU(115)=1D0 CKIN(5)=0.2D0 CKIN(6)=0.2D0 ENDIF C...Define pT cut-off parameters and whether run involves low-pT. PTMVMD=PTMRUN VINT(154)=PTMVMD PTMDIR=PTMVMD IF(MSTP(18).EQ.2) PTMDIR=PARP(15) PTMANO=PTMVMD IF(MSTP(15).EQ.5) PTMANO=0.60D0+ & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2 IPTL=1 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0 IF(MSEL.EQ.2) IPTL=1 C...Set up for p/gamma * gamma; real or virtual photons. IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND. & MSTP(14).EQ.30)) THEN C...Set up for p/VMD * VMD. IF(MINT(122).EQ.1) THEN MINT(123)=2 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 C...Set up for p/VMD * direct gamma. ELSEIF(MINT(122).EQ.2) THEN MINT(123)=0 IF(MINT(121).EQ.6) MINT(123)=5 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for p/VMD * anomalous gamma. ELSEIF(MINT(122).EQ.3) THEN MINT(123)=3 IF(MINT(121).EQ.6) MINT(123)=7 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 C...Set up for DIS * p. ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR. & IABS(MINT(12)).GT.100)) THEN MINT(123)=8 IF(IPTL.EQ.1) MSUB(99)=1 C...Set up for direct * direct gamma (switch off leptons). ELSEIF(MINT(122).EQ.4) THEN MINT(123)=0 MSUB(137)=1 MSUB(138)=1 MSUB(139)=1 MSUB(140)=1 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) 110 CONTINUE IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for direct * anomalous gamma. ELSEIF(MINT(122).EQ.5) THEN MINT(123)=6 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMANO C...Set up for anomalous * anomalous gamma. ELSEIF(MINT(122).EQ.6) THEN MINT(123)=3 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 ENDIF C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom. ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN C...Set up for direct * direct gamma (switch off leptons). IF(MINT(122).EQ.1) THEN MINT(123)=0 MSUB(137)=1 MSUB(138)=1 MSUB(139)=1 MSUB(140)=1 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) 120 CONTINUE IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for direct * VMD and VMD * direct gamma. ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN MINT(123)=5 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for direct * anomalous and anomalous * direct gamma. ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN MINT(123)=6 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMANO C...Set up for VMD*VMD. ELSEIF(MINT(122).EQ.5) THEN MINT(123)=2 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 C...Set up for VMD * anomalous and anomalous * VMD gamma. ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN MINT(123)=7 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 C...Set up for anomalous * anomalous gamma. ELSEIF(MINT(122).EQ.9) THEN MINT(123)=3 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 C...Set up for DIS * VMD and VMD * DIS gamma. ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN MINT(123)=8 IF(IPTL.EQ.1) MSUB(99)=1 C...Set up for DIS * anomalous and anomalous * DIS gamma. ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN MINT(123)=9 IF(IPTL.EQ.1) MSUB(99)=1 ENDIF C...Set up for gamma* * p; virtual photons = dir, res. ELSEIF(MINT(121).EQ.2) THEN C...Set up for direct * p. IF(MINT(122).EQ.1) THEN MINT(123)=0 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for resolved * p. ELSEIF(MINT(122).EQ.2) THEN MINT(123)=1 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 ENDIF C...Set up for gamma* * gamma*; virtual photons = dir, res. ELSEIF(MINT(121).EQ.4) THEN C...Set up for direct * direct gamma (switch off leptons). IF(MINT(122).EQ.1) THEN MINT(123)=0 MSUB(137)=1 MSUB(138)=1 MSUB(139)=1 MSUB(140)=1 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) 130 CONTINUE IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for direct * resolved and resolved * direct gamma. ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN MINT(123)=5 MSUB(131)=1 MSUB(132)=1 MSUB(135)=1 MSUB(136)=1 IF(IPTL.EQ.1) CKIN(3)=PTMDIR C...Set up for resolved * resolved gamma. ELSEIF(MINT(122).EQ.4) THEN MINT(123)=2 MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 IF(IPTL.EQ.1) MSUB(95)=1 IF(MSEL.EQ.2) THEN MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 ENDIF IF(IPTL.EQ.1) CKIN(3)=0D0 ENDIF C...End of special set up for gamma-p and gamma-gamma. ENDIF CKIN(1)=2D0*CKIN(3) ENDIF C...Flavour information for individual beams. DO 140 I=1,2 MINT(40+I)=1 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2 MINT(44+I)=MINT(40+I) IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR. & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3 140 CONTINUE C...If two real gammas, whereof one direct, pick the first. C...For two virtual photons, keep requested order. IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN MINT(41)=1 MINT(45)=1 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR. & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN MINT(41)=1 MINT(45)=1 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR. & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN MINT(42)=1 MINT(46)=1 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN MINT(41)=1 MINT(45)=1 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN MINT(42)=1 MINT(46)=1 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN MINT(41)=1 MINT(45)=1 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN MINT(42)=1 MINT(46)=1 ENDIF ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN IF(MINT(11).EQ.22) THEN MINT(41)=1 MINT(45)=1 ELSE MINT(42)=1 MINT(46)=1 ENDIF ENDIF IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26, & '(PYINPR:) unallowed MSTP(14) code for single photon') ENDIF C...Flavour information on combination of incoming particles. MINT(43)=2*MINT(41)+MINT(42)-2 MINT(44)=MINT(43) IF(MINT(123).LE.0) THEN IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1 ELSEIF(MINT(123).LE.3) THEN IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN MINT(43)=4 MINT(44)=1 ENDIF MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7 MINT(50)=0 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) MINT(50)=1 MINT(107)=0 MINT(108)=0 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12) & MINT(107)=2 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13) & MINT(107)=3 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR. & MINT(122).EQ.10) MINT(108)=2 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR. & MINT(122).EQ.11) MINT(108)=3 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN IF(MINT(122).GE.3) MINT(107)=1 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1 ELSEIF(MINT(121).EQ.2) THEN IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1 ELSE IF(MINT(11).EQ.22) THEN MINT(107)=MINT(123) IF(MINT(123).GE.4) MINT(107)=0 IF(MINT(123).EQ.7) MINT(107)=2 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4 IF(MSTP(14).EQ.28) MINT(107)=2 IF(MSTP(14).EQ.29) MINT(107)=3 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4) & MINT(107)=4 ENDIF IF(MINT(12).EQ.22) THEN MINT(108)=MINT(123) IF(MINT(123).GE.4) MINT(108)=MINT(123)-3 IF(MINT(123).EQ.7) MINT(108)=3 IF(MSTP(14).EQ.26) MINT(108)=2 IF(MSTP(14).EQ.27) MINT(108)=3 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4) & MINT(108)=4 ENDIF IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR. & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN MINTTP=MINT(107) MINT(107)=MINT(108) MINT(108)=MINTTP ENDIF ENDIF IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0 C...Select default processes according to incoming beams C...(already done for gamma-p and gamma-gamma with C...MSTP(14) = 10, 20, 25 or 30). IF(MINT(121).GT.1) THEN ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN IF(MINT(43).EQ.1) THEN C...Lepton + lepton -> gamma/Z0 or W. IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND. & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN C...Unresolved photon + lepton: Compton scattering. MSUB(133)=1 MSUB(134)=1 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22 & .OR.MINT(12).EQ.22)) THEN C...DIS as pure gamma* + f -> f process. MSUB(99)=1 ELSEIF(MINT(43).LE.3) THEN C...Lepton + hadron: deep inelastic scattering. MSUB(10)=1 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND. & MINT(12).EQ.22) THEN C...Two unresolved photons: fermion pair production, C...exclude lepton pairs. DO 150 ISUB=137,140 MSUB(ISUB)=1 150 CONTINUE DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) 160 CONTINUE PTMDIR=PTMRUN IF(MSTP(18).EQ.2) PTMDIR=PARP(15) IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR CKIN(1)=MAX(CKIN(1),2D0*CKIN(3)) ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22)) & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND. & MINT(12).EQ.22)) THEN C...Unresolved photon + hadron: photon-parton scattering. DO 170 ISUB=131,136 MSUB(ISUB)=1 170 CONTINUE ELSEIF(MSEL.EQ.1) THEN C...High-pT QCD processes: MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 PTMN=PTMRUN VINT(154)=PTMN IF(CKIN(3).LT.PTMN) MSUB(95)=1 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0 ELSE C...All QCD processes: MSUB(11)=1 MSUB(12)=1 MSUB(13)=1 MSUB(28)=1 MSUB(53)=1 MSUB(68)=1 MSUB(91)=1 MSUB(92)=1 MSUB(93)=1 MSUB(94)=1 MSUB(95)=1 ENDIF ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN C...Heavy quark production. MSUB(81)=1 MSUB(82)=1 MSUB(84)=1 DO 180 J=1,MIN(8,MDCY(21,3)) MDME(MDCY(21,2)+J-1,1)=0 180 CONTINUE MDME(MDCY(21,2)+MSEL-1,1)=1 MSUB(85)=1 DO 190 J=1,MIN(12,MDCY(22,3)) MDME(MDCY(22,2)+J-1,1)=0 190 CONTINUE MDME(MDCY(22,2)+MSEL-1,1)=1 ELSEIF(MSEL.EQ.10) THEN C...Prompt photon production: MSUB(14)=1 MSUB(18)=1 MSUB(29)=1 ELSEIF(MSEL.EQ.11) THEN C...Z0/gamma* production: MSUB(1)=1 ELSEIF(MSEL.EQ.12) THEN C...W+/- production: MSUB(2)=1 ELSEIF(MSEL.EQ.13) THEN C...Z0 + jet: MSUB(15)=1 MSUB(30)=1 ELSEIF(MSEL.EQ.14) THEN C...W+/- + jet: MSUB(16)=1 MSUB(31)=1 ELSEIF(MSEL.EQ.15) THEN C...Z0 & W+/- pair production: MSUB(19)=1 MSUB(20)=1 MSUB(22)=1 MSUB(23)=1 MSUB(25)=1 ELSEIF(MSEL.EQ.16) THEN C...h0 production: MSUB(3)=1 MSUB(102)=1 MSUB(103)=1 MSUB(123)=1 MSUB(124)=1 ELSEIF(MSEL.EQ.17) THEN C...h0 & Z0 or W+/- pair production: MSUB(24)=1 MSUB(26)=1 ELSEIF(MSEL.EQ.18) THEN C...h0 production; interesting processes in e+e-. MSUB(24)=1 MSUB(103)=1 MSUB(123)=1 MSUB(124)=1 ELSEIF(MSEL.EQ.19) THEN C...h0, H0 and A0 production; interesting processes in e+e-. MSUB(24)=1 MSUB(103)=1 MSUB(123)=1 MSUB(124)=1 MSUB(153)=1 MSUB(171)=1 MSUB(173)=1 MSUB(174)=1 MSUB(158)=1 MSUB(176)=1 MSUB(178)=1 MSUB(179)=1 ELSEIF(MSEL.EQ.21) THEN C...Z'0 production: MSUB(141)=1 ELSEIF(MSEL.EQ.22) THEN C...W'+/- production: MSUB(142)=1 ELSEIF(MSEL.EQ.23) THEN C...H+/- production: MSUB(143)=1 ELSEIF(MSEL.EQ.24) THEN C...R production: MSUB(144)=1 ELSEIF(MSEL.EQ.25) THEN C...LQ (leptoquark) production. MSUB(145)=1 MSUB(162)=1 MSUB(163)=1 MSUB(164)=1 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN C...Production of one heavy quark (W exchange): MSUB(83)=1 DO 200 J=1,MIN(8,MDCY(21,3)) MDME(MDCY(21,2)+J-1,1)=0 200 CONTINUE MDME(MDCY(21,2)+MSEL-31,1)=1 CMRENNA++Define SUSY alternatives. ELSEIF(MSEL.EQ.39) THEN C...Turn on all SUSY processes. IF(MINT(43).EQ.4) THEN C...Hadron-hadron processes. DO 210 I=201,301 IF(ISET(I).GE.0) MSUB(I)=1 210 CONTINUE ELSEIF(MINT(43).EQ.1) THEN C...Lepton-lepton processes: QED production of squarks. DO 220 I=201,214 MSUB(I)=1 220 CONTINUE MSUB(210)=0 MSUB(211)=0 MSUB(212)=0 DO 230 I=216,228 MSUB(I)=1 230 CONTINUE DO 240 I=261,263 MSUB(I)=1 240 CONTINUE MSUB(277)=1 MSUB(278)=1 ENDIF ELSEIF(MSEL.EQ.40) THEN C...Gluinos and squarks. IF(MINT(43).EQ.4) THEN MSUB(243)=1 MSUB(244)=1 MSUB(258)=1 MSUB(259)=1 MSUB(261)=1 MSUB(262)=1 MSUB(264)=1 MSUB(265)=1 DO 250 I=271,296 MSUB(I)=1 250 CONTINUE ELSEIF(MINT(43).EQ.1) THEN MSUB(277)=1 MSUB(278)=1 ENDIF ELSEIF(MSEL.EQ.41) THEN C...Stop production. MSUB(261)=1 MSUB(262)=1 MSUB(263)=1 IF(MINT(43).EQ.4) THEN MSUB(264)=1 MSUB(265)=1 ENDIF ELSEIF(MSEL.EQ.42) THEN C...Slepton production. DO 260 I=201,214 MSUB(I)=1 260 CONTINUE IF(MINT(43).NE.4) THEN MSUB(210)=0 MSUB(211)=0 MSUB(212)=0 ENDIF ELSEIF(MSEL.EQ.43) THEN C...Neutralino/Chargino + Gluino/Squark. IF(MINT(43).EQ.4) THEN DO 270 I=237,242 MSUB(I)=1 270 CONTINUE DO 280 I=246,257 MSUB(I)=1 280 CONTINUE ENDIF ELSEIF(MSEL.EQ.44) THEN C...Neutralino/Chargino pair production. IF(MINT(43).EQ.4) THEN DO 290 I=216,236 MSUB(I)=1 290 CONTINUE ELSEIF(MINT(43).EQ.1) THEN DO 300 I=216,228 MSUB(I)=1 300 CONTINUE ENDIF ELSEIF(MSEL.EQ.45) THEN C...Sbottom production. MSUB(287)=1 MSUB(288)=1 IF(MINT(43).EQ.4) THEN DO 310 I=281,296 MSUB(I)=1 310 CONTINUE ENDIF ELSEIF(MSEL.EQ.50) THEN DO 320 I=361,368 MSUB(I)=1 320 CONTINUE IF(MINT(43).EQ.4) THEN DO 330 I=370,377 MSUB(I)=1 330 CONTINUE ENDIF ENDIF C...Find heaviest new quark flavour allowed in processes 81-84. KFLQM=1 DO 340 I=1,MIN(8,MDCY(21,3)) IDC=I+MDCY(21,2)-1 IF(MDME(IDC,1).LE.0) GOTO 340 KFLQM=I 340 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 350 I=1,MIN(12,MDCY(22,3)) IDC=I+MDCY(22,2)-1 IF(MDME(IDC,1).LE.0) GOTO 350 KFLFM=KFDP(IDC,1) 350 CONTINUE IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND. &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7) MINT(56)=KFLFM KFPR(85,1)=KFLFM KFPR(85,2)=KFLFM C...Import relevant information on external user processes. IF(MINT(111).EQ.11) THEN IPYPR=0 DO 380 IUP=1,NPRUP C...Find next empty PYTHIA process number slot and enable it. 360 IPYPR=IPYPR+1 IF(IPYPR.GT.500) CALL PYERRM(26, & '(PYINPR.) no more empty slots for user processes') IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 360 ISET(IPYPR)=11 C...Overwrite KFPR with references back to process number and ID. KFPR(IPYPR,1)=IUP KFPR(IPYPR,2)=LPRUP(IUP) C...Process title. WRITE(CHIPR,'(I10)') LPRUP(IUP) ICHIN=1 DO 370 ICH=1,9 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1 370 CONTINUE PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' ' C...Switch on process. MSUB(IPYPR)=1 380 CONTINUE ENDIF RETURN END C********************************************************************* C...PYXTOT C...Parametrizes total, elastic and diffractive cross-sections C...for different energies and beams. Donnachie-Landshoff for C...total and Schuler-Sjostrand for elastic and diffractive. C...Process code IPROC: C...= 1 : p + p; C...= 2 : pbar + p; C...= 3 : pi+ + p; C...= 4 : pi- + p; C...= 5 : pi0 + p; C...= 6 : phi + p; C...= 7 : J/psi + p; C...= 11 : rho + rho; C...= 12 : rho + phi; C...= 13 : rho + J/psi; C...= 14 : phi + phi; C...= 15 : phi + J/psi; C...= 16 : J/psi + J/psi; C...= 21 : gamma + p (DL); C...= 22 : gamma + p (VDM). C...= 23 : gamma + pi (DL); C...= 24 : gamma + pi (VDM); C...= 25 : gamma + gamma (DL); C...= 26 : gamma + gamma (VDM). SUBROUTINE PYXTOT C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT7/SIGT(0:6,0:6,0:5) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/ C...Local arrays. DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20), &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8), &CEFFD(10,9),SIGTMP(6,0:5) C...Common constants. DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/, &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/, &FACDD/0.0084D0/ C...Number of multiple processes to be evaluated (= 0 : undefined). DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/ C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta). DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0, &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0, &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/ DATA YPAR/ &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0, &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0, &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/ C...Beam and target hadron class: C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi. DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/ DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/ C...Characteristic class masses, slope parameters, beta = sqrt(X). DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/ DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/ DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/ C...Fitting constants used in parametrizations of diffractive results. DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/ DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/ DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/ &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0, &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0, &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0, &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0, &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0, &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0, &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0, &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0, &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0, &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/ DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/ &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0, &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0, &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0, &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0, &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0, &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0, &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0, &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0, &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0, &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0, &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0, &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0, &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0, &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0, &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/ C...Parameters. Combinations of the energy. AEM=PARU(101) PMTH=PARP(102) S=VINT(2) SRT=VINT(1) SEPS=S**EPS SETA=S**ETA SLOG=LOG(S) C...Ratio of gamma/pi (for rescaling in parton distributions). VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/ &(XPAR(5)*SEPS+YPAR(5)*SETA) VINT(317)=1D0 IF(MINT(50).NE.1) RETURN C...Order flavours of incoming particles: KF1 < KF2. IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN KF1=IABS(MINT(11)) KF2=IABS(MINT(12)) IORD=1 ELSE KF1=IABS(MINT(12)) KF2=IABS(MINT(11)) IORD=2 ENDIF ISGN12=ISIGN(1,MINT(11)*MINT(12)) C...Find process number (for lookup tables). IF(KF1.GT.1000) THEN IPROC=1 IF(ISGN12.LT.0) IPROC=2 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN IPROC=3 IF(ISGN12.LT.0) IPROC=4 IF(KF1.EQ.111) IPROC=5 ELSEIF(KF1.GT.100) THEN IPROC=11 ELSEIF(KF2.GT.1000) THEN IPROC=21 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22 ELSEIF(KF2.GT.100) THEN IPROC=23 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24 ELSE IPROC=25 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26 ENDIF C... Number of multiple processes to be stored; beam/target side. NPR=NPROC(IPROC) MINT(101)=1 MINT(102)=1 IF(NPR.EQ.3) THEN MINT(100+IORD)=4 ELSEIF(NPR.EQ.6) THEN MINT(101)=4 MINT(102)=4 ENDIF N1=0 IF(MINT(101).EQ.4) N1=4 N2=0 IF(MINT(102).EQ.4) N2=4 C...Do not do any more for user-set or undefined cross-sections. IF(MSTP(31).LE.0) RETURN IF(NPR.EQ.0) CALL PYERRM(26, &'(PYXTOT:) cross section for this process not yet implemented') C...Parameters. Combinations of the energy. AEM=PARU(101) PMTH=PARP(102) S=VINT(2) SRT=VINT(1) SEPS=S**EPS SETA=S**ETA SLOG=LOG(S) C...Loop over multiple processes (for VDM). DO 110 I=1,NPR IF(NPR.EQ.1) THEN IPR=IPROC ELSEIF(NPR.EQ.3) THEN IPR=I+4 IF(KF2.LT.1000) IPR=I+10 ELSEIF(NPR.EQ.6) THEN IPR=I+10 ENDIF C...Evaluate hadron species, mass, slope contribution and fit number. IHA=IHADA(IPR) IHB=IHADB(IPR) PMA=PMHAD(IHA) PMB=PMHAD(IHB) BHA=BHAD(IHA) BHB=BHAD(IHB) ISD=IFITSD(IPR) IDD=IFITDD(IPR) C...Skip if energy too low relative to masses. DO 100 J=0,5 SIGTMP(I,J)=0D0 100 CONTINUE IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110 C...Total cross-section. Elastic slope parameter and cross-section. SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL C...Diffractive scattering A + B -> X + B. BSD=2D0*BHB SQML=(PMA+PMTH)**2 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2) SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/ & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP) BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/ & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB) SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2) C...Diffractive scattering A + B -> A + X. BSD=2D0*BHA SQML=(PMB+PMTH)**2 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6) SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/ & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP) BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/ & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX) SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2) C...Order single diffractive correctly. IF(IORD.EQ.2) THEN SIGSAV=SIGTMP(I,2) SIGTMP(I,2)=SIGTMP(I,3) SIGTMP(I,3)=SIGSAV ENDIF C...Double diffractive scattering A + B -> X1 + X2. YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2) DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2 SUM1=DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0)/(2D0*ALP) IF(YEFF.LE.0) SUM1=0D0 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2) SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC)))) SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC)))) SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/ & (2D0*ALP) SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC)))) SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC)))) SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/ & (2D0*ALP) BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB*PMRC))) SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)* & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX) SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4) C...Non-diffractive by unitarity. SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)- & SIGTMP(I,4) 110 CONTINUE C...Put temporary results in output array: only one process. IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN DO 120 J=0,5 SIGT(0,0,J)=SIGTMP(1,J) 120 CONTINUE C...Beam multiple processes. ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN IF(MINT(107).EQ.2) THEN VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2 ELSE VINT(317)=16D0*PARP(15)**2*VINT(154)**2/ & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307))) ENDIF IF(MSTP(20).GT.0) THEN VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20) ENDIF DO 140 I=1,4 IF(MINT(107).EQ.2) THEN CONV=(AEM/PARP(160+I))*VINT(317) ELSEIF(VINT(154).GT.PARP(15)) THEN CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2* & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317) ELSE CONV=0D0 ENDIF I1=MAX(1,I-1) DO 130 J=0,5 SIGT(I,0,J)=CONV*SIGTMP(I1,J) 130 CONTINUE 140 CONTINUE DO 150 J=0,5 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J) 150 CONTINUE C...Target multiple processes. ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN IF(MINT(108).EQ.2) THEN VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2 ELSE VINT(317)=16D0*PARP(15)**2*VINT(154)**2/ & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308))) ENDIF IF(MSTP(20).GT.0) THEN VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20) ENDIF DO 170 I=1,4 IF(MINT(108).EQ.2) THEN CONV=(AEM/PARP(160+I))*VINT(317) ELSEIF(VINT(154).GT.PARP(15)) THEN CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2* & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317) ELSE CONV=0D0 ENDIF IV=MAX(1,I-1) DO 160 J=0,5 SIGT(0,I,J)=CONV*SIGTMP(IV,J) 160 CONTINUE 170 CONTINUE DO 180 J=0,5 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J) 180 CONTINUE C...Both beam and target multiple processes. ELSE IF(MINT(107).EQ.2) THEN VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2 ELSE VINT(317)=16D0*PARP(15)**2*VINT(154)**2/ & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307))) ENDIF IF(MINT(108).EQ.2) THEN VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2 ELSE VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/ & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308))) ENDIF IF(MSTP(20).GT.0) THEN VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+ & VINT(308)))**MSTP(20) ENDIF DO 210 I1=1,4 DO 200 I2=1,4 IF(MINT(107).EQ.2) THEN CONV=(AEM/PARP(160+I1))*VINT(317) ELSEIF(VINT(154).GT.PARP(15)) THEN CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2* & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317) ELSE CONV=0D0 ENDIF IF(MINT(108).EQ.2) THEN CONV=CONV*(AEM/PARP(160+I2)) ELSEIF(VINT(154).GT.PARP(15)) THEN CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2* & (1D0/PARP(15)**2-1D0/VINT(154)**2) ELSE CONV=0D0 ENDIF IF(I1.LE.2) THEN IV=MAX(1,I2-1) ELSEIF(I2.LE.2) THEN IV=MAX(1,I1-1) ELSEIF(I1.EQ.I2) THEN IV=2*I1-2 ELSE IV=5 ENDIF DO 190 J=0,5 JV=J IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV) 190 CONTINUE 200 CONTINUE 210 CONTINUE DO 230 J=0,5 DO 220 I=1,4 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J) SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J) 220 CONTINUE SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J) 230 CONTINUE ENDIF C...Scale up uniformly for Donnachie-Landshoff parametrization. IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0) DO 260 I1=0,N1 DO 250 I2=0,N2 DO 240 J=0,5 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J) 240 CONTINUE 250 CONTINUE 260 CONTINUE ENDIF RETURN END C********************************************************************* C...PYMAXI C...Finds optimal set of coefficients for kinematical variable selection C...and the maximum of the part of the differential cross-section used C...in the event weighting. SUBROUTINE PYMAXI C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...User process initialization commonblock. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) SAVE /HEPRUP/ C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT6/PROC(0:500) CHARACTER PROC*28 COMMON/PYINT7/SIGT(0:6,0:6,0:5) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/ C...Local arrays, character variables and data. CHARACTER CVAR(4)*4 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500), &NAREL(7),WTREL(7),WTMAT(7,7),WTRELN(7),COEFU(7),COEFO(7), &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2) DATA CVAR/'tau ','tau''','y* ','cth '/ DATA SIGSSM/3*0D0/ C...Initial values and loop over subprocesses. NPOSI=0 VINT(143)=1D0 VINT(144)=1D0 XSEC(0,1)=0D0 DO 460 ISUB=1,500 MINT(1)=ISUB MINT(51)=0 C...Find maximum weight factors for photon flux. IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA) ENDIF C...Select subprocess to study: skip cases not applicable. IF(ISET(ISUB).EQ.11) THEN IF(MSUB(ISUB).NE.1) GOTO 460 C...User process intialization: cross section model dependent. IF(IABS(IDWTUP).EQ.1) THEN IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process') XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1))) ELSE IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND. & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process') IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process') XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1))) ENDIF IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)= & WTGAGA*XSEC(ISUB,1) NPOSI=NPOSI+1 GOTO 450 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN CALL PYSIGH(NCHN,SIGS) XSEC(ISUB,1)=SIGS IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)= & WTGAGA*XSEC(ISUB,1) IF(MSUB(ISUB).NE.1) GOTO 460 NPOSI=NPOSI+1 GOTO 450 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN CALL PYSIGH(NCHN,SIGS) XSEC(ISUB,1)=SIGS IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)= & WTGAGA*XSEC(ISUB,1) IF(XSEC(ISUB,1).EQ.0D0) THEN MSUB(ISUB)=0 ELSE NPOSI=NPOSI+1 ENDIF GOTO 450 ELSEIF(ISUB.EQ.96) THEN IF(MINT(50).EQ.0) GOTO 460 IF(MSUB(95).NE.1.AND.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 ISTSB=ISET(ISUB) IF(ISUB.EQ.96) ISTSB=2 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB MWTXS=0 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+ & MSUB(94)+MSUB(95).EQ.0) MWTXS=1 C...Find resonances (explicit or implicit in cross-section). MINT(72)=0 KFR1=0 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN KFR1=KFPR(ISUB,1) ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN KFR1=23 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172 & .OR.ISUB.EQ.177) THEN KFR1=24 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN KFR1=25 IF(MSTP(46).EQ.5) THEN KFR1=89 PMAS(89,1)=PARP(45) PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2) ENDIF ELSEIF(ISUB.EQ.194) THEN KFR1=KTECHN+113 ELSEIF(ISUB.EQ.195) THEN KFR1=KTECHN+213 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN KFR1=KTECHN+113 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN KFR1=KTECHN+213 ENDIF CKMX=CKIN(2) IF(CKMX.LE.0D0) CKMX=VINT(1) KCR1=PYCOMP(KFR1) IF(KFR1.NE.0) THEN IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR. & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0 ENDIF IF(KFR1.NE.0) THEN TAUR1=PMAS(KCR1,1)**2/VINT(2) IF(KFR1.EQ.KTECHN+113) THEN CALL PYTECM(S1,S2) TAUR1=S1/VINT(2) ENDIF GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2) MINT(72)=1 MINT(73)=KFR1 VINT(73)=TAUR1 VINT(74)=GAMR1 ENDIF KFR2=0 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368)) $ THEN KFR2=23 IF(ISUB.EQ.194) THEN KFR2=KTECHN+223 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN KFR2=KTECHN+223 ENDIF KCR2=PYCOMP(KFR2) TAUR2=PMAS(KCR2,1)**2/VINT(2) IF(KFR2.EQ.KTECHN+223) THEN CALL PYTECM(S1,S2) TAUR2=S2/VINT(2) ENDIF GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2) IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR. & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN MINT(72)=2 MINT(74)=KFR2 VINT(75)=TAUR2 VINT(76)=GAMR2 ELSEIF(KFR2.NE.0) THEN KFR1=KFR2 TAUR1=TAUR2 GAMR1=GAMR2 MINT(72)=1 MINT(73)=KFR1 VINT(73)=TAUR1 VINT(74)=GAMR1 KFR2=0 ENDIF ENDIF C...Find product masses and minimum pT of process. SQM3=0D0 SQM4=0D0 MINT(71)=0 VINT(71)=CKIN(3) VINT(80)=1D0 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN NBW=0 DO 110 I=1,2 PMMN(I)=0D0 IF(KFPR(ISUB,I).EQ.0) THEN ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT. & PARP(41)) THEN IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2 ELSE NBW=NBW+1 C...This prevents SUSY/t particles from becoming too light. KFLW=KFPR(ISUB,I) IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN KCW=PYCOMP(KFLW) PMMN(I)=PMAS(KCW,1) DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+ & PMAS(PYCOMP(KFDP(IDC,2)),1) IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+ & PMAS(PYCOMP(KFDP(IDC,3)),1) PMMN(I)=MIN(PMMN(I),PMSUM) ENDIF 100 CONTINUE ELSEIF(KFLW.EQ.6) THEN PMMN(I)=PMAS(24,1)+PMAS(5,1) ENDIF ENDIF 110 CONTINUE IF(NBW.GE.1) THEN CKIN41=CKIN(41) CKIN43=CKIN(43) CKIN(41)=MAX(PMMN(1),CKIN(41)) CKIN(43)=MAX(PMMN(2),CKIN(43)) CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4) CKIN(41)=CKIN41 CKIN(43)=CKIN43 IF(MINT(51).EQ.1) THEN WRITE(MSTU(11),5100) ISUB MSUB(ISUB)=0 GOTO 460 ENDIF SQM3=PQM3**2 SQM4=PQM4**2 ENDIF IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5)) IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90) ELSEIF(ISUB.EQ.96) THEN VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90) ENDIF ENDIF VINT(63)=SQM3 VINT(64)=SQM4 C...Prepare for additional variable choices in 2 -> 3. IF(ISTSB.EQ.5) THEN VINT(201)=0D0 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1) VINT(206)=VINT(201) VINT(204)=PMAS(23,1) IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1) IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1) IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187) 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).GE.5) THEN IF(ISTSB.LE.2.OR.ISTSB.GT.5) NPTS(1)=NPTS(1)+1 ENDIF NPTS(2)=1 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN IF(MINT(47).GE.2) NPTS(2)=2 IF(MINT(47).GE.5) NPTS(2)=3 ENDIF NPTS(3)=1 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN NPTS(3)=3 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1 ENDIF NPTS(4)=1 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4) C...Reset coefficients of cross-section weighting. DO 120 J=1,20 COEF(ISUB,J)=0D0 120 CONTINUE COEF(ISUB,1)=1D0 COEF(ISUB,8)=0.5D0 COEF(ISUB,9)=0.5D0 COEF(ISUB,13)=1D0 COEF(ISUB,18)=1D0 MCTH=0 MTAUP=0 METAUP=0 VINT(23)=0D0 VINT(26)=0D0 SIGSAM=0D0 C...Find limits and select tau, y*, cos(theta-hat) and tau' values, C...in grid of phase space points. CALL PYKLIM(1) METAU=MINT(51) NACC=0 DO 150 ITRY=1,NTRY MINT(51)=0 IF(METAU.EQ.1) GOTO 150 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4)) IF(MTAU.GT.2+2*MINT(72)) MTAU=7 RTAU=0.5D0 C...Special case when both resonances have same mass, C...as is often the case in process 194. IF(MINT(72).EQ.2) THEN IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT. & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN RTAU=0.4D0 ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN RTAU=0.6D0 ENDIF ENDIF ENDIF CALL PYKMAP(1,MTAU,RTAU) IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4) METAUP=MINT(51) ENDIF IF(METAUP.EQ.1) GOTO 150 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4)) & .EQ.0) THEN MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2)) CALL PYKMAP(4,MTAUP,0.5D0) ENDIF IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN CALL PYKLIM(2) MEYST=MINT(51) ENDIF IF(MEYST.EQ.1) GOTO 150 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3)) IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5 CALL PYKMAP(2,MYST,0.5D0) CALL PYKLIM(3) MECTH=MINT(51) ENDIF IF(MECTH.EQ.1) GOTO 150 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN MCTH=1+MOD(ITRY-1,NPTS(4)) CALL PYKMAP(3,MCTH,0.5D0) ENDIF IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2) C...Store position and limits. MINT(51)=0 CALL PYKLIM(0) IF(MINT(51).EQ.1) GOTO 150 NACC=NACC+1 MVARPT(NACC,1)=MTAU MVARPT(NACC,2)=MTAUP MVARPT(NACC,3)=MYST MVARPT(NACC,4)=MCTH DO 130 J=1,30 VINTPT(NACC,J)=VINT(10+J) 130 CONTINUE C...Normal case: calculate cross-section. IF(ISTSB.NE.5) THEN CALL PYSIGH(NCHN,SIGS) IF(MWTXS.EQ.1) THEN CALL PYEVWT(WTXS) SIGS=WTXS*SIGS ENDIF C..2 -> 3: find highest value out of a number of tries. ELSE SIGS=0D0 DO 140 IKIN3=1,MSTP(129) CALL PYKMAP(5,0,0D0) IF(MINT(51).EQ.1) GOTO 140 CALL PYSIGH(NCHN,SIGTMP) IF(MWTXS.EQ.1) THEN CALL PYEVWT(WTXS) SIGTMP=WTXS*SIGTMP ENDIF IF(SIGTMP.GT.SIGS) SIGS=SIGTMP 140 CONTINUE ENDIF C...Store cross-section. SIGSPT(NACC)=SIGS IF(SIGS.GT.SIGSAM) SIGSAM=SIGS IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP, & VINT(21),VINT(22),VINT(23),VINT(26),SIGS 150 CONTINUE IF(NACC.EQ.0) THEN WRITE(MSTU(11),5100) ISUB MSUB(ISUB)=0 GOTO 460 ELSEIF(SIGSAM.EQ.0D0) THEN WRITE(MSTU(11),5300) ISUB MSUB(ISUB)=0 GOTO 460 ENDIF IF(ISUB.NE.96) NPOSI=NPOSI+1 C...Calculate integrals in tau over maximal phase space limits. TAUMIN=VINT(11) TAUMAX=VINT(31) ATAU1=LOG(TAUMAX/TAUMIN) IF(NPTS(1).GE.2) THEN ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN) ENDIF IF(NPTS(1).GE.4) THEN ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/ & GAMR1 ENDIF IF(NPTS(1).GE.6) THEN ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/ & GAMR2 ENDIF IF(NPTS(1).GT.2+2*MINT(72)) THEN ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX)) ENDIF C...Reset. Sum up cross-sections in points calculated. DO 320 IVAR=1,4 IF(NPTS(IVAR).EQ.1) GOTO 320 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320 NBIN=NPTS(IVAR) DO 170 J1=1,NBIN NAREL(J1)=0 WTREL(J1)=0D0 COEFU(J1)=0D0 DO 160 J2=1,NBIN WTMAT(J1,J2)=0D0 160 CONTINUE 170 CONTINUE DO 180 IACC=1,NACC IBIN=MVARPT(IACC,IVAR) IF(IVAR.EQ.1.AND.IBIN.EQ.7) IBIN=3+2*MINT(72) IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4 NAREL(IBIN)=NAREL(IBIN)+1 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC) C...Sum up tau cross-section pieces in points used. IF(IVAR.EQ.1) THEN TAU=VINTPT(IACC,11) WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU IF(NBIN.GE.4) THEN WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1) WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/ & ((TAU-TAUR1)**2+GAMR1**2) ENDIF IF(NBIN.GE.6) THEN WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2) WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/ & ((TAU-TAUR2)**2+GAMR2**2) ENDIF IF(NBIN.GT.2+2*MINT(72)) THEN WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(ATAU1/ATAU7)* & TAU/MAX(2D-10,1D0-TAU) ENDIF C...Sum up tau' cross-section pieces in points used. ELSEIF(IVAR.EQ.2) THEN TAU=VINTPT(IACC,11) TAUP=VINTPT(IACC,16) TAUPMN=VINTPT(IACC,6) TAUPMX=VINTPT(IACC,26) ATAUP1=LOG(TAUPMX/TAUPMN) ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU) WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)* & (1D0-TAU/TAUP)**3/TAUP IF(NBIN.GE.3) THEN ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX)) WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)* & TAUP/MAX(2D-10,1D0-TAUP) ENDIF C...Sum up y* cross-section pieces in points used. ELSEIF(IVAR.EQ.3) THEN YST=VINTPT(IACC,12) YSTMIN=VINTPT(IACC,2) YSTMAX=VINTPT(IACC,22) AYST0=YSTMAX-YSTMIN AYST1=0.5D0*(YSTMAX-YSTMIN)**2 AYST2=AYST1 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN))) WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN) WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST) WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST) IF(MINT(45).EQ.3) THEN TAUE=VINTPT(IACC,11) IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16) YST0=-0.5D0*LOG(TAUE) AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/ & MAX(1D-10,EXP(YST0-YSTMAX)-1D0)) WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/ & MAX(1D-10,1D0-EXP(YST-YST0)) ENDIF IF(MINT(46).EQ.3) THEN TAUE=VINTPT(IACC,11) IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16) YST0=-0.5D0*LOG(TAUE) AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/ & MAX(1D-10,EXP(YST0+YSTMIN)-1D0)) WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/ & MAX(1D-10,1D0-EXP(-YST-YST0)) ENDIF C...Sum up cos(theta-hat) cross-section pieces in points used. ELSE RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2) RSQM=1D0+RM34 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2))) CTHMIN=-CTHMAX IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/ & (TAUMAX*VINT(2))) ACTH1=CTHMAX-CTHMIN ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX)) ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN)) ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN) ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX) CTH=VINTPT(IACC,13) WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/ & MAX(RM34,RSQM-CTH) WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/ & MAX(RM34,RSQM+CTH) WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/ & MAX(RM34,RSQM-CTH)**2 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/ & MAX(RM34,RSQM+CTH)**2 ENDIF 180 CONTINUE C...Check that equation system solvable. IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR) MSOLV=1 WTRELS=0D0 DO 190 IBIN=1,NBIN IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED), & IRED=1,NBIN),WTREL(IBIN) IF(NAREL(IBIN).EQ.0) MSOLV=0 WTRELS=WTRELS+WTREL(IBIN) 190 CONTINUE IF(ABS(WTRELS).LT.1D-20) MSOLV=0 C...Solve to find relative importance of cross-section pieces. IF(MSOLV.EQ.1) THEN DO 200 IBIN=1,NBIN WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS) 200 CONTINUE DO 230 IRED=1,NBIN-1 DO 220 IBIN=IRED+1,NBIN IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN MSOLV=0 GOTO 260 ENDIF RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED) WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED) DO 210 ICOE=IRED,NBIN WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE) 210 CONTINUE 220 CONTINUE 230 CONTINUE DO 250 IRED=NBIN,1,-1 DO 240 ICOE=IRED+1,NBIN WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE) 240 CONTINUE COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED) 250 CONTINUE ENDIF C...Share evenly if failure. 260 IF(MSOLV.EQ.0) THEN DO 270 IBIN=1,NBIN COEFU(IBIN)=1D0 WTRELN(IBIN)=0.1D0 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0, & WTREL(IBIN)/WTRELS) 270 CONTINUE ENDIF C...Normalize coefficients, with piece shared democratically. COEFSU=0D0 WTRELS=0D0 DO 280 IBIN=1,NBIN COEFU(IBIN)=MAX(0D0,COEFU(IBIN)) COEFSU=COEFSU+COEFU(IBIN) WTRELS=WTRELS+WTRELN(IBIN) 280 CONTINUE IF(COEFSU.GT.0D0) THEN DO 290 IBIN=1,NBIN COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0* & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS) 290 CONTINUE ELSE DO 300 IBIN=1,NBIN COEFO(IBIN)=1D0/NBIN 300 CONTINUE ENDIF IF(IVAR.EQ.1) IOFF=0 IF(IVAR.EQ.2) IOFF=17 IF(IVAR.EQ.3) IOFF=7 IF(IVAR.EQ.4) IOFF=12 DO 310 IBIN=1,NBIN ICOF=IOFF+IBIN IF(IVAR.EQ.1.AND.IBIN.GT.2+2*MINT(72)) ICOF=7 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1 COEF(ISUB,ICOF)=COEFO(IBIN) 310 CONTINUE IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR), & (COEFO(IBIN),IBIN=1,NBIN) 320 CONTINUE C...Find two most promising maxima among points previously determined. DO 330 J=1,4 IACCMX(J)=0 SIGSMX(J)=0D0 330 CONTINUE NMAX=0 DO 390 IACC=1,NACC DO 340 J=1,30 VINT(10+J)=VINTPT(IACC,J) 340 CONTINUE IF(ISTSB.NE.5) THEN CALL PYSIGH(NCHN,SIGS) IF(MWTXS.EQ.1) THEN CALL PYEVWT(WTXS) SIGS=WTXS*SIGS ENDIF ELSE SIGS=0D0 DO 350 IKIN3=1,MSTP(129) CALL PYKMAP(5,0,0D0) IF(MINT(51).EQ.1) GOTO 350 CALL PYSIGH(NCHN,SIGTMP) IF(MWTXS.EQ.1) THEN CALL PYEVWT(WTXS) SIGTMP=WTXS*SIGTMP ENDIF IF(SIGTMP.GT.SIGS) SIGS=SIGTMP 350 CONTINUE ENDIF IEQ=0 DO 360 IMV=1,NMAX IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV 360 CONTINUE IF(IEQ.EQ.0) THEN DO 370 IMV=NMAX,1,-1 IIN=IMV+1 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380 IACCMX(IMV+1)=IACCMX(IMV) SIGSMX(IMV+1)=SIGSMX(IMV) 370 CONTINUE IIN=1 380 IACCMX(IIN)=IACC SIGSMX(IIN)=SIGS IF(NMAX.LE.1) NMAX=NMAX+1 ENDIF 390 CONTINUE C...Read out starting position for search. IF(MSTP(122).GE.2) WRITE(MSTU(11),5700) SIGSAM=SIGSMX(1) DO 440 IMAX=1,NMAX IACC=IACCMX(IMAX) MTAU=MVARPT(IACC,1) MTAUP=MVARPT(IACC,2) MYST=MVARPT(IACC,3) MCTH=MVARPT(IACC,4) VTAU=0.5D0 VYST=0.5D0 VCTH=0.5D0 VTAUP=0.5D0 C...Starting point and step size in parameter space. DO 430 IRPT=1,2 DO 420 IVAR=1,4 IF(NPTS(IVAR).EQ.1) GOTO 420 IF(IVAR.EQ.1) VVAR=VTAU IF(IVAR.EQ.2) VVAR=VTAUP IF(IVAR.EQ.3) VVAR=VYST IF(IVAR.EQ.4) VVAR=VCTH IF(IVAR.EQ.1) MVAR=MTAU IF(IVAR.EQ.2) MVAR=MTAUP IF(IVAR.EQ.3) MVAR=MYST IF(IVAR.EQ.4) MVAR=MCTH IF(IRPT.EQ.1) VDEL=0.1D0 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0, & 0.98D0-VVAR)) IF(IRPT.EQ.1) VMAR=0.02D0 IF(IRPT.EQ.2) VMAR=0.002D0 IMOV0=1 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0 DO 410 IMOV=IMOV0,8 C...Define new point in parameter space. IF(IMOV.EQ.0) THEN INEW=2 VNEW=VVAR ELSEIF(IMOV.EQ.1) THEN INEW=3 VNEW=VVAR+VDEL ELSEIF(IMOV.EQ.2) THEN INEW=1 VNEW=VVAR-VDEL ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND. & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN VVAR=VVAR+VDEL SIGSSM(1)=SIGSSM(2) SIGSSM(2)=SIGSSM(3) INEW=3 VNEW=VVAR+VDEL ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND. & VVAR-2D0*VDEL.GT.VMAR) THEN VVAR=VVAR-VDEL SIGSSM(3)=SIGSSM(2) SIGSSM(2)=SIGSSM(1) INEW=1 VNEW=VVAR-VDEL ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN VDEL=0.5D0*VDEL VVAR=VVAR+VDEL SIGSSM(1)=SIGSSM(2) INEW=2 VNEW=VVAR ELSE VDEL=0.5D0*VDEL VVAR=VVAR-VDEL SIGSSM(3)=SIGSSM(2) INEW=2 VNEW=VVAR ENDIF C...Convert to relevant variables and find derived new limits. ILERR=0 IF(IVAR.EQ.1) THEN VTAU=VNEW CALL PYKMAP(1,MTAU,VTAU) IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN CALL PYKLIM(4) IF(MINT(51).EQ.1) ILERR=1 ENDIF ENDIF IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND. & ILERR.EQ.0) THEN IF(IVAR.EQ.2) VTAUP=VNEW CALL PYKMAP(4,MTAUP,VTAUP) ENDIF IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN CALL PYKLIM(2) IF(MINT(51).EQ.1) ILERR=1 ENDIF IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN IF(IVAR.EQ.3) VYST=VNEW CALL PYKMAP(2,MYST,VYST) CALL PYKLIM(3) IF(MINT(51).EQ.1) ILERR=1 ENDIF IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND. & ILERR.EQ.0) THEN IF(IVAR.EQ.4) VCTH=VNEW CALL PYKMAP(3,MCTH,VCTH) ENDIF IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2) C...Evaluate cross-section. Save new maximum. Final maximum. IF(ILERR.NE.0) THEN SIGS=0. ELSEIF(ISTSB.NE.5) THEN CALL PYSIGH(NCHN,SIGS) IF(MWTXS.EQ.1) THEN CALL PYEVWT(WTXS) SIGS=WTXS*SIGS ENDIF ELSE SIGS=0D0 DO 400 IKIN3=1,MSTP(129) CALL PYKMAP(5,0,0D0) IF(MINT(51).EQ.1) GOTO 400 CALL PYSIGH(NCHN,SIGTMP) IF(MWTXS.EQ.1) THEN CALL PYEVWT(WTXS) SIGTMP=WTXS*SIGTMP ENDIF IF(SIGTMP.GT.SIGS) SIGS=SIGTMP 400 CONTINUE ENDIF SIGSSM(INEW)=SIGS IF(SIGS.GT.SIGSAM) SIGSAM=SIGS IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR, & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS 410 CONTINUE 420 CONTINUE 430 CONTINUE 440 CONTINUE IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM XSEC(ISUB,1)=1.05D0*SIGSAM IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)= & WTGAGA*XSEC(ISUB,1) 450 CONTINUE IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)= & PARP(174)*XSEC(ISUB,1) IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1) 460 CONTINUE MINT(51)=0 C...Print summary table. IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN IF(MSTP(127).NE.1) THEN WRITE(MSTU(11),5900) STOP ELSE WRITE(MSTU(11),6400) MSTI(53)=1 ENDIF ENDIF IF(MSTP(122).GE.1) THEN WRITE(MSTU(11),6000) WRITE(MSTU(11),6100) DO 470 ISUB=1,500 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.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('=')) 6400 FORMAT(1X,'Error: no requested process has non-vanishing ', &'cross-section.'/ &1X,'Execution will stop if you try to generate events.') RETURN END C********************************************************************* C...PYPILE C...Initializes multiplicity distribution and selects mutliplicity C...of pileup events, i.e. several events occuring at the same C...beam crossing. SUBROUTINE PYPILE(MPILE) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT7/SIGT(0:6,0:6,0:5) SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/ C...Local arrays and saved variables. DIMENSION WTI(0:200) SAVE IMIN,IMAX,WTI,WTS C...Sum of allowed cross-sections for pileup events. IF(MPILE.EQ.1) THEN VINT(131)=SIGT(0,0,5) IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4) IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3) IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1) IF(MSTP(133).LE.0) RETURN C...Initialize multiplicity distribution at maximum. XNAVE=VINT(131)*PARP(131) IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE INAVE=MAX(1,MIN(200,NINT(XNAVE))) WTI(INAVE)=1D0 WTS=WTI(INAVE) WTN=WTI(INAVE)*INAVE C...Find shape of multiplicity distribution below maximum. IMIN=INAVE DO 100 I=INAVE-1,1,-1 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE IF(WTI(I).LT.1D-6) GOTO 110 WTS=WTS+WTI(I) WTN=WTN+WTI(I)*I IMIN=I 100 CONTINUE C...Find shape of multiplicity distribution above maximum. 110 IMAX=INAVE DO 120 I=INAVE+1,200 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1) IF(WTI(I).LT.1D-6) GOTO 130 WTS=WTS+WTI(I) WTN=WTN+WTI(I)*I IMAX=I 120 CONTINUE 130 VINT(132)=XNAVE VINT(133)=WTN/WTS IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)= & WTS/(WTS+WTI(1)/XNAVE) IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0 IF(MSTP(133).GE.2) VINT(134)=XNAVE C...Pick multiplicity of pileup events. ELSE IF(MSTP(133).LE.0) THEN MINT(81)=MAX(1,MSTP(134)) ELSE WTR=WTS*PYR(0) DO 140 I=IMIN,IMAX MINT(81)=I WTR=WTR-WTI(I) IF(WTR.LE.0D0) GOTO 150 140 CONTINUE 150 CONTINUE ENDIF ENDIF C...Format statement for error message. 5000 FORMAT(1X,'Warning: requested average number of events per bunch', &'crossing too large, ',1P,D12.4) RETURN END C********************************************************************* C...PYSAVE C...Saves and restores parameter and cross section values for the C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives. C...Also makes random choice between alternatives. SUBROUTINE PYSAVE(ISAVE,IGA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT7/SIGT(0:6,0:6,0:5) SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/ C...Local arrays and saved variables. DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20), &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5), &INTCP(15,20),RECP(15,20) SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP C...Save list of subprocesses and cross-section information. IF(ISAVE.EQ.1) THEN ICP=0 DO 120 I=1,500 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120 ICP=ICP+1 NSUBCP(IGA,ICP)=I MSUBCP(IGA,ICP)=MSUB(I) DO 100 J=1,20 COEFCP(IGA,ICP,J)=COEF(I,J) 100 CONTINUE DO 110 J=1,3 NGENCP(IGA,ICP,J)=NGEN(I,J) XSECCP(IGA,ICP,J)=XSEC(I,J) 110 CONTINUE 120 CONTINUE NCP(IGA)=ICP DO 130 J=1,3 NGENCP(IGA,0,J)=NGEN(0,J) XSECCP(IGA,0,J)=XSEC(0,J) 130 CONTINUE DO 160 I1=0,6 DO 150 I2=0,6 DO 140 J=0,5 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J) 140 CONTINUE 150 CONTINUE 160 CONTINUE C...Save various common process variables. DO 170 J=1,10 INTCP(IGA,J)=MINT(40+J) 170 CONTINUE INTCP(IGA,11)=MINT(101) INTCP(IGA,12)=MINT(102) INTCP(IGA,13)=MINT(107) INTCP(IGA,14)=MINT(108) INTCP(IGA,15)=MINT(123) RECP(IGA,1)=CKIN(3) RECP(IGA,2)=VINT(318) C...Save cross-section information only. ELSEIF(ISAVE.EQ.2) THEN DO 190 ICP=1,NCP(IGA) I=NSUBCP(IGA,ICP) DO 180 J=1,3 NGENCP(IGA,ICP,J)=NGEN(I,J) XSECCP(IGA,ICP,J)=XSEC(I,J) 180 CONTINUE 190 CONTINUE DO 200 J=1,3 NGENCP(IGA,0,J)=NGEN(0,J) XSECCP(IGA,0,J)=XSEC(0,J) 200 CONTINUE C...Choose between allowed alternatives. ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN IF(ISAVE.EQ.4) THEN XSUMCP=0D0 DO 210 IG=1,MINT(121) XSUMCP=XSUMCP+XSECCP(IG,0,1) 210 CONTINUE XSUMCP=XSUMCP*PYR(0) DO 220 IG=1,MINT(121) IGA=IG XSUMCP=XSUMCP-XSECCP(IG,0,1) IF(XSUMCP.LE.0D0) GOTO 230 220 CONTINUE 230 CONTINUE ENDIF C...Restore cross-section information. DO 240 I=1,500 MSUB(I)=0 240 CONTINUE DO 270 ICP=1,NCP(IGA) I=NSUBCP(IGA,ICP) MSUB(I)=MSUBCP(IGA,ICP) DO 250 J=1,20 COEF(I,J)=COEFCP(IGA,ICP,J) 250 CONTINUE DO 260 J=1,3 NGEN(I,J)=NGENCP(IGA,ICP,J) XSEC(I,J)=XSECCP(IGA,ICP,J) 260 CONTINUE 270 CONTINUE DO 280 J=1,3 NGEN(0,J)=NGENCP(IGA,0,J) XSEC(0,J)=XSECCP(IGA,0,J) 280 CONTINUE DO 310 I1=0,6 DO 300 I2=0,6 DO 290 J=0,5 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J) 290 CONTINUE 300 CONTINUE 310 CONTINUE C...Restore various common process variables. DO 320 J=1,10 MINT(40+J)=INTCP(IGA,J) 320 CONTINUE MINT(101)=INTCP(IGA,11) MINT(102)=INTCP(IGA,12) MINT(107)=INTCP(IGA,13) MINT(108)=INTCP(IGA,14) MINT(123)=INTCP(IGA,15) CKIN(3)=RECP(IGA,1) CKIN(1)=2D0*CKIN(3) VINT(318)=RECP(IGA,2) C...Sum up cross-section info (for PYSTAT). ELSEIF(ISAVE.EQ.5) THEN DO 330 I=1,500 MSUB(I)=0 NGEN(I,1)=0 NGEN(I,3)=0 XSEC(I,3)=0D0 330 CONTINUE NGEN(0,1)=0 NGEN(0,2)=0 NGEN(0,3)=0 XSEC(0,3)=0 DO 350 IG=1,MINT(121) DO 340 ICP=1,NCP(IG) I=NSUBCP(IG,ICP) IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1) NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3) XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3) 340 CONTINUE NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1) NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2) NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3) XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3) 350 CONTINUE ENDIF RETURN END C********************************************************************* C...PYGAGA C...For lepton beams it gives photon-hadron or photon-photon systems C...to be treated with the ordinary machinery and combines this with a C...description of the lepton -> lepton + photon branching. SUBROUTINE PYGAGA(IGAGA,WTGAGA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT5/ C...Local variables and data statement. DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3), &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3) SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN DATA EPS/1D-4/ C...Initialize generation of photons inside leptons. IF(IGAGA.EQ.1) THEN C...Save quantities on incoming lepton system. VINT(301)=VINT(1) VINT(302)=VINT(2) PMS(1)=VINT(303)**2 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3)) PMS(2)=VINT(304)**2 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4)) PMC(3)=VINT(302)-PMS(1)-PMS(2) W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2 C...Calculate range of x and Q2 values allowed in generation. DO 100 I=1,2 PMC(I)=VINT(302)+PMS(I)-PMS(3-I) IF(MINT(140+I).NE.0) THEN XMIN(I)=MAX(CKIN(59+2*I),EPS) XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/ & PMC(I),1D0-EPS) YMIN=MAX(CKIN(71+2*I),EPS) YMAX=MIN(CKIN(72+2*I),1D0-EPS) IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I), & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I)) XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I)) THEMIN=MAX(CKIN(67+2*I),0D0) THEMAX=MIN(CKIN(68+2*I),PARU(1)) IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1) Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+ & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))- & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0) Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+ & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))- & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I)) C...W limits when lepton on one side only. IF(MINT(143-I).EQ.0) THEN XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I)) IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I), & (CKIN(78)**2-PMS(3-I))/PMC(I)) ENDIF ENDIF 100 CONTINUE C...W limits when lepton on both sides. IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1), & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1)) IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2), & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2)) IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN- & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1)) XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN- & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2)) ELSE XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2))) XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1))) ENDIF ENDIF C...Q2 and W values and photon flux weight factors for initialization. ELSEIF(IGAGA.EQ.2) THEN ISUB=MINT(1) MINT(15)=0 MINT(16)=0 C...W value for photon on one or both sides, and for processes C...with gamma-gamma cross section peaked at small shat. IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1)) ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2)) ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2) IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2) ELSE VINT(2)=XMAX(1)*XMAX(2)*VINT(302) IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2) ENDIF VINT(1)=SQRT(MAX(0D0,VINT(2))) C...Upper estimate of photon flux weight factor. C...Initialization Q2 scale. Flag incoming unresolved photon. WTGAGA=1D0 DO 110 I=1,2 IF(MINT(140+I).NE.0) THEN WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))* & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I)) IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3) & THEN Q2INIT=5D0+Q2MIN(3-I) ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I) ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR. & (ISUB.EQ.139.AND.I.EQ.1)) THEN Q2INIT=VINT(2)/3D0 ELSEIF(ISUB.EQ.140) THEN Q2INIT=VINT(2)/2D0 ELSE Q2INIT=Q2MIN(I) ENDIF VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT))) IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140)) & MINT(14+I)=22 VINT(306+I)=VINT(2+I)**2 ENDIF 110 CONTINUE VINT(320)=WTGAGA C...Update pTmin and cross section information. IF(MSTP(82).LE.1) THEN PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90) ELSE PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) ENDIF VINT(149)=4D0*PTMN**2/VINT(2) VINT(154)=PTMN CALL PYXTOT VINT(318)=VINT(317) C...Generate photons inside leptons and C...calculate photon flux weight factors. ELSEIF(IGAGA.EQ.3) THEN ISUB=MINT(1) MINT(15)=0 MINT(16)=0 C...Generate phase space point and check against cuts. LOOP=0 120 LOOP=LOOP+1 DO 130 I=1,2 IF(MINT(140+I).NE.0) THEN C...Pick x and Q2 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0) Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0) C...Cuts on internal consistency in x and Q2. IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))- & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120 C...Cuts on y and theta. Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3) IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/ & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I))) THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT)))) IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I)) & GOTO 120 C...Phi angle isotropic. Reconstruct pT. PHI(I)=PARU(2)*PYR(0) PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))- & PMS(I))*SIN(THETA(I)) C...Store info on variables selected, for documentation purposes. VINT(2+I)=-SQRT(Q2(I)) VINT(304+I)=X(I) VINT(306+I)=Q2(I) VINT(308+I)=Y(I) VINT(310+I)=THETA(I) VINT(312+I)=PHI(I) ELSE VINT(304+I)=1D0 VINT(306+I)=0D0 VINT(308+I)=1D0 VINT(310+I)=0D0 VINT(312+I)=0D0 ENDIF 130 CONTINUE C...Cut on W combines info from two sides. IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)- & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0* & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)* & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2) IF(W2.LT.W2MIN) GOTO 120 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120 PMS1=-Q2(1) PMS2=-Q2(2) ELSEIF(MINT(141).NE.0) THEN W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1)) PMS1=-Q2(1) PMS2=PMS(2) ELSEIF(MINT(142).NE.0) THEN W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2)) PMS1=PMS(1) PMS2=-Q2(2) ENDIF C...Store kinematics info for photon(s) in subsystem cm frame. VINT(2)=W2 VINT(1)=SQRT(W2) VINT(291)=0D0 VINT(292)=0D0 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1) VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1) VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1) VINT(296)=0D0 VINT(297)=0D0 VINT(298)=-VINT(293) VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1) VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2) C...Assign weight for photon flux; different for transverse and C...longitudinal photons. Flag incoming unresolved photon. WTGAGA=1D0 DO 140 I=1,2 IF(MINT(140+I).NE.0) THEN WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))* & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I)) IF(MSTP(16).EQ.0) THEN XY=X(I) ELSE WTGAGA=WTGAGA*X(I)/Y(I) XY=Y(I) ENDIF IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN WTGAGA=WTGAGA*(1D0-XY) ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN WTGAGA=WTGAGA*(1D0-XY) ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN WTGAGA=WTGAGA*(1D0-XY) ELSE WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)- & PMS(I)*XY**2/Q2(I)) ENDIF IF(MINT(106+I).EQ.0) MINT(14+I)=22 ENDIF 140 CONTINUE VINT(319)=WTGAGA MINT(143)=LOOP C...Update pTmin and cross section information. IF(MSTP(82).LE.1) THEN PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90) ELSE PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) ENDIF VINT(149)=4D0*PTMN**2/VINT(2) VINT(154)=PTMN CALL PYXTOT C...Reconstruct kinematics of photons inside leptons. ELSEIF(IGAGA.EQ.4) THEN C...Make place for incoming particles and scattered leptons. MOVE=3 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4 MINT(4)=MINT(4)+MOVE DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1 IF(K(I,1).EQ.21) THEN DO 150 J=1,5 K(I+MOVE,J)=K(I,J) P(I+MOVE,J)=P(I,J) V(I+MOVE,J)=V(I,J) 150 CONTINUE IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84)) & K(I+MOVE,3)=K(I,3)+MOVE IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84)) & K(I+MOVE,4)=K(I,4)+MOVE IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84)) & K(I+MOVE,5)=K(I,5)+MOVE ENDIF 160 CONTINUE DO 170 I=MINT(84)+1,N IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84)) & K(I,3)=K(I,3)+MOVE 170 CONTINUE C...Fill in incoming particles. DO 190 I=MINT(83)+1,MINT(83)+MOVE DO 180 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 180 CONTINUE 190 CONTINUE DO 200 I=1,2 K(MINT(83)+I,1)=21 IF(MINT(140+I).NE.0) THEN K(MINT(83)+I,2)=MINT(140+I) P(MINT(83)+I,5)=VINT(302+I) ELSE K(MINT(83)+I,2)=MINT(10+I) P(MINT(83)+I,5)=VINT(2+I) ENDIF P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/ & VINT(302))*(-1D0)**(I+1) P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301) 200 CONTINUE C...New mother-daughter relations in documentation section. IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN K(MINT(83)+1,4)=MINT(83)+3 K(MINT(83)+1,5)=MINT(83)+5 K(MINT(83)+2,4)=MINT(83)+4 K(MINT(83)+2,5)=MINT(83)+6 K(MINT(83)+3,3)=MINT(83)+1 K(MINT(83)+5,3)=MINT(83)+1 K(MINT(83)+4,3)=MINT(83)+2 K(MINT(83)+6,3)=MINT(83)+2 ELSEIF(MINT(141).NE.0) THEN K(MINT(83)+1,4)=MINT(83)+3 K(MINT(83)+1,5)=MINT(83)+4 K(MINT(83)+2,4)=MINT(83)+5 K(MINT(83)+3,3)=MINT(83)+1 K(MINT(83)+4,3)=MINT(83)+1 K(MINT(83)+5,3)=MINT(83)+2 ELSEIF(MINT(142).NE.0) THEN K(MINT(83)+1,4)=MINT(83)+4 K(MINT(83)+2,4)=MINT(83)+3 K(MINT(83)+2,5)=MINT(83)+5 K(MINT(83)+3,3)=MINT(83)+2 K(MINT(83)+4,3)=MINT(83)+1 K(MINT(83)+5,3)=MINT(83)+2 ENDIF C...Fill scattered lepton(s). DO 210 I=1,2 IF(MINT(140+I).NE.0) THEN LSC=MINT(83)+MIN(I+2,MOVE) K(LSC,1)=21 K(LSC,2)=MINT(140+I) P(LSC,1)=PT(I)*COS(PHI(I)) P(LSC,2)=PT(I)*SIN(PHI(I)) P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4) P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))* & (-1D0)**(I-1) P(LSC,5)=VINT(302+I) ENDIF 210 CONTINUE C...Find incoming four-vectors to subprocess. K(N+1,1)=21 IF(MINT(141).NE.0) THEN DO 220 J=1,4 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J) 220 CONTINUE ELSE DO 230 J=1,4 P(N+1,J)=P(MINT(83)+1,J) 230 CONTINUE ENDIF K(N+2,1)=21 IF(MINT(142).NE.0) THEN DO 240 J=1,4 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J) 240 CONTINUE ELSE DO 250 J=1,4 P(N+2,J)=P(MINT(83)+2,J) 250 CONTINUE ENDIF C...Define boost and rotation between hadronic subsystem and C...collision rest frame; boost hadronic subsystem to this frame. DO 260 J=1,3 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4)) 260 CONTINUE CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) BPHI=PYANGL(P(N+1,1),P(N+1,2)) CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0) BTHETA=PYANGL(P(N+1,3),P(N+1,1)) CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2), & BETA(3)) C...Add on scattered leptons to final state. DO 280 I=1,2 IF(MINT(140+I).NE.0) THEN LSC=MINT(83)+MIN(I+2,MOVE) N=N+1 DO 270 J=1,5 K(N,J)=K(LSC,J) P(N,J)=P(LSC,J) V(N,J)=V(LSC,J) 270 CONTINUE K(N,1)=1 K(N,3)=LSC ENDIF 280 CONTINUE ENDIF RETURN END C********************************************************************* C...PYRAND C...Generates quantities characterizing the high-pT scattering at the C...parton level according to the matrix elements. Chooses incoming, C...reacting partons, their momentum fractions and one of the possible C...subprocesses. SUBROUTINE PYRAND C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...User process initialization and event commonblocks. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) INTEGER MAXNUP PARAMETER (MAXNUP=500) INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), &VTIMUP(MAXNUP),SPINUP(MAXNUP) SAVE /HEPRUP/,/HEPEUP/ C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT7/SIGT(0:6,0:6,0:5) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/ C...Local arrays. DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2) C...Parameters and data used in elastic/diffractive treatment. DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/, &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/ C...Initial values, specifically for (first) semihard interaction. MINT(10)=0 MINT(17)=0 MINT(18)=0 VINT(97)=1D0 VINT(143)=1D0 VINT(144)=1D0 VINT(157)=0D0 VINT(158)=0D0 MFAIL=0 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1 ISUB=0 ISTSB=0 LOOP=0 100 LOOP=LOOP+1 MINT(51)=0 MINT(143)=1 C...Start by assuming incoming photon is entering subprocess. IF(MINT(11).EQ.22) THEN MINT(15)=22 VINT(307)=VINT(3)**2 ENDIF IF(MINT(12).EQ.22) THEN MINT(16)=22 VINT(308)=VINT(4)**2 ENDIF MINT(103)=MINT(11) MINT(104)=MINT(12) C...Choice of process type - first event of pileup. INMULT=0 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN ELSEIF(MINT(82).EQ.1) THEN C...For gamma-p or gamma-gamma first pick between alternatives. IGA=0 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA) MINT(122)=IGA C...For real gamma + gamma with different nature, flip at random. IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND. & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN MINTSV=MINT(41) MINT(41)=MINT(42) MINT(42)=MINTSV MINTSV=MINT(45) MINT(45)=MINT(46) MINT(46)=MINTSV MINTSV=MINT(107) MINT(107)=MINT(108) MINT(108)=MINTSV IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47) ENDIF C...Pick process type, possibly by user process machinery. C...(If the latter, also event will be picked here.) IF(MINT(111).EQ.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN CALL UPEVNT ELSEIF(MINT(111).EQ.11.AND.IABS(IDWTUP).GE.3) THEN CALL UPEVNT ISUB=0 110 ISUB=ISUB+1 IF(KFPR(ISUB,2).NE.IDPRUP.AND.ISUB.LT.500) GOTO 110 ELSE RSUB=XSEC(0,1)*PYR(0) DO 120 I=1,500 IF(MSUB(I).NE.1) GOTO 120 ISUB=I RSUB=RSUB-XSEC(I,1) IF(RSUB.LE.0D0) GOTO 130 120 CONTINUE 130 IF(ISUB.EQ.95) ISUB=96 IF(ISUB.EQ.96) INMULT=1 IF(ISET(ISUB).EQ.11) THEN IDPRUP=KFPR(ISUB,2) CALL UPEVNT ENDIF ENDIF C...Choice of inclusive process type - pileup events. ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN RSUB=VINT(131)*PYR(0) ISUB=96 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2)) & ISUB=91 IF(ISUB.EQ.96) INMULT=1 ENDIF C...Choice of photon energy and flux factor inside lepton. IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN CALL PYGAGA(3,WTGAGA) IF(ISUB.GE.131.AND.ISUB.LE.140) THEN CKIN(3)=MAX(VINT(285),VINT(154)) CKIN(1)=2D0*CKIN(3) ENDIF C...When necessary set direct/resolved photon by hand. ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0 ENDIF C...Restrict direct*resolved processes to pTmin >= Q, C...to avoid doublecounting with DIS. IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN IF(MINT(15).EQ.22) THEN CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3))) ELSE CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4))) ENDIF CKIN(1)=2D0*CKIN(3) ENDIF C...Set up for multiple interactions. IF(INMULT.EQ.1) CALL PYMULT(2) C...Loopback point for minimum bias in photon physics. LOOP2=0 140 LOOP2=LOOP2+1 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143) IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143) IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1) &NGEN(97,1)=NGEN(97,1)+MINT(143) MINT(1)=ISUB ISTSB=ISET(ISUB) C...Random choice of flavour for some SUSY processes. IF(ISUB.GE.201.AND.ISUB.LE.301) THEN C...~e_L ~nu_e or ~mu_L ~nu_mu. IF(ISUB.EQ.210) THEN KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0)) KFPR(ISUB,2)=KFPR(ISUB,1)+1 C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar). ELSEIF(ISUB.EQ.213) THEN KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0)) KFPR(ISUB,2)=KFPR(ISUB,1) C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b. ELSEIF(ISUB.GE.246.AND.ISUB.LE.259) THEN IF(ISUB.GE.258) THEN RKF=4D0 ELSE RKF=5D0 ENDIF IF(MOD(ISUB,2).EQ.0) THEN KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0)) ELSE KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0)) ENDIF C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c. ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN KSU1=KSUSY1 KSU2=KSUSY1 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN KSU1=KSUSY2 KSU2=KSUSY2 ELSEIF(PYR(0).LT.0.5D0) THEN KSU1=KSUSY1 KSU2=KSUSY2 ELSE KSU1=KSUSY2 KSU2=KSUSY1 ENDIF KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0)) KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0)) C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c. ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0)) KFPR(ISUB,2)=KFPR(ISUB,1) ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0)) KFPR(ISUB,2)=KFPR(ISUB,1) C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c. ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN KSU1=KSUSY1 KSU2=KSUSY1 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN KSU1=KSUSY2 KSU2=KSUSY2 ELSEIF(PYR(0).LT.0.5D0) THEN KSU1=KSUSY1 KSU2=KSUSY2 ELSE KSU1=KSUSY2 KSU2=KSUSY1 ENDIF IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN RKF=5D0 ELSE RKF=4D0 ENDIF KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0)) ENDIF ENDIF C...Find resonances (explicit or implicit in cross-section). MINT(72)=0 KFR1=0 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN KFR1=KFPR(ISUB,1) ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR. & ISUB.EQ.171.OR.ISUB.EQ.176) THEN KFR1=23 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR. & ISUB.EQ.177) THEN KFR1=24 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN KFR1=25 IF(MSTP(46).EQ.5) THEN KFR1=89 PMAS(89,1)=PARP(45) PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2) ENDIF ELSEIF(ISUB.EQ.194) THEN KFR1=KTECHN+113 ELSEIF(ISUB.EQ.195) THEN KFR1=KTECHN+213 ELSEIF(ISUB.GE.361.AND.ISUB.LE.368) THEN KFR1=KTECHN+113 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN KFR1=KTECHN+213 ENDIF CKMX=CKIN(2) IF(CKMX.LE.0D0) CKMX=VINT(1) KCR1=PYCOMP(KFR1) IF(KFR1.NE.0) THEN IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR. & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0 ENDIF IF(KFR1.NE.0) THEN TAUR1=PMAS(KCR1,1)**2/VINT(2) IF(KFR1.EQ.KTECHN+113) THEN CALL PYTECM(S1,S2) TAUR1=S1/VINT(2) ENDIF GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2) MINT(72)=1 MINT(73)=KFR1 VINT(73)=TAUR1 VINT(74)=GAMR1 ENDIF IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.(ISUB.GE.364.AND.ISUB.LE.368)) $THEN KFR2=23 IF(ISUB.EQ.194) THEN KFR2=KTECHN+223 ELSEIF(ISUB.GE.364.AND.ISUB.LE.368) THEN KFR2=KTECHN+223 ENDIF KCR2=PYCOMP(KFR2) TAUR2=PMAS(KCR2,1)**2/VINT(2) IF(KFR2.EQ.KTECHN+223) THEN CALL PYTECM(S1,S2) TAUR2=S2/VINT(2) ENDIF GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2) IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR. & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) KFR2=0 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN MINT(72)=2 MINT(74)=KFR2 VINT(75)=TAUR2 VINT(76)=GAMR2 ELSEIF(KFR2.NE.0) THEN KFR1=KFR2 TAUR1=TAUR2 GAMR1=GAMR2 MINT(72)=1 MINT(73)=KFR1 VINT(73)=TAUR1 VINT(74)=GAMR1 ENDIF ENDIF C...Find product masses and minimum pT of process, C...optionally with broadening according to a truncated Breit-Wigner. VINT(63)=0D0 VINT(64)=0D0 MINT(71)=0 VINT(71)=CKIN(3) IF(MINT(82).GE.2) VINT(71)=0D0 VINT(80)=1D0 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN NBW=0 DO 160 I=1,2 PMMN(I)=0D0 IF(KFPR(ISUB,I).EQ.0) THEN ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT. & PARP(41)) THEN VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2 ELSE NBW=NBW+1 C...This prevents SUSY/t particles from becoming too light. KFLW=KFPR(ISUB,I) IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN KCW=PYCOMP(KFLW) PMMN(I)=PMAS(KCW,1) DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+ & PMAS(PYCOMP(KFDP(IDC,2)),1) IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+ & PMAS(PYCOMP(KFDP(IDC,3)),1) PMMN(I)=MIN(PMMN(I),PMSUM) ENDIF 150 CONTINUE ELSEIF(KFLW.EQ.6) THEN PMMN(I)=PMAS(24,1)+PMAS(5,1) ENDIF ENDIF 160 CONTINUE IF(NBW.GE.1) THEN CKIN41=CKIN(41) CKIN43=CKIN(43) CKIN(41)=MAX(PMMN(1),CKIN(41)) CKIN(43)=MAX(PMMN(2),CKIN(43)) CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4) CKIN(41)=CKIN41 CKIN(43)=CKIN43 IF(MINT(51).EQ.1) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(MFAIL.EQ.1) THEN MSTI(61)=1 RETURN ENDIF GOTO 100 ENDIF VINT(63)=PQM3**2 VINT(64)=PQM4**2 ENDIF IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5)) ENDIF C...Prepare for additional variable choices in 2 -> 3. IF(ISTSB.EQ.5) THEN VINT(201)=0D0 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1) VINT(206)=VINT(201) VINT(204)=PMAS(23,1) IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1) IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1) IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR. & ISUB.EQ.186.OR.ISUB.EQ.187) 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.3.OR.MINT(123).EQ.7)) THEN VRN=PYR(0)*SIGT(0,0,5) IF(MINT(101).LE.1) THEN I1MN=0 I1MX=0 ELSE I1MN=1 I1MX=MINT(101) ENDIF IF(MINT(102).LE.1) THEN I2MN=0 I2MX=0 ELSE I2MN=1 I2MX=MINT(102) ENDIF DO 180 I1=I1MN,I1MX KFV1=110*I1+3 DO 170 I2=I2MN,I2MX KFV2=110*I2+3 VRN=VRN-SIGT(I1,I2,5) IF(VRN.LE.0D0) GOTO 190 170 CONTINUE 180 CONTINUE 190 IF(MINT(101).GE.2) MINT(103)=KFV1 IF(MINT(102).GE.2) MINT(104)=KFV2 ENDIF IF(ISTSB.EQ.0) THEN C...Elastic scattering or single or double diffractive scattering. C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass. MINT(103)=MINT(11) MINT(104)=MINT(12) PMM(1)=VINT(3) PMM(2)=VINT(4) IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN JJ=ISUB-90 VRN=PYR(0)*SIGT(0,0,JJ) IF(MINT(101).LE.1) THEN I1MN=0 I1MX=0 ELSE I1MN=1 I1MX=MINT(101) ENDIF IF(MINT(102).LE.1) THEN I2MN=0 I2MX=0 ELSE I2MN=1 I2MX=MINT(102) ENDIF DO 210 I1=I1MN,I1MX KFV1=110*I1+3 DO 200 I2=I2MN,I2MX KFV2=110*I2+3 VRN=VRN-SIGT(I1,I2,JJ) IF(VRN.LE.0D0) GOTO 220 200 CONTINUE 210 CONTINUE 220 IF(MINT(101).GE.2) THEN MINT(103)=KFV1 PMM(1)=PYMASS(KFV1) ENDIF IF(MINT(102).GE.2) THEN MINT(104)=KFV2 PMM(2)=PYMASS(KFV2) ENDIF ENDIF VINT(67)=PMM(1) VINT(68)=PMM(2) C...Select mass for GVMD states (rejecting previous assignment). Q0S=4D0*PARP(15)**2 Q1S=4D0*VINT(154)**2 LOOP3=0 230 LOOP3=LOOP3+1 DO 240 JT=1,2 IF(MINT(106+JT).EQ.3) THEN PS=VINT(2+JT)**2 PMM(JT)=(Q0S+PS)*(Q1S+PS)/ & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)- & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1) ENDIF 240 CONTINUE IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3)) & GOTO 230 GOTO 100 ENDIF C...Side/sides of diffractive system. MINT(17)=0 MINT(18)=0 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1 C...Find masses of particles and minimal masses of diffractive states. DO 250 JT=1,2 PDIF(JT)=PMM(JT) VINT(68+JT)=PDIF(JT) IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102) 250 CONTINUE SH=VINT(2) SQM1=PMM(1)**2 SQM2=PMM(2)**2 SQM3=PDIF(1)**2 SQM4=PDIF(2)**2 SMRES1=(PMM(1)+PMRC)**2 SMRES2=(PMM(2)+PMRC)**2 C...Find elastic slope and lower limit diffractive slope. IHA=MAX(2,IABS(MINT(103))/110) IF(IHA.GE.5) IHA=1 IHB=MAX(2,IABS(MINT(104))/110) IF(IHB.GE.5) IHB=1 IF(ISUB.EQ.91) THEN BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0 ELSEIF(ISUB.EQ.92) THEN BMN=MAX(2D0,2D0*BHAD(IHB)) ELSEIF(ISUB.EQ.93) THEN BMN=MAX(2D0,2D0*BHAD(IHA)) ELSEIF(ISUB.EQ.94) THEN BMN=2D0*ALP*4D0 ENDIF C...Determine maximum possible t range and coefficient of generation. SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)* & (SQM1*SQM4-SQM2*SQM3)/SH THL=-0.5D0*(THA+THB) THU=THC/THL THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0 C...Select diffractive mass/masses according to dm^2/m^2. LOOP3=0 260 LOOP3=LOOP3+1 DO 270 JT=1,2 IF(MINT(16+JT).EQ.0) THEN PDIF(2+JT)=PDIF(JT) ELSE PMMIN=PDIF(JT) PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT)) PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0) ENDIF 270 CONTINUE SQM3=PDIF(3)**2 SQM4=PDIF(4)**2 C..Additional mass factors, including resonance enhancement. IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN IF(LOOP3.LT.100) GOTO 260 GOTO 100 ENDIF IF(ISUB.EQ.92) THEN FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3)) IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260 ELSEIF(ISUB.EQ.93) THEN FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4)) IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260 ELSEIF(ISUB.EQ.94) THEN FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/ & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))* & (1D0+CRES*SMRES2/(SMRES2+SQM4)) IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260 ENDIF C...Select t according to exp(Bmn*t) and correct to right slope. TH=THU+LOG(1D0+THRND*PYR(0))/BMN IF(ISUB.GE.92) THEN IF(ISUB.EQ.92) THEN BADD=2D0*ALP*LOG(SH/SQM3) IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0) ELSEIF(ISUB.EQ.93) THEN BADD=2D0*ALP*LOG(SH/SQM4) IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0) ELSEIF(ISUB.EQ.94) THEN BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0) ENDIF IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260 ENDIF C...Check whether m^2 and t choices are consistent. SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH IF(THB.LE.1D-8) GOTO 260 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)* & (SQM1*SQM4-SQM2*SQM3)/SH THLM=-0.5D0*(THA+THB) THUM=THC/THLM IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260 C...Information to output. VINT(21)=1D0 VINT(22)=0D0 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB)) VINT(45)=TH VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB VINT(63)=PDIF(3)**2 VINT(64)=PDIF(4)**2 VINT(283)=PMM(1)**2/4D0 VINT(284)=PMM(2)**2/4D0 C...Note: in the following, by In is meant the integral over the C...quantity multiplying coefficient cn. C...Choose tau according to h1(tau)/tau, where C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) + C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) + C...I1/I5*c5*1/(tau+tau_R') + C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) + C...I1/I7*c7*tau/(1.-tau), and C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1. ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN CALL PYKLIM(1) IF(MINT(51).NE.0) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(MFAIL.EQ.1) THEN MSTI(61)=1 RETURN ENDIF GOTO 100 ENDIF RTAU=PYR(0) MTAU=1 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)) & MTAU=5 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+ & COEF(ISUB,5)) MTAU=6 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+ & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7 CALL PYKMAP(1,MTAU,PYR(0)) C...2 -> 3, 4 processes: C...Choose tau' according to h4(tau,tau')/tau', where C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' + C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1. IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN CALL PYKLIM(4) IF(MINT(51).NE.0) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(MFAIL.EQ.1) THEN MSTI(61)=1 RETURN ENDIF GOTO 100 ENDIF RTAUP=PYR(0) MTAUP=1 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3 CALL PYKMAP(4,MTAUP,PYR(0)) ENDIF C...Choose y* according to h2(y*), where C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) + C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) + C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min, C...and c1 + c2 + c3 + c4 + c5 = 1. CALL PYKLIM(2) IF(MINT(51).NE.0) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(MFAIL.EQ.1) THEN MSTI(61)=1 RETURN ENDIF GOTO 100 ENDIF RYST=PYR(0) MYST=1 IF(RYST.GT.COEF(ISUB,8)) MYST=2 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+ & COEF(ISUB,11)) MYST=5 CALL PYKMAP(2,MYST,PYR(0)) C...2 -> 2 processes: C...Choose cos(theta-hat) (cth) according to h3(cth), where C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) + C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2, C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products), C...and c0 + c1 + c2 + c3 + c4 = 1. CALL PYKLIM(3) IF(MINT(51).NE.0) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(MFAIL.EQ.1) THEN MSTI(61)=1 RETURN ENDIF GOTO 100 ENDIF IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN RCTH=PYR(0) MCTH=1 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+ & COEF(ISUB,16)) MCTH=5 CALL PYKMAP(3,MCTH,PYR(0)) ENDIF C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing. IF(ISTSB.EQ.5) THEN CALL PYKMAP(5,0,0D0) IF(MINT(51).NE.0) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(MFAIL.EQ.1) THEN MSTI(61)=1 RETURN ENDIF GOTO 100 ENDIF ENDIF C...DIS as f + gamma* -> f process: set dummy values. ELSEIF(ISTSB.EQ.8) THEN VINT(21)=0.9D0 VINT(22)=0D0 VINT(23)=0D0 VINT(47)=0D0 VINT(48)=0D0 C...Low-pT or multiple interactions (first semihard interaction). ELSEIF(ISTSB.EQ.9) THEN CALL PYMULT(3) ISUB=MINT(1) C...Study user-defined process: kinematics plus weight. ELSEIF(ISTSB.EQ.11) THEN IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process') MSTI(51)=0 IF(NUP.LE.0) THEN MINT(51)=2 MSTI(51)=1 IF(MINT(82).EQ.1) THEN NGEN(0,1)=NGEN(0,1)-1 NGEN(ISUB,1)=NGEN(ISUB,1)-1 ENDIF IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) RETURN ENDIF C...Extract cross section event weight. IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN SIGS=1D-9*XWGTUP ELSE SIGS=1D-9*XSECUP(KFPR(ISUB,1)) ENDIF IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN VINT(97)=SIGN(1D0,XWGTUP) ELSE VINT(97)=1D-9*XWGTUP ENDIF C...Construct 'trivial' kinematical variables needed. KFL1=IDUP(1) KFL2=IDUP(2) VINT(41)=PUP(4,1)/EBMUP(1) VINT(42)=PUP(4,2)/EBMUP(2) VINT(21)=VINT(41)*VINT(42) VINT(22)=0.5D0*LOG(VINT(41)/VINT(42)) VINT(44)=VINT(21)*VINT(2) VINT(43)=SQRT(MAX(0D0,VINT(44))) VINT(55)=SCALUP IF(SCALUP.LE.0D0) VINT(55)=VINT(43) VINT(56)=VINT(55)**2 VINT(57)=AQEDUP VINT(58)=AQCDUP C...Construct other kinematical variables needed (approximately). VINT(23)=0D0 VINT(26)=VINT(21) VINT(45)=-0.5D0*VINT(44) VINT(46)=-0.5D0*VINT(44) VINT(49)=VINT(43) VINT(50)=VINT(44) VINT(51)=VINT(55) VINT(52)=VINT(56) VINT(53)=VINT(55) VINT(54)=VINT(56) VINT(25)=0D0 VINT(48)=0D0 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26, & '(PYRAND:) unacceptable ISTUP code for incoming particles') DO 280 IUP=3,NUP IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26, & '(PYRAND:) unacceptable ISTUP code for particles') IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+ & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2) IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+ & PUP(2,IUP)**2) 280 CONTINUE VINT(47)=SQRT(VINT(48)) ENDIF C...Choose azimuthal angle. VINT(24)=0D0 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0) C...Check against user cuts on kinematics at parton level. MINT(51)=0 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0) IF(MINT(51).NE.0) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(MFAIL.EQ.1) THEN MSTI(61)=1 RETURN ENDIF GOTO 100 ENDIF IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN MCUT=0 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0) & CALL PYKCUT(MCUT) IF(MCUT.NE.0) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(MFAIL.EQ.1) THEN MSTI(61)=1 RETURN ENDIF GOTO 100 ENDIF ENDIF C...Calculate differential cross-section for different subprocesses. IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS) SIGSOR=SIGS SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316) C...Multiply cross section by lepton -> photon flux factor. IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN SIGS=WTGAGA*SIGS DO 290 ICHN=1,NCHN SIGH(ICHN)=WTGAGA*SIGH(ICHN) 290 CONTINUE SIGLPT=WTGAGA*SIGLPT ENDIF C...Multiply cross-section by user-defined weights. IF(MSTP(173).EQ.1) THEN SIGS=PARP(173)*SIGS DO 300 ICHN=1,NCHN SIGH(ICHN)=PARP(173)*SIGH(ICHN) 300 CONTINUE SIGLPT=PARP(173)*SIGLPT ENDIF WTXS=1D0 SIGSWT=SIGS VINT(99)=1D0 VINT(100)=1D0 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+ & MSUB(95).EQ.0) CALL PYEVWT(WTXS) SIGSWT=WTXS*SIGS VINT(99)=WTXS IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS ENDIF C...Calculations for Monte Carlo estimate of all cross-sections. IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN IF(MSTP(142).LE.1) THEN XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS ELSE XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT ENDIF ELSEIF(MINT(82).EQ.1) THEN XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS ENDIF IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND. &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT C...Multiple interactions: store results of cross-section calculation. IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN VINT(153)=SIGSOR CALL PYMULT(4) ENDIF C...Ratio of actual to maximum cross section. IF(ISTSB.NE.11) THEN VIOL=SIGSWT/XSEC(ISUB,1) IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174) ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1)) ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1))) ELSE VIOL=1D0 ENDIF C...Check that weight not negative. IF(MSTP(123).LE.0) THEN IF(VIOL.LT.-1D-3) THEN WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21), & VINT(22),VINT(23),VINT(26) STOP ENDIF ELSE IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN VINT(109)=VIOL WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21), & VINT(22),VINT(23),VINT(26) ENDIF ENDIF C...Weighting using estimate of maximum of differential cross-section. IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN IF(VIOL.LT.PYR(0)) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0 GOTO 100 ENDIF ELSEIF(MFAIL.EQ.0) THEN RATND=SIGLPT/XSEC(95,1) IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) ISUB=0 GOTO 100 ENDIF VIOL=VIOL/RATND IF(VIOL.LT.PYR(0)) THEN GOTO 140 ENDIF ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN IF(VIOL.LT.PYR(0)) THEN MSTI(61)=1 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) RETURN ENDIF ELSE RATND=SIGLPT/XSEC(95,1) IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN MSTI(61)=1 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) RETURN ENDIF VIOL=VIOL/RATND IF(VIOL.LT.PYR(0)) THEN IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) GOTO 100 ENDIF ENDIF C...Check for possible violation of estimated maximum of differential C...cross-section used in weighting. IF(MSTP(123).LE.0) THEN IF(VIOL.GT.1D0) THEN WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21), & VINT(22),VINT(23),VINT(26) STOP ENDIF ELSEIF(MSTP(123).EQ.1) THEN IF(VIOL.GT.VINT(108)) THEN VINT(108)=VIOL IF(VIOL.GT.1.0001D0) THEN MINT(10)=1 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21), & VINT(22),VINT(23),VINT(26) ENDIF ENDIF ELSEIF(VIOL.GT.VINT(108)) THEN VINT(108)=VIOL IF(VIOL.GT.1D0) THEN MINT(10)=1 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2)) & THEN XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1)) IF(KFPR(ISUB,1).LE.9) THEN WRITE(MSTU(11),5800) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1)) ELSEIF(KFPR(ISUB,1).LE.99) THEN WRITE(MSTU(11),5900) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1)) ELSE WRITE(MSTU(11),6000) KFPR(ISUB,1),XMAXUP(KFPR(ISUB,1)) ENDIF ENDIF IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN XDIF=XSEC(ISUB,1)*(VIOL-1D0) XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) & XSEC(0,1)=XSEC(0,1)+XDIF IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21), & VINT(22),VINT(23),VINT(26) IF(ISUB.LE.9) THEN WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1) ELSEIF(ISUB.LE.99) THEN WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1) ELSE WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1) ENDIF ENDIF VINT(108)=1D0 ENDIF ENDIF C...Multiple interactions: choose impact parameter. VINT(148)=1D0 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND. &MSTP(82).GE.3) THEN 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)+MINT(143) IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1 ENDIF IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1 C...Choose flavour of reacting partons (and subprocess). IF(ISTSB.GE.11) GOTO 320 RSIGS=SIGS*PYR(0) QT2=VINT(48) RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)* &(VINT(1)/PARP(89))**PARP(90))**2))**2) IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR. &PYR(0).GT.RQQBAR)) THEN DO 310 ICHN=1,NCHN KFL1=ISIG(ICHN,1) KFL2=ISIG(ICHN,2) MINT(2)=ISIG(ICHN,3) RSIGS=RSIGS-SIGH(ICHN) IF(RSIGS.LE.0D0) GOTO 320 310 CONTINUE C...Multiple interactions: choose qqbar preferentially at small pT. ELSEIF(ISUB.EQ.96) THEN MINT(105)=MINT(103) MINT(109)=MINT(107) CALL PYSPLI(MINT(11),21,KFL1,KFLDUM) MINT(105)=MINT(104) MINT(109)=MINT(108) CALL PYSPLI(MINT(12),21,KFL2,KFLDUM) MINT(1)=11 MINT(2)=1 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2 C...Low-pT: choose string drawing configuration. ELSE KFL1=21 KFL2=21 RSIGS=6D0*PYR(0) MINT(2)=1 IF(RSIGS.GT.1D0) MINT(2)=2 IF(RSIGS.GT.2D0) MINT(2)=3 ENDIF C...Reassign QCD process. Partons before initial state radiation. 320 IF(MINT(2).GT.10) THEN MINT(1)=MINT(2)/10 MINT(2)=MOD(MINT(2),10) ENDIF IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)= &NGEN(MINT(1),2)+1 MINT(15)=KFL1 MINT(16)=KFL2 MINT(13)=MINT(15) MINT(14)=MINT(16) VINT(141)=VINT(41) VINT(142)=VINT(42) VINT(151)=0D0 VINT(152)=0D0 C...Calculate x value of photon for parton inside photon inside e. DO 350 JT=1,2 MINT(18+JT)=0 VINT(154+JT)=0D0 MSPLI=0 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1 IF(MSPLI.EQ.2) THEN KFLH=MINT(14+JT) XHRD=VINT(140+JT) Q2HRD=VINT(54) MINT(105)=MINT(102+JT) MINT(109)=MINT(106+JT) VINT(120)=VINT(2+JT) IF(MSTP(57).LE.1) THEN CALL PYPDFU(22,XHRD,Q2HRD,XPQ) ELSE CALL PYPDFL(22,XHRD,Q2HRD,XPQ) ENDIF WTMX=4D0*XPQ(KFLH) IF(MSTP(13).EQ.2) THEN Q2PMS=Q2HRD/PMAS(11,1)**2 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2)) ENDIF 330 XE=XHRD**PYR(0) XG=MIN(1D0-1D-10,XHRD/XE) IF(MSTP(57).LE.1) THEN CALL PYPDFU(22,XG,Q2HRD,XPQ) ELSE CALL PYPDFL(22,XG,Q2HRD,XPQ) ENDIF WT=(1D0+(1D0-XE)**2)*XPQ(KFLH) IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2)) IF(WT.LT.PYR(0)*WTMX) GOTO 330 MINT(18+JT)=1 VINT(154+JT)=XE DO 340 KFLS=-25,25 XSFX(JT,KFLS)=XPQ(KFLS) 340 CONTINUE ENDIF 350 CONTINUE C...Pick scale where photon is resolved. Q0S=PARP(15)**2 Q1S=VINT(154)**2 VINT(283)=0D0 IF(MINT(107).EQ.3) THEN IF(MSTP(66).EQ.1) THEN VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0) ELSEIF(MSTP(66).EQ.2) THEN PS=VINT(3)**2 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) Q2INT=SQRT(Q0S*Q2EFF) VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0) ELSEIF(MSTP(66).EQ.3) THEN VINT(283)=Q0S*(Q1S/Q0S)**PYR(0) ELSEIF(MSTP(66).GE.4) THEN PS=0.25D0*VINT(3)**2 VINT(283)=(Q0S+PS)*(Q1S+PS)/ & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS ENDIF ENDIF VINT(284)=0D0 IF(MINT(108).EQ.3) THEN IF(MSTP(66).EQ.1) THEN VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0) ELSEIF(MSTP(66).EQ.2) THEN PS=VINT(4)**2 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) Q2INT=SQRT(Q0S*Q2EFF) VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0) ELSEIF(MSTP(66).EQ.3) THEN VINT(284)=Q0S*(Q1S/Q0S)**PYR(0) ELSEIF(MSTP(66).GE.4) THEN PS=0.25D0*VINT(4)**2 VINT(284)=(Q0S+PS)*(Q1S+PS)/ & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS ENDIF ENDIF IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) C...Format statements for differential cross-section maximum violations. 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X, &'in event',1X,I7,'D0'/1X,'Execution stopped!') 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P, &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3) 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X, &'in event',1X,I7) 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X, &'in event',1X,I7,'D0'/1X,'Execution stopped!') 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X, &'in event',1X,I7) 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3) 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3) 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3) 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3) 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3) 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3) RETURN END C********************************************************************* C...PYSCAT C...Finds outgoing flavours and event type; sets up the kinematics C...and colour flow of the hard scattering SUBROUTINE PYSCAT C...Double precision and integer declarations IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...User process event common block. INTEGER MAXNUP PARAMETER (MAXNUP=500) INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), &VTIMUP(MAXNUP),SPINUP(MAXNUP) SAVE /HEPEUP/ C...Commonblocks COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/, &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/ C...Local arrays and saved variables DIMENSION WDTP(0:300),WDTE(0:300,0:5),PMQ(2),Z(2),CTHE(2), &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100) SAVE VINTSV C...Read out process ISUB=MINT(1) ISUBSV=ISUB C...Restore information for low-pT processes IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN DO 100 J=41,66 100 VINT(J)=VINTSV(J) ENDIF C...Convert H' or A process into equivalent H one IHIGG=1 KFHIGG=25 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND. &ISUB.LE.190)) THEN IHIGG=2 IF(MOD(ISUB-1,10).GE.5) IHIGG=3 KFHIGG=33+IHIGG IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113 ENDIF C...Choice of subprocess, number of documentation lines IDOC=6+ISET(ISUB) IF(ISUB.EQ.95) IDOC=8 IF(ISET(ISUB).EQ.5) IDOC=9 IF(ISET(ISUB).EQ.11) IDOC=4+NUP MINT(3)=IDOC-6 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2 MINT(4)=IDOC IPU1=MINT(84)+1 IPU2=MINT(84)+2 IPU3=MINT(84)+3 IPU4=MINT(84)+4 IPU5=MINT(84)+5 IPU6=MINT(84)+6 C...Reset K, P and V vectors. Store incoming particles DO 120 JT=1,MSTP(126)+100 I=MINT(83)+JT IF(I.GT.MSTU(4)) GOTO 120 DO 110 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 110 CONTINUE 120 CONTINUE DO 140 JT=1,2 I=MINT(83)+JT K(I,1)=21 K(I,2)=MINT(10+JT) DO 130 J=1,5 P(I,J)=VINT(285+5*JT+J) 130 CONTINUE 140 CONTINUE MINT(6)=2 KFRES=0 C...Store incoming partons in their CM-frame SH=VINT(44) SHR=SQRT(SH) SHP=VINT(26)*VINT(2) SHPR=SQRT(SHP) SHUSER=SHR IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR DO 150 JT=1,2 I=MINT(84)+JT K(I,1)=14 K(I,2)=MINT(14+JT) K(I,3)=MINT(83)+2+JT P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1) P(I,4)=0.5D0*SHUSER 150 CONTINUE C...Copy incoming partons to documentation lines DO 170 JT=1,2 I1=MINT(83)+4+JT I2=MINT(84)+JT K(I1,1)=21 K(I1,2)=K(I2,2) K(I1,3)=I1-2 DO 160 J=1,5 P(I1,J)=P(I2,J) 160 CONTINUE 170 CONTINUE C...Choose new quark/lepton flavour for relevant annihilation graphs IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR. &(ISUB.GE.135.AND.ISUB.LE.140)) THEN IGLGA=21 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22 CALL PYWIDT(IGLGA,SH,WDTP,WDTE) 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0) DO 190 I=1,MDCY(IGLGA,3) KFLF=KFDP(I+MDCY(IGLGA,2)-1,1) RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4)) IF(RKFL.LE.0D0) GOTO 200 190 CONTINUE 200 CONTINUE IF(ISUB.EQ.53.AND.MINT(2).LE.2) THEN IF(KFLF.GE.4) GOTO 180 ELSEIF(ISUB.EQ.53.AND.MINT(2).LE.4) THEN KFLF=4 MINT(2)=MINT(2)-2 ELSEIF(ISUB.EQ.53) THEN KFLF=5 MINT(2)=MINT(2)-4 ELSEIF(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.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180 ENDIF ENDIF C...Final state flavours and colour flow: default values JS=1 MINT(21)=MINT(15) MINT(22)=MINT(16) MINT(23)=0 MINT(24)=0 KCC=20 KCS=ISIGN(1,MINT(15)) IF(ISET(ISUB).EQ.11) THEN C...User-defined processes: find products MINT(3)=0 DO 210 IUP=3,NUP IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN MINT(21+IUP)=IDUP(IUP) ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR. & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN ELSEIF(IDUP(IUP).EQ.0) THEN ELSE MINT(3)=MINT(3)+1 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP) ENDIF 210 CONTINUE ELSEIF(ISUB.LE.10) THEN IF(ISUB.EQ.1) THEN C...f + fbar -> gamma*/Z0 KFRES=23 ELSEIF(ISUB.EQ.2) THEN C...f + fbar' -> W+/- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) KFRES=ISIGN(24,KCH1+KCH2) ELSEIF(ISUB.EQ.3) THEN C...f + fbar -> h0 (or H0, or A0) KFRES=KFHIGG ELSEIF(ISUB.EQ.4) THEN C...gamma + W+/- -> W+/- ELSEIF(ISUB.EQ.5) THEN C...Z0 + Z0 -> h0 XH=SH/SHP MINT(21)=MINT(15) MINT(22)=MINT(16) PMQ(1)=PYMASS(MINT(21)) PMQ(2)=PYMASS(MINT(22)) 220 JT=INT(1.5D0+PYR(0)) ZMIN=2D0*PMQ(JT)/SHPR ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ & (SHPR*(SHPR-PMQ(3-JT))) ZMAX=MIN(1D0-XH,ZMAX) Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 220 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) Z(3-JT)=1D0-XH/(1D0-Z(JT)) SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 220 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) PHIR=PARU(2)*PYR(0) CPHI=COS(PHIR) ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* & SQRT(1D0-CTHE(2)**2)*CPHI Z1=2D0-Z(JT) Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* & PMQ(3-JT)**2/SHP)) ZMIN=2D0*PMQ(3-JT)/SHPR ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) ZMAX=MIN(1D0-XH,ZMAX) IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220 KCC=22 KFRES=25 ELSEIF(ISUB.EQ.6) THEN C...Z0 + W+/- -> W+/- ELSEIF(ISUB.EQ.7) THEN C...W+ + W- -> Z0 ELSEIF(ISUB.EQ.8) THEN C...W+ + W- -> h0 XH=SH/SHP 230 DO 260 JT=1,2 I=MINT(14+JT) IA=IABS(I) IF(IA.LE.10) THEN RVCKM=VINT(180+I)*PYR(0) DO 240 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240 MINT(20+JT)=ISIGN(IB,I) RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) IF(RVCKM.LE.0D0) GOTO 250 240 CONTINUE ELSE IB=2*((IA+1)/2)-1+MOD(IA,2) MINT(20+JT)=ISIGN(IB,I) ENDIF 250 PMQ(JT)=PYMASS(MINT(20+JT)) 260 CONTINUE JT=INT(1.5D0+PYR(0)) ZMIN=2D0*PMQ(JT)/SHPR ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ & (SHPR*(SHPR-PMQ(3-JT))) ZMAX=MIN(1D0-XH,ZMAX) IF(ZMIN.GE.ZMAX) GOTO 230 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 230 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) Z(3-JT)=1D0-XH/(1D0-Z(JT)) SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 230 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) PHIR=PARU(2)*PYR(0) CPHI=COS(PHIR) ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* & SQRT(1D0-CTHE(2)**2)*CPHI Z1=2D0-Z(JT) Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* & PMQ(3-JT)**2/SHP)) ZMIN=2D0*PMQ(3-JT)/SHPR ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) ZMAX=MIN(1D0-XH,ZMAX) IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230 KCC=22 KFRES=25 ELSEIF(ISUB.EQ.10) THEN C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2 IF(MINT(2).EQ.1) THEN KCC=22 ELSE C...W exchange: need to mix flavours according to CKM matrix DO 280 JT=1,2 I=MINT(14+JT) IA=IABS(I) IF(IA.LE.10) THEN RVCKM=VINT(180+I)*PYR(0) DO 270 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270 MINT(20+JT)=ISIGN(IB,I) RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) IF(RVCKM.LE.0D0) GOTO 280 270 CONTINUE ELSE IB=2*((IA+1)/2)-1+MOD(IA,2) MINT(20+JT)=ISIGN(IB,I) ENDIF 280 CONTINUE KCC=22 ENDIF ENDIF ELSEIF(ISUB.LE.20) THEN IF(ISUB.EQ.11) THEN C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2 KCC=MINT(2) IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 ELSEIF(ISUB.EQ.12) THEN C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2 MINT(21)=ISIGN(KFLF,MINT(15)) MINT(22)=-MINT(21) KCC=4 ELSEIF(ISUB.EQ.13) THEN C...f + fbar -> g + g; th arbitrary MINT(21)=21 MINT(22)=21 KCC=MINT(2)+4 ELSEIF(ISUB.EQ.14) THEN C...f + fbar -> g + gamma; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=21 MINT(23-JS)=22 KCC=17+JS ELSEIF(ISUB.EQ.15) THEN C...f + fbar -> g + Z0; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=21 MINT(23-JS)=23 KCC=17+JS ELSEIF(ISUB.EQ.16) THEN C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2 MINT(20+JS)=21 MINT(23-JS)=ISIGN(24,KCH1+KCH2) KCC=17+JS ELSEIF(ISUB.EQ.17) THEN C...f + fbar -> g + h0; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=21 MINT(23-JS)=25 KCC=17+JS ELSEIF(ISUB.EQ.18) THEN C...f + fbar -> gamma + gamma; th arbitrary MINT(21)=22 MINT(22)=22 ELSEIF(ISUB.EQ.19) THEN C...f + fbar -> gamma + Z0; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=22 MINT(23-JS)=23 ELSEIF(ISUB.EQ.20) THEN C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or C...(p(fbar')-p(W+))**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2 MINT(20+JS)=22 MINT(23-JS)=ISIGN(24,KCH1+KCH2) ENDIF ELSEIF(ISUB.LE.30) THEN IF(ISUB.EQ.21) THEN C...f + fbar -> gamma + h0; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=22 MINT(23-JS)=25 ELSEIF(ISUB.EQ.22) THEN C...f + fbar -> Z0 + Z0; th arbitrary MINT(21)=23 MINT(22)=23 ELSEIF(ISUB.EQ.23) THEN C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2 MINT(20+JS)=23 MINT(23-JS)=ISIGN(24,KCH1+KCH2) ELSEIF(ISUB.EQ.24) THEN C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=23 MINT(23-JS)=KFHIGG ELSEIF(ISUB.EQ.25) THEN C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2 MINT(21)=-ISIGN(24,MINT(15)) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.26) THEN C...f + fbar' -> W+/- + h0 (or H0, or A0); C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 MINT(20+JS)=ISIGN(24,KCH1+KCH2) MINT(23-JS)=KFHIGG ELSEIF(ISUB.EQ.27) THEN C...f + fbar -> h0 + h0 ELSEIF(ISUB.EQ.28) THEN C...f + g -> f + g; th = (p(f)-p(f))**2 KCC=MINT(2)+6 IF(MINT(15).EQ.21) KCC=KCC+2 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15)) IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16)) ELSEIF(ISUB.EQ.29) THEN C...f + g -> f + gamma; th = (p(f)-p(f))**2 IF(MINT(15).EQ.21) JS=2 MINT(23-JS)=22 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.30) THEN C...f + g -> f + Z0; th = (p(f)-p(f))**2 IF(MINT(15).EQ.21) JS=2 MINT(23-JS)=23 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ENDIF ELSEIF(ISUB.LE.40) THEN IF(ISUB.EQ.31) THEN C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f' IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I) RVCKM=VINT(180+I)*PYR(0) DO 290 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290 MINT(20+JS)=ISIGN(IB,I) RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) IF(RVCKM.LE.0D0) GOTO 300 290 CONTINUE 300 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.32) THEN C...f + g -> f + h0; th = (p(f)-p(f))**2 IF(MINT(15).EQ.21) JS=2 MINT(23-JS)=25 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.33) THEN C...f + gamma -> f + g; th=(p(f)-p(f))**2 IF(MINT(15).EQ.22) JS=2 MINT(23-JS)=21 KCC=24+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.34) THEN C...f + gamma -> f + gamma; th=(p(f)-p(f))**2 IF(MINT(15).EQ.22) JS=2 KCC=22 KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.35) THEN C...f + gamma -> f + Z0; th=(p(f)-p(f))**2 IF(MINT(15).EQ.22) JS=2 MINT(23-JS)=23 KCC=22 ELSEIF(ISUB.EQ.36) THEN C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2 IF(MINT(15).EQ.22) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I) IF(IA.LE.10) THEN RVCKM=VINT(180+I)*PYR(0) DO 310 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310 MINT(20+JS)=ISIGN(IB,I) RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) IF(RVCKM.LE.0D0) GOTO 320 310 CONTINUE ELSE IB=2*((IA+1)/2)-1+MOD(IA,2) MINT(20+JS)=ISIGN(IB,I) ENDIF 320 KCC=22 ELSEIF(ISUB.EQ.37) THEN C...f + gamma -> f + h0 ELSEIF(ISUB.EQ.38) THEN C...f + Z0 -> f + g ELSEIF(ISUB.EQ.39) THEN C...f + Z0 -> f + gamma ELSEIF(ISUB.EQ.40) THEN C...f + Z0 -> f + Z0 ENDIF ELSEIF(ISUB.LE.50) THEN IF(ISUB.EQ.41) THEN C...f + Z0 -> f' + W+/- ELSEIF(ISUB.EQ.42) THEN C...f + Z0 -> f + h0 ELSEIF(ISUB.EQ.43) THEN C...f + W+/- -> f' + g ELSEIF(ISUB.EQ.44) THEN C...f + W+/- -> f' + gamma ELSEIF(ISUB.EQ.45) THEN C...f + W+/- -> f' + Z0 ELSEIF(ISUB.EQ.46) THEN C...f + W+/- -> f' + W+/- ELSEIF(ISUB.EQ.47) THEN C...f + W+/- -> f' + h0 ELSEIF(ISUB.EQ.48) THEN C...f + h0 -> f + g ELSEIF(ISUB.EQ.49) THEN C...f + h0 -> f + gamma ELSEIF(ISUB.EQ.50) THEN C...f + h0 -> f + Z0 ENDIF ELSEIF(ISUB.LE.60) THEN IF(ISUB.EQ.51) THEN C...f + h0 -> f' + W+/- ELSEIF(ISUB.EQ.52) THEN C...f + h0 -> f + h0 ELSEIF(ISUB.EQ.53) THEN C...g + g -> f + fbar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFLF,KCS) MINT(22)=-MINT(21) KCC=MINT(2)+10 ELSEIF(ISUB.EQ.54) THEN C...g + gamma -> f + fbar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFLF,KCS) MINT(22)=-MINT(21) KCC=27 IF(MINT(16).EQ.21) KCC=28 ELSEIF(ISUB.EQ.55) THEN C...g + Z0 -> f + fbar ELSEIF(ISUB.EQ.56) THEN C...g + W+/- -> f + fbar' ELSEIF(ISUB.EQ.57) THEN C...g + h0 -> f + fbar ELSEIF(ISUB.EQ.58) THEN C...gamma + gamma -> f + fbar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFLF,KCS) MINT(22)=-MINT(21) KCC=21 ELSEIF(ISUB.EQ.59) THEN C...gamma + Z0 -> f + fbar ELSEIF(ISUB.EQ.60) THEN C...gamma + W+/- -> f + fbar' ENDIF ELSEIF(ISUB.LE.70) THEN IF(ISUB.EQ.61) THEN C...gamma + h0 -> f + fbar ELSEIF(ISUB.EQ.62) THEN C...Z0 + Z0 -> f + fbar ELSEIF(ISUB.EQ.63) THEN C...Z0 + W+/- -> f + fbar' ELSEIF(ISUB.EQ.64) THEN C...Z0 + h0 -> f + fbar ELSEIF(ISUB.EQ.65) THEN C...W+ + W- -> f + fbar ELSEIF(ISUB.EQ.66) THEN C...W+/- + h0 -> f + fbar' ELSEIF(ISUB.EQ.67) THEN C...h0 + h0 -> f + fbar ELSEIF(ISUB.EQ.68) THEN C...g + g -> g + g; th arbitrary KCC=MINT(2)+12 KCS=(-1)**INT(1.5D0+PYR(0)) ELSEIF(ISUB.EQ.69) THEN C...gamma + gamma -> W+ + W-; th arbitrary MINT(21)=24 MINT(22)=-24 KCC=21 ELSEIF(ISUB.EQ.70) THEN C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2 IF(MINT(15).EQ.22) MINT(21)=23 IF(MINT(16).EQ.22) MINT(22)=23 KCC=21 ENDIF ELSEIF(ISUB.LE.80) THEN IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W- XH=SH/SHP MINT(21)=MINT(15) MINT(22)=MINT(16) PMQ(1)=PYMASS(MINT(21)) PMQ(2)=PYMASS(MINT(22)) 330 JT=INT(1.5D0+PYR(0)) ZMIN=2D0*PMQ(JT)/SHPR ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ & (SHPR*(SHPR-PMQ(3-JT))) ZMAX=MIN(1D0-XH,ZMAX) Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 330 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) Z(3-JT)=1D0-XH/(1D0-Z(JT)) SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 330 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) PHIR=PARU(2)*PYR(0) CPHI=COS(PHIR) ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* & SQRT(1D0-CTHE(2)**2)*CPHI Z1=2D0-Z(JT) Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* & PMQ(3-JT)**2/SHP)) ZMIN=2D0*PMQ(3-JT)/SHPR ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) ZMAX=MIN(1D0-XH,ZMAX) IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330 KCC=22 ELSEIF(ISUB.EQ.73) THEN C...Z0 + W+/- -> Z0 + W+/- JS=MINT(2) XH=SH/SHP 340 JT=3-MINT(2) I=MINT(14+JT) IA=IABS(I) IF(IA.LE.10) THEN RVCKM=VINT(180+I)*PYR(0) DO 350 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350 MINT(20+JT)=ISIGN(IB,I) RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) IF(RVCKM.LE.0D0) GOTO 360 350 CONTINUE ELSE IB=2*((IA+1)/2)-1+MOD(IA,2) MINT(20+JT)=ISIGN(IB,I) ENDIF 360 PMQ(JT)=PYMASS(MINT(20+JT)) MINT(23-JT)=MINT(17-JT) PMQ(3-JT)=PYMASS(MINT(23-JT)) JT=INT(1.5D0+PYR(0)) ZMIN=2D0*PMQ(JT)/SHPR ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ & (SHPR*(SHPR-PMQ(3-JT))) ZMAX=MIN(1D0-XH,ZMAX) IF(ZMIN.GE.ZMAX) GOTO 340 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 340 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) Z(3-JT)=1D0-XH/(1D0-Z(JT)) SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 340 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) PHIR=PARU(2)*PYR(0) CPHI=COS(PHIR) ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* & SQRT(1D0-CTHE(2)**2)*CPHI Z1=2D0-Z(JT) Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* & PMQ(3-JT)**2/SHP)) ZMIN=2D0*PMQ(3-JT)/SHPR ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) ZMAX=MIN(1D0-XH,ZMAX) IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340 KCC=22 ELSEIF(ISUB.EQ.74) THEN C...Z0 + h0 -> Z0 + h0 ELSEIF(ISUB.EQ.75) THEN C...W+ + W- -> gamma + gamma ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W- XH=SH/SHP 370 DO 400 JT=1,2 I=MINT(14+JT) IA=IABS(I) IF(IA.LE.10) THEN RVCKM=VINT(180+I)*PYR(0) DO 380 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380 MINT(20+JT)=ISIGN(IB,I) RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) IF(RVCKM.LE.0D0) GOTO 390 380 CONTINUE ELSE IB=2*((IA+1)/2)-1+MOD(IA,2) MINT(20+JT)=ISIGN(IB,I) ENDIF 390 PMQ(JT)=PYMASS(MINT(20+JT)) 400 CONTINUE JT=INT(1.5D0+PYR(0)) ZMIN=2D0*PMQ(JT)/SHPR ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ & (SHPR*(SHPR-PMQ(3-JT))) ZMAX=MIN(1D0-XH,ZMAX) IF(ZMIN.GE.ZMAX) GOTO 370 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 370 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) Z(3-JT)=1D0-XH/(1D0-Z(JT)) SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) IF(SQC1.LT.1D-8) GOTO 370 C1=SQRT(SQC1) C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) PHIR=PARU(2)*PYR(0) CPHI=COS(PHIR) ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* & SQRT(1D0-CTHE(2)**2)*CPHI Z1=2D0-Z(JT) Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* & PMQ(3-JT)**2/SHP)) ZMIN=2D0*PMQ(3-JT)/SHPR ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) ZMAX=MIN(1D0-XH,ZMAX) IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370 KCC=22 ELSEIF(ISUB.EQ.78) THEN C...W+/- + h0 -> W+/- + h0 ELSEIF(ISUB.EQ.79) THEN C...h0 + h0 -> h0 + h0 ELSEIF(ISUB.EQ.80) THEN C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2 IF(MINT(15).EQ.22) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I) IB=3-IA MINT(20+JS)=ISIGN(IB,I) KCC=22 ENDIF ELSEIF(ISUB.LE.90) THEN IF(ISUB.EQ.81) THEN C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2 MINT(21)=ISIGN(MINT(55),MINT(15)) MINT(22)=-MINT(21) KCC=4 ELSEIF(ISUB.EQ.82) THEN C...g + g -> Q + Qbar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(MINT(55),KCS) MINT(22)=-MINT(21) KCC=MINT(2)+10 ELSEIF(ISUB.EQ.83) THEN C...f + q -> f' + Q; th = (p(f) - p(f'))**2 KFOLD=MINT(16) IF(MINT(2).EQ.2) KFOLD=MINT(15) KFAOLD=IABS(KFOLD) IF(KFAOLD.GT.10) THEN KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1 ELSE RCKM=VINT(180+KFOLD)*PYR(0) IPM=(5-ISIGN(1,KFOLD))/2 KFANEW=-MOD(KFAOLD+1,2) 410 KFANEW=KFANEW+2 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM- & VCKM(KFAOLD/2,(KFANEW+1)/2) IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM- & VCKM(KFANEW/2,(KFAOLD+1)/2) ENDIF IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410 ENDIF IF(MINT(2).EQ.1) THEN MINT(21)=ISIGN(MINT(55),MINT(15)) MINT(22)=ISIGN(KFANEW,MINT(16)) ELSE MINT(21)=ISIGN(KFANEW,MINT(15)) MINT(22)=ISIGN(MINT(55),MINT(16)) JS=2 ENDIF KCC=22 ELSEIF(ISUB.EQ.84) THEN C...g + gamma -> Q + Qbar; th arbitary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(MINT(55),KCS) MINT(22)=-MINT(21) KCC=27 IF(MINT(16).EQ.21) KCC=28 ELSEIF(ISUB.EQ.85) THEN C...gamma + gamma -> F + Fbar; th arbitary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(MINT(56),KCS) MINT(22)=-MINT(21) KCC=21 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g MINT(21)=KFPR(ISUB,1) MINT(22)=KFPR(ISUB,2) KCC=24 KCS=(-1)**INT(1.5D0+PYR(0)) ENDIF ELSEIF(ISUB.LE.100) THEN IF(ISUB.EQ.95) THEN C...Low-pT ( = energyless g + g -> g + g) KCC=MINT(2)+12 KCS=(-1)**INT(1.5D0+PYR(0)) ELSEIF(ISUB.EQ.96) THEN C...Multiple interactions (should be reassigned to QCD process) ENDIF ELSEIF(ISUB.LE.110) THEN IF(ISUB.EQ.101) THEN C...g + g -> gamma*/Z0 KCC=21 KFRES=22 ELSEIF(ISUB.EQ.102) THEN C...g + g -> h0 (or H0, or A0) KCC=21 KFRES=KFHIGG ELSEIF(ISUB.EQ.103) THEN C...gamma + gamma -> h0 (or H0, or A0) KCC=21 KFRES=KFHIGG ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN C...g + g -> chi_0c or chi_2c. KCC=21 KFRES=KFPR(ISUB,1) ELSEIF(ISUB.EQ.106) THEN C...g + g -> J/Psi + gamma MINT(21)=KFPR(ISUB,1) MINT(22)=KFPR(ISUB,2) KCC=21 ELSEIF(ISUB.EQ.107) THEN C...g + gamma -> J/Psi + g MINT(21)=KFPR(ISUB,1) MINT(22)=KFPR(ISUB,2) KCC=22 IF(MINT(16).EQ.22) KCC=33 ELSEIF(ISUB.EQ.108) THEN C...gamma + gamma -> J/Psi + gamma MINT(21)=KFPR(ISUB,1) MINT(22)=KFPR(ISUB,2) ELSEIF(ISUB.EQ.110) THEN C...f + fbar -> gamma + h0; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=22 MINT(23-JS)=KFHIGG ENDIF ELSEIF(ISUB.LE.120) THEN IF(ISUB.EQ.111) THEN C...f + fbar -> g + h0; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=21 MINT(23-JS)=KFHIGG KCC=17+JS ELSEIF(ISUB.EQ.112) THEN C...f + g -> f + h0; th = (p(f) - p(f))**2 IF(MINT(15).EQ.21) JS=2 MINT(23-JS)=KFHIGG KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.113) THEN C...g + g -> g + h0; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(23-JS)=KFHIGG KCC=22+JS KCS=(-1)**INT(1.5D0+PYR(0)) ELSEIF(ISUB.EQ.114) THEN C...g + g -> gamma + gamma; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(21)=22 MINT(22)=22 KCC=21 ELSEIF(ISUB.EQ.115) THEN C...g + g -> g + gamma; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(23-JS)=22 KCC=22+JS KCS=(-1)**INT(1.5D0+PYR(0)) ELSEIF(ISUB.EQ.116) THEN C...g + g -> gamma + Z0 ELSEIF(ISUB.EQ.117) THEN C...g + g -> Z0 + Z0 ELSEIF(ISUB.EQ.118) THEN C...g + g -> W+ + W- ENDIF ELSEIF(ISUB.LE.140) THEN IF(ISUB.EQ.121) THEN C...g + g -> Q + Qbar + h0 KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS) MINT(22)=-MINT(21) KCC=11+INT(0.5D0+PYR(0)) KFRES=KFHIGG ELSEIF(ISUB.EQ.122) THEN C...q + qbar -> Q + Qbar + h0 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15)) MINT(22)=-MINT(21) KCC=4 KFRES=KFHIGG ELSEIF(ISUB.EQ.123) THEN C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as C...inner process) KCC=22 KFRES=KFHIGG ELSEIF(ISUB.EQ.124) THEN C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as C...inner process) DO 430 JT=1,2 I=MINT(14+JT) IA=IABS(I) IF(IA.LE.10) THEN RVCKM=VINT(180+I)*PYR(0) DO 420 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420 MINT(20+JT)=ISIGN(IB,I) RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) IF(RVCKM.LE.0D0) GOTO 430 420 CONTINUE ELSE IB=2*((IA+1)/2)-1+MOD(IA,2) MINT(20+JT)=ISIGN(IB,I) ENDIF 430 CONTINUE KCC=22 KFRES=KFHIGG ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2 IF(MINT(15).EQ.22) JS=2 MINT(23-JS)=21 KCC=24+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2 IF(MINT(15).EQ.22) JS=2 KCC=22 KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN C...g + gamma*_(T,L) -> f + fbar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFLF,KCS) MINT(22)=-MINT(21) KCC=27 IF(MINT(16).EQ.21) KCC=28 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFLF,KCS) MINT(22)=-MINT(21) KCC=21 ENDIF ELSEIF(ISUB.LE.160) THEN IF(ISUB.EQ.141) THEN C...f + fbar -> gamma*/Z0/Z'0 KFRES=32 ELSEIF(ISUB.EQ.142) THEN C...f + fbar' -> W'+/- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) KFRES=ISIGN(34,KCH1+KCH2) ELSEIF(ISUB.EQ.143) THEN C...f + fbar' -> H+/- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) KFRES=ISIGN(37,KCH1+KCH2) ELSEIF(ISUB.EQ.144) THEN C...f + fbar' -> R KFRES=ISIGN(41,MINT(15)+MINT(16)) ELSEIF(ISUB.EQ.145) THEN C...q + l -> LQ (leptoquark) IF(IABS(MINT(16)).LE.8) JS=2 KFRES=ISIGN(42,MINT(14+JS)) KCC=28+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.146) THEN C...e + gamma -> e* (excited lepton) IF(MINT(15).EQ.22) JS=2 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS)) KCC=22 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN C...q + g -> q* (excited quark) IF(MINT(15).EQ.21) JS=2 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS)) KCC=30+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.149) THEN C...g + g -> eta_tc KFRES=KTECHN+331 KCC=23 KCS=(-1)**INT(1.5D0+PYR(0)) ENDIF ELSEIF(ISUB.LE.200) THEN IF(ISUB.EQ.161) THEN C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I) IB=IA+MOD(IA,2)-MOD(IA+1,2) MINT(20+JS)=ISIGN(IB,I) KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.162) THEN C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2 IF(MINT(15).EQ.21) JS=2 MINT(20+JS)=ISIGN(42,MINT(14+JS)) KFLQL=KFDP(MDCY(42,2),2) MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS)) KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.163) THEN C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(42,KCS) MINT(22)=-MINT(21) KCC=MINT(2)+10 ELSEIF(ISUB.EQ.164) THEN C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2 MINT(21)=ISIGN(42,MINT(15)) MINT(22)=-MINT(21) KCC=4 ELSEIF(ISUB.EQ.165) THEN C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.166) THEN C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2 IF(MOD(MINT(15),2).EQ.0) THEN MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15)) MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16)) ELSE MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16)) ENDIF ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN C...q + q' -> q" + q* (excited quark) KFQSTR=KFPR(ISUB,2) KFQEXC=MOD(KFQSTR,KEXCIT) JS=MINT(2) MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS)) IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC) & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS)) KCC=22 JS=3-JS ELSEIF(ISUB.EQ.169) THEN C...q + qbar -> e + e* (excited lepton) KFQSTR=KFPR(ISUB,2) KFQEXC=MOD(KFQSTR,KEXCIT) JS=MINT(2) MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS)) MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS)) JS=3-JS ELSEIF(ISUB.EQ.191) THEN C...f + fbar -> rho_tc0. KFRES=KTECHN+113 ELSEIF(ISUB.EQ.192) THEN C...f + fbar' -> rho_tc+/- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) KFRES=ISIGN(KTECHN+213,KCH1+KCH2) ELSEIF(ISUB.EQ.193) THEN C...f + fbar -> omega_tc0. KFRES=KTECHN+223 ELSEIF(ISUB.EQ.194) THEN C...f + fbar -> f' + fbar' via mixture of s-channel C...rho_tc and omega_tc; th=(p(f)-p(f'))**2 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.195) THEN C...f + fbar' -> f'' + fbar''' via s-channel C...rho_tc+ th=(p(f)-p(f'))**2 C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2 IF(MOD(MINT(15),2).EQ.0) THEN MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15)) MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16)) ELSE MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16)) ENDIF ENDIF CMRENNA++ ELSEIF(ISUB.LE.215) THEN IF(ISUB.EQ.201) THEN C...f + fbar -> ~e_L + ~e_Lbar MINT(21)=ISIGN(KSUSY1+11,KCS) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.202) THEN C...f + fbar -> ~e_R + ~e_Rbar MINT(21)=ISIGN(KSUSY2+11,KCS) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.203) THEN C...f + fbar -> ~e_L + ~e_Rbar KCS=1 IF(MINT(2).EQ.2) KCS=-1 KS2=KSUSY2+11 KS1=KSUSY1+11 IF(KCS.EQ.-1) THEN KS2=KSUSY1+11 KS1=KSUSY2+11 JS=2 ENDIF MINT(21)=ISIGN(KS1,MINT(15)) MINT(22)=ISIGN(KS2,MINT(16)) c KCS=1 c IF(MINT(2).EQ.2) KCS=-1 C MINT(21)=ISIGN(KSUSY1+11,KCS) C MINT(22)=-ISIGN(KSUSY2+11,KCS) c IF(KCS.EQ.-1) THEN C KS1=KSUSY1+11 C KS2=KSUSY2+11 C JS=2 c ENDIF c MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) c MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16)) 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 KS2=KSUSY2+13 KS1=KSUSY1+13 IF(KCS.EQ.-1) THEN KS2=KSUSY1+13 KS1=KSUSY2+13 JS=2 ENDIF MINT(21)=ISIGN(KS1,MINT(15)) MINT(22)=ISIGN(KS2,MINT(16)) c MINT(21)=ISIGN(KSUSY1+13,KCS) c 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 KS2=KSUSY2+15 KS1=KSUSY1+15 IF(KCS.EQ.-1) THEN KS2=KSUSY1+15 KS1=KSUSY2+15 JS=2 ENDIF MINT(21)=ISIGN(KS1,MINT(15)) MINT(22)=ISIGN(KS2,MINT(16)) C KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) C IF(MINT(2).EQ.1) THEN C MINT(21)= ISIGN(KSUSY1+15,KCH1) C MINT(22)= -ISIGN(KSUSY2+15,KCH1) C ELSE C MINT(21)= ISIGN(KSUSY2+15,KCH1) C MINT(22)= -ISIGN(KSUSY1+15,KCH1) C JS=2 C ENDIF ELSEIF(ISUB.EQ.210) THEN C...q + qbar' -> ~l_L + ~nulbar; th arbitrary KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2) MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2) ELSEIF(ISUB.EQ.211) THEN C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2) MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2) ELSEIF(ISUB.EQ.212) THEN C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2) MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2) ELSEIF(ISUB.EQ.213) THEN C...f + fbar -> ~nul + ~nulbar MINT(21)=ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.214) THEN C...f + fbar -> ~nutau + ~nutaubar MINT(21)=ISIGN(KSUSY1+16,KCS) MINT(22)=-MINT(21) ENDIF ELSEIF(ISUB.LE.225) THEN IF(ISUB.EQ.216) THEN C...f + fbar -> ~chi01 + ~chi01 MINT(21)=KSUSY1+22 MINT(22)=KSUSY1+22 ELSEIF(ISUB.EQ.217) THEN C...f + fbar -> ~chi02 + ~chi02 MINT(21)=KSUSY1+23 MINT(22)=KSUSY1+23 ELSEIF(ISUB.EQ.218 ) THEN C...f + fbar -> ~chi03 + ~chi03 MINT(21)=KSUSY1+25 MINT(22)=KSUSY1+25 ELSEIF(ISUB.EQ.219 ) THEN C...f + fbar -> ~chi04 + ~chi04 MINT(21)=KSUSY1+35 MINT(22)=KSUSY1+35 ELSEIF(ISUB.EQ.220 ) THEN C...f + fbar -> ~chi01 + ~chi02 IF(MINT(15).LT.0) JS=2 C IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+22 MINT(23-JS)=KSUSY1+23 ELSEIF(ISUB.EQ.221 ) THEN C...f + fbar -> ~chi01 + ~chi03 IF(MINT(15).LT.0) JS=2 C IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+22 MINT(23-JS)=KSUSY1+25 ELSEIF(ISUB.EQ.222) THEN C...f + fbar -> ~chi01 + ~chi04 IF(MINT(15).LT.0) JS=2 C IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+22 MINT(23-JS)=KSUSY1+35 ELSEIF(ISUB.EQ.223) THEN C...f + fbar -> ~chi02 + ~chi03 IF(MINT(15).LT.0) JS=2 C IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+23 MINT(23-JS)=KSUSY1+25 ELSEIF(ISUB.EQ.224) THEN C...f + fbar -> ~chi02 + ~chi04 IF(MINT(15).LT.0) JS=2 C IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+23 MINT(23-JS)=KSUSY1+35 ELSEIF(ISUB.EQ.225) THEN C...f + fbar -> ~chi03 + ~chi04 IF(MINT(15).LT.0) JS=2 C IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+25 MINT(23-JS)=KSUSY1+35 ENDIF ELSEIF(ISUB.LE.236) THEN IF(ISUB.EQ.226) THEN C...f + fbar -> ~chi+-1 + ~chi-+1 C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) MINT(21)=ISIGN(KSUSY1+24,KCH1) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.227) THEN C...f + fbar -> ~chi+-2 + ~chi-+2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) MINT(21)=ISIGN(KSUSY1+37,KCH1) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.228) THEN C...f + fbar -> ~chi+-1 + ~chi-+2 C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2 C...js=1 if pyr<.5, js=2 if pyr>.5 C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2 C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2 C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2 C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=INT(1-KCH1)/2 IF(MINT(2).EQ.1) THEN MINT(21)= ISIGN(KSUSY1+24,KCH1) MINT(22)= -ISIGN(KSUSY1+37,KCH1) c IF(KCH2.EQ.0) JS=2 ELSE MINT(21)= ISIGN(KSUSY1+37,KCH1) MINT(22)= -ISIGN(KSUSY1+24,KCH1) JS=2 c IF(KCH2.EQ.1) JS=2 ENDIF ELSEIF(ISUB.EQ.229) THEN C...q + qbar' -> ~chi01 + ~chi+-1 C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) C...CHECK THIS IF(MOD(MINT(15),2).EQ.0) JS=2 MINT(20+JS)=KSUSY1+22 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) ELSEIF(ISUB.EQ.230) THEN C...q + qbar' -> ~chi02 + ~chi+-1 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MOD(MINT(15),2).EQ.0) JS=2 MINT(20+JS)=KSUSY1+23 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) ELSEIF(ISUB.EQ.231) THEN C...q + qbar' -> ~chi03 + ~chi+-1 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MOD(MINT(15),2).EQ.0) JS=2 MINT(20+JS)=KSUSY1+25 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) ELSEIF(ISUB.EQ.232) THEN C...q + qbar' -> ~chi04 + ~chi+-1 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MOD(MINT(15),2).EQ.0) JS=2 MINT(20+JS)=KSUSY1+35 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) ELSEIF(ISUB.EQ.233) THEN C...q + qbar' -> ~chi01 + ~chi+-2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MOD(MINT(15),2).EQ.0) JS=2 MINT(20+JS)=KSUSY1+22 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) ELSEIF(ISUB.EQ.234) THEN C...q + qbar' -> ~chi02 + ~chi+-2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MOD(MINT(15),2).EQ.0) JS=2 MINT(20+JS)=KSUSY1+23 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) ELSEIF(ISUB.EQ.235) THEN C...q + qbar' -> ~chi03 + ~chi+-2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MOD(MINT(15),2).EQ.0) JS=2 MINT(20+JS)=KSUSY1+25 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) ELSEIF(ISUB.EQ.236) THEN C...q + qbar' -> ~chi04 + ~chi+-2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MOD(MINT(15),2).EQ.0) JS=2 MINT(20+JS)=KSUSY1+35 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) ENDIF ELSEIF(ISUB.LE.245) THEN IF(ISUB.EQ.237) THEN C...q + qbar -> ~chi01 + ~g C...th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+21 MINT(23-JS)=KSUSY1+22 KCC=17+JS ELSEIF(ISUB.EQ.238) THEN C...q + qbar -> ~chi02 + ~g C...th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+21 MINT(23-JS)=KSUSY1+23 KCC=17+JS ELSEIF(ISUB.EQ.239) THEN C...q + qbar -> ~chi03 + ~g C...th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+21 MINT(23-JS)=KSUSY1+25 KCC=17+JS ELSEIF(ISUB.EQ.240) THEN C...q + qbar -> ~chi04 + ~g C...th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KSUSY1+21 MINT(23-JS)=KSUSY1+35 KCC=17+JS ELSEIF(ISUB.EQ.241) THEN C...q + qbar' -> ~chi+-1 + ~g C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+ C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi- C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi- C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+ C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) JS=1 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 MINT(20+JS)=KSUSY1+21 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) KCC=17+JS ELSEIF(ISUB.EQ.242) THEN C...q + qbar' -> ~chi+-2 + ~g C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+ C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi- C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi- C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+ C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) JS=1 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 MINT(20+JS)=KSUSY1+21 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) KCC=17+JS ELSEIF(ISUB.EQ.243) THEN C...q + qbar -> ~g + ~g ; th arbitrary MINT(21)=KSUSY1+21 MINT(22)=KSUSY1+21 KCC=MINT(2)+4 ELSEIF(ISUB.EQ.244) THEN C...g + g -> ~g + ~g ; th arbitrary KCC=MINT(2)+12 KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=KSUSY1+21 MINT(22)=KSUSY1+21 ENDIF ELSEIF(ISUB.LE.260) THEN IF(ISUB.EQ.246) THEN C...qj + g -> ~qj_L + ~chi01 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY1+IA,I) MINT(23-JS)=KSUSY1+22 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.247) THEN C...qj + g -> ~qj_R + ~chi01 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY2+IA,I) MINT(23-JS)=KSUSY1+22 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.248) THEN C...qj + g -> ~qj_L + ~chi02 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY1+IA,I) MINT(23-JS)=KSUSY1+23 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.249) THEN C...qj + g -> ~qj_R + ~chi02 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY2+IA,I) MINT(23-JS)=KSUSY1+23 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.250) THEN C...qj + g -> ~qj_L + ~chi03 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY1+IA,I) MINT(23-JS)=KSUSY1+25 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.251) THEN C...qj + g -> ~qj_R + ~chi03 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY2+IA,I) MINT(23-JS)=KSUSY1+25 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.252) THEN C...qj + g -> ~qj_L + ~chi04 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY1+IA,I) MINT(23-JS)=KSUSY1+35 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.253) THEN C...qj + g -> ~qj_R + ~chi04 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY2+IA,I) MINT(23-JS)=KSUSY1+35 KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.254) THEN C...qj + g -> ~qk_L + ~chi+-1 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I) IB=-IA+INT((IA+1)/2)*4-1 MINT(20+JS)=ISIGN(KSUSY1+IB,I) KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.255) THEN C...qj + g -> ~qk_L + ~chi+-1 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I) IB=-IA+INT((IA+1)/2)*4-1 MINT(20+JS)=ISIGN(KSUSY2+IB,I) KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.256) THEN C...qj + g -> ~qk_L + ~chi+-2 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) IB=-IA+INT((IA+1)/2)*4-1 MINT(20+JS)=ISIGN(KSUSY1+IB,I) MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I) KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.257) THEN C...qj + g -> ~qk_R + ~chi+-2 IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) IB=-IA+INT((IA+1)/2)*4-1 MINT(20+JS)=ISIGN(KSUSY2+IB,I) MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I) KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.258) THEN C...qj + g -> ~qj_L + ~g IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY1+IA,I) MINT(23-JS)=KSUSY1+21 KCC=MINT(2)+6 IF(JS.EQ.2) KCC=KCC+2 KCS=ISIGN(1,I) ELSEIF(ISUB.EQ.259) THEN C...qj + g -> ~qj_R + ~g IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY2+IA,I) MINT(23-JS)=KSUSY1+21 KCC=MINT(2)+6 IF(JS.EQ.2) KCC=KCC+2 KCS=ISIGN(1,I) ENDIF ELSEIF(ISUB.LE.270) THEN IF(ISUB.EQ.261) THEN C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2 ISGN=1 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) C...Correct color combination IF(MINT(43).EQ.4) KCC=4 ELSEIF(ISUB.EQ.262) THEN C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2 ISGN=1 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) C...Correct color combination IF(MINT(43).EQ.4) KCC=4 ELSEIF(ISUB.EQ.263) THEN C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR. & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN MINT(21)=ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-ISIGN(KFPR(ISUB,2),KCS) ELSE JS=2 MINT(21)=ISIGN(KFPR(ISUB,2),KCS) MINT(22)=-ISIGN(KFPR(ISUB,1),KCS) ENDIF C...Correct color combination IF(MINT(43).EQ.4) KCC=4 ELSEIF(ISUB.EQ.264) THEN C...g + g -> ~t_1 + ~t_1bar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) KCC=MINT(2)+10 ELSEIF(ISUB.EQ.265) THEN C...g + g -> ~t_2 + ~t_2bar; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) KCC=MINT(2)+10 ENDIF ELSEIF(ISUB.LE.296) THEN IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN C...qi + qj -> ~qi_L + ~qj_L KCC=MINT(2) IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15)) MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16)) ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN C...qi + qj -> ~qi_R + ~qj_R KCC=MINT(2) IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15)) MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16)) ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN C...qi + qj -> ~qi_L + ~qj_R MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16)) KCC=MINT(2) IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15)) MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16)) KCC=MINT(2) IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15)) MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16)) KCC=MINT(2) IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16)) KCC=MINT(2) IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2 ISGN=1 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) IF(MINT(43).EQ.4) KCC=4 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2 ISGN=1 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) IF(MINT(43).EQ.4) KCC=4 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary C...pure LL + RR KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) KCC=MINT(2)+10 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary KCS=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) KCC=MINT(2)+10 ELSEIF(ISUB.EQ.294) THEN C...qj + g -> ~qj_L + ~g IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY1+IA,I) MINT(23-JS)=KSUSY1+21 KCC=MINT(2)+6 IF(JS.EQ.2) KCC=KCC+2 KCS=ISIGN(1,I) ELSEIF(ISUB.EQ.295) THEN C...qj + g -> ~qj_R + ~g IF(MINT(15).EQ.21) JS=2 I=MINT(14+JS) IA=IABS(I) MINT(20+JS)=ISIGN(KSUSY2+IA,I) MINT(23-JS)=KSUSY1+21 KCC=MINT(2)+6 IF(JS.EQ.2) KCC=KCC+2 KCS=ISIGN(1,I) ENDIF ELSEIF(ISUB.LE.340) THEN IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN C...q + qbar' -> H+ + H0 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 MINT(20+JS)=ISIGN(37,KCH1+KCH2) MINT(23-JS)=KFPR(ISUB,2) ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN C...f + fbar -> A0 + H0; th arbitrary IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KFPR(ISUB,1) MINT(23-JS)=KFPR(ISUB,2) ELSEIF(ISUB.EQ.301) THEN C...f + fbar -> H+ H- MINT(21)=ISIGN(KFPR(ISUB,1),KCS) MINT(22)=-MINT(21) ENDIF CMRENNA-- ELSEIF(ISUB.LE.360) THEN IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN C...l + l -> H_L++/--, H_R++/-- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2) ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2 IF(MINT(15).EQ.22) JS=2 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS)) MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS)) KCC=22 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15)) MINT(22)=-MINT(21) ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- C...as inner process). DO 450 JT=1,2 I=MINT(14+JT) IA=IABS(I) IF(IA.LE.10) THEN RVCKM=VINT(180+I)*PYR(0) DO 440 J=1,MSTP(1) IB=2*J-1+MOD(IA,2) IPM=(5-ISIGN(1,I))/2 IDC=J+MDCY(IA,2)+2 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440 MINT(20+JT)=ISIGN(IB,I) RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) IF(RVCKM.LE.0D0) GOTO 450 440 CONTINUE ELSE IB=2*((IA+1)/2)-1+MOD(IA,2) MINT(20+JT)=ISIGN(IB,I) ENDIF 450 CONTINUE KCC=22 KFRES=ISIGN(KFPR(ISUB,1),MINT(15)) IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES ELSEIF(ISUB.EQ.353) THEN C...f + fbar -> Z_R0 KFRES=KFPR(ISUB,1) ELSEIF(ISUB.EQ.354) THEN C...f + fbar' -> W+/- KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2) ENDIF ELSEIF(ISUB.LE.380) THEN IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN C...f + fbar -> charged+ charged- technicolor KSW=(-1)**INT(1.5D0+PYR(0)) MINT(21)=ISIGN(KFPR(ISUB,1),KSW) MINT(22)=-ISIGN(KFPR(ISUB,2),KSW) ELSEIF(ISUB.LE.367) THEN C...f + fbar -> neutral neutral technicolor MINT(21)=KFPR(ISUB,1) MINT(22)=KFPR(ISUB,2) ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375) THEN C...f + fbar' -> neutral charged technicolor IN=1 IC=2 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2) MINT(20+JS)=KFPR(ISUB,IN) ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN C...f + fbar' -> charged neutral technicolor IN=2 IC=1 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2) MINT(23-JS)=KFPR(ISUB,IN) ENDIF ELSEIF(ISUB.LE.400) THEN IF(ISUB.EQ.391) THEN C...f + fbar -> G*. KFRES=KFPR(ISUB,1) ELSEIF(ISUB.EQ.392) THEN C...g + g -> G*. KCC=21 KFRES=KFPR(ISUB,1) ELSEIF(ISUB.EQ.393) THEN C...q + qbar -> g + G*; th arbitrary. IF(PYR(0).GT.0.5D0) JS=2 MINT(20+JS)=KFPR(ISUB,1) MINT(23-JS)=KFPR(ISUB,2) KCC=17+JS ELSEIF(ISUB.EQ.394) THEN C...q + g -> q + G*; th = (p(f) - p(f))**2 IF(MINT(15).EQ.21) JS=2 MINT(23-JS)=KFPR(ISUB,2) KCC=15+JS KCS=ISIGN(1,MINT(14+JS)) ELSEIF(ISUB.EQ.395) THEN C...g + g -> G* + g; th arbitrary. IF(PYR(0).GT.0.5D0) JS=2 MINT(23-JS)=KFPR(ISUB,2) KCC=22+JS ENDIF ENDIF IF(ISET(ISUB).EQ.11) THEN C...Store documentation for user-defined processes BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2)) KUPPO(1)=MINT(83)+5 KUPPO(2)=MINT(83)+6 I=MINT(83)+6 DO 470 IUP=3,NUP KUPPO(IUP)=0 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN IDOC=IDOC-1 MINT(4)=MINT(4)-1 GOTO 470 ENDIF I=I+1 KUPPO(IUP)=I K(I,1)=21 K(I,2)=IDUP(IUP) IF(IDUP(IUP).EQ.0) K(I,2)=90 K(I,3)=0 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP)) K(I,4)=0 K(I,5)=0 DO 460 J=1,5 P(I,J)=PUP(J,IUP) 460 CONTINUE V(I,5)=VTIMUP(IUP) 470 CONTINUE CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0, & -BEZUP) C...Store final state partons for user-defined processes N=IPU2 DO 490 IUP=3,NUP N=N+1 K(N,1)=1 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11 K(N,2)=IDUP(IUP) IF(IDUP(IUP).EQ.0) K(N,2)=90 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN K(N,3)=KUPPO(IUP) ELSE K(N,3)=MINT(84)+MOTHUP(1,IUP) ENDIF K(N,4)=0 K(N,5)=0 DO 480 J=1,5 P(N,J)=PUP(J,IUP) 480 CONTINUE V(N,5)=VTIMUP(IUP) 490 CONTINUE CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP) C...Arrange colour flow for user-defined processes NLBL=0 DO 540 IUP1=1,NUP I1=MINT(84)+IUP1 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540 IF(K(I1,1).EQ.1) K(I1,1)=3 IF(K(I1,1).EQ.11) K(I1,1)=14 C...Find a not yet considered colour/anticolour line. DO 530 ISDE1=1,2 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530 NMAT=0 DO 500 ILBL=1,NLBL IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1 500 CONTINUE IF(NMAT.EQ.0) THEN NLBL=NLBL+1 ILAB(NLBL)=ICOLUP(ISDE1,IUP1) C...Find all others belonging to same line. I3=I1 I4=0 DO 520 IUP2=IUP1+1,NUP I2=MINT(84)+IUP2 DO 510 ISDE2=1,2 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN IF(ISDE2.EQ.ISDE1) THEN K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3 I3=I2 ELSEIF(I4.NE.0) THEN K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4 I4=I2 ELSEIF(IUP2.LE.2) THEN K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1 I4=I2 ELSE K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1 I4=I2 ENDIF ENDIF 510 CONTINUE 520 CONTINUE ENDIF 530 CONTINUE 540 CONTINUE ELSEIF(IDOC.EQ.7) THEN C...Resonance not decaying; store kinematics I=MINT(83)+7 K(IPU3,1)=1 K(IPU3,2)=KFRES K(IPU3,3)=I P(IPU3,4)=SHUSER P(IPU3,5)=SHUSER K(I,1)=21 K(I,2)=KFRES P(I,4)=SHUSER P(I,5)=SHUSER N=IPU3 MINT(21)=KFRES MINT(22)=0 C...Special cases: colour flow in coloured resonances KCRES=PYCOMP(KFRES) IF(KCHG(KCRES,2).NE.0) THEN K(IPU3,1)=3 DO 550 J=1,2 JC=J IF(KCS.EQ.-1) JC=3-J IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)= & MINT(84)+ICOL(KCC,1,JC) IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)= & MINT(84)+ICOL(KCC,2,JC) IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)= & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC)) 550 CONTINUE ELSE K(IPU1,4)=IPU2 K(IPU1,5)=IPU2 K(IPU2,4)=IPU1 K(IPU2,5)=IPU1 ENDIF ELSEIF(IDOC.EQ.8) THEN C...2 -> 2 processes: store outgoing partons in their CM-frame DO 560 JT=1,2 I=MINT(84)+2+JT KCA=PYCOMP(MINT(20+JT)) K(I,1)=1 IF(KCHG(KCA,2).NE.0) K(I,1)=3 K(I,2)=MINT(20+JT) K(I,3)=MINT(83)+IDOC+JT-2 KFAA=IABS(K(I,2)) IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN P(I,5)=SQRT(VINT(63+MOD(JS+JT,2))) ELSE P(I,5)=PYMASS(K(I,2)) ENDIF IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND. & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2)) 560 CONTINUE IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN KFA1=IABS(MINT(21)) KFA2=IABS(MINT(22)) IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21)) & THEN MINT(51)=1 RETURN ENDIF P(IPU3,5)=0D0 P(IPU4,5)=0D0 ENDIF P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR) P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2)) P(IPU4,4)=SHR-P(IPU3,4) P(IPU4,3)=-P(IPU3,3) N=IPU4 MINT(7)=MINT(83)+7 MINT(8)=MINT(83)+8 C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4) CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0) ELSEIF(IDOC.EQ.9) THEN C...2 -> 3 processes: store outgoing partons in their CM frame DO 570 JT=1,2 I=MINT(84)+2+JT KCA=PYCOMP(MINT(20+JT)) K(I,1)=1 IF(KCHG(KCA,2).NE.0) K(I,1)=3 K(I,2)=MINT(20+JT) K(I,3)=MINT(83)+IDOC+JT-3 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)) 570 CONTINUE K(IPU5,1)=1 K(IPU5,2)=KFRES K(IPU5,3)=MINT(83)+IDOC P(IPU5,5)=SHR P(IPU5,1)=-P(IPU3,1)-P(IPU4,1) P(IPU5,2)=-P(IPU3,2)-P(IPU4,2) PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2 PMT3=SQRT(PMS3) P(IPU5,3)=PMT3*SINH(VINT(211)) P(IPU5,4)=PMT3*COSH(VINT(211)) PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2 IF(SQL12.LE.0D0) THEN MINT(51)=1 RETURN ENDIF P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+ & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12) P(IPU4,3)=-P(IPU3,3)-P(IPU5,3) P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2) P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2) MINT(23)=KFRES N=IPU5 MINT(7)=MINT(83)+7 MINT(8)=MINT(83)+8 ELSEIF(IDOC.EQ.11) THEN C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons PHI(1)=PARU(2)*PYR(0) PHI(2)=PHI(1)-PHIR DO 580 JT=1,2 I=MINT(84)+2+JT K(I,1)=1 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3 K(I,2)=MINT(20+JT) K(I,3)=MINT(83)+IDOC+JT-2 P(I,5)=PYMASS(K(I,2)) IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN MINT(51)=1 RETURN ENDIF PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2)) PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2)) P(I,1)=PTABS*COS(PHI(JT)) P(I,2)=PTABS*SIN(PHI(JT)) P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1) P(I,4)=0.5D0*SHPR*Z(JT) IZW=MINT(83)+6+JT K(IZW,1)=21 K(IZW,2)=23 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))) K(IZW,3)=IZW-2 P(IZW,1)=-P(I,1) P(IZW,2)=-P(I,2) P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1) P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT)) P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2)) 580 CONTINUE I=MINT(83)+9 K(IPU5,1)=1 K(IPU5,2)=KFRES K(IPU5,3)=I P(IPU5,5)=SHR P(IPU5,1)=-P(IPU3,1)-P(IPU4,1) P(IPU5,2)=-P(IPU3,2)-P(IPU4,2) P(IPU5,3)=-P(IPU3,3)-P(IPU4,3) P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4) K(I,1)=21 K(I,2)=KFRES DO 590 J=1,5 P(I,J)=P(IPU5,J) 590 CONTINUE N=IPU5 MINT(23)=KFRES ELSEIF(IDOC.EQ.12) THEN C...Z0 and W+/- scattering: store bosons and outgoing partons PHI(1)=PARU(2)*PYR(0) PHI(2)=PHI(1)-PHIR JTRAN=INT(1.5D0+PYR(0)) DO 600 JT=1,2 I=MINT(84)+2+JT K(I,1)=1 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3 K(I,2)=MINT(20+JT) K(I,3)=MINT(83)+IDOC+JT-2 P(I,5)=PYMASS(K(I,2)) IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2)) PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2)) P(I,1)=PTABS*COS(PHI(JT)) P(I,2)=PTABS*SIN(PHI(JT)) P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1) P(I,4)=0.5D0*SHPR*Z(JT) IZW=MINT(83)+6+JT K(IZW,1)=21 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN K(IZW,2)=23 ELSE K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT))) ENDIF K(IZW,3)=IZW-2 P(IZW,1)=-P(I,1) P(IZW,2)=-P(I,2) P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1) P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT)) P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2)) IPU=MINT(84)+4+JT K(IPU,1)=3 K(IPU,2)=KFPR(ISUB,JT) IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2) IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2) K(IPU,3)=MINT(83)+8+JT IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN P(IPU,5)=PYMASS(K(IPU,2)) ELSE P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2))) ENDIF MINT(22+JT)=K(IPU,2) 600 CONTINUE C...Find rotation and boost for hard scattering subsystem I1=MINT(83)+7 I2=MINT(83)+8 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4)) BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4)) BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4)) GAMCM=(P(I1,4)+P(I2,4))/SHR BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3) PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM THECM=PYANGL(PZ,SQRT(PX**2+PY**2)) PHICM=PYANGL(PX,PY) C...Store hard scattering subsystem. Rotate and boost it SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2* & P(IPU6,5)**2 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH))) CTHWZ=VINT(23) STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2)) PHIWZ=VINT(24)-PHICM P(IPU5,1)=PABS*STHWZ*COS(PHIWZ) P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ) P(IPU5,3)=PABS*CTHWZ P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2) P(IPU6,1)=-P(IPU5,1) P(IPU6,2)=-P(IPU5,2) P(IPU6,3)=-P(IPU5,3) P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2) CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM) DO 620 JT=1,2 I1=MINT(83)+8+JT I2=MINT(84)+4+JT K(I1,1)=21 K(I1,2)=K(I2,2) DO 610 J=1,5 P(I1,J)=P(I2,J) 610 CONTINUE 620 CONTINUE N=IPU6 MINT(7)=MINT(83)+9 MINT(8)=MINT(83)+10 ENDIF IF(ISET(ISUB).EQ.11) THEN ELSEIF(IDOC.GE.8) THEN C...Store colour connection indices DO 630 J=1,2 JC=J IF(KCS.EQ.-1) JC=3-J IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)= & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC) IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)= & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC) IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)= & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC)) IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)= & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC)) 630 CONTINUE C...Copy outgoing partons to documentation lines IMAX=2 IF(IDOC.EQ.9) IMAX=3 DO 650 I=1,IMAX I1=MINT(83)+IDOC-IMAX+I I2=MINT(84)+2+I K(I1,1)=21 K(I1,2)=K(I2,2) IF(IDOC.LE.9) K(I1,3)=0 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I DO 640 J=1,5 P(I1,J)=P(I2,J) 640 CONTINUE 650 CONTINUE ELSEIF(IDOC.EQ.9) THEN C...Store colour connection indices DO 660 J=1,2 JC=J IF(KCS.EQ.-1) JC=3-J IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)= & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+ & MAX(0,MIN(1,ICOL(KCC,1,JC)-2)) IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)= & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+ & MAX(0,MIN(1,ICOL(KCC,2,JC)-2)) IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)= & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC)) IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)= & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC)) 660 CONTINUE C...Copy outgoing partons to documentation lines DO 680 I=1,3 I1=MINT(83)+IDOC-3+I I2=MINT(84)+2+I K(I1,1)=21 K(I1,2)=K(I2,2) K(I1,3)=0 DO 670 J=1,5 P(I1,J)=P(I2,J) 670 CONTINUE 680 CONTINUE ENDIF C...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 690 J=41,66 VINTSV(J)=VINT(J) VINT(J)=0D0 690 CONTINUE DO 710 I=MINT(83)+5,MINT(83)+8 DO 700 J=1,5 P(I,J)=0D0 700 CONTINUE 710 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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT2/,/PYINT3/ C...Local arrays and data. DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2), &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25), &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4), &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2), &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2) DATA IS/2*0/ C...Read out basic information; set global Q^2 scale. IPUS1=IPU1 IPUS2=IPU2 ISUB=MINT(1) Q2MX=VINT(56) IF(ISET(ISUB).EQ.2) Q2MX=MIN(VINT(2),PARP(67)*VINT(56)) FCQ2MX=1D0 C...Define which processes ME corrections have been implemented for. MECOR=0 IF(MSTP(68).EQ.1) THEN IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR. & ISUB.EQ.144) MECOR=1 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2 ENDIF C...Initialize QCD evolution and check phase space. Q2MNC=PARP(62)**2 Q2MNCS(1)=Q2MNC Q2MNCS(2)=Q2MNC IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN Q0S=PARP(15)**2 PS=VINT(3)**2 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) Q2INT=SQRT(Q0S*Q2EFF) Q2MNCS(1)=MAX(Q2MNC,Q2INT) ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN Q2MNCS(1)=MAX(Q2MNC,VINT(283)) ENDIF IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN Q0S=PARP(15)**2 PS=VINT(4)**2 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) Q2INT=SQRT(Q0S*Q2EFF) Q2MNCS(2)=MAX(Q2MNC,Q2INT) ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN Q2MNCS(2)=MAX(Q2MNC,VINT(284)) ENDIF MCEV=0 ALAMS=PARU(112) PARU(112)=PARP(61) FQ2C=1D0 TCMX=0D0 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN MCEV=1 IF(MSTP(64).EQ.1) FQ2C=PARP(63) IF(MSTP(64).EQ.2) FQ2C=PARP(64) TCMX=LOG(FQ2C*Q2MX/PARP(61)**2) IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0) & MCEV=0 ENDIF C...Initialize QED evolution and check phase space. MEEV=0 XEE=1D-10 SPME=PMAS(11,1)**2 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13) &SPME=PMAS(13,1)**2 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15) &SPME=PMAS(15,1)**2 Q2MNE=MAX(PARP(68)**2,2D0*SPME) TEMX=0D0 FWTE=10D0 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN MEEV=1 TEMX=LOG(Q2MX/SPME) IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0 ENDIF IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN MEEV=2 TEMX=TCMX FWTE=1D0 ENDIF IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN C...Loopback point in case of failure to reconstruct kinematics. NS=N LOOP=0 100 LOOP=LOOP+1 IF(LOOP.GT.100) THEN MINT(51)=1 RETURN ENDIF N=NS C...Initial values: flavours, momenta, virtualities. DO 120 JT=1,2 MORE(JT)=1 KFBEAM(JT)=MINT(10+JT) IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22 KFLS(JT)=MINT(14+JT) KFLS(JT+2)=KFLS(JT) XS(JT)=VINT(40+JT) IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT) ZS(JT)=1D0 Q2S(JT)=FCQ2MX*Q2MX DQ2(JT)=0D0 TEVCSV(JT)=TCMX ALAM(JT)=PARP(61) THE2(JT)=1D0 TEVESV(JT)=TEMX MCESV(JT)=0 C...Calculate initial parton distribution weights. MINT(105)=MINT(102+JT) MINT(109)=MINT(106+JT) VINT(120)=VINT(2+JT) C.... ALICE C.... Store side in MINT(124) MINT(124) = JT IF(XS(JT).LT.1D0-XEE) THEN IF(MSTP(57).LE.1) THEN CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB) ELSE CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB) ENDIF ENDIF DO 110 KFL=-25,25 XFS(JT,KFL)=XFB(KFL) 110 CONTINUE C...Special kinematics check for c/b quarks (that g -> c cbar or C...b bbar kinematically possible). KFLCB=IABS(KFLS(JT)) IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN MINT(51)=1 RETURN ENDIF ENDIF 120 CONTINUE DSH=VINT(44) IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2) C...Find if interference with final state partons. MFIS=0 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67) IF(MFIS.NE.0) THEN DO 140 I=1,2 KCFI(I)=0 KCA=PYCOMP(IABS(KFLS(I))) IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I)) NFIS(I)=0 IF(KCFI(I).NE.0) THEN IF(I.EQ.1) IPFS=IPUS1 IF(I.EQ.2) IPFS=IPUS2 DO 130 J=1,2 ICSI=MOD(K(IPFS,3+J),MSTU(5)) IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND. & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN NFIS(I)=NFIS(I)+1 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+ & P(ICSI,2)**2)) IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I)) ENDIF 130 CONTINUE ENDIF 140 CONTINUE IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0 ENDIF C...Pick up leg with highest virtuality. JTOLD=1 150 N=N+1 JT=1 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT IF(MORE(JT).EQ.0) JT=3-JT JTOLD=JT KFLB=KFLS(JT) XB=XS(JT) DO 160 KFL=-25,25 XFB(KFL)=XFS(JT,KFL) 160 CONTINUE DSHR=2D0*SQRT(DSH) DSHZ=DSH/ZS(JT) C...Check if allowed to branch. MCEV=0 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN MCEV=1 XEC=MAX(PARP(65)*DSHR/VINT(2),XB*(1D0/(1D0-PARP(66))-1D0)) IF(XB.GE.1D0-2D0*XEC) MCEV=0 ENDIF MEEV=0 IF(MINT(44+JT).EQ.3) THEN MEEV=1 IF(XB.GE.1D0-2D0*XEE) MEEV=0 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC) & MEEV=0 C***Currently kill QED shower for resolved photoproduction. IF(MINT(18+JT).EQ.1) MEEV=0 C***Currently kill shower for W inside electron. IF(IABS(KFLB).EQ.24) THEN MCEV=0 MEEV=0 ENDIF ENDIF IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10) &MEEV=2 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN Q2B=0D0 GOTO 260 ENDIF C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f. Q2B=Q2S(JT) TEVCB=TEVCSV(JT) TEVEB=TEVESV(JT) IF(MSTP(62).LE.1) THEN IF(ZS(JT).GT.0.99999D0) THEN Q2B=Q2S(JT) ELSE Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)* & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+ & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT)))) ENDIF IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2) IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME) ENDIF IF(MCEV.EQ.1) THEN ALSDUM=PYALPS(FQ2C*Q2B) TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117)) ALAM(JT)=PARU(117) B0=(33D0-2D0*MSTU(118))/6D0 ENDIF IF(MEEV.EQ.2) TEVEB=TEVCB TEVCBS=TEVCB TEVEBS=TEVEB C...Select side for interference with final state partons. IF(MFIS.GE.1.AND.N.LE.NS+2) THEN IFI=N-NS ISFI(IFI)=0 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN ISFI(IFI)=1 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN IF(PYR(0).GT.0.5D0) ISFI(IFI)=1 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN ISFI(IFI)=1 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2 ENDIF ENDIF C...Calculate preweighting factor for ME-corrected processes. IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG) C...Calculate Altarelli-Parisi weights. DO 170 KFL=-25,25 WTAPC(KFL)=0D0 WTAPE(KFL)=0D0 WTSF(KFL)=0D0 170 CONTINUE C...q -> q (g or gamma emission), g -> q. IF(IABS(KFLB).LE.10) THEN WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC))) WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC)) EQ2=1D0/9D0 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/ & (XEC*(1D0-XEC))) IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN WTAPC(KFLB)=WTFF*WTAPC(KFLB) WTAPC(21)=WTGF*WTAPC(21) WTAPE(KFLB)=WTFF*WTAPE(KFLB) ENDIF C...f -> f, gamma -> f. ELSEIF(IABS(KFLB).LE.20) THEN WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE))) WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE))) WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2) IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE) IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN WTAPE(KFLB)=WTFF*WTAPE(KFLB) WTAPE(22)=WTGF*WTAPE(22) ENDIF C...f -> g, g -> g. ELSEIF(KFLB.EQ.21) THEN WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB)) DO 180 KFL=1,MSTP(58) WTAPC(KFL)=WTAPQ WTAPC(-KFL)=WTAPQ 180 CONTINUE WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC) IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN DO 190 KFL=1,MSTP(58) WTAPC(KFL)=WTFG*WTAPC(KFL) WTAPC(-KFL)=WTFG*WTAPC(-KFL) 190 CONTINUE WTAPC(21)=WTGG*WTAPC(21) ENDIF C...f -> gamma, W+, W-. ELSEIF(KFLB.EQ.22) THEN WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB WTAPE(11)=WTAPF WTAPE(-11)=WTAPF IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN WTAPE(11)=WTFG*WTAPE(11) WTAPE(-11)=WTFG*WTAPE(-11) ENDIF ELSEIF(KFLB.EQ.24) THEN WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/ & (XEE*(XB+XEE)))/XB ELSEIF(KFLB.EQ.-24) THEN WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/ & (XEE*(XB+XEE)))/XB ENDIF C...Calculate parton distribution weights and sum. NTRY=0 200 NTRY=NTRY+1 IF(NTRY.GT.500) THEN MINT(51)=1 RETURN ENDIF WTSUMC=0D0 WTSUME=0D0 XFBO=MAX(1D-10,XFB(KFLB)) DO 210 KFL=-25,25 WTSF(KFL)=XFB(KFL)/XFBO WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL) WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL) 210 CONTINUE WTSUMC=MAX(0.0001D0,WTSUMC) WTSUME=MAX(0.0001D0/FWTE,WTSUME) C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2). NTRY2=0 220 NTRY2=NTRY2+1 IF(NTRY2.GT.500) THEN MINT(51)=1 RETURN ENDIF IF(MCEV.EQ.1) THEN IF(MSTP(64).LE.0) THEN TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC) ELSEIF(MSTP(64).EQ.1) THEN TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC)) ELSE TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC))) ENDIF ENDIF IF(MEEV.EQ.1) THEN TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/ & (PARU(101)*FWTE*WTSUME*TEMX))) ELSEIF(MEEV.EQ.2) THEN TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME) ENDIF C...Translate t into Q2 scale; choose between QCD and QED evolution. 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB)) IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C C...Ensure that Q2 is above threshold for charm/bottom. KFLCB=IABS(KFLB) IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND. &MCEV.EQ.1) THEN IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN Q2CB=1.1D0*PMAS(KFLCB,1)**2 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2) FCQ2MX=MIN(2D0,1.05D0*FCQ2MX) ENDIF ENDIF IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND. &MEEV.EQ.2) THEN IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0 ENDIF MCE=0 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN IF(Q2CB.GT.Q2MNCS(JT)) MCE=1 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN IF(Q2EB.GT.Q2MNE) MCE=2 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN IF(Q2EB.GT.Q2MNCS(JT)) MCE=2 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN MCE=1 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0 ELSE MCE=2 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0 ENDIF C...Evolution possibly ended. Update t values. IF(MCE.EQ.0) THEN Q2B=0D0 GOTO 260 ELSEIF(MCE.EQ.1) THEN Q2B=Q2CB Q2REF=FQ2C*Q2B IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME) IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2) ELSE Q2B=Q2EB Q2REF=Q2B IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2) ENDIF C...Select flavour for branching parton. IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME KFLA=-25 240 KFLA=KFLA+1 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA) IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA) IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240 IF(KFLA.EQ.25) THEN Q2B=0D0 GOTO 260 ENDIF C...Choose z value and corrective weight. WTZ=0D0 C...q -> q + g or q -> q + gamma. IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN Z=1D0-((1D0-XB-XEC)/(1D0-XEC))* & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0) WTZ=0.5D0*(1D0+Z**2) C...q -> g + q. ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z) C...f -> f + gamma. ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN Z=1D0-((1D0-XB-XEE)/(1D0-XEE))* & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0) ELSE Z=XB+XB*(XEE/(1D0-XEE))* & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0) ENDIF WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB) C...f -> gamma + f. ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN Z=XB+XB*(XEE/(1D0-XEE))* & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0) WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z C...f -> W+- + f. ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN Z=XB+XB*(XEE/(1D0-XEE))* & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0) WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)* & (Q2B/(Q2B+PMAS(24,1)**2)) C...g -> q + qbar. ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC)) WTZ=1D0-2D0*Z*(1D0-Z) C...g -> g + g. ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0)) WTZ=(1D0-Z*(1D0-Z))**2 C...gamma -> f + fbar. ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE)) WTZ=1D0-2D0*Z*(1D0-Z) ENDIF IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX) C...Option with resummation of soft gluon emission as effective z shift. IF(MCE.EQ.1) THEN IF(MSTP(65).GE.1) THEN RSOFT=6D0 IF(KFLB.NE.21) RSOFT=8D0/3D0 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0)) IF(Z.LE.XB) GOTO 220 ENDIF C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight. IF(MSTP(64).GE.2) THEN IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z)) IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0 ENDIF ENDIF C...Remove kinematically impossible branchings. UHAT=Q2B-DSH*(1D0-Z)/Z IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220 C...Select phi angle of branching at random. PHIBR=PARU(2)*PYR(0) C...Matrix-element corrections for some processes. IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME) WTZ=WTZ*WTME/WTFF ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME) WTZ=WTZ*WTME/WTGF ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME) WTZ=WTZ*WTME/WTFG ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME) WTZ=WTZ*WTME/WTGG ENDIF ENDIF C...Impose angular constraint in first branching from interference C...with final state partons. IF(MCE.EQ.1) THEN IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN THE2D=(4D0*Q2B)/(DSH*(1D0-Z)) IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220 ENDIF ENDIF C...Option with angular ordering requirement. IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT(2)) IF(THE2T.GT.THE2(JT)) GOTO 220 ENDIF ENDIF C...Weighting with new parton distributions. MINT(105)=MINT(102+JT) MINT(109)=MINT(106+JT) VINT(120)=VINT(2+JT) C.... ALICE C.... Store side in MINT(124) MINT(124)=JT IF(MSTP(57).LE.1) THEN CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN) ELSE CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN) ENDIF XFBN=XFN(KFLB) IF(XFBN.LT.1D-20) THEN IF(KFLA.EQ.KFLB) THEN TEVCB=TEVCBS TEVEB=TEVEBS WTAPC(KFLB)=0D0 WTAPE(KFLB)=0D0 GOTO 200 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN TEVCB=0.5D0*(TEVCBS+TEVCB) GOTO 230 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN TEVEB=0.5D0*(TEVEBS+TEVEB) GOTO 230 ELSE XFBN=1D-10 XFN(KFLB)=XFBN ENDIF ENDIF DO 250 KFL=-25,25 XFB(KFL)=XFN(KFL) 250 CONTINUE XA=XB/Z C.... ALICE C.... Store side in MINT(124) MINT(124) = JT C.... IF(MSTP(57).LE.1) THEN CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA) ELSE CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA) ENDIF XFAN=XFA(KFLA) IF(XFAN.LT.1D-20) GOTO 200 WTSFA=WTSF(KFLA) IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200 C...Define two hard scatterers in their CM-frame. 260 IF(N.EQ.NS+2) THEN DQ2(JT)=Q2B DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR DO 280 JR=1,2 I=NS+JR IF(JR.EQ.1) IPO=IPUS1 IF(JR.EQ.2) IPO=IPUS2 DO 270 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 270 CONTINUE K(I,1)=14 K(I,2)=KFLS(JR+2) K(I,4)=IPO K(I,5)=IPO P(I,3)=DPLCM*(-1)**(JR+1) P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR P(I,5)=-SQRT(DQ2(JR)) K(IPO,1)=14 K(IPO,3)=I K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I 280 CONTINUE C...Find maximum allowed mass of timelike parton. ELSEIF(N.GT.NS+2) THEN JR=3-JT DQ2(3)=Q2B DPC(1)=P(IS(1),4) DPC(2)=P(IS(2),4) DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3))) DPD(1)=DSH+DQ2(JR)+DQ2(JT) DPD(2)=DSHZ+DQ2(JR)+DQ2(3) DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT)) DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3)) IKIN=0 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE. & 1D-10*DPD(1)) IKIN=1 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))* & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3))) IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/ & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3) C...Generate timelike parton shower (if required). IT=N DO 290 J=1,5 K(IT,J)=0 P(IT,J)=0D0 V(IT,J)=0D0 290 CONTINUE C...f -> f + g (gamma). IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN K(IT,2)=21 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22 C...f -> g (gamma, W+-) + f. ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN K(IT,2)=KFLB IF(KFLS(JT+2).EQ.24) THEN K(IT,2)=-12 ELSEIF(KFLS(JT+2).EQ.-24) THEN K(IT,2)=12 ENDIF C...g (gamma) -> f + fbar, g + g. ELSE K(IT,2)=-KFLS(JT+2) IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2) ENDIF K(IT,1)=3 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR. & IABS(K(IT,2)).EQ.22) K(IT,1)=1 P(IT,5)=PYMASS(K(IT,2)) IF(DMSMA.LE.P(IT,5)**2) GOTO 100 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN MSTJ48=MSTJ(48) PARJ85=PARJ(85) P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2) IF(MSTP(63).EQ.1) THEN Q2TIM=DMSMA ELSEIF(MSTP(63).EQ.2) THEN Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT)) ELSE Q2TIM=DMSMA MSTJ(48)=1 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT)) IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)* & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2) PARJ(85)=SQRT(MAX(0D0,DPT2))* & (1D0/P(IT,4)+1D0/P(IS(JT),4)) ENDIF CALL PYSHOW(IT,0,SQRT(Q2TIM)) MSTJ(48)=MSTJ48 PARJ(85)=PARJ85 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5) ENDIF C...Reconstruct kinematics of branching: timelike parton shower. DMS=P(IT,5)**2 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT)) IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+ & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/ & (4D0*DSH*DPC(3)**2) IF(DPT2.LT.0D0) GOTO 100 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/ & DSHR)/DPC(3)-DPC(3) P(IT,1)=SQRT(DPT2) P(IT,3)=DPB(1)*(-1)**(JT+1) P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS) IF(N.GE.IT+1) THEN DPB(1)=SQRT(DPB(1)**2+DPT2) DPB(2)=SQRT(DPB(1)**2+DMS) DPB(3)=P(IT+1,3) DPB(4)=SQRT(DPB(3)**2+DMS) DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)* & DPB(1)) CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ) THE=PYANGL(P(IT,3),P(IT,1)) CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0) ENDIF C...Reconstruct kinematics of branching: spacelike parton. DO 300 J=1,5 K(N+1,J)=0 P(N+1,J)=0D0 V(N+1,J)=0D0 300 CONTINUE K(N+1,1)=14 K(N+1,2)=KFLB P(N+1,1)=P(IT,1) P(N+1,3)=P(IT,3)+P(IS(JT),3) P(N+1,4)=P(IT,4)+P(IS(JT),4) P(N+1,5)=-SQRT(DQ2(3)) C...Define colour flow of branching. K(IS(JT),3)=N+1 K(IT,3)=N+1 IM1=N+1 IM2=N+1 C...f -> f + gamma (Z, W). IF(IABS(K(IT,2)).GE.22) THEN K(IT,1)=1 ID1=IS(JT) ID2=IS(JT) C...f -> gamma (Z, W) + f. ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN ID1=IT ID2=IT C...gamma -> q + qbar, g + g. ELSEIF(K(N+1,2).EQ.22) THEN ID1=IS(JT) ID2=IT IM1=ID2 IM2=ID1 C...q -> q + g. ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN ID1=IT ID2=IS(JT) C...q -> g + q. ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN ID1=IS(JT) ID2=IT C...qbar -> qbar + g. ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN ID1=IS(JT) ID2=IT C...qbar -> g + qbar. ELSEIF(K(N+1,2).LT.0) THEN ID1=IT ID2=IS(JT) C...g -> g + g; g -> q + qbar. ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN ID1=IS(JT) ID2=IT ELSE ID1=IT ID2=IS(JT) ENDIF IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2 IF(ID1.NE.ID2) THEN K(ID1,5)=K(ID1,5)+MSTU(5)*ID2 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1 ENDIF N=N+1 C...Boost to new CM-frame. DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4)) DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4)) IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ) IR=N+(JT-1)*(IS(1)-N) CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT), & 0D0,0D0,0D0) ENDIF C...Update kinematics variables. IS(JT)=N DQ2(JT)=Q2B IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THE2(JT)=THE2T DSH=DSHZ C...Save quantities; loop back. Q2S(JT)=Q2B DPHI(JT)=PHIBR MCESV(JT)=MCE IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR. &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN KFLS(JT+2)=KFLS(JT) KFLS(JT)=KFLA XS(JT)=XA ZS(JT)=Z DO 310 KFL=-25,25 XFS(JT,KFL)=XFA(KFL) 310 CONTINUE TEVCSV(JT)=TEVCB TEVESV(JT)=TEVEB ELSE MORE(JT)=0 IF(JT.EQ.1) IPU1=N IF(JT.EQ.2) IPU2=N ENDIF IF(N.GT.MSTU(4)-MSTU(32)-10) THEN CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS') IF(MSTU(21).GE.1) N=NS IF(MSTU(21).GE.1) RETURN ENDIF IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150 C...Boost hard scattering partons to frame of shower initiators. DO 320 J=1,3 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4)) 320 CONTINUE K(N+2,1)=1 DO 330 J=1,5 P(N+2,J)=P(NS+1,J) 330 CONTINUE CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5)) ROBO(2)=PYANGL(P(N+2,1),P(N+2,2)) ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2)) CALL PYROBO(MINT(83)+5,NS,0D0,-ROBO(2),0D0,0D0,0D0) 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 340 JT=1,2 MINT(12+JT)=KFLS(JT) VINT(140+JT)=XS(JT) IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT) 340 CONTINUE PARU(112)=ALAMS RETURN END C********************************************************************* C...PYMEMX C...Generates maximum ME weight in some initial-state showers. C...Inparameter MECOR: kind of hard scattering process C...Outparameter WTFF: maximum weight for fermion -> fermion C... WTGF: maximum weight for gluon/photon -> fermion C... WTFG: maximum weight for fermion -> gluon/photon C... WTGG: maximum weight for gluon -> gluon SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/ C...Default maximum weight. WTFF=1D0 WTGF=1D0 WTFG=1D0 WTGG=1D0 C...Select maximum weight by process. IF(MECOR.EQ.1) THEN WTFF=1D0 WTGF=3D0 ELSEIF(MECOR.EQ.2) THEN WTFG=1D0 WTGG=1D0 ENDIF RETURN END C********************************************************************* C...PYMEWT C...Calculates actual ME weight in some initial-state showers. C...Inparameter MECOR: kind of hard scattering process C... IFLCB: flavour combination of branching, C... 1 for fermion -> fermion, C... 2 for gluon/photon -> fermion C... 3 for fermion -> gluon/photon, C... 4 for gluon -> gluon C... Q2: Q2 value of shower branching C... Z: Z value of branching C...In+outparameter PHIBR: azimuthal angle of branching C...Outparameter WTME: actual ME weight SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/ C...Default output. WTME=1D0 C...Define kinematics of shower branching in Mandelstam variables. SQM=VINT(44) SH=SQM/Z TH=-Q2 UH=Q2-SQM*(1D0-Z)/Z C...Matrix-element corrections for f + fbar -> s-channel vector boson. IF(MECOR.EQ.1) THEN IF(IFLCB.EQ.1) THEN WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2) ELSEIF(IFLCB.EQ.2) THEN WTME=(SH**2+UH**2+2D0*SQM*TH)/((SH-SQM)**2+SQM**2) ENDIF C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0). ELSEIF(MECOR.EQ.2) THEN IF(IFLCB.EQ.3) THEN WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2) ELSEIF(IFLCB.EQ.4) THEN WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2 ENDIF ENDIF RETURN END C********************************************************************* C...PYADSH C...Administers the generation of successive final-state showers C...in external processes. SUBROUTINE PYADSH(NFIN) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/ C...Local array. DIMENSION IBEG(100),KSAV(10,5),IORD(10),PSUM(4),BETA(3) C...Set primary vertex. DO 100 J=1,5 V(MINT(83)+5,J)=0D0 V(MINT(83)+6,J)=0D0 V(MINT(84)+1,J)=0D0 V(MINT(84)+2,J)=0D0 100 CONTINUE C...Isolate systems of particles with the same mother. NSYS=0 IMS=-1 DO 140 I=MINT(84)+3,NFIN IM=K(I,3) IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3) IF(IM.NE.IMS) THEN NSYS=NSYS+1 IBEG(NSYS)=I IMS=IM ENDIF C...Set production vertices. IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2)) & THEN DO 110 J=1,4 V(I,J)=0D0 110 CONTINUE ELSE DO 120 J=1,4 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5) 120 CONTINUE ENDIF IF(MSTP(125).GE.1) THEN IDOC=I-MSTP(126)+4 DO 130 J=1,5 V(IDOC,J)=V(I,J) 130 CONTINUE ENDIF 140 CONTINUE C...End loop over systems. Return if no showers to be performed. IBEG(NSYS+1)=NFIN+1 IF(MSTP(71).LE.0) RETURN C...Loop through systems of particles; check that sensible size. DO 260 ISYS=1,NSYS NSIZ=IBEG(ISYS+1)-IBEG(ISYS) IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN ELSEIF(NSIZ.LE.1) THEN CALL PYERRM(2,'(PYADSH:) only one particle in system') ELSEIF(NSIZ.GT.7) THEN CALL PYERRM(2,'(PYADSH:) more than seven particles in system') ELSE C...Save status codes and daughters of showering pair; reset them. DO 150 J=1,4 PSUM(J)=0D0 150 CONTINUE DO 170 II=1,NSIZ I=IBEG(ISYS)-1+II KSAV(II,1)=K(I,1) IF(K(I,1).GT.10) THEN K(I,1)=1 IF(KSAV(II,1).EQ.14) K(I,1)=3 ENDIF IF(KSAV(II,1).LE.10) THEN ELSEIF(K(I,1).EQ.1) THEN KSAV(II,4)=K(I,4) KSAV(II,5)=K(I,5) K(I,4)=0 K(I,5)=0 ELSE KSAV(II,4)=MOD(K(I,4),MSTU(5)) KSAV(II,5)=MOD(K(I,5),MSTU(5)) K(I,4)=K(I,4)-KSAV(II,4) K(I,5)=K(I,5)-KSAV(II,5) ENDIF DO 160 J=1,4 PSUM(J)=PSUM(J)+P(I,J) 160 CONTINUE 170 CONTINUE C...Perform shower. QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2- & PSUM(3)**2)) IF(ISYS.EQ.1) QMAX=VINT(55) NSAV=N IF(NSIZ.EQ.2) THEN CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX) ELSE CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX) ENDIF C...Look up showered copies of original showering particles. DO 250 II=1,NSIZ I=IBEG(ISYS)-1+II IMV=I IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN ELSEIF(K(I,1).EQ.11) THEN 180 IMV=MOD(K(IMV,4),MSTU(5)) IF(K(IMV,1).EQ.11) GOTO 180 ELSE KDA1=MOD(K(I,4),MSTU(5)) KDA2=MOD(K(I,5),MSTU(5)) DO 190 I3=I+1,N IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2)) & THEN IMV=I3 KDA1=MOD(K(I3,4),MSTU(5)) KDA2=MOD(K(I3,5),MSTU(5)) ENDIF 190 CONTINUE ENDIF C...Restore daughter info of original partons to showered copies. IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1) IF(KSAV(II,1).LE.10) THEN ELSEIF(K(I,1).EQ.1) THEN K(IMV,4)=KSAV(II,4) K(IMV,5)=KSAV(II,5) ELSE K(IMV,4)=K(IMV,4)+KSAV(II,4) K(IMV,5)=K(IMV,5)+KSAV(II,5) ENDIF C...Reset mother info of existing daughters to showered copies. DO 200 I3=IBEG(ISYS+1),NFIN IF(K(I3,3).EQ.I) K(I3,3)=IMV IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I) IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I) ENDIF 200 CONTINUE C...Boost all original daughters to new frame of showered copy. IF(IMV.NE.I) THEN DO 210 J=1,3 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4)) 210 CONTINUE FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2) DO 220 J=1,3 BETA(J)=FAC*BETA(J) 220 CONTINUE DO 240 I3=IBEG(ISYS+1),NFIN IMO=I3 230 IMO=K(IMO,3) IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 230 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3))) & CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3)) 240 CONTINUE ENDIF 250 CONTINUE C...End of loop over showering systems ENDIF 260 CONTINUE RETURN END C********************************************************************* C...PYRESD C...Allows resonances to decay (including parton showers for hadronic C...channels). SUBROUTINE PYRESD(IRES) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/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:300),WDTE(0:300,0:5),DPMO(5),XM(5),VDCY(4) COMPLEX FGK,HA(6,6),HC(6,6) REAL TIR,UIR CHARACTER CODE*9,MASS*9 C...The F, Xi and Xj functions of Gunion and Kunszt C...(Phys. Rev. D33, 665, plus errata from the authors). FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)* &HC(I1,I4)+HA(I3,I5)*HC(I3,I4)) DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/ &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34)) DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU- &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+ &2D0*(D34/D56+D56/D34)) C...Some general constants. XW=PARU(102) XWV=XW IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2 XW1=1D0-XW SQMZ=PMAS(23,1)**2 GMMZ=PMAS(23,1)*PMAS(23,2) SQMW=PMAS(24,1)**2 GMMW=PMAS(24,1)*PMAS(24,2) SH=VINT(44) C...Boost and rotate to rest frame of incoming partons, C...to get proper amount of smearing of decay angles. IBST=0 IF(IRES.EQ.0) THEN IBST=1 ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4) BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN) PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2)) CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0) THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1)) CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0) ENDIF C...Reset original resonance configuration. DO 100 JT=1,8 IREF(1,JT)=0 100 CONTINUE C...Define initial one, two or three objects for subprocess. IHDEC=0 IF(IRES.EQ.0) THEN ISUB=MINT(1) IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN IREF(1,1)=MINT(84)+2+ISET(ISUB) IREF(1,4)=MINT(83)+6+ISET(ISUB) JTMAX=1 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN IREF(1,1)=MINT(84)+1+ISET(ISUB) IREF(1,2)=MINT(84)+2+ISET(ISUB) IREF(1,4)=MINT(83)+5+ISET(ISUB) IREF(1,5)=MINT(83)+6+ISET(ISUB) JTMAX=2 ELSEIF(ISET(ISUB).EQ.5) THEN IREF(1,1)=MINT(84)+3 IREF(1,2)=MINT(84)+4 IREF(1,3)=MINT(84)+5 IREF(1,4)=MINT(83)+7 IREF(1,5)=MINT(83)+8 IREF(1,6)=MINT(83)+9 JTMAX=3 ENDIF C...Define original resonance for odd cases. ELSE ISUB=0 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36) & IHDEC=1 IF(IHDEC.EQ.1) ISUB=3 IREF(1,1)=IRES IREF(1,4)=K(IRES,3) JTMAX=1 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 KDA1=MOD(K(IREF(1,JT),4),MSTU(5)) KDA2=MOD(K(IREF(1,JT),5),MSTU(5)) DO 110 I=IREF(1,JT)+1,N IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR. & I.EQ.KDA2)) THEN IREF(1,JT)=I KDA1=MOD(K(IREF(1,JT),4),MSTU(5)) KDA2=MOD(K(IREF(1,JT),5),MSTU(5)) ENDIF 110 CONTINUE ELSE KDA=MOD(K(IREF(1,JT),4),MSTU(5)) IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA ENDIF ENDIF ENDIF 120 CONTINUE C.....Set decay vertex for initial resonances DO 140 JT=1,JTMAX DO 130 I=1,4 V(IREF(1,JT),I)=0D0 130 CONTINUE 140 CONTINUE C...Loop over decay history. NP=1 IP=0 150 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. 160 N=NSAV DO 250 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 240 KFA=IABS(K(ID,2)) KCA=PYCOMP(KFA) IF(MWID(KCA).EQ.0) GOTO 240 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 240 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR. & KFA.EQ.18) IT4=IT4+1 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5)) K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5)) C...Choose lifetime and determine decay vertex. IF(K(ID,1).EQ.5) THEN V(ID,5)=0D0 ELSEIF(K(ID,1).NE.4) THEN V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0)) ENDIF DO 170 J=1,4 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5) 170 CONTINUE C...Determine whether decay allowed or not. MOUT=0 IF(MSTJ(22).EQ.2) THEN IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1 ELSEIF(MSTJ(22).EQ.3) THEN IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1 ELSEIF(MSTJ(22).EQ.4) THEN IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1 ENDIF IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN K(ID,1)=4 GOTO 240 ENDIF C...Info for selection of decay channel: sign, pairings. IF(KCHG(KCA,3).EQ.0) THEN IPM=2 ELSE IPM=(5-ISIGN(1,K(ID,2)))/2 ENDIF KFB=0 IF(JTMAX.EQ.2) THEN KFB=IABS(K(IREF(IP,3-JT),2)) ELSEIF(JTMAX.EQ.3) THEN JT2=JT+1-3*(JT/3) KFB=IABS(K(IREF(IP,JT2),2)) IF(KFB.NE.KFA) THEN JT2=JT+2-3*((JT+1)/3) KFB=IABS(K(IREF(IP,JT2),2)) ENDIF ENDIF C...Select decay channel. IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR. & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE) WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4) IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5) IF(WDTE0S.LE.0D0) GOTO 240 RKFL=WDTE0S*PYR(0) IDL=0 180 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 180 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) JTZ=JT C...Select masses; to begin with assume resonances narrow. DO 200 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 200 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 190 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 190 CONTINUE CMRENNA-- ELSEIF(KFLW.EQ.6) THEN PMMN(I)=PMAS(24,1)+PMAS(5,1) ENDIF 200 CONTINUE C...Check which two out of three are widest. IWID1=1 IWID2=2 PWID1=PMAS(KFC1A,2) PWID2=PMAS(KFC2A,2) KFLW1=IABS(KFL1(JT)) KFLW2=IABS(KFL2(JT)) IF(KFL3(JT).NE.0) THEN PWID3=PMAS(KFC3A,2) IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN IWID1=3 PWID1=PWID3 KFLW1=IABS(KFL3(JT)) ELSEIF(PWID3.GT.PWID2) THEN IWID2=3 PWID2=PWID3 KFLW2=IABS(KFL3(JT)) ENDIF ENDIF C...If all narrow then only check that masses consistent. IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND. & PWID2.LT.PARP(41))) THEN CMRENNA++ C....Handle near degeneracy cases. IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0 ENDIF ENDIF CMRENNA-- IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN CALL PYERRM(13,'(PYRESD:) daughter masses too large') MINT(51)=1 GOTO 630 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN CALL PYERRM(3,'(PYRESD:) daughter masses too large') MINT(51)=1 GOTO 630 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 210 LOOP=LOOP+1 P(N+IWID3,5)=PYMASS(KFLW3) IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 210 PMTOT=PMTOT-P(N+IWID3,5) ENDIF C...Select other two correlated within remaining phase space. IF(IP.EQ.1) THEN CKIN45=CKIN(45) CKIN47=CKIN(47) CKIN(45)=MAX(PMMN(IWID1),CKIN(45)) CKIN(47)=MAX(PMMN(IWID2),CKIN(47)) CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5), & P(N+IWID2,5)) CKIN(45)=CKIN45 CKIN(47)=CKIN47 ELSE CKIN(49)=PMMN(IWID1) CKIN(50)=PMMN(IWID2) CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5), & P(N+IWID2,5)) CKIN(49)=0D0 CKIN(50)=0D0 ENDIF IF(MINT(51).EQ.1) GOTO 630 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 230 I=N+1,N+3 DO 220 J=1,5 K(I,J)=0 C V(I,J)=0D0 220 CONTINUE 230 CONTINUE K(N+1,1)=1 K(N+1,2)=KFL1(JT) K(N+2,1)=1 K(N+2,2)=KFL2(JT) K(N+3,1)=1 K(N+3,2)=KFL3(JT) IDIN=ID CALL PYTBDY(IDIN) C...Set colour flow for t -> W + b + Z. IF(KFA.EQ.6) THEN K(N+2,1)=3 ISID=4 IF(KCQM(JT).EQ.-1) ISID=5 IDAU=N+2 K(ID,ISID)=K(ID,ISID)+IDAU K(IDAU,ISID)=MSTU(5)*ID C...Set colour flow in three-body decays - programmed as special cases. ELSEIF(KFC2A.LE.6) THEN K(N+2,1)=3 K(N+3,1)=3 ISID=4 IF(KFL2(JT).LT.0) ISID=5 K(N+2,ISID)=MSTU(5)*(N+3) K(N+3,9-ISID)=MSTU(5)*(N+2) ENDIF IF(KFL1(JT).EQ.KSUSY1+21) THEN K(N+1,1)=3 K(N+2,1)=3 K(N+3,1)=3 ISID=4 IF(KFL2(JT).LT.0) ISID=5 K(N+1,ISID)=MSTU(5)*(N+2) K(N+1,9-ISID)=MSTU(5)*(N+3) K(N+2,ISID)=MSTU(5)*(N+1) K(N+3,9-ISID)=MSTU(5)*(N+1) ENDIF IF(KFA.EQ.KSUSY1+21) THEN K(N+2,1)=3 K(N+3,1)=3 ISID=4 IF(KFL2(JT).LT.0) ISID=5 K(ID,ISID)=K(ID,ISID)+(N+2) K(ID,9-ISID)=K(ID,9-ISID)+(N+3) K(N+2,ISID)=MSTU(5)*ID K(N+3,9-ISID)=MSTU(5)*ID ENDIF IF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND. & IABS(KCQ2(JT)).EQ.1) THEN K(N+2,1)=3 K(N+3,1)=3 ISID=4 IF(KFL2(JT).LT.0) ISID=5 K(N+2,ISID)=MSTU(5)*(N+3) K(N+3,9-ISID)=MSTU(5)*(N+2) ENDIF 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 240 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0)) & NINH=NINH+1 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND. & KFL1(JT).EQ.0) THEN WRITE(CODE,'(I9)') K(ID,2) WRITE(MASS,'(F9.3)') P(ID,5) CALL PYERRM(3,'(PYRESD:) Failed to decay particle'// & CODE//' with mass'//MASS) MINT(51)=1 GOTO 630 ENDIF 250 CONTINUE C...Check for allowed combinations. Skip if no decays. IF(JTMAX.EQ.1) THEN IF(KDCY(1).EQ.0) GOTO 620 ELSEIF(JTMAX.EQ.2) THEN IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 620 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160 ELSEIF(JTMAX.EQ.3) THEN IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 620 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 160 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 160 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 160 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 160 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 160 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 160 ENDIF C...Special case: matrix element option for Z0 decay to quarks. IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND. &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN C...Check consistency of MSTJ options set. IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN CALL PYERRM(6, & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1') MSTJ(110)=1 ENDIF IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN CALL PYERRM(6, & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0') MSTJ(111)=0 ENDIF C...Select alpha_strong behaviour. MST111=MSTU(111) PAR112=PARU(112) MSTU(111)=MSTJ(108) IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1)) & MSTU(111)=1 PARU(112)=PARJ(121) IF(MSTU(111).EQ.2) PARU(112)=PARJ(122) C...Find axial fraction in total cross section for scalar gluon model. PARJ(171)=0D0 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR. & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN POLL=1D0-PARJ(131)*PARJ(132) SFF=1D0/(16D0*XW*XW1) SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+ & (PARJ(123)*PARJ(124))**2) SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2) VE=4D0*XW-1D0 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131)) HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE* & (PARJ(132)-PARJ(131))) KFLC=IABS(KFL1(1)) PMQ=PYMASS(KFLC) QF=KCHG(KFLC,1)/3D0 VQ=1D0 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0, & 1D0-(2D0*PMQ/P(ID,5))**2)) VF=SIGN(1D0,QF)-4D0*QF*XW RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+ & VF**2*HF1W)+VQ**3*HF1W IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV) ENDIF C...Choice of jet configuration. CALL PYXJET(P(ID,5),NJET,CUT) KFLC=IABS(KFL1(1)) KFLN=21 IF(NJET.EQ.4) THEN CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14) ELSEIF(NJET.EQ.3) THEN CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3) ELSE MSTJ(120)=1 ENDIF C...Fill jet configuration; return if incorrect kinematics. NC=N-2 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5)) ELSEIF(NJET.EQ.2) THEN CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5)) ELSEIF(NJET.EQ.3) THEN CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3) ELSEIF(KFLN.EQ.21) THEN CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4, & X12,X14) ELSE CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4, & X12,X14) ENDIF IF(MSTU(24).NE.0) THEN MINT(51)=1 MSTU(111)=MST111 PARU(112)=PAR112 GOTO 630 ENDIF C...Angular orientation according to matrix element. IF(MSTJ(106).EQ.1) THEN CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ) IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ CTHE(1)=COS(THEZ) CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0) CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0) ENDIF C...Boost partons to Z0 rest frame. CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4), & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4)) C...Mark decayed resonance and add documentation lines, K(ID,1)=K(ID,1)+10 IDOC=MINT(83)+MINT(4) DO 270 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 260 J=1,5 P(I1,J)=P(I,J) 260 CONTINUE ENDIF 270 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 610 ENDIF C...Order incoming partons and outgoing resonances. IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND. &NINH.EQ.0) THEN ILIN(1)=MINT(84)+1 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22) & ILIN(1)=2*MINT(84)+3-ILIN(1) ILIN(2)=2*MINT(84)+3-ILIN(1) IMIN=1 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7) & .EQ.36) IMIN=3 IMAX=2 IORD=1 IF(K(IREF(IP,1),2).EQ.23) IORD=2 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2 IAKIPD=IABS(K(IREF(IP,IORD),2)) IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD IF(KDCY(IORD).EQ.0) IORD=3-IORD C...Order decay products of resonances. DO 280 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 280 CONTINUE C...Find charge, isospin, left- and righthanded couplings. DO 300 I=IMIN,IMAX DO 290 J=1,4 COUP(I,J)=0D0 290 CONTINUE KFA=IABS(K(ILIN(I),2)) IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 300 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) 300 CONTINUE C...Full propagator dependence and flavour correlations for 2 gamma*/Z. IF(ISUB.EQ.22) THEN DO 330 I=3,5,2 I1=IORD IF(I.EQ.5) I1=3-IORD DO 320 J1=1,2 DO 310 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 310 CONTINUE 320 CONTINUE 330 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 160 ENDIF ENDIF C...Select angular orientation type - Z'/W' only. MZPWP=0 IF(ISUB.EQ.141) THEN IF(PYR(0).LT.PARU(130)) MZPWP=1 IF(IP.EQ.2) THEN IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2 IAKIR=IABS(K(IREF(2,2),2)) IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2 IF(IAKIR.LE.20) MZPWP=2 ENDIF IF(IP.GE.3) MZPWP=2 ELSEIF(ISUB.EQ.142) THEN IF(PYR(0).LT.PARU(136)) MZPWP=1 IF(IP.EQ.2) THEN IAKIR=IABS(K(IREF(2,2),2)) IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2 IF(IAKIR.LE.20) MZPWP=2 ENDIF IF(IP.GE.3) MZPWP=2 ENDIF C...Select random angles (begin of weighting procedure). 340 DO 350 JT=1,JTMAX IF(KDCY(JT).EQ.0) GOTO 350 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0) IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33) PHI(JT)=VINT(24) ELSE CTHE(JT)=2D0*PYR(0)-1D0 PHI(JT)=PARU(2)*PYR(0) ENDIF 350 CONTINUE IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN C...Construct massless four-vectors. DO 370 I=N+1,N+4 K(I,1)=1 DO 360 J=1,5 P(I,J)=0D0 C V(I,J)=0D0 360 CONTINUE 370 CONTINUE DO 380 JT=1,JTMAX IF(KDCY(JT).EQ.0) GOTO 380 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)) 380 CONTINUE C...Store incoming and outgoing momenta, with random rotation to C...avoid accidental zeroes in HA expressions. IF(ISUB.NE.0) THEN DO 400 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 390 J=1,3 P(N+4+I,J)=P(ILIN(I),J) 390 CONTINUE 400 CONTINUE 410 THERR=ACOS(2D0*PYR(0)-1D0) PHIRR=PARU(2)*PYR(0) CALL PYROBO(N+5,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0) DO 430 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 410 DO 420 J=1,4 PK(I,J)=P(N+4+I,J) 420 CONTINUE 430 CONTINUE ENDIF C...Calculate internal products. IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR. & ISUB.EQ.142) THEN DO 450 I1=IMIN,IMAX-1 DO 440 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) 440 CONTINUE 450 CONTINUE ENDIF C...Calculate four-products. IF(ISUB.NE.0) THEN DO 470 I=1,2 DO 460 J=1,4 PK(I,J)=-PK(I,J) 460 CONTINUE 470 CONTINUE DO 490 I1=IMIN,IMAX-1 DO 480 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) 480 CONTINUE 490 CONTINUE ENDIF ENDIF KFAGM=IABS(IREF(IP,7)) IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN C...Isotropic decay selected by user. WT=1D0 WTMAX=1D0 ELSEIF(JTMAX.EQ.3) THEN C...Isotropic decay when three mother particles. WT=1D0 WTMAX=1D0 ELSEIF(IT4.GE.1) THEN C... Isotropic decay t -> b + W etc for 4th generation q and l. WT=1D0 WTMAX=1D0 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR. & IREF(IP,7).EQ.36) THEN C...Angular weight for h0 -> 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. RM3=PMAS(IABS(KFL1(1)),1)**2/SH RM4=PMAS(IABS(KFL2(1)),1)**2/SH BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2 WTMAX=4D0 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) -> C...-> gluon/gamma + 2 quarks/leptons. CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+ & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+ & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+ & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+ & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+ & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2) WTMAX=(CLILF+CLIRF+CRILF+CRIRF)* & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2) ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN C...Angular weight for f + fbar' -> gluon/gamma + W+/- -> C...-> gluon/gamma + 2 quarks/leptons. WT=PKK(1,3)**2+PKK(2,4)**2 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2 ELSEIF(ISUB.EQ.22) THEN C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons. S34=P(IREF(IP,IORD),5)**2 S56=P(IREF(IP,3-IORD),5)**2 TI=PKK(1,3)+PKK(1,4)+S34 UI=PKK(1,5)+PKK(1,6)+S56 TIR=REAL(TI) UIR=REAL(UI) FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2 WT= & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+ & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+ & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+ & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+ & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56* & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+ & 1D0/UI**2)) ELSEIF(ISUB.EQ.23) THEN C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons. D34=P(IREF(IP,IORD),5)**2 D56=P(IREF(IP,3-IORD),5)**2 DT=PKK(1,3)+PKK(1,4)+D34 DU=PKK(1,5)+PKK(1,6)+D56 FACBW=1D0/((SH-SQMW)**2+GMMW**2) CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+ & REAL(CBWZ)*FGK(1,2,5,6,3,4)) FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+ & REAL(CBWZ)*FGK(1,2,6,5,3,4)) WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2* & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU)) ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0 C...(or H0, or A0). WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)* & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)* & COUP(3,3))**2)*PKK(1,4)*PKK(2,3) WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)* & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4)) ELSEIF(ISUB.EQ.25) THEN C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons. POLR=(1D0+PARJ(132))*(1D0-PARJ(131)) POLL=(1D0-PARJ(132))*(1D0+PARJ(131)) D34=P(IREF(IP,IORD),5)**2 D56=P(IREF(IP,3-IORD),5)**2 DT=PKK(1,3)+PKK(1,4)+D34 DU=PKK(1,5)+PKK(1,6)+D56 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2) CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)- & REAL(CBWW)*FGK(1,2,5,6,3,4)) FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6)) IF(MSTP(50).LE.0) THEN WT=FGK135**2+(CCWW*FGK253)**2 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)- & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)- & DJGK(DT,DU))) ELSE WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+ & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+ & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))) ENDIF ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0 C...(or H0, or A0). WT=PKK(1,3)*PKK(2,4) WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4)) ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN C...Angular weight for f + g/gamma -> f + (gamma*/Z0) C...-> f + 2 quarks/leptons. CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+ & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+ & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+ & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+ & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+ & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2) IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+ & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2) WTMAX=(CLILF+CLIRF+CRILF+CRIRF)* & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2) ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions. IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR. & ISUB.EQ.77) THEN C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W). WT=16D0*PKK(3,5)*PKK(4,6) WTMAX=SH**2 ELSEIF(ISUB.EQ.110) THEN C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic. WT=1D0 WTMAX=1D0 ELSEIF(ISUB.EQ.141) THEN IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons. C...Couplings of incoming flavour. KFAI=IABS(MINT(15)) EI=KCHG(KFAI,1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV KFAIC=1 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN VPI=PARU(119+2*KFAIC) API=PARU(120+2*KFAIC) ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN VPI=PARJ(178+2*KFAIC) API=PARJ(179+2*KFAIC) ELSE VPI=PARJ(186+2*KFAIC) API=PARJ(187+2*KFAIC) ENDIF C...Couplings of final flavour. KFAF=IABS(KFL1(1)) EF=KCHG(KFAF,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV KFAFC=1 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN VPF=PARU(119+2*KFAFC) APF=PARU(120+2*KFAFC) ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN VPF=PARJ(178+2*KFAFC) APF=PARJ(179+2*KFAFC) ELSE VPF=PARJ(186+2*KFAFC) APF=PARJ(187+2*KFAFC) ENDIF C...Asymmetry and weight. ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+ & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)* & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/ & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+ & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)* & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+ & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2)) WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2 WTMAX=2D0+ABS(ASYM) ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN C...Angular weight for f + fbar -> Z' -> W+ + W-. RM1=P(NSD(1)+1,5)**2/SH RM2=P(NSD(1)+2,5)**2/SH CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)* & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2) CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+ & (RM2-RM1)**2) WT=CFLAT+CCOS2*CTHE(1)**2 WTMAX=CFLAT+MAX(0D0,CCOS2) ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR. & IABS(KFL1(1)).EQ.37)) THEN C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-. WT=1D0-CTHE(1)**2 WTMAX=1D0 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN C...Angular weight for f + fbar -> Z' -> Z0 + h0. RM1=P(NSD(1)+1,5)**2/SH RM2=P(NSD(1)+2,5)**2/SH FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2) WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1) WTMAX=1D0+FLAM2/(8D0*RM1) ELSEIF(MZPWP.EQ.0) THEN C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons C...(W:s like if intermediate Z). D34=P(IREF(IP,IORD),5)**2 D56=P(IREF(IP,3-IORD),5)**2 DT=PKK(1,3)+PKK(1,4)+D34 DU=PKK(1,5)+PKK(1,6)+D56 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4)) FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6)) WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)* & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)) ELSEIF(MZPWP.EQ.1) THEN C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons C...(W:s approximately longitudinal, like if intermediate H). WT=16D0*PKK(3,5)*PKK(4,6) WTMAX=SH**2 ELSE C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0, C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- . WT=1D0 WTMAX=1D0 ENDIF ELSEIF(ISUB.EQ.142) THEN IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons. KFAI=IABS(MINT(15)) KFAIC=1 IF(KFAI.GT.10) KFAIC=2 VI=PARU(129+2*KFAIC) AI=PARU(130+2*KFAIC) KFAF=IABS(KFL1(1)) KFAFC=1 IF(KFAF.GT.10) KFAFC=2 VF=PARU(129+2*KFAFC) AF=PARU(130+2*KFAFC) ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2)) WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2 WTMAX=2D0+ABS(ASYM) ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0. RM1=P(NSD(1)+1,5)**2/SH RM2=P(NSD(1)+2,5)**2/SH CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)* & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2) CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+ & (RM2-RM1)**2) WT=CFLAT+CCOS2*CTHE(1)**2 WTMAX=CFLAT+MAX(0D0,CCOS2) ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN C...Angular weight for f + fbar -> W'+/- -> W+/- + h0. RM1=P(NSD(1)+1,5)**2/SH RM2=P(NSD(1)+2,5)**2/SH FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2) WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1) WTMAX=1D0+FLAM2/(8D0*RM1) ELSEIF(MZPWP.EQ.0) THEN C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons C...(W/Z like if intermediate W). D34=P(IREF(IP,IORD),5)**2 D56=P(IREF(IP,3-IORD),5)**2 DT=PKK(1,3)+PKK(1,4)+D34 DU=PKK(1,5)+PKK(1,6)+D56 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4)) FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4)) WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)* & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)) ELSEIF(MZPWP.EQ.1) THEN C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons C...(W/Z approximately longitudinal, like if intermediate H). WT=16D0*PKK(3,5)*PKK(4,6) WTMAX=SH**2 ELSE C...Angular weight for f + fbar -> W' -> W + h0 -> whatever, C...t + bbar -> t + W + bbar. WT=1D0 WTMAX=1D0 ENDIF ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164) & THEN C...Isotropic decay of leptoquarks (assumed spin 0). WT=1D0 WTMAX=1D0 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-). SIDE=1D0 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN WT=1D0+SIDE*CTHE(1) WTMAX=2D0 ELSEIF(IP.EQ.1) THEN RM1=P(NSD(1)+1,5)**2/SH WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1) WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1) ELSE C...W/Z decay assumed isotropic, since not known. WT=1D0 WTMAX=1D0 ENDIF ELSEIF(ISUB.EQ.149) THEN C...Isotropic decay of techni-eta. WT=1D0 WTMAX=1D0 ELSEIF(ISUB.EQ.191) THEN IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN C...Angular weight for f + fbar -> rho_tc0 -> W+ W-, C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-. WT=1D0-CTHE(1)**2 WTMAX=1D0 ELSEIF(IP.EQ.1) THEN C...Angular weight for f + fbar -> rho_tc0 -> f fbar. CTHESG=CTHE(1)*ISIGN(1,MINT(15)) XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW)) BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) KFAI=IABS(MINT(15)) EI=KCHG(KFAI,1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV VALI=0.5D0*(VI+AI) VARI=0.5D0*(VI-AI) ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2 KFAF=IABS(KFL1(1)) EF=KCHG(KFAF,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV VALF=0.5D0*(VF+AF) VARF=0.5D0*(VF-AF) ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2 WTMAX=4D0*MAX(ASAME,AFLIP) ELSE C...Isotropic decay of W/pi_tc produced in rho_tc decay. WT=1D0 WTMAX=1D0 ENDIF ELSEIF(ISUB.EQ.192) THEN IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0, C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0. WT=1D0-CTHE(1)**2 WTMAX=1D0 ELSEIF(IP.EQ.1) THEN C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'. CTHESG=CTHE(1)*ISIGN(1,MINT(15)) WT=(1D0+CTHESG)**2 WTMAX=4D0 ELSE C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay. WT=1D0 WTMAX=1D0 ENDIF ELSEIF(ISUB.EQ.193) THEN IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN C...Angular weight for f + fbar -> omega_tc0 -> C...gamma pi_tc0 or Z0 pi_tc0. WT=1D0+CTHE(1)**2 WTMAX=2D0 ELSEIF(IP.EQ.1) THEN C...Angular weight for f + fbar -> omega_tc0 -> f fbar. CTHESG=CTHE(1)*ISIGN(1,MINT(15)) BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) KFAI=IABS(MINT(15)) EI=KCHG(KFAI,1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV VALI=0.5D0*(VI+AI) VARI=0.5D0*(VI-AI) BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2 KFAF=IABS(KFL1(1)) EF=KCHG(KFAF,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV VALF=0.5D0*(VF+AF) VARF=0.5D0*(VF-AF) BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2 WTMAX=4D0*MAX(BSAME,BFLIP) ELSE C...Isotropic decay of Z/pi_tc produced in omega_tc decay. WT=1D0 WTMAX=1D0 ENDIF ELSEIF(ISUB.EQ.353) THEN C...Angular weight for Z_R0 -> 2 quarks/leptons. EI=KCHG(IABS(MINT(15)),1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV EF=KCHG(PYCOMP(KFL1(1)),1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH) WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2) WT2=RMF*(VI**2+AI**2)*VF**2 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+ & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)) WTMAX=2D0*(WT1+ABS(WT3)) ELSEIF(ISUB.EQ.354) THEN C...Angular weight for W_R+/- -> 2 quarks/leptons. RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2 WTMAX=4D0 ELSEIF(ISUB.EQ.391) THEN C...Angular weight for f + fbar -> G* -> f + fbar IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4 WTMAX=2D0 C...Other G* decays not yet implemented angular distributions. ELSE WT=1D0 WTMAX=1D0 ENDIF ELSEIF(ISUB.EQ.392) THEN C...Angular weight for g + g -> G* -> f + fbar IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN WT=1D0-CTHE(1)**4 WTMAX=1D0 C...Other G* decays not yet implemented angular distributions. ELSE WT=1D0 WTMAX=1D0 ENDIF C...Obtain correct angular distribution by rejection techniques. ELSE WT=1D0 WTMAX=1D0 ENDIF IF(WT.LT.PYR(0)*WTMAX) GOTO 340 C...Construct massive four-vectors using angles chosen. 500 DO 600 JT=1,JTMAX IF(KDCY(JT).EQ.0) GOTO 600 ID=IREF(IP,JT) DO 510 J=1,5 DPMO(J)=P(ID,J) 510 CONTINUE DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2) CMRENNA++ IF(KFL3(JT).EQ.0) THEN CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT), & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4)) N0=NSD(JT)+2 ELSE CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT), & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4)) N0=NSD(JT)+3 ENDIF DO 520 J=1,4 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5) 520 CONTINUE C...Fill in position of decay vertex. DO 540 I=NSD(JT)+1,N0 DO 530 J=1,4 V(I,J)=VDCY(J) 530 CONTINUE V(I,5)=0D0 540 CONTINUE CMRENNA-- C...Mark decayed resonances; trace history. K(ID,1)=K(ID,1)+10 KFA=IABS(K(ID,2)) KCA=PYCOMP(KFA) IF(KCQM(JT).NE.0) THEN C...Do not kill colour flow through coloured resonance! ELSE K(ID,4)=NSD(JT)+1 K(ID,5)=NSD(JT)+2 IF(KFL3(JT).NE.0) K(ID,5)=NSD(JT)+3 ENDIF C...Add documentation lines. IF(IRES.EQ.0) THEN IDOC=MINT(83)+MINT(4) CMRENNA+++ IHI=NSD(JT)+2 IF(KFL3(JT).NE.0) IHI=IHI+1 DO 560 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 550 J=1,5 P(I1,J)=P(I,J) 550 CONTINUE ENDIF 560 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 of two or three objects. NSHBEF=N IF(MSTP(71).GE.1) THEN IF(KFL3(JT).EQ.0) THEN CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5)) ELSE CALL PYSHOW(NSD(JT)+1,-3,P(ID,5)) ENDIF 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 570 I=NSHBEF+1,NSHAFT IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I 570 CONTINUE ENDIF IF(K(NSD2,1).GT.10) THEN DO 580 I=NSHBEF+1,NSHAFT IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND. & I.NE.NSD1) NSD2=I 580 CONTINUE ENDIF IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN DO 590 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 590 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) 600 CONTINUE C...Fill information for 2 -> 1 -> 2. 610 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN MINT(7)=MINT(83)+6+2*ISET(ISUB) MINT(8)=MINT(83)+7+2*ISET(ISUB) MINT(25)=KFL1(1) MINT(26)=KFL2(1) VINT(23)=CTHE(1) RM3=P(N-1,5)**2/SH RM4=P(N,5)**2/SH BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1)) VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1)) VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2) VINT(47)=SQRT(VINT(48)) ENDIF C...Possibility of colour rearrangement in W+W- events. IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN IAKF1=IABS(KFL1(1)) IAKF2=IABS(KFL1(2)) IAKF3=IABS(KFL2(1)) IAKF4=IABS(KFL2(2)) IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND. & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1) ENDIF C...Loop back if needed. 620 IF(IP.LT.NP) GOTO 150 C...Boost back to standard frame. 630 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN, &BEZIN) RETURN END C********************************************************************* C...PYMULT C...Initializes treatment of multiple interactions, selects kinematics C...of hardest interaction if low-pT physics included in run, and C...generates all non-hardest interactions. SUBROUTINE PYMULT(MMUL) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT7/SIGT(0:6,0:6,0:5) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/ C...Local arrays and saved variables. DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80) SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM C...Initialization of multiple interaction treatment. IF(MMUL.EQ.1) THEN IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82) ISUB=96 MINT(1)=96 VINT(63)=0D0 VINT(64)=0D0 VINT(143)=1D0 VINT(144)=1D0 C...Loop over phase space points: xT2 choice in 20 bins. 100 SIGSUM=0D0 DO 120 IXT2=1,20 NMUL(IXT2)=MSTP(83) SIGM(IXT2)=0D0 DO 110 ITRY=1,MSTP(83) RSCA=0.05D0*((21-IXT2)-PYR(0)) XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149) XT2=MAX(0.01D0*VINT(149),XT2) VINT(25)=XT2 C...Choose tau and y*. Calculate cos(theta-hat). IF(PYR(0).LE.COEF(ISUB,1)) THEN TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) ELSE TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) ENDIF VINT(21)=TAU CALL PYKLIM(2) RYST=PYR(0) MYST=1 IF(RYST.GT.COEF(ISUB,8)) MYST=2 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 CALL PYKMAP(2,MYST,PYR(0)) VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) C...Calculate differential cross-section. VINT(71)=0.5D0*VINT(1)*SQRT(XT2) CALL PYSIGH(NCHN,SIGS) SIGM(IXT2)=SIGM(IXT2)+SIGS 110 CONTINUE SIGSUM=SIGSUM+SIGM(IXT2) 120 CONTINUE SIGSUM=SIGSUM/(20D0*MSTP(83)) C...Reject result if sigma(parton-parton) is smaller than hadronic one. IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM PARP(82)=0.9D0*PARP(82) VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/ & VINT(2) GOTO 100 ENDIF IF(MSTP(122).GE.1) WRITE(MSTU(11),5200) & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM C...Start iteration to find k factor. YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5)) SO=0.5D0 XI=0D0 YI=0D0 XF=0D0 YF=0D0 XK=0.5D0 IIT=0 130 IF(IIT.EQ.0) THEN XK=2D0*XK ELSEIF(IIT.EQ.1) THEN XK=0.5D0*XK ELSE XK=XI+(YKE-YI)*(XF-XI)/(YF-YI) ENDIF C...Evaluate overlap integrals. IF(MSTP(82).EQ.2) THEN SP=0.5D0*PARU(1)*(1D0-EXP(-XK)) SOP=SP/PARU(1) ELSE IF(MSTP(82).EQ.3) 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 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5)) IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT* & VINT(317)/(VINT(318)*VINT(320)) XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149)) ELSEIF(MSTP(82).EQ.2) THEN XT2=1D0 XT2FAC=VINT(146)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))* & VINT(149)*(1D0+VINT(149)) ELSE XC2=4D0*CKIN(3)**2/VINT(2) IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0 ENDIF ELSEIF(MMUL.EQ.3) THEN C...Low-pT or multiple interactions (first semihard interaction): C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm) C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....). ISUB=MINT(1) IF(MSTP(82).LE.0) THEN XT2=0D0 ELSEIF(MSTP(82).EQ.1) THEN XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) ELSEIF(MSTP(82).EQ.2) THEN IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+ & VINT(149)))).GT.PYR(0)) XT2=1D0 IF(XT2.GE.1D0) THEN XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0- & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))- & VINT(149) ELSE XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)* & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))- & VINT(149) ENDIF XT2=MAX(0.01D0*VINT(149),XT2) ELSE XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)- & PYR(0)*(1D0-XC2))-VINT(149) XT2=MAX(0.01D0*VINT(149),XT2) ENDIF VINT(25)=XT2 C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed. IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-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 ISUB=MINT(1) 150 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 160 IBIN=IRBIN+1,20 RNCOR=RNCOR+NMUL(IBIN) SIGCOR=SIGCOR+SIGM(IBIN) 160 CONTINUE SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149)) IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289) VINT(150)=EXP(-MIN(50D0,VINT(146)*VINT(148)* & SIGABV/MAX(1D-10,SIGT(0,0,5)))) IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND. & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN IF(VINT(150).LT.PYR(0)) GOTO 150 VINT(150)=1D0 ENDIF C...Generate additional multiple semihard interactions. ELSEIF(MMUL.EQ.6) THEN ISUBSV=MINT(1) DO 170 J=11,80 VINTSV(J)=VINT(J) 170 CONTINUE ISUB=96 MINT(1)=96 VINT(151)=0D0 VINT(152)=0D0 C...Reconstruct strings in hard scattering. NMAX=MINT(84)+4 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3) NSTR=0 DO 190 I=MINT(84)+1,NMAX KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2)) IF(KCS.EQ.0) GOTO 190 DO 180 J=1,4 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 180 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 180 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 180 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 180 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 180 CONTINUE 190 CONTINUE C...Set up starting values for iteration in xT2. IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND. & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND. & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND. & ISUBSV.NE.96)) THEN XT2=(1D0-VINT(141))*(1D0-VINT(142)) ELSE XT2=VINT(25) IF(ISET(ISUBSV).EQ.1) XT2=VINT(21) IF(ISET(ISUBSV).EQ.2) & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2) IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26) ENDIF IF(MSTP(82).LE.1) THEN SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5)) IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT* & VINT(317)/(VINT(318)*VINT(320)) XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149)) ELSE XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/ & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149)) ENDIF VINT(63)=0D0 VINT(64)=0D0 VINT(143)=1D0-VINT(141) VINT(144)=1D0-VINT(142) C...Iterate downwards in xT2. 200 IF(MSTP(82).LE.1) THEN XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) IF(XT2.LT.VINT(149)) GOTO 250 ELSE IF(XT2.LE.0.01001D0*VINT(149)) GOTO 250 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))* & LOG(PYR(0)))-VINT(149) IF(XT2.LE.0D0) GOTO 250 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 200 VINT(71)=0.5D0*VINT(1)*SQRT(XT2) CALL PYSIGH(NCHN,SIGS) IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320) IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 200 C...Reset K, P and V vectors. Select some variables. DO 220 I=N+1,N+2 DO 210 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 210 CONTINUE 220 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 240 I=N+1,N+2 DMIN=1D8 DO 230 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 230 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 240 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 200 250 CONTINUE MINT(1)=ISUBSV DO 260 J=11,80 VINT(J)=VINTSV(J) 260 CONTINUE ENDIF C...Format statements for printout. 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter', &'actions for MSTP(82) =',I2,' ******') 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P, &D9.2,' mb: rejected') 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P, &D9.2,' mb: accepted') RETURN END C********************************************************************* C...PYREMN C...Adds on target remnants (one or two from each side) and C...includes primordial kT for hadron beams. SUBROUTINE PYREMN(IPU1,IPU2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ C...Local arrays. DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5), &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4) C...Find event type and remaining energy. ISUB=MINT(1) NS=N IF(MINT(50).EQ.0.OR.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 PTA=SQRT(VINT(282+JT)) PTB=0D0 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN PTB=PARP(99)*SQRT(-LOG(PYR(0))) ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN RPT1=PYR(0) RPT2=PYR(0) PTB=-PARP(99)*LOG(RPT1*RPT2) ENDIF IF(PTB.GT.PARP(100)) GOTO 120 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0))) PT=PT*0.8D0**MINT(57) IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10) ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN IF(MSTP(93).LE.0) THEN PT=0D0 ELSEIF(MSTP(93).EQ.1) THEN PT=PARP(99)*SQRT(-LOG(PYR(0))) ELSEIF(MSTP(93).EQ.2) THEN RPT1=PYR(0) RPT2=PYR(0) PT=-PARP(99)*LOG(RPT1*RPT2) ELSEIF(MSTP(93).EQ.3) THEN HA=PARP(99)**2 HB=PARP(100)**2 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA)) ELSE HA=PARP(99)**2 HB=PARP(100)**2 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2) PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA)) ENDIF IF(PT.GT.PARP(100)) GOTO 120 ELSE PT=0D0 ENDIF VINT(156+JT)=PT PHI=PARU(2)*PYR(0) P(I,1)=PT*COS(PHI) P(I,2)=PT*SIN(PHI) PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2 ENDIF 130 CONTINUE IF(MINT(47).EQ.1) RETURN C...Kinematics construction for initial partons. I1=MINT(83)+3 I2=MINT(83)+4 IF(ISUB.EQ.95) THEN SHS=0D0 SHR=0D0 ELSE SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+ & (P(I1,2)+P(I2,2))**2 SHR=SQRT(MAX(0D0,SHS)) IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR) P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1))) P(I2,4)=SHR-P(I1,4) P(I2,3)=-P(I1,3) C...Transform partons to overall CM-frame. ROBO(3)=(P(I1,1)+P(I2,1))/SHR ROBO(4)=(P(I1,2)+P(I2,2))/SHR CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0) ROBO(2)=PYANGL(P(I1,1),P(I1,2)) CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0) ROBO(1)=PYANGL(P(I1,3),P(I1,1)) CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0) CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0) CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0) ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142)) CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5)) ENDIF C...Optionally fix up x and Q2 definitions for leptoproduction. IDISXQ=0 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND. &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1 IF(IDISXQ.EQ.1) THEN C...Find where incoming and outgoing leptons/partons are sitting. LESD=1 IF(MINT(42).EQ.1) LESD=2 LPIN=MINT(83)+3-LESD LEIN=MINT(84)+LESD LQIN=MINT(84)+3-LESD LEOUT=MINT(84)+2+LESD LQOUT=MINT(84)+5-LESD IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3) IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3) LSCMS=0 DO 140 I=MINT(84)+5,N IF(K(I,2).EQ.94) THEN LSCMS=I LEOUT=I+LESD LQOUT=I+3-LESD ENDIF 140 CONTINUE LQBG=IPU1 IF(LESD.EQ.1) LQBG=IPU2 C...Calculate actual and wanted momentum transfer. XNOM=VINT(43-LESD) Q2NOM=-VINT(45) HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)- & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))* & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4)) HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK))) FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2)) P(N+1,1)=FAC*P(LEOUT,1) P(N+1,2)=FAC*P(LEOUT,2) P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)- & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1) P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+ & P(N+1,3)**2) DO 150 J=1,4 QOLD(J)=P(LEIN,J)-P(LEOUT,J) QNEW(J)=P(LEIN,J)-P(N+1,J) 150 CONTINUE C...Boost outgoing electron and daughters. IF(LSCMS.EQ.0) THEN DO 160 J=1,4 P(LEOUT,J)=P(N+1,J) 160 CONTINUE ELSE DO 170 J=1,3 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4)) 170 CONTINUE PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2) DO 180 J=1,3 DBE(J)=PINV*P(N+2,J) 180 CONTINUE DO 200 I=LSCMS+1,N IORIG=I 190 IORIG=K(IORIG,3) IF(IORIG.GT.LEOUT) GOTO 190 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT) & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3)) 200 CONTINUE ENDIF C...Copy shower initiator and all outgoing partons. NCOP=N+1 K(NCOP,3)=LQBG DO 210 J=1,5 P(NCOP,J)=P(LQBG,J) 210 CONTINUE DO 240 I=MINT(84)+1,N ICOP=0 IF(K(I,1).GT.10) GOTO 240 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN ICOP=I ELSE IORIG=I 220 IORIG=K(IORIG,3) IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN ICOP=IORIG ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN GOTO 220 ENDIF ENDIF IF(ICOP.NE.0) THEN NCOP=NCOP+1 K(NCOP,3)=I DO 230 J=1,5 P(NCOP,J)=P(I,J) 230 CONTINUE ENDIF 240 CONTINUE C...Calculate relative rescaling factors. SLC=3-2*LESD PLCSUM=0D0 DO 250 I=N+2,NCOP PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3)) 250 CONTINUE DO 260 I=N+2,NCOP V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM 260 CONTINUE C...Transfer extra three-momentum of current. DO 280 I=N+2,NCOP DO 270 J=1,3 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J)) 270 CONTINUE P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) 280 CONTINUE C...Iterate change of initiator momentum to get energy right. ITER=0 290 ITER=ITER+1 PEEX=-P(N+1,4)-QNEW(4) PEMV=-P(N+1,3)/P(N+1,4) DO 300 I=N+2,NCOP PEEX=PEEX+P(I,4) PEMV=PEMV+V(I,1)*P(I,3)/P(I,4) 300 CONTINUE IF(ABS(PEMV).LT.1D-10) THEN MINT(51)=1 MINT(57)=MINT(57)+1 RETURN ENDIF PZCH=-PEEX/PEMV P(N+1,3)=P(N+1,3)+PZCH P(N+1,4)=SQRT(P(N+1,5)**2+P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2) DO 310 I=N+2,NCOP P(I,3)=P(I,3)+V(I,1)*PZCH P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) 310 CONTINUE IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290 C...Modify momenta in event record. HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/ & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2) IF(ABS(HBE).GE.1D0) THEN MINT(51)=1 MINT(57)=MINT(57)+1 RETURN ENDIF I=MINT(83)+5-LESD CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE) DO 330 I=N+1,NCOP ICOP=K(I,3) DO 320 J=1,4 P(ICOP,J)=P(I,J) 320 CONTINUE 330 CONTINUE ENDIF C...Check minimum invariant mass of remnant system(s). PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152)) PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152)) PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2) PMIN(0)=SQRT(PMS(0)) DO 340 JT=1,2 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT) PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1) PMIN(JT)=0D0 IF(MINT(44+JT).EQ.1) GOTO 340 MINT(105)=MINT(102+JT) MINT(109)=MINT(106+JT) CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT)) IF(MINT(51).NE.0) THEN MINT(57)=MINT(57)+1 RETURN ENDIF IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT)) IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT)) IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111) PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+ & P(MINT(83)+JT+2,2)**2) 340 CONTINUE IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND. &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT. &PSYS(2,4))) THEN MINT(51)=1 MINT(57)=MINT(57)+1 RETURN ENDIF C...Loop over two remnants; skip if none there. I=NS DO 410 JT=1,2 ISN(JT)=0 IF(MINT(44+JT).EQ.1) GOTO 410 IF(JT.EQ.1) IPU=IPU1 IF(JT.EQ.2) IPU=IPU2 C...Store first remnant parton. I=I+1 IS(JT)=I ISN(JT)=1 DO 350 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 350 CONTINUE K(I,1)=1 K(I,2)=KFLSP(JT) K(I,3)=MINT(83)+JT P(I,5)=PYMASS(K(I,2)) C...First parton colour connections and kinematics. KCOL=KCHG(PYCOMP(KFLSP(JT)),2) IF(KCOL.EQ.2) THEN K(I,1)=3 K(I,4)=MSTU(5)*IPU+IPU K(I,5)=MSTU(5)*IPU+IPU K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I ELSEIF(KCOL.NE.0) THEN K(I,1)=3 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2 K(I,KFLS+3)=IPU K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I ENDIF IF(KFLCH(JT).EQ.0) THEN P(I,1)=-P(MINT(83)+JT+2,1) P(I,2)=-P(MINT(83)+JT+2,2) PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1) P(I,3)=PSYS(JT,3) P(I,4)=PSYS(JT,4) C...When extra remnant parton or hadron: store extra remnant. ELSE I=I+1 ISN(JT)=2 DO 360 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 360 CONTINUE K(I,1)=1 K(I,2)=KFLCH(JT) K(I,3)=MINT(83)+JT P(I,5)=PYMASS(K(I,2)) C...Find parton colour connections of extra remnant. KCOL=KCHG(PYCOMP(KFLCH(JT)),2) IF(KCOL.EQ.2) THEN K(I,1)=3 K(I,4)=MSTU(5)*IPU+IPU K(I,5)=MSTU(5)*IPU+IPU K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I ELSEIF(KCOL.NE.0) THEN K(I,1)=3 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2 K(I,KFLS+3)=IPU K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I ENDIF C...Relative transverse momentum when two remnants. LOOP=0 370 LOOP=LOOP+1 CALL PYPTDI(1,P(I-1,1),P(I-1,2)) IF(IABS(MINT(10+JT)).LT.20) THEN P(I-1,1)=0D0 P(I-1,2)=0D0 ELSE P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1) P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2) ENDIF PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1) P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2) PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2 C...Meson or baryon; photon as meson. For splitup below. IMB=1 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2 C***Relative distribution for electron into two electrons. Temporary! IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT)) & THEN CHI(JT)=PYR(0) C...Relative distribution of electron energy into electron plus parton. ELSEIF(IABS(MINT(10+JT)).LT.20) THEN XHRD=VINT(140+JT) XE=VINT(154+JT) CHI(JT)=(XE-XHRD)/(1D0-XHRD) C...Relative distribution of energy for particle into two jets. ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN CHIK=PARP(92+2*IMB) IF(MSTP(92).LE.1) THEN IF(IMB.EQ.1) CHI(JT)=PYR(0) IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0)) ELSEIF(MSTP(92).EQ.2) THEN CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK)) ELSEIF(MSTP(92).EQ.3) THEN CUT=2D0*0.3D0/VINT(1) 380 CHI(JT)=PYR(0)**2 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0* & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380 ELSEIF(MSTP(92).EQ.4) THEN CUT=2D0*0.3D0/VINT(1) CUTR=(1D0+SQRT(1D0+CUT**2))/CUT 390 CHIR=CUT*CUTR**PYR(0) CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR) IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390 ELSE CUT=2D0*0.3D0/VINT(1) CUTA=CUT**(1D0-PARP(98)) CUTB=(1D0+CUT)**(1D0-PARP(98)) 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98))) IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))** & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400 ENDIF C...Relative distribution of energy for particle into jet plus particle. ELSE IF(MSTP(94).LE.1) THEN IF(IMB.EQ.1) CHI(JT)=PYR(0) IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0)) IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT) ELSEIF(MSTP(94).EQ.2) THEN CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB))) IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT) ELSEIF(MSTP(94).EQ.3) THEN CALL PYZDIS(1,0,PMS(JT+4),ZZ) CHI(JT)=ZZ ELSE CALL PYZDIS(1000,0,PMS(JT+4),ZZ) CHI(JT)=ZZ ENDIF ENDIF C...Construct total transverse mass; reject if too large. CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT))) PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT)) IF(PMS(JT).GT.PSYS(JT,4)**2) THEN IF(LOOP.LT.100) THEN GOTO 370 ELSE MINT(51)=1 MINT(57)=MINT(57)+1 RETURN ENDIF ENDIF PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1) VINT(158+JT)=CHI(JT) C...Subdivide longitudinal momentum according to value selected above. PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3))) P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1) P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1) P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4) P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3) ENDIF 410 CONTINUE N=I C...Check if longitudinal boosts needed - if so pick two systems. PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+ &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3)) IF(PDEV.LE.1D-6*VINT(1)) RETURN IF(ISN(1).EQ.0) THEN IR=0 IL=2 ELSEIF(ISN(2).EQ.0) THEN IR=1 IL=0 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN IR=1 IL=2 ELSEIF(VINT(143).GT.0.2D0) THEN IR=1 IL=0 ELSEIF(VINT(144).GT.0.2D0) THEN IR=0 IL=2 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN IR=1 IL=0 ELSE IR=0 IL=2 ENDIF IG=3-IR-IL C...E+-pL wanted for system to be modified. IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN PPB=VINT(1) PNB=VINT(1) ELSE PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3)) PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3)) ENDIF C...To keep x and Q2 in leptoproduction: do not count scattered lepton. IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN PPB=PPB-(PSYS(0,4)+PSYS(0,3)) PNB=PNB-(PSYS(0,4)-PSYS(0,3)) DO 420 J=1,4 PSYS(0,J)=0D0 420 CONTINUE DO 450 I=MINT(84)+1,NS IF(K(I,1).GT.10) GOTO 450 INCL=0 IORIG=I 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1 IORIG=K(IORIG,3) IF(IORIG.GT.LPIN) GOTO 430 IF(INCL.EQ.0) GOTO 450 DO 440 J=1,4 PSYS(0,J)=PSYS(0,J)+P(I,J) 440 CONTINUE 450 CONTINUE PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2) PPB=PPB+(PSYS(0,4)+PSYS(0,3)) PNB=PNB+(PSYS(0,4)-PSYS(0,3)) ENDIF C...Construct longitudinal boosts. DPMTB=PPB*PNB DPMTR=PMS(IR) DPMTL=PMS(IL) DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL)) IF(DSQLAM.LE.1D-6*DPMTB) THEN MINT(51)=1 MINT(57)=MINT(57)+1 RETURN ENDIF DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4)) DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/ &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB) DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/ &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB) DBER=(DRKR**2-1D0)/(DRKR**2+1D0) DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0) C...Perform longitudinal boosts. IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN P(IS(1),3)=0D0 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2) ELSEIF(IR.EQ.1) THEN CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER) ELSEIF(IDISXQ.EQ.1) THEN DO 470 I=I1,NS INCL=0 IORIG=I 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1 IORIG=K(IORIG,3) IF(IORIG.GT.LPIN) GOTO 460 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER) 470 CONTINUE ELSE CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER) ENDIF IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN P(IS(2),3)=0D0 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2) ELSEIF(IL.EQ.2) THEN CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL) ELSEIF(IDISXQ.EQ.1) THEN DO 490 I=I1,NS INCL=0 IORIG=I 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1 IORIG=K(IORIG,3) IF(IORIG.GT.LPIN) GOTO 480 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL) 490 CONTINUE ELSE CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL) ENDIF C...Final check that energy-momentum conservation worked. PESUM=0D0 PZSUM=0D0 DO 500 I=MINT(84)+1,N IF(K(I,1).GT.10) GOTO 500 PESUM=PESUM+P(I,4) PZSUM=PZSUM+P(I,3) 500 CONTINUE PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM) IF(PDEV.GT.1D-4*VINT(1)) THEN MINT(51)=1 MINT(57)=MINT(57)+1 RETURN ENDIF C...Calculate rotation and boost from overall CM frame to C...hadronic CM frame in leptoproduction. MINT(91)=0 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN MINT(91)=1 LESD=1 IF(MINT(42).EQ.1) LESD=2 LPIN=MINT(83)+3-LESD C...Sum upp momenta of everything not lepton or photon to define boost. DO 510 J=1,4 PSUM(J)=0D0 510 CONTINUE DO 530 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530 IF(K(I,2).EQ.22) GOTO 530 DO 520 J=1,4 PSUM(J)=PSUM(J)+P(I,J) 520 CONTINUE 530 CONTINUE VINT(223)=-PSUM(1)/PSUM(4) VINT(224)=-PSUM(2)/PSUM(4) VINT(225)=-PSUM(3)/PSUM(4) C...Boost incoming hadron to hadronic CM frame to determine rotations. K(N+1,1)=1 DO 540 J=1,5 P(N+1,J)=P(LPIN,J) V(N+1,J)=V(LPIN,J) 540 CONTINUE CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225)) VINT(222)=-PYANGL(P(N+1,1),P(N+1,2)) CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0) IF(LESD.EQ.2) THEN VINT(221)=-PYANGL(P(N+1,3),P(N+1,1)) ELSE VINT(221)=PYANGL(-P(N+1,3),P(N+1,1)) ENDIF ENDIF RETURN END C********************************************************************* C...PYDIFF C...Handles diffractive and elastic scattering. SUBROUTINE PYDIFF C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/ C...Reset K, P and V vectors. Store incoming particles. DO 110 JT=1,MSTP(126)+10 I=MINT(83)+JT DO 100 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 100 CONTINUE 110 CONTINUE N=MINT(84) MINT(3)=0 MINT(21)=0 MINT(22)=0 MINT(23)=0 MINT(24)=0 MINT(4)=4 DO 130 JT=1,2 I=MINT(83)+JT K(I,1)=21 K(I,2)=MINT(10+JT) DO 120 J=1,5 P(I,J)=VINT(285+5*JT+J) 120 CONTINUE 130 CONTINUE MINT(6)=2 C...Subprocess; kinematics. SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64) PZ=SQRT(SQLAM)/(2D0*VINT(1)) DO 200 JT=1,2 I=MINT(83)+JT PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1)) KFH=MINT(102+JT) C...Elastically scattered particle. (Except elastic GVMD states.) IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR. & MINT(106+JT).NE.3)) THEN N=N+1 K(N,1)=1 K(N,2)=KFH K(N,3)=I+2 P(N,3)=PZ*(-1)**(JT+1) P(N,4)=PE P(N,5)=SQRT(VINT(62+JT)) C...Decay rho from elastic scattering of gamma with sin**2(theta) C...distribution of decay products (in rho rest frame). IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN NSAV=N DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2) P(N,3)=0D0 P(N,4)=P(N,5) CALL PYDECY(NSAV) IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2)) CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0) THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1)) CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0) 140 CTHE=2D0*PYR(0)-1D0 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0) ENDIF CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ) ENDIF C...Diffracted particle: low-mass system to two particles. ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN N=N+2 K(N-1,1)=1 K(N,1)=1 K(N-1,3)=I+2 K(N,3)=I+2 PMMAS=SQRT(VINT(62+JT)) NTRY=0 150 NTRY=NTRY+1 IF(NTRY.LT.20) THEN MINT(105)=MINT(102+JT) MINT(109)=MINT(106+JT) CALL PYSPLI(KFH,21,KFL1,KFL2) CALL PYKFDI(KFL1,0,KFL3,KF1) IF(KF1.EQ.0) GOTO 150 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2) IF(KF2.EQ.0) GOTO 150 ELSE KF1=KFH KF2=111 ENDIF PM1=PYMASS(KF1) PM2=PYMASS(KF2) IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150 K(N-1,2)=KF1 K(N,2)=KF2 P(N-1,5)=PM1 P(N,5)=PM2 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2- & 4D0*PM1**2*PM2**2))/(2D0*PMMAS) P(N-1,3)=PZP P(N,3)=-PZP P(N-1,4)=SQRT(PM1**2+PZP**2) P(N,4)=SQRT(PM2**2+PZP**2) CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0), & 0D0,0D0,0D0) DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2) CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ) C...Diffracted particle: valence quark kicked out. ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT. & PARP(101))) THEN N=N+2 K(N-1,1)=2 K(N,1)=1 K(N-1,3)=I+2 K(N,3)=I+2 MINT(105)=MINT(102+JT) MINT(109)=MINT(106+JT) CALL PYSPLI(KFH,21,K(N,2),K(N-1,2)) P(N-1,5)=PYMASS(K(N-1,2)) P(N,5)=PYMASS(K(N,2)) SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2- & 4D0*P(N-1,5)**2*P(N,5)**2 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2- & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1) P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2) P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3) P(N,4)=SQRT(P(N,3)**2+P(N,5)**2) C...Diffracted particle: gluon kicked out. ELSE N=N+3 K(N-2,1)=2 K(N-1,1)=2 K(N,1)=1 K(N-2,3)=I+2 K(N-1,3)=I+2 K(N,3)=I+2 MINT(105)=MINT(102+JT) MINT(109)=MINT(106+JT) CALL PYSPLI(KFH,21,K(N,2),K(N-2,2)) K(N-1,2)=21 P(N-2,5)=PYMASS(K(N-2,2)) P(N-1,5)=0D0 P(N,5)=PYMASS(K(N,2)) C...Energy distribution for particle into two jets. 160 IMB=1 IF(MOD(KFH/1000,10).NE.0) IMB=2 CHIK=PARP(92+2*IMB) IF(MSTP(92).LE.1) THEN IF(IMB.EQ.1) CHI=PYR(0) IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0)) ELSEIF(MSTP(92).EQ.2) THEN CHI=1D0-PYR(0)**(1D0/(1D0+CHIK)) ELSEIF(MSTP(92).EQ.3) THEN CUT=2D0*0.3D0/VINT(1) 170 CHI=PYR(0)**2 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT. & PYR(0)) GOTO 170 ELSEIF(MSTP(92).EQ.4) THEN CUT=2D0*0.3D0/VINT(1) CUTR=(1D0+SQRT(1D0+CUT**2))/CUT 180 CHIR=CUT*CUTR**PYR(0) CHI=(CHIR**2-CUT**2)/(2D0*CHIR) IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180 ELSE CUT=2D0*0.3D0/VINT(1) CUTA=CUT**(1D0-PARP(98)) CUTB=(1D0+CUT)**(1D0-PARP(98)) 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98))) IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))** & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190 ENDIF IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/ & VINT(62+JT)) GOTO 160 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/ & (2D0*VINT(62+JT)) PEI=SQRT(PZI**2+SQM) PQQP=(1D0-CHI)*(PEI+PZI) P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1) P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2) P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI) P(N-1,3)=P(N-1,4)*(-1)**JT P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3) P(N,4)=SQRT(P(N,3)**2+P(N,5)**2) ENDIF C...Documentation lines. K(I+2,1)=21 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND. & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10) K(I+2,3)=I P(I+2,3)=PZ*(-1)**(JT+1) P(I+2,4)=PE P(I+2,5)=SQRT(VINT(62+JT)) 200 CONTINUE C...Rotate outgoing partons/particles using cos(theta). IF(VINT(23).LT.0.9D0) THEN CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0) ELSE CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0) ENDIF RETURN END C********************************************************************* C...PYDISG C...Set up a DIS process as gamma* + f -> f, with beam remnant C...and showering added consecutively. Photon flux by the PYGAGA C...routine (if at all). SUBROUTINE PYDISG C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/ C...Local arrays. DIMENSION PMS(4) C...Choice of subprocess, number of documentation lines IDOC=7 MINT(3)=IDOC-6 MINT(4)=IDOC IPU1=MINT(84)+1 IPU2=MINT(84)+2 IPU3=MINT(84)+3 ISIDE=1 IF(MINT(107).EQ.4) ISIDE=2 C...Reset K, P and V vectors. Store incoming particles DO 110 JT=1,MSTP(126)+20 I=MINT(83)+JT DO 100 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=0D0 100 CONTINUE 110 CONTINUE DO 130 JT=1,2 I=MINT(83)+JT K(I,1)=21 K(I,2)=MINT(10+JT) DO 120 J=1,5 P(I,J)=VINT(285+5*JT+J) 120 CONTINUE 130 CONTINUE MINT(6)=2 C...Store incoming partons in hadronic CM-frame DO 140 JT=1,2 I=MINT(84)+JT K(I,1)=14 K(I,2)=MINT(14+JT) K(I,3)=MINT(83)+2+JT 140 CONTINUE IF(MINT(15).EQ.22) THEN P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1)) P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1)) P(MINT(84)+1,5)=-SQRT(VINT(307)) P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1) P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1) KFRES=MINT(16) ISIDE=2 ELSE P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1) P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1) P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1)) P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1)) P(MINT(84)+1,5)=-SQRT(VINT(308)) KFRES=MINT(15) ISIDE=1 ENDIF SIDESG=(-1D0)**(ISIDE-1) C...Copy incoming partons to documentation lines. DO 170 JT=1,2 I1=MINT(83)+4+JT I2=MINT(84)+JT K(I1,1)=21 K(I1,2)=K(I2,2) K(I1,3)=I1-2 DO 150 J=1,5 P(I1,J)=P(I2,J) 150 CONTINUE C...Second copy for partons before ISR shower, since no such. I1=MINT(83)+2+JT K(I1,1)=21 K(I1,2)=K(I2,2) K(I1,3)=I1-2 DO 160 J=1,5 P(I1,J)=P(I2,J) 160 CONTINUE 170 CONTINUE C...Define initial partons. NTRY=0 180 NTRY=NTRY+1 IF(NTRY.GT.100) THEN MINT(51)=1 RETURN ENDIF C...Scattered quark in hadronic CM frame. I=MINT(83)+7 K(IPU3,1)=3 K(IPU3,2)=KFRES K(IPU3,3)=I P(IPU3,5)=PYMASS(KFRES) P(IPU3,3)=P(IPU1,3)+P(IPU2,3) P(IPU3,4)=P(IPU1,4)+P(IPU2,4) P(IPU3,5)=0D0 K(I,1)=21 K(I,2)=KFRES K(I,3)=MINT(83)+4+ISIDE P(I,3)=P(IPU3,3) P(I,4)=P(IPU3,4) P(I,5)=P(IPU3,5) N=IPU3 MINT(21)=KFRES MINT(22)=0 C...No primordial kT, or chosen according to truncated Gaussian or C...exponential, or (for photon) predetermined or power law. 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN IF(MSTP(91).LE.0) THEN PT=0D0 ELSEIF(MSTP(91).EQ.1) THEN PT=PARP(91)*SQRT(-LOG(PYR(0))) ELSE RPT1=PYR(0) RPT2=PYR(0) PT=-PARP(92)*LOG(RPT1*RPT2) ENDIF IF(PT.GT.PARP(93)) GOTO 190 ELSEIF(MINT(106+ISIDE).EQ.3) THEN PTA=SQRT(VINT(282+ISIDE)) PTB=0D0 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN PTB=PARP(99)*SQRT(-LOG(PYR(0))) ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN RPT1=PYR(0) RPT2=PYR(0) PTB=-PARP(99)*LOG(RPT1*RPT2) ENDIF IF(PTB.GT.PARP(100)) GOTO 190 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0))) IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10) ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN IF(MSTP(93).LE.0) THEN PT=0D0 ELSEIF(MSTP(93).EQ.1) THEN PT=PARP(99)*SQRT(-LOG(PYR(0))) ELSEIF(MSTP(93).EQ.2) THEN RPT1=PYR(0) RPT2=PYR(0) PT=-PARP(99)*LOG(RPT1*RPT2) ELSEIF(MSTP(93).EQ.3) THEN HA=PARP(99)**2 HB=PARP(100)**2 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA)) ELSE HA=PARP(99)**2 HB=PARP(100)**2 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2) PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA)) ENDIF IF(PT.GT.PARP(100)) GOTO 190 ELSE PT=0D0 ENDIF VINT(156+ISIDE)=PT PHI=PARU(2)*PYR(0) P(IPU3,1)=PT*COS(PHI) P(IPU3,2)=PT*SIN(PHI) P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2) PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2 PCP=P(IPU3,4)+ABS(P(IPU3,3)) C...Find one or two beam remnants. MINT(105)=MINT(102+ISIDE) MINT(109)=MINT(106+ISIDE) CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP) IF(MINT(51).NE.0) THEN MINT(51)=0 GOTO 180 ENDIF C...Store first remnant parton, with colour info and kinematics. I=N+1 K(I,1)=1 K(I,2)=KFLSP K(I,3)=MINT(83)+ISIDE P(I,5)=PYMASS(K(I,2)) KCOL=KCHG(PYCOMP(KFLSP),2) IF(KCOL.NE.0) THEN K(I,1)=3 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2 K(I,KFLS+3)=MSTU(5)*IPU3 K(IPU3,6-KFLS)=MSTU(5)*I ICOLR=I ENDIF IF(KFLCH.EQ.0) THEN P(I,1)=-P(IPU3,1) P(I,2)=-P(IPU3,2) PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2 P(I,3)=-P(IPU3,3) P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2) PRP=P(I,4)+ABS(P(I,3)) C...When extra remnant parton or hadron: store extra remnant. ELSE I=I+1 K(I,1)=1 K(I,2)=KFLCH K(I,3)=MINT(83)+ISIDE P(I,5)=PYMASS(K(I,2)) KCOL=KCHG(PYCOMP(KFLCH),2) IF(KCOL.NE.0) THEN K(I,1)=3 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2 K(I,KFLS+3)=MSTU(5)*IPU3 K(IPU3,6-KFLS)=MSTU(5)*I ICOLR=I ENDIF C...Relative transverse momentum when two remnants. LOOP=0 200 LOOP=LOOP+1 CALL PYPTDI(1,P(I-1,1),P(I-1,2)) P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1) P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2) PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2 P(I,1)=-P(IPU3,1)-P(I-1,1) P(I,2)=-P(IPU3,2)-P(I-1,2) PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2 C...Relative distribution of energy for particle into jet plus particle. IMB=1 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2 IF(MSTP(94).LE.1) THEN IF(IMB.EQ.1) CHI=PYR(0) IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0)) IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI ELSEIF(MSTP(94).EQ.2) THEN CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB))) IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI ELSEIF(MSTP(94).EQ.3) THEN CALL PYZDIS(1,0,PMS(4),ZZ) CHI=ZZ ELSE CALL PYZDIS(1000,0,PMS(4),ZZ) CHI=ZZ ENDIF C...Construct total transverse mass; reject if too large. CHI=MAX(1D-8,MIN(1D0-1D-8,CHI)) PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI) IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN IF(LOOP.LT.10) GOTO 200 GOTO 180 ENDIF VINT(158+ISIDE)=CHI C...Subdivide longitudinal momentum according to value selected above. PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3)) PW1=(1D0-CHI)*PRP P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1) P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG PW2=CHI*PRP P(I,4)=0.5D0*(PW2+PMS(4)/PW2) P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG ENDIF N=I C...Boost current and remnant systems to correct frame. IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2))) DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/ &(2D0*VINT(1)*PCP) DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/ &(2D0*VINT(1)*PRP) DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0) DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0) CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC) CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER) C...Let current quark shower; recoil but no showering by colour partner. QMAX=2D0*SQRT(VINT(309-ISIDE)) MSTJ48=MSTJ(48) MSTJ(48)=1 PARJ86=PARJ(86) PARJ(86)=0D0 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX) MSTJ(48)=MSTJ48 PARJ(86)=PARJ86 RETURN END C********************************************************************* C...PYDOCU C...Handles the documentation of the process in MSTI and PARI, C...and also computes cross-sections based on accumulated statistics. SUBROUTINE PYDOCU C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/, &/PYINT5/ C...Calculate Monte Carlo estimates of cross-sections. ISUB=MINT(1) IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1 NGEN(0,3)=NGEN(0,3)+1 XSEC(0,3)=0D0 DO 100 I=1,500 IF(I.EQ.96.OR.I.EQ.97) THEN XSEC(I,3)=0D0 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR. & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))* & DBLE(NGEN(96,2))) ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN XSEC(I,3)=0D0 ELSEIF(NGEN(I,2).EQ.0) THEN XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))* & DBLE(NGEN(0,2))) ELSE XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))* & DBLE(NGEN(I,2))) ENDIF XSEC(0,3)=XSEC(0,3)+XSEC(I,3) 100 CONTINUE C...Rescale to known low-pT cross-section for standard QCD processes. IF(MSUB(95).EQ.1) THEN XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+ & XSEC(68,3)+XSEC(95,3) XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1))) IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN FAC=XSECW/XSECH XSEC(11,3)=FAC*XSEC(11,3) XSEC(12,3)=FAC*XSEC(12,3) XSEC(13,3)=FAC*XSEC(13,3) XSEC(28,3)=FAC*XSEC(28,3) XSEC(53,3)=FAC*XSEC(53,3) XSEC(68,3)=FAC*XSEC(68,3) XSEC(95,3)=FAC*XSEC(95,3) XSEC(0,3)=XSEC(0,3)-XSECH+XSECW ENDIF ENDIF C...Save information for gamma-p and gamma-gamma. IF(MINT(121).GT.1) THEN IGA=MINT(122) CALL PYSAVE(2,IGA) CALL PYSAVE(5,0) ENDIF C...Reset information on hard interaction. DO 110 J=1,200 MSTI(J)=0 PARI(J)=0D0 110 CONTINUE C...Copy integer valued information from MINT into MSTI. DO 120 J=1,32 MSTI(J)=MINT(J) 120 CONTINUE IF(MINT(121).GT.1) MSTI(9)=MINT(122) C...Store cross-section variables in PARI. PARI(1)=XSEC(0,3) PARI(2)=XSEC(0,3)/MINT(5) PARI(7)=VINT(97) PARI(9)=VINT(99) PARI(10)=VINT(100) VINT(98)=VINT(98)+VINT(100) IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98) C...Store kinematics variables in PARI. PARI(11)=VINT(1) PARI(12)=VINT(2) IF(ISUB.NE.95) THEN DO 130 J=13,26 PARI(J)=VINT(30+J) 130 CONTINUE PARI(31)=VINT(141) PARI(32)=VINT(142) PARI(33)=VINT(41) PARI(34)=VINT(42) PARI(35)=PARI(33)-PARI(34) PARI(36)=VINT(21) PARI(37)=VINT(22) PARI(38)=VINT(26) PARI(39)=VINT(157) PARI(40)=VINT(158) PARI(41)=VINT(23) PARI(42)=2D0*VINT(47)/VINT(1) ENDIF C...Store information on scattered partons in PARI. IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN DO 140 IS=7,8 I=MINT(IS) PARI(36+IS)=P(I,3)/VINT(1) PARI(38+IS)=P(I,4)/VINT(1) PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2) PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/ & SQRT(PR),1D20)),P(I,3)) PR=MAX(1D-20,P(I,1)**2+P(I,2)**2) PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/ & SQRT(PR),1D20)),P(I,3)) PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2) PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2)) PARI(48+IS)=PYANGL(P(I,1),P(I,2)) 140 CONTINUE ENDIF C...Store sum up transverse and longitudinal momenta. PARI(65)=2D0*PARI(17) IF(ISUB.LE.90.OR.ISUB.GE.95) THEN DO 150 I=MSTP(126)+1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150 PT=SQRT(P(I,1)**2+P(I,2)**2) PARI(69)=PARI(69)+PT IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT 150 CONTINUE PARI(67)=PARI(68) PARI(71)=VINT(151) PARI(72)=VINT(152) PARI(73)=VINT(151) PARI(74)=VINT(152) ELSE PARI(66)=PARI(65) PARI(69)=PARI(65) ENDIF C...Store various other pieces of information into PARI. PARI(61)=VINT(148) PARI(75)=VINT(155) PARI(76)=VINT(156) PARI(77)=VINT(159) PARI(78)=VINT(160) PARI(81)=VINT(138) C...Store information on lepton -> lepton + gamma in PYGAGA. MSTI(71)=MINT(141) MSTI(72)=MINT(142) PARI(101)=VINT(301) PARI(102)=VINT(302) DO 160 I=103,114 PARI(I)=VINT(I+202) 160 CONTINUE C...Set information for PYTABU. IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN MSTU(161)=MINT(21) MSTU(162)=0 ELSEIF(ISET(ISUB).EQ.5) THEN MSTU(161)=MINT(23) MSTU(162)=0 ELSE MSTU(161)=MINT(21) MSTU(162)=MINT(22) ENDIF RETURN END C********************************************************************* C...PYFRAM C...Performs transformations between different coordinate frames. SUBROUTINE PYFRAM(IFRAME) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYDAT1/,/PYPARS/,/PYINT1/ C...Check that transformation can and should be done. IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND. &MINT(91).EQ.1)) THEN IF(IFRAME.EQ.MINT(6)) RETURN ELSE WRITE(MSTU(11),5000) IFRAME,MINT(6) RETURN ENDIF IF(MINT(6).EQ.1) THEN C...Transform from fixed target or user specified frame to C...overall CM frame. CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) ELSEIF(MINT(6).EQ.3) THEN C...Transform from hadronic CM frame in DIS to overall CM frame. CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224), & -VINT(225)) ENDIF IF(IFRAME.EQ.1) THEN C...Transform from overall CM frame to fixed target or user specified C...frame. CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10)) ELSEIF(IFRAME.EQ.3) THEN C...Transform from overall CM frame to hadronic CM frame in DIS. CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225)) CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0) CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0) ENDIF C...Set information about new frame. MINT(6)=IFRAME MSTI(6)=IFRAME 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X, &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =', &1X,I5) RETURN END C********************************************************************* C...PYWIDT C...Calculates full and partial widths of resonances. SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT4/,/PYMSSM/,/PYSSMT/ C...Local arrays and saved variables. COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR DIMENSION WDTP(0:300),WDTE(0:300,0:5),MOFSV(3,2),WIDWSV(3,2), &WID2SV(3,2),WDTPP(0:300),WDTEP(0:300,0:5) SAVE MOFSV,WIDWSV,WID2SV DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/ C...Compressed code and sign; mass. KFLA=IABS(KFLR) KFLS=ISIGN(1,KFLR) KC=PYCOMP(KFLA) SHR=SQRT(SH) PMR=PMAS(KC,1) C...Reset width information. DO 110 I=0,200 WDTP(I)=0D0 DO 100 J=0,5 WDTE(I,J)=0D0 100 CONTINUE 110 CONTINUE C...Allow for fudge factor to rescale resonance width. FUDGE=1D0 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR. &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN IF(MSTP(110).EQ.KFLA) THEN FUDGE=PARP(110) ELSEIF(MSTP(110).EQ.-1) THEN IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110) ELSEIF(MSTP(110).EQ.-2) THEN FUDGE=PARP(110) ENDIF ENDIF C...Not to be treated as a resonance: return. IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND. &KFLA.NE.22) THEN WDTP(0)=1D0 WDTE(0,0)=1D0 MINT(61)=0 MINT(62)=0 MINT(63)=0 RETURN C...Treatment as a resonance based on tabulated branching ratios. ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN C...Loop over possible decay channels; skip irrelevant ones. DO 120 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 120 C...Read out decay products and nominal masses. KFD1=KFDP(IDC,1) KFC1=PYCOMP(KFD1) IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1 PM1=PMAS(KFC1,1) KFD2=KFDP(IDC,2) KFC2=PYCOMP(KFD2) IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2 PM2=PMAS(KFC2,1) KFD3=KFDP(IDC,3) PM3=0D0 IF(KFD3.NE.0) THEN KFC3=PYCOMP(KFD3) IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3 PM3=PMAS(KFC3,1) ENDIF C...Naive partial width and alternative threshold factors. WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR) IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND. & PM1+PM2+PM3.GE.SHR) THEN WDTP(I)=0D0 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2- & 4D0*PM1**2*PM2**2))/SH ELSEIF(MDME(IDC,2).EQ.52) THEN PMA=MAX(PM1,PM2,PM3) PMC=MIN(PM1,PM2,PM3) PMB=PM1+PM2+PM3-PMA-PMC PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC) PMAN=PMA**2/SH PMBN=PMB**2/SH PMCN=PMC**2/SH PMBCN=PMBC**2/SH WDTP(I)=WDTP(I)*SQRT(MAX(0D0, & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)* & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))* & ((SHR-PMA)**2-(PMB+PMC)**2)* & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/ & ((1D0-PMBCN)*PMBCN*SH) ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN WDTP(I)=WDTP(I)*SQRT( & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/ & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)) ELSEIF(MDME(IDC,2).EQ.53) THEN PMA=MAX(PM1,PM2,PM3) PMC=MIN(PM1,PM2,PM3) PMB=PM1+PM2+PM3-PMA-PMC PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC) PMAN=PMA**2/SH PMBN=PMB**2/SH PMCN=PMC**2/SH PMBCN=PMBC**2/SH FACACT=SQRT(MAX(0D0, & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)* & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))* & ((SHR-PMA)**2-(PMB+PMC)**2)* & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/ & ((1D0-PMBCN)*PMBCN*SH) PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC) PMAN=PMA**2/PMR**2 PMBN=PMB**2/PMR**2 PMCN=PMC**2/PMR**2 PMBCN=PMBC**2/PMR**2 FACNOM=SQRT(MAX(0D0, & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)* & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))* & ((PMR-PMA)**2-(PMB+PMC)**2)* & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/ & ((1D0-PMBCN)*PMBCN*PMR**2) WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) C...Calculate secondary width (at most two identical/opposite). WID2=1D0 IF(MDME(IDC,1).GT.0) THEN IF(KFD2.EQ.KFD1) THEN IF(KCHG(KFC1,3).EQ.0) THEN WID2=WIDS(KFC1,1) ELSEIF(KFD1.GT.0) THEN WID2=WIDS(KFC1,4) ELSE WID2=WIDS(KFC1,5) ENDIF IF(KFD3.GT.0) THEN WID2=WID2*WIDS(KFC3,2) ELSEIF(KFD3.LT.0) THEN WID2=WID2*WIDS(KFC3,3) ENDIF ELSEIF(KFD2.EQ.-KFD1) THEN WID2=WIDS(KFC1,1) IF(KFD3.GT.0) THEN WID2=WID2*WIDS(KFC3,2) ELSEIF(KFD3.LT.0) THEN WID2=WID2*WIDS(KFC3,3) ENDIF ELSEIF(KFD3.EQ.KFD1) THEN IF(KCHG(KFC1,3).EQ.0) THEN WID2=WIDS(KFC1,1) ELSEIF(KFD1.GT.0) THEN WID2=WIDS(KFC1,4) ELSE WID2=WIDS(KFC1,5) ENDIF IF(KFD2.GT.0) THEN WID2=WID2*WIDS(KFC2,2) ELSEIF(KFD2.LT.0) THEN WID2=WID2*WIDS(KFC2,3) ENDIF ELSEIF(KFD3.EQ.-KFD1) THEN WID2=WIDS(KFC1,1) IF(KFD2.GT.0) THEN WID2=WID2*WIDS(KFC2,2) ELSEIF(KFD2.LT.0) THEN WID2=WID2*WIDS(KFC2,3) ENDIF ELSEIF(KFD3.EQ.KFD2) THEN IF(KCHG(KFC2,3).EQ.0) THEN WID2=WIDS(KFC2,1) ELSEIF(KFD2.GT.0) THEN WID2=WIDS(KFC2,4) ELSE WID2=WIDS(KFC2,5) ENDIF IF(KFD1.GT.0) THEN WID2=WID2*WIDS(KFC1,2) ELSEIF(KFD1.LT.0) THEN WID2=WID2*WIDS(KFC1,3) ENDIF ELSEIF(KFD3.EQ.-KFD2) THEN WID2=WIDS(KFC2,1) IF(KFD1.GT.0) THEN WID2=WID2*WIDS(KFC1,2) ELSEIF(KFD1.LT.0) THEN WID2=WID2*WIDS(KFC1,3) ENDIF ELSE IF(KFD1.GT.0) THEN WID2=WIDS(KFC1,2) ELSE WID2=WIDS(KFC1,3) ENDIF IF(KFD2.GT.0) THEN WID2=WID2*WIDS(KFC2,2) ELSE WID2=WID2*WIDS(KFC2,3) ENDIF IF(KFD3.GT.0) THEN WID2=WID2*WIDS(KFC3,2) ELSEIF(KFD3.LT.0) THEN WID2=WID2*WIDS(KFC3,3) ENDIF ENDIF C...Store effective widths according to case. WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 120 CONTINUE C...Return. MINT(61)=0 MINT(62)=0 MINT(63)=0 RETURN ENDIF C...Here begins detailed dynamical calculation of resonance widths. C...Shared treatment of Higgs states. KFHIGG=25 IHIGG=1 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN KFHIGG=KFLA IHIGG=KFLA-33 ENDIF C...Common electroweak and strong constants. XW=PARU(102) XWV=XW IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2 XW1=1D0-XW AEM=PYALEM(SH) IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1) AS=PYALPS(SH) RADC=1D0+AS/PARU(1) IF(KFLA.EQ.6) THEN C...t quark. FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR RADCT=1D0-2.5D0*AS/PARU(1) DO 140 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 140 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140 WID2=1D0 IF(I.GE.4.AND.I.LE.7) THEN C...t -> W + q; including approximate QCD correction factor. WDTP(I)=FAC*VCKM(3,I-3)*RADCT* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) IF(KFLR.GT.0) THEN WID2=WIDS(24,2) IF(I.EQ.7) WID2=WID2*WIDS(7,2) ELSE WID2=WIDS(24,3) IF(I.EQ.7) WID2=WID2*WIDS(7,3) ENDIF ELSEIF(I.EQ.9) THEN C...t -> H + b. 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 DO 130 IK=1,4 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK)) 130 CONTINUE AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB) AR=-ET*ZMIXC(IZ,1)*TANW BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR BR=AL FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)* & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR) WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM* & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+ & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH IF(KFLR.GT.0) THEN WID2=WIDS(KFC1,2)*WIDS(KFC2,2) ELSE WID2=WIDS(KFC1,2)*WIDS(KFC2,3) ENDIF ENDIF ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN C...t -> ~g + ~t KFC1=PYCOMP(KFDP(IDC,1)) KFC2=PYCOMP(KFDP(IDC,2)) PMNCHI=PMAS(KFC1,1) PMSTOP=PMAS(KFC2,1) IF(SHR.GT.PMNCHI+PMSTOP) THEN RL=SFMIX(6,1) RR=-SFMIX(6,2) PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)* & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR) WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)* & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH IF(KFLR.GT.0) THEN WID2=WIDS(KFC1,2)*WIDS(KFC2,2) ELSE WID2=WIDS(KFC1,2)*WIDS(KFC2,3) ENDIF ENDIF ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN C...t -> ~gravitino + ~t XMP2=RMSS(29)**2 KFC1=PYCOMP(KFDP(IDC,1)) XMGR2=PMAS(KFC1,1)**2 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4 KFC2=PYCOMP(KFDP(IDC,2)) WID2=WIDS(KFC2,2) IF(KFLR.LT.0) WID2=WIDS(KFC2,3) CMRENNA-- ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 140 CONTINUE ELSEIF(KFLA.EQ.7) THEN C...b' quark. FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR DO 150 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 150 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150 WID2=1D0 IF(I.GE.4.AND.I.LE.7) THEN C...b' -> W + q. WDTP(I)=FAC*VCKM(I-3,4)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) IF(KFLR.GT.0) THEN WID2=WIDS(24,3) IF(I.EQ.6) WID2=WID2*WIDS(6,2) IF(I.EQ.7) WID2=WID2*WIDS(8,2) ELSE WID2=WIDS(24,2) IF(I.EQ.6) WID2=WID2*WIDS(6,3) IF(I.EQ.7) WID2=WID2*WIDS(8,3) ENDIF WID2=WIDS(24,3) IF(KFLR.LT.0) WID2=WIDS(24,2) ELSEIF(I.EQ.9.OR.I.EQ.10) THEN C...b' -> H + q. WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2) IF(KFLR.GT.0) THEN WID2=WIDS(37,3) IF(I.EQ.10) WID2=WID2*WIDS(6,2) ELSE WID2=WIDS(37,2) IF(I.EQ.10) WID2=WID2*WIDS(6,3) ENDIF ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 150 CONTINUE ELSEIF(KFLA.EQ.8) THEN C...t' quark. FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR DO 160 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 160 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160 WID2=1D0 IF(I.GE.4.AND.I.LE.7) THEN C...t' -> W + q. WDTP(I)=FAC*VCKM(4,I-3)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) IF(KFLR.GT.0) THEN WID2=WIDS(24,2) IF(I.EQ.7) WID2=WID2*WIDS(7,2) ELSE WID2=WIDS(24,3) IF(I.EQ.7) WID2=WID2*WIDS(7,3) ENDIF ELSEIF(I.EQ.9.OR.I.EQ.10) THEN C...t' -> H + q. WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2) IF(KFLR.GT.0) THEN WID2=WIDS(37,2) IF(I.EQ.10) WID2=WID2*WIDS(7,2) ELSE WID2=WIDS(37,3) IF(I.EQ.10) WID2=WID2*WIDS(7,3) ENDIF ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 160 CONTINUE ELSEIF(KFLA.EQ.17) THEN C...tau' lepton. FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR DO 170 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 170 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170 WID2=1D0 IF(I.EQ.3) THEN C...tau' -> W + nu'_tau. WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) IF(KFLR.GT.0) THEN WID2=WIDS(24,3) WID2=WID2*WIDS(18,2) ELSE WID2=WIDS(24,2) WID2=WID2*WIDS(18,3) ENDIF ELSEIF(I.EQ.5) THEN C...tau' -> H + nu'_tau. WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2) IF(KFLR.GT.0) THEN WID2=WIDS(37,3) WID2=WID2*WIDS(18,2) ELSE WID2=WIDS(37,2) WID2=WID2*WIDS(18,3) ENDIF ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 170 CONTINUE ELSEIF(KFLA.EQ.18) THEN C...nu'_tau neutrino. FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR DO 180 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 180 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180 WID2=1D0 IF(I.EQ.2) THEN C...nu'_tau -> W + tau'. WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) IF(KFLR.GT.0) THEN WID2=WIDS(24,2) WID2=WID2*WIDS(17,2) ELSE WID2=WIDS(24,3) WID2=WID2*WIDS(17,3) ENDIF ELSEIF(I.EQ.3) THEN C...nu'_tau -> H + tau'. WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2) IF(KFLR.GT.0) THEN WID2=WIDS(37,2) WID2=WID2*WIDS(17,2) ELSE WID2=WIDS(37,3) WID2=WID2*WIDS(17,3) ENDIF ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 180 CONTINUE ELSEIF(KFLA.EQ.21) THEN C...QCD: C***Note that widths are not given in dimensional quantities here. DO 190 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 190 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190 WID2=1D0 IF(I.LE.8) THEN C...QCD -> q + qbar WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1)) IF(I.EQ.6) WID2=WIDS(6,1) IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 190 CONTINUE ELSEIF(KFLA.EQ.22) THEN C...QED photon. C***Note that widths are not given in dimensional quantities here. DO 200 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 200 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200 WID2=1D0 IF(I.LE.8) THEN C...QED -> q + qbar. EF=KCHG(I,1)/3D0 FCOF=3D0*RADC IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0) WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1)) IF(I.EQ.6) WID2=WIDS(6,1) IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) ELSEIF(I.LE.12) THEN C...QED -> l+ + l-. EF=KCHG(9+2*(I-8),1)/3D0 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1)) IF(I.EQ.12) WID2=WIDS(17,1) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 200 CONTINUE ELSEIF(KFLA.EQ.23) THEN C...Z0: ICASE=1 XWC=1D0/(16D0*XW*XW1) FAC=(AEM*XWC/3D0)*SHR 210 CONTINUE IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN VINT(111)=0D0 VINT(112)=0D0 VINT(114)=0D0 ENDIF IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN KFI=IABS(MINT(15)) IF(KFI.GT.20) KFI=IABS(MINT(16)) EI=KCHG(KFI,1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV SQMZ=PMAS(23,1)**2 HZ=SHR*WDTP(0) IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0 IF(MSTP(43).EQ.3) VINT(112)= & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2) IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)= & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2) ENDIF DO 220 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 220 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220 WID2=1D0 IF(I.LE.8) THEN C...Z0 -> q + qbar EF=KCHG(I,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV FCOF=3D0*RADC IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0) IF(I.EQ.6) WID2=WIDS(6,1) IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) ELSEIF(I.LE.16) THEN C...Z0 -> l+ + l-, nu + nubar EF=KCHG(I+2,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV FCOF=1D0 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1) ENDIF BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) IF(ICASE.EQ.1) THEN WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))* & BE34 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)* & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+ & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34 ENDIF IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I) IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR. & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+ & WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)= & VINT(111)+FGGF*WID2 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)= & VINT(114)+FZZF*WID2 ENDIF ENDIF 220 CONTINUE IF(MINT(61).GE.1) ICASE=3-ICASE IF(ICASE.EQ.2) GOTO 210 ELSEIF(KFLA.EQ.24) THEN C...W+/-: FAC=(AEM/(24D0*XW))*SHR DO 230 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 230 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230 WID2=1D0 IF(I.LE.16) THEN C...W+/- -> q + qbar' FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1) IF(KFLR.GT.0) THEN IF(MOD(I,4).EQ.3) WID2=WIDS(6,2) IF(MOD(I,4).EQ.0) WID2=WIDS(8,2) IF(I.GE.13) WID2=WID2*WIDS(7,3) ELSE IF(MOD(I,4).EQ.3) WID2=WIDS(6,3) IF(MOD(I,4).EQ.0) WID2=WIDS(8,3) IF(I.GE.13) WID2=WID2*WIDS(7,2) ENDIF ELSEIF(I.LE.20) THEN C...W+/- -> l+/- + nu FCOF=1D0 IF(KFLR.GT.0) THEN IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2) ELSE IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3) ENDIF ENDIF WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 230 CONTINUE ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN C...h0 (or H0, or A0): IF(MSTP(49).EQ.0) THEN SHFS=SH ELSE SHFS=PMAS(KFHIGG,1)**2 ENDIF FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR DO 270 I=1,MDCY(KFHIGG,3) IDC=I+MDCY(KFHIGG,2)-1 IF(MDME(IDC,1).LT.0) GOTO 270 KFC1=PYCOMP(KFDP(IDC,1)) KFC2=PYCOMP(KFDP(IDC,2)) RM1=PMAS(KFC1,1)**2/SH RM2=PMAS(KFC2,1)**2/SH IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0) & GOTO 270 WID2=1D0 IF(I.LE.8) THEN C...h0 -> q + qbar WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)* & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC C...A0 behaves like beta, ho and H0 like beta**3. IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1) IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2 IF(IHIGG.NE.3) THEN WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/ & PARU(151+10*IHIGG))**2 ENDIF ENDIF ENDIF IF(I.EQ.6) WID2=WIDS(6,1) IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) ELSEIF(I.LE.12) THEN C...h0 -> l+ + l- WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS) C...A0 behaves like beta, ho and H0 like beta**3. IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1) IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)* & PARU(153+10*IHIGG)**2 IF(I.EQ.12) WID2=WIDS(17,1) ELSEIF(I.EQ.13) THEN C...h0 -> g + g; quark loop contribution only ETARE=0D0 ETAIM=0D0 DO 240 J=1,2*MSTP(1) EPS=(2D0*PMAS(J,1))**2/SH C...Loop integral; function of eps=4m^2/shat; different for A0. IF(EPS.LE.1D0) THEN IF(EPS.GT.1D-4) THEN ROOT=SQRT(1D0-EPS) RLN=LOG((1D0+ROOT)/(1D0-ROOT)) ELSE RLN=LOG(4D0/EPS-2D0) ENDIF PHIRE=-0.25D0*(RLN**2-PARU(1)**2) PHIIM=0.5D0*PARU(1)*RLN ELSE PHIRE=(ASIN(1D0/SQRT(EPS)))**2 PHIIM=0D0 ENDIF IF(IHIGG.LE.2) THEN ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE) ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM ELSE ETAREJ=-0.5D0*EPS*PHIRE ETAIMJ=-0.5D0*EPS*PHIIM ENDIF C...Couplings (=1 for standard model Higgs). IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN IF(MOD(J,2).EQ.1) THEN ETAREJ=ETAREJ*PARU(151+10*IHIGG) ETAIMJ=ETAIMJ*PARU(151+10*IHIGG) ELSE ETAREJ=ETAREJ*PARU(152+10*IHIGG) ETAIMJ=ETAIMJ*PARU(152+10*IHIGG) ENDIF ENDIF ETARE=ETARE+ETAREJ ETAIM=ETAIM+ETAIMJ 240 CONTINUE ETA2=ETARE**2+ETAIM**2 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2 ELSEIF(I.EQ.14) THEN C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions ETARE=0D0 ETAIM=0D0 JMAX=3*MSTP(1)+1 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1 DO 250 J=1,JMAX IF(J.LE.2*MSTP(1)) THEN EJ=KCHG(J,1)/3D0 EPS=(2D0*PMAS(J,1))**2/SH ELSEIF(J.LE.3*MSTP(1)) THEN JL=2*(J-2*MSTP(1))-1 EJ=KCHG(10+JL,1)/3D0 EPS=(2D0*PMAS(10+JL,1))**2/SH ELSEIF(J.EQ.3*MSTP(1)+1) THEN EPS=(2D0*PMAS(24,1))**2/SH ELSE EPS=(2D0*PMAS(37,1))**2/SH ENDIF C...Loop integral; function of eps=4m^2/shat. IF(EPS.LE.1D0) THEN IF(EPS.GT.1D-4) THEN ROOT=SQRT(1D0-EPS) RLN=LOG((1D0+ROOT)/(1D0-ROOT)) ELSE RLN=LOG(4D0/EPS-2D0) ENDIF PHIRE=-0.25D0*(RLN**2-PARU(1)**2) PHIIM=0.5D0*PARU(1)*RLN ELSE PHIRE=(ASIN(1D0/SQRT(EPS)))**2 PHIIM=0D0 ENDIF IF(J.LE.3*MSTP(1)) THEN C...Fermion loops: loop integral different for A0; charges. IF(IHIGG.LE.2) THEN PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE) PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM ELSE PHIPRE=-0.5D0*EPS*PHIRE PHIPIM=-0.5D0*EPS*PHIIM ENDIF IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN EJC=3D0*EJ**2 EJH=PARU(151+10*IHIGG) ELSEIF(J.LE.2*MSTP(1)) THEN EJC=3D0*EJ**2 EJH=PARU(152+10*IHIGG) ELSE EJC=EJ**2 EJH=PARU(153+10*IHIGG) ENDIF IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0 ETAREJ=EJC*EJH*PHIPRE ETAIMJ=EJC*EJH*PHIPIM ELSEIF(J.EQ.3*MSTP(1)+1) THEN C...W loops: loop integral and charges. ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE) ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN ETAREJ=ETAREJ*PARU(155+10*IHIGG) ETAIMJ=ETAIMJ*PARU(155+10*IHIGG) ENDIF ELSE C...Charged H loops: loop integral and charges. FACHHH=(PMAS(24,1)/PMAS(37,1))**2* & PARU(158+10*IHIGG+2*(IHIGG/3)) ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH ETAIMJ=-EPS**2*PHIIM*FACHHH ENDIF ETARE=ETARE+ETAREJ ETAIM=ETAIM+ETAIMJ 250 CONTINUE ETA2=ETARE**2+ETAIM**2 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2 ELSEIF(I.EQ.15) THEN C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions ETARE=0D0 ETAIM=0D0 JMAX=3*MSTP(1)+1 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1 DO 260 J=1,JMAX IF(J.LE.2*MSTP(1)) THEN EJ=KCHG(J,1)/3D0 AJ=SIGN(1D0,EJ+0.1D0) VJ=AJ-4D0*EJ*XWV EPS=(2D0*PMAS(J,1))**2/SH EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2 ELSEIF(J.LE.3*MSTP(1)) THEN JL=2*(J-2*MSTP(1))-1 EJ=KCHG(10+JL,1)/3D0 AJ=SIGN(1D0,EJ+0.1D0) VJ=AJ-4D0*EJ*XWV EPS=(2D0*PMAS(10+JL,1))**2/SH EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2 ELSE EPS=(2D0*PMAS(24,1))**2/SH EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2 ENDIF C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2. IF(EPS.LE.1D0) THEN ROOT=SQRT(1D0-EPS) IF(EPS.GT.1D-4) THEN RLN=LOG((1D0+ROOT)/(1D0-ROOT)) ELSE RLN=LOG(4D0/EPS-2D0) ENDIF PHIRE=-0.25D0*(RLN**2-PARU(1)**2) PHIIM=0.5D0*PARU(1)*RLN PSIRE=0.5D0*ROOT*RLN PSIIM=-0.5D0*ROOT*PARU(1) ELSE PHIRE=(ASIN(1D0/SQRT(EPS)))**2 PHIIM=0D0 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS)) PSIIM=0D0 ENDIF IF(EPSP.LE.1D0) THEN ROOT=SQRT(1D0-EPSP) IF(EPSP.GT.1D-4) THEN RLN=LOG((1D0+ROOT)/(1D0-ROOT)) ELSE RLN=LOG(4D0/EPSP-2D0) ENDIF PHIREP=-0.25D0*(RLN**2-PARU(1)**2) PHIIMP=0.5D0*PARU(1)*RLN PSIREP=0.5D0*ROOT*RLN PSIIMP=-0.5D0*ROOT*PARU(1) ELSE PHIREP=(ASIN(1D0/SQRT(EPSP)))**2 PHIIMP=0D0 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP)) PSIIMP=0D0 ENDIF FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)* & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP)) FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)* & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP)) F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP) F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP) IF(J.LE.3*MSTP(1)) THEN C...Fermion loops: loop integral different for A0; charges. IF(IHIGG.EQ.3) FXYRE=0D0 IF(IHIGG.EQ.3) FXYIM=0D0 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN EJC=-3D0*EJ*VJ EJH=PARU(151+10*IHIGG) ELSEIF(J.LE.2*MSTP(1)) THEN EJC=-3D0*EJ*VJ EJH=PARU(152+10*IHIGG) ELSE EJC=-EJ*VJ EJH=PARU(153+10*IHIGG) ENDIF IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE) ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM) ELSEIF(J.EQ.3*MSTP(1)+1) THEN C...W loops: loop integral and charges. HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS) ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE) ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM) IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN ETAREJ=ETAREJ*PARU(155+10*IHIGG) ETAIMJ=ETAIMJ*PARU(155+10*IHIGG) ENDIF ELSE C...Charged H loops: loop integral and charges. FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)* & PARU(158+10*IHIGG+2*(IHIGG/3)) ETAREJ=FACHHH*FXYRE ETAIMJ=FACHHH*FXYIM ENDIF ETARE=ETARE+ETAREJ ETAIM=ETAIM+ETAIMJ 260 CONTINUE ETA2=(ETARE**2+ETAIM**2)/(XW*XW1) WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2 WID2=WIDS(23,2) ELSEIF(I.LE.17) THEN C...h0 -> Z0 + Z0, W+ + W- PM1=PMAS(IABS(KFDP(IDC,1)),1) PG1=PMAS(IABS(KFDP(IDC,1)),2) IF(MINT(62).GE.1) THEN IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND. & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND. & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN MOFSV(IHIGG,I-15)=0 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0, & 1D0-4D0*RM1)) WID2=1D0 ELSE MOFSV(IHIGG,I-15)=1 RMAS=SQRT(MAX(0D0,SH)) CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW, & WID2) WIDWSV(IHIGG,I-15)=WIDW WID2SV(IHIGG,I-15)=WID2 ENDIF ELSE IF(MOFSV(IHIGG,I-15).EQ.0) THEN WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0, & 1D0-4D0*RM1)) WID2=1D0 ELSE WIDW=WIDWSV(IHIGG,I-15) WID2=WID2SV(IHIGG,I-15) ENDIF ENDIF WDTP(I)=FAC*WIDW/(2D0*(18-I)) IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)* & PARU(138+I+10*IHIGG)**2 WID2=WID2*WIDS(7+I,1) ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN C...H0 -> Z0 + h0, A0-> Z0 + h0 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0, & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 IF(IHIGG.EQ.2) THEN WDTP(I)=WDTP(I)*PARU(179)**2 ELSEIF(IHIGG.EQ.3) THEN WDTP(I)=WDTP(I)*PARU(186)**2 ENDIF WID2=WIDS(23,2)*WIDS(25,2) ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN C...H0 -> h0 + h0, A0-> h0 + h0 WDTP(I)=FAC*0.25D0* & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1)) IF(IHIGG.EQ.2) THEN WDTP(I)=WDTP(I)*PARU(176)**2 ELSEIF(IHIGG.EQ.3) THEN WDTP(I)=WDTP(I)*PARU(169)**2 ENDIF WID2=WIDS(25,1) ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+ WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0, & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 & *PARU(195+IHIGG)**2 IF(I.EQ.20) THEN WID2=WIDS(24,2)*WIDS(37,3) ELSEIF(I.EQ.21) THEN WID2=WIDS(24,3)*WIDS(37,2) ENDIF ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN C...H0 -> Z0 + A0. WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0, & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*0.0D0 WID2=WIDS(36,2)*WIDS(23,2) ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN C...H0 -> h0 + A0. WDTP(I)=FAC*0.5D0*PARU(180)**2* & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1)) WID2=WIDS(25,2)*WIDS(36,2) ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN C...H0 -> A0 + A0 WDTP(I)=FAC*0.25D0*PARU(177)**2* & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1)) WID2=WIDS(36,1) CMRENNA++ ELSE C...Add in SUSY decays (two-body) by rescaling by phase space factor. RM10=RM1*SH/PMR**2 RM20=RM2*SH/PMR**2 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20) WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2) IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN WFAC=0D0 ELSE WFAC=WFAC/WFAC0 ENDIF WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC) CMRENNA-- IF(KFC2.EQ.KFC1) THEN WID2=WIDS(KFC1,1) ELSE KSGN1=2 IF(KFDP(IDC,1).LT.0) KSGN1=3 KSGN2=2 IF(KFDP(IDC,2).LT.0) KSGN2=3 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2) ENDIF ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 270 CONTINUE ELSEIF(KFLA.EQ.32) THEN C...Z'0: ICASE=1 XWC=1D0/(16D0*XW*XW1) FAC=(AEM*XWC/3D0)*SHR VINT(117)=0D0 280 CONTINUE IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN VINT(111)=0D0 VINT(112)=0D0 VINT(113)=0D0 VINT(114)=0D0 VINT(115)=0D0 VINT(116)=0D0 ENDIF IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN KFAI=IABS(MINT(15)) EI=KCHG(KFAI,1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV KFAIC=1 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN VPI=PARU(119+2*KFAIC) API=PARU(120+2*KFAIC) ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN VPI=PARJ(178+2*KFAIC) API=PARJ(179+2*KFAIC) ELSE VPI=PARJ(186+2*KFAIC) API=PARJ(187+2*KFAIC) ENDIF SQMZ=PMAS(23,1)**2 HZ=SHR*VINT(117) SQMZP=PMAS(32,1)**2 HZP=SHR*WDTP(0) IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR. & MSTP(44).EQ.7) VINT(111)=1D0 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)= & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2) IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)= & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2) IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR. & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2) IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)= & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/ & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2)) IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR. & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2) ENDIF DO 290 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 290 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290 WID2=1D0 IF(I.LE.16) THEN IF(I.LE.8) THEN C...Z'0 -> q + qbar EF=KCHG(I,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV IF(I.LE.2) THEN VPF=PARU(123-2*MOD(I,2)) APF=PARU(124-2*MOD(I,2)) ELSEIF(I.LE.4) THEN VPF=PARJ(182-2*MOD(I,2)) APF=PARJ(183-2*MOD(I,2)) ELSE VPF=PARJ(190-2*MOD(I,2)) APF=PARJ(191-2*MOD(I,2)) ENDIF FCOF=3D0*RADC IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF* & PYHFTH(SH,SH*RM1,1D0) IF(I.EQ.6) WID2=WIDS(6,1) IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) ELSEIF(I.LE.16) THEN C...Z'0 -> l+ + l-, nu + nubar EF=KCHG(I+2,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV IF(I.LE.10) THEN VPF=PARU(127-2*MOD(I,2)) APF=PARU(128-2*MOD(I,2)) ELSEIF(I.LE.12) THEN VPF=PARJ(186-2*MOD(I,2)) APF=PARJ(187-2*MOD(I,2)) ELSE VPF=PARJ(194-2*MOD(I,2)) APF=PARJ(195-2*MOD(I,2)) ENDIF FCOF=1D0 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1) ENDIF BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) IF(ICASE.EQ.1) THEN WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+ & APF**2*(1D0-4D0*RM1))*BE34 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)* & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)* & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)* & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)* & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)* & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34 ELSEIF(MINT(61).EQ.2) THEN FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))* & BE34 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))* & BE34 ENDIF ELSEIF(I.EQ.17) THEN C...Z'0 -> W+ + W- WDTPZP=PARU(129)**2*XW1**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2) IF(ICASE.EQ.1) THEN WDTPZ=0D0 WDTP(I)=FAC*WDTPZP ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP ELSEIF(MINT(61).EQ.2) THEN FGGF=0D0 FGZF=0D0 FGZPF=0D0 FZZF=0D0 FZZPF=0D0 FZPZPF=WDTPZP ENDIF WID2=WIDS(24,1) ELSEIF(I.EQ.18) THEN C...Z'0 -> H+ + H- CZC=2D0*(1D0-2D0*XW) BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1)) IF(ICASE.EQ.1) THEN WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI* & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2* & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)* & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2* & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C ELSEIF(MINT(61).EQ.2) THEN FGGF=0.25D0*BE34C FGZF=0.25D0*PARU(142)*CZC*BE34C FGZPF=0.25D0*PARU(143)*CZC*BE34C FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C ENDIF WID2=WIDS(37,1) ELSEIF(I.EQ.19) THEN C...Z'0 -> Z0 + gamma. ELSEIF(I.EQ.20) THEN C...Z'0 -> Z0 + h0 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)* & (3D0*RM1+0.25D0*FLAM**2)*FLAM IF(ICASE.EQ.1) THEN WDTPZ=0D0 WDTP(I)=FAC*WDTPZP ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP ELSEIF(MINT(61).EQ.2) THEN FGGF=0D0 FGZF=0D0 FGZPF=0D0 FZZF=0D0 FZZPF=0D0 FZPZPF=WDTPZP ENDIF WID2=WIDS(23,2)*WIDS(25,2) ELSEIF(I.EQ.21.OR.I.EQ.22) THEN C...Z' -> h0 + A0 or H0 + A0. BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 IF(I.EQ.21) THEN CZAH=PARU(186) CZPAH=PARU(188) ELSE CZAH=PARU(187) CZPAH=PARU(189) ENDIF IF(ICASE.EQ.1) THEN WDTPZ=CZAH**2*BE34C WDTP(I)=FAC*CZPAH**2*BE34C ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH* & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)* & VINT(116))*BE34C ELSEIF(MINT(61).EQ.2) THEN FGGF=0D0 FGZF=0D0 FGZPF=0D0 FZZF=CZAH**2*BE34C FZZPF=CZAH*CZPAH*BE34C FZPZPF=CZPAH**2*BE34C ENDIF IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2) IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2) ENDIF IF(ICASE.EQ.1) THEN VINT(117)=VINT(117)+FAC*WDTPZ WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) ENDIF IF(MDME(IDC,1).GT.0) THEN IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR. & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+ & WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR. & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+ & FGZF*WID2 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+ & FGZPF*WID2 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR. & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+ & FZZPF*WID2 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR. & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2 ENDIF ENDIF 290 CONTINUE IF(MINT(61).GE.1) ICASE=3-ICASE IF(ICASE.EQ.2) GOTO 280 ELSEIF(KFLA.EQ.34) THEN C...W'+/-: FAC=(AEM/(24D0*XW))*SHR DO 300 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 300 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300 WID2=1D0 IF(I.LE.20) THEN IF(I.LE.16) THEN C...W'+/- -> q + qbar' FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)* & VCKM((I-1)/4+1,MOD(I-1,4)+1) IF(KFLR.GT.0) THEN IF(MOD(I,4).EQ.3) WID2=WIDS(6,2) IF(MOD(I,4).EQ.0) WID2=WIDS(8,2) IF(I.GE.13) WID2=WID2*WIDS(7,3) ELSE IF(MOD(I,4).EQ.3) WID2=WIDS(6,3) IF(MOD(I,4).EQ.0) WID2=WIDS(8,3) IF(I.GE.13) WID2=WID2*WIDS(7,2) ENDIF ELSEIF(I.LE.20) THEN C...W'+/- -> l+/- + nu FCOF=PARU(133)**2+PARU(134)**2 IF(KFLR.GT.0) THEN IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2) ELSE IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3) ENDIF ENDIF WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) ELSEIF(I.EQ.21) THEN C...W'+/- -> W+/- + Z0 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2) IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2) IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2) ELSEIF(I.EQ.23) THEN C...W'+/- -> W+/- + h0 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2) IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 300 CONTINUE ELSEIF(KFLA.EQ.37) THEN C...H+/-: IF(MSTP(49).EQ.0) THEN SHFS=SH ELSE SHFS=PMAS(37,1)**2 ENDIF FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR DO 310 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 310 KFC1=PYCOMP(KFDP(IDC,1)) KFC2=PYCOMP(KFDP(IDC,2)) RM1=PMAS(KFC1,1)**2/SH RM2=PMAS(KFC2,1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310 WID2=1D0 IF(I.LE.4) THEN C...H+/- -> q + qbar' RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+ & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS) IF(KFLR.GT.0) THEN IF(I.EQ.3) WID2=WIDS(6,2) IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2) ELSE IF(I.EQ.3) WID2=WIDS(6,3) IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3) ENDIF ELSEIF(I.LE.8) THEN C...H+/- -> l+/- + nu WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)* & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0, & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS) IF(KFLR.GT.0) THEN IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2) ELSE IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3) ENDIF ELSEIF(I.EQ.9) THEN C...H+/- -> W+/- + h0. WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0, & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2) IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2) CMRENNA++ ELSE C...Add in SUSY decays (two-body) by rescaling by phase space factor. RM10=RM1*SH/PMR**2 RM20=RM2*SH/PMR**2 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20) WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2) IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN WFAC=0D0 ELSE WFAC=WFAC/WFAC0 ENDIF WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC) CMRENNA-- KSGN1=2 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3 KSGN2=2 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 310 CONTINUE ELSEIF(KFLA.EQ.41) THEN C...R: FAC=(AEM/(12D0*XW))*SHR DO 320 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 320 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320 WID2=1D0 IF(I.LE.6) THEN C...R -> q + qbar' FCOF=3D0*RADC ELSEIF(I.LE.9) THEN C...R -> l+ + l'- FCOF=1D0 ENDIF WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) IF(KFLR.GT.0) THEN IF(I.EQ.4) WID2=WIDS(6,3) IF(I.EQ.5) WID2=WIDS(7,3) IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3) IF(I.EQ.9) WID2=WIDS(17,3) ELSE IF(I.EQ.4) WID2=WIDS(6,2) IF(I.EQ.5) WID2=WIDS(7,2) IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2) IF(I.EQ.9) WID2=WIDS(17,2) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 320 CONTINUE ELSEIF(KFLA.EQ.42) THEN C...LQ (leptoquark). FAC=(AEM/4D0)*PARU(151)*SHR DO 330 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 330 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=1D0 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR) IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2) IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3) ILQL=KFDP(IDC,2)*ISIGN(1,KFLR) IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2) IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3) WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 330 CONTINUE ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN C...Techni-pi0 and techni-pi0': FAC=(1D0/(32D0*PARU(1)*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_tc -> g + g IF(I.EQ.8) THEN FACP=(AS/(4D0*PARU(1))*PARP(144)/PARP(142))**2 & /(8D0*PARU(1))*SH*SHR IF(KFLA.EQ.KTECHN+111) THEN FACP=FACP*PARP(149) ELSE FACP=FACP*PARP(150) ENDIF WDTP(I)=FACP ELSE C...pi_tc -> f + fbar. FCOF=1D0 IKA=IABS(KFDP(IDC,1)) IF(IKA.LT.10) FCOF=3D0*RADC HM1=PM1 HM2=PM2 IF(IKA.GE.4.AND.IKA.LE.6) THEN FCOF=FCOF*PARP(141+IKA)**2 HM1=PYMRUN(KFDP(IDC,1),SH) HM2=PYMRUN(KFDP(IDC,2),SH) ELSEIF(IKA.EQ.15) THEN FCOF=FCOF*PARP(148)**2 ENDIF WDTP(I)=FAC*FCOF*(HM1+HM2)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 340 CONTINUE ELSEIF(KFLA.EQ.KTECHN+211) THEN C...pi+_tc FAC=(1D0/(32D0*PARU(1)*PARP(142)**2))*SHR DO 350 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 350 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1) PM2=PMAS(PYCOMP(KFDP(IDC,2)),1) PM3=0D0 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1) RM1=PM1**2/SH RM2=PM2**2/SH RM3=PM3**2/SH IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350 WID2=1D0 C...pi_tc -> f + f'. FCOF=1D0 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC C...pi_tc+ -> W b b~ IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN FCOF=3D0*RADC XMT2=PMAS(6,1)**2/SH FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*PARP(147)**2 KFC3=PYCOMP(KFDP(IDC,3)) CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3) CHECK = SQRT(RM1) T0 = (1D0-CHECK**2)* & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)- & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2) T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2) & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3) T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1) WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0)) & +T3*LOG(CHECK)) IF(KFLR.GT.0) THEN WID2=WIDS(24,2) ELSE WID2=WIDS(24,3) ENDIF ELSE FCOF=1D0 IKA=IABS(KFDP(IDC,1)) IF(IKA.LT.10) FCOF=3D0*RADC HM1=PM1 HM2=PM2 IF(I.GE.1.AND.I.LE.5) THEN IF(I.LE.2) THEN FCOF=FCOF*PARP(145)**2 ELSEIF(I.LE.4) THEN FCOF=FCOF*PARP(146)**2 ELSEIF(I.EQ.5) THEN FCOF=FCOF*PARP(147)**2 ENDIF HM1=PYMRUN(KFDP(IDC,1),SH) HM2=PYMRUN(KFDP(IDC,2),SH) ELSEIF(I.EQ.8) THEN FCOF=FCOF*PARP(148)**2 ENDIF WDTP(I)=FAC*FCOF*(HM1+HM2)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 350 CONTINUE ELSEIF(KFLA.EQ.KTECHN+331) THEN C...Techni-eta. FAC=(SH/PARP(46)**2)*SHR DO 360 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 360 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360 WID2=1D0 IF(I.LE.2) THEN WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1)) IF(I.EQ.2) WID2=WIDS(6,1) ELSE WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 360 CONTINUE ELSEIF(KFLA.EQ.KTECHN+113) THEN C...Techni-rho0: ALPRHT=2.91D0*(3D0/PARP(144)) FAC=(ALPRHT/12D0)*SHR FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR SQMZ=PMAS(23,1)**2 SQMW=PMAS(24,1)**2 SHP=SH CALL PYWIDX(23,SHP,WDTPP,WDTEP) GMMZ=SHR*WDTPP(0) XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW)) BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) DO 370 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 370 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370 WID2=1D0 IF(I.EQ.1) THEN C...rho_tc0 -> W+ + W-. WDTP(I)=FAC*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_tc0 -> W+ + pi_tc-. WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)* & (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(138)**2*SHR**3 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3) ELSEIF(I.EQ.3) THEN C...rho_tc0 -> pi_tc+ + W-. WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)* & (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(138)**2*SHR**3 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3) ELSEIF(I.EQ.4) THEN C...rho_tc0 -> pi_tc+ + pi_tc-. WDTP(I)=FAC*(1D0-PARP(141)**2)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=WIDS(PYCOMP(KTECHN+211),1) ELSEIF(I.EQ.5) THEN C...rho_tc0 -> gamma + pi_tc0 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARP(137)**2* & SHR**3 WID2=WIDS(PYCOMP(KTECHN+111),2) ELSEIF(I.EQ.6) THEN C...rho_tc0 -> gamma + pi_tc0' WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (1D0-PARP(139)**2)/24D0/PARP(137)**2*SHR**3 WID2=WIDS(PYCOMP(KTECHN+221),2) ELSEIF(I.EQ.7) THEN C...rho_tc0 -> Z0 + pi_tc0 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARP(137)**2* & XW/XW1*SHR**3 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2) ELSEIF(I.EQ.8) THEN C...rho_tc0 -> Z0 + pi_tc0' WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (1D0-PARP(139)**2)/24D0/PARP(137)**2*(1D0-2D0*XW)**2/4D0/ & XW/XW1*SHR**3 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2) ELSE C...rho_tc0 -> f + fbar. WID2=1D0 IF(I.LE.16) THEN IA=I-8 FCOF=3D0*RADC IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1) ELSE IA=I-6 FCOF=1D0 IF(IA.GE.17) WID2=WIDS(IA,1) ENDIF EI=KCHG(IA,1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV VALI=0.5D0*(VI+AI) VARI=0.5D0*(VI-AI) WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)* & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+ & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*( & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2)) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 370 CONTINUE ELSEIF(KFLA.EQ.KTECHN+213) THEN C...Techni-rho+/-: ALPRHT=2.91D0*(3D0/PARP(144)) FAC=(ALPRHT/12D0)*SHR SQMZ=PMAS(23,1)**2 SQMW=PMAS(24,1)**2 SHP=SH CALL PYWIDX(24,SHP,WDTPP,WDTEP) GMMW=SHR*WDTPP(0) FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR* & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2) DO 380 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 380 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380 WID2=1D0 IF(I.EQ.1) THEN C...rho_tc+ -> W+ + Z0. WDTP(I)=FAC*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_tc+ -> W+ + pi_tc0. WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)* & (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(138)**2*SHR**3 IF(KFLR.GT.0) THEN WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2) ELSE WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2) ENDIF ELSEIF(I.EQ.3) THEN C...rho_tc+ -> pi_tc+ + Z0. WDTP(I)=FAC*PARP(141)**2*(1D0-PARP(141)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)* & (1D0-PARP(141)**2)/4D0/XW/XW1/24D0/PARP(138)**2*SHR**3+ & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARP(137)**2* & SHR**3*XW/XW1 IF(KFLR.GT.0) THEN WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2) ELSE WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2) ENDIF ELSEIF(I.EQ.4) THEN C...rho_tc+ -> pi_tc+ + pi_tc0. WDTP(I)=FAC*(1D0-PARP(141)**2)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 IF(KFLR.GT.0) THEN WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2) ELSE WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2) ENDIF ELSEIF(I.EQ.5) THEN C...rho_tc+ -> pi_tc+ + gamma WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (2D0*PARP(143)-1D0)**2*(1D0-PARP(141)**2)/24D0/PARP(137)**2* & SHR**3 IF(KFLR.GT.0) THEN WID2=WIDS(PYCOMP(KTECHN+211),2) ELSE WID2=WIDS(PYCOMP(KTECHN+211),3) ENDIF ELSEIF(I.EQ.6) THEN C...rho_tc+ -> W+ + pi_tc0' WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (1D0-PARP(139)**2)/4D0/XW/24D0/PARP(137)**2*SHR**3 IF(KFLR.GT.0) THEN WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2) ELSE WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2) ENDIF ELSE C...rho_tc+ -> f + fbar'. IA=I-6 WID2=1D0 IF(IA.LE.16) THEN FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1) IF(KFLR.GT.0) THEN IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2) IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2) IF(IA.GE.13) WID2=WID2*WIDS(7,3) ELSE IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3) IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3) IF(IA.GE.13) WID2=WID2*WIDS(7,2) ENDIF ELSE FCOF=1D0 IF(KFLR.GT.0) THEN IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2) ELSE IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3) ENDIF ENDIF WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 380 CONTINUE ELSEIF(KFLA.EQ.KTECHN+223) THEN C...Techni-omega: ALPRHT=2.91D0*(3D0/PARP(144)) FAC=(ALPRHT/12D0)*SHR FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*PARP(143)-1D0)**2 SQMZ=PMAS(23,1)**2 SHP=SH CALL PYWIDX(23,SHP,WDTPP,WDTEP) GMMZ=SHR*WDTPP(0) BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) DO 390 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 390 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390 WID2=1D0 IF(I.EQ.1) THEN C...omega_tc0 -> gamma + pi_tc0. WDTP(I)=AEM/24D0/PARP(137)**2*(1D0-PARP(141)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3 WID2=WIDS(PYCOMP(KTECHN+111),2) ELSEIF(I.EQ.2) THEN C...omega_tc0 -> Z0 + pi_tc0 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (1D0-PARP(141)**2)/24D0/PARP(137)**2*(1D0-2D0*XW)**2/4D0/ & XW/XW1*SHR**3 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2) ELSEIF(I.EQ.3) THEN C...omega_tc0 -> gamma + pi_tc0' WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (2D0*PARP(143)-1D0)**2*(1D0-PARP(139)**2)/24D0/PARP(137)**2* & SHR**3 WID2=WIDS(PYCOMP(KTECHN+221),2) ELSEIF(I.EQ.4) THEN C...omega_tc0 -> Z0 + pi_tc0' WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (2D0*PARP(143)-1D0)**2*(1D0-PARP(139)**2)/24D0/PARP(137)**2* & XW/XW1*SHR**3 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2) ELSEIF(I.EQ.5) THEN C...omega_tc0 -> W+ + pi_tc- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(137)**2*SHR**3+ & FAC*PARP(141)**2*(1D0-PARP(141)**2)*PARP(140)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3) ELSEIF(I.EQ.6) THEN C...omega_tc0 -> pi_tc+ + W- WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* & (1D0-PARP(141)**2)/4D0/XW/24D0/PARP(137)**2*SHR**3+ & FAC*PARP(141)**2*(1D0-PARP(141)**2)*PARP(140)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2) ELSEIF(I.EQ.7) THEN C...omega_tc0 -> W+ + W-. WDTP(I)=FAC*PARP(141)**4*PARP(140)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=WIDS(24,1) ELSEIF(I.EQ.8) THEN C...omega_tc0 -> pi_tc+ + pi_tc-. WDTP(I)=FAC*(1D0-PARP(141)**2)**2*PARP(140)**2* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 WID2=WIDS(PYCOMP(KTECHN+211),1) ELSE C...omega_tc0 -> f + fbar. WID2=1D0 IF(I.LE.14) THEN IA=I-8 FCOF=3D0*RADC IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1) ELSE IA=I-6 FCOF=1D0 IF(IA.GE.17) WID2=WIDS(IA,1) ENDIF EI=KCHG(IA,1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV VALI=0.5D0*(VI+AI) VARI=0.5D0*(VI-AI) WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)* & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+ & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*( & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2)) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 390 CONTINUE C.....V8 -> quark anti-quark ELSEIF(KFLA.EQ.KTECHN+100021) THEN FAC=AS/6D0*SHR TANT3=ABS(PARP(155)) IF(PARP(155).GT.0) THEN IMDL=1 ELSE IMDL=2 ENDIF DO 400 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 400 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1) RM1=PM1**2/SH IF(RM1.GT.0.25D0) GOTO 400 WID2=1D0 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN FMIX=1D0/TANT3**2 ELSE FMIX=TANT3**2 ENDIF WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX IF(I.EQ.6) WID2=WIDS(6,1) WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 400 CONTINUE ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN FAC=(1D0/(4D0*PARU(1)*PARP(142)**2))*SHR CLEBF=0D0 DO 410 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 410 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410 WID2=1D0 C...pi_tc -> g + g IF(I.EQ.7) THEN IF(KFLA.EQ.KTECHN+100111) THEN CLEBG=4D0/3D0 ELSE CLEBG=5D0/3D0 ENDIF FACP=(AS/(8D0*PARU(1))*PARP(144)/PARP(142))**2 & /(2D0*PARU(1))*SH*SHR*CLEBG WDTP(I)=FACP ELSE C...pi_tc -> f + fbar. IF(I.EQ.6) WID2=WIDS(6,1) FCOF=1D0 IKA=IABS(KFDP(IDC,1)) IF(IKA.LT.10) FCOF=3D0*RADC HM1=PYMRUN(KFDP(IDC,1),SH) WDTP(I)=FAC*FCOF*HM1**2*CLEBF* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 410 CONTINUE ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN FAC=AS/6D0*SHR ALPRHT=2.91D0*(3D0/PARP(144)) TANT3=ABS(PARP(155)) SIN2T=2D0*TANT3/(TANT3**2+1D0) SINT3=TANT3/SQRT(TANT3**2+1D0) CSXPP=1D0/SQRT(2D0) RM82=PARP(156)**2 X12=(1D0/SQRT(2D0)*1D0/SQRT(2D0)+ & 1D0/SQRT(2D0)*1D0/SQRT(2D0))/SQRT(2D0) X21=1D-6 X11=(.25D0*((1D0/SQRT(2D0))**2+(1D0/SQRT(2D0))**2+2D0)- & SINT3**2)*2D0 X22=(.25D0*((1D0/SQRT(2D0))**2+(1D0/SQRT(2D0))**2)- & SINT3**2)*2D0 IF(PARP(155).GT.0) THEN IMDL=1 ELSE IMDL=2 ENDIF DO 420 I=1,MDCY(KC,3) IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR. & KFLA.EQ.KTECHN+300113)) GOTO 420 IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 420 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420 WID2=1D0 IF(I.LE.6) THEN IF(I.EQ.6) WID2=WIDS(6,1) XIG=1D0 IF(KFLA.EQ.KTECHN+200113) THEN XIG=0D0 XIJ=X12 ELSEIF(KFLA.EQ.KTECHN+300113) THEN XIG=0D0 XIJ=X21 ELSEIF(KFLA.EQ.KTECHN+100113) THEN XIJ=X11 ELSE XIJ=X22 ENDIF IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN FMIX=1D0/TANT3/SIN2T ELSE FMIX=-TANT3/SIN2T ENDIF XFAC=(XIG+FMIX*XIJ)**2 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC ELSEIF(I.EQ.7) THEN WDTP(I)=SHR*AS**2/(2D0*ALPRHT) ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN PSH=SHR*(1D0-RM1)/2D0 WDTP(I)=AS/9D0*PSH**3/RM82 IF(I.EQ.8) THEN WDTP(I)=2D0*WDTP(I)*CSXPP**2 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2) ELSE WDTP(I)=5D0*WDTP(I) WID2=WIDS(PYCOMP(KFDP(IDC,1)),2) ENDIF ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 420 CONTINUE ELSEIF(KFLA.EQ.KEXCIT+1) THEN C...d* excited quark. FAC=(SH/PARU(155)**2)*SHR DO 430 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 430 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430 WID2=1D0 IF(I.EQ.1) THEN C...d* -> g + d. WDTP(I)=FAC*AS*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(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 430 CONTINUE ELSEIF(KFLA.EQ.KEXCIT+2) THEN C...u* excited quark. FAC=(SH/PARU(155)**2)*SHR DO 440 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 440 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440 WID2=1D0 IF(I.EQ.1) THEN C...u* -> g + u. WDTP(I)=FAC*AS*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(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 440 CONTINUE ELSEIF(KFLA.EQ.KEXCIT+11) THEN C...e* excited lepton. FAC=(SH/PARU(155)**2)*SHR DO 450 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 450 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450 WID2=1D0 IF(I.EQ.1) THEN C...e* -> gamma + e. QF=-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(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 450 CONTINUE ELSEIF(KFLA.EQ.KEXCIT+12) THEN C...nu*_e excited neutrino. FAC=(SH/PARU(155)**2)*SHR DO 460 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 460 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460 WID2=1D0 IF(I.EQ.1) THEN C...nu*_e -> Z0 + nu*_e. QF=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(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 460 CONTINUE ELSEIF(KFLA.EQ.KDIMEN+39) THEN C...G* (graviton resonance): FAC=(PARP(50)**2/PARU(1))*SHR DO 470 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 470 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470 WID2=1D0 IF(I.LE.8) THEN C...G* -> q + qbar FCOF=3D0*RADC IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF* & PYHFTH(SH,SH*RM1,1D0) WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3* & (1D0+8D0*RM1/3D0)/320D0 IF(I.EQ.6) WID2=WIDS(6,1) IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1) ELSEIF(I.LE.16) THEN C...G* -> l+ + l-, nu + nubar FCOF=1D0 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3* & (1D0+8D0*RM1/3D0)/320D0 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1) ELSEIF(I.EQ.17) THEN C...G* -> g + g. WDTP(I)=FAC/20D0 ELSEIF(I.EQ.18) THEN C...G* -> gamma + gamma. WDTP(I)=FAC/160D0 ELSEIF(I.EQ.19) THEN C...G* -> Z0 + Z0. WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+ & 14D0*RM1/3D0+4D0*RM1**2)/160D0 WID2=WIDS(23,1) ELSEIF(I.EQ.20) THEN C...G* -> W+ + W-. WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+ & 14D0*RM1/3D0+4D0*RM1**2)/80D0 WID2=WIDS(24,1) ENDIF WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 470 CONTINUE ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos. PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1)) FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4 DO 480 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 480 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1) PM2=PMAS(PYCOMP(KFDP(IDC,2)),1) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1) IF(PM1+PM2+PM3.GE.SHR) GOTO 480 WID2=1D0 IF(I.LE.9) THEN C...nu_lR -> l- qbar q' FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1) IF(MOD(I,3).EQ.0) WID2=WIDS(6,2) ELSEIF(I.LE.18) THEN C...nu_lR -> l+ q qbar' FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1) IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3) ELSE C...nu_lR -> l- l'+ nu_lR' + charge conjugate. FCOF=1D0 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2) ENDIF X=(PM1+PM2+PM3)/SHR FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X) Y=(SHR/PMWR)**2 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4 WDTP(I)=FAC*FCOF*FX*FY WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 480 CONTINUE ELSEIF(KFLA.EQ.9900023) THEN C...Z_R0: FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR DO 490 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 490 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490 WID2=1D0 SYMMET=1D0 IF(I.LE.6) THEN C...Z_R0 -> q + qbar EF=KCHG(I,1)/3D0 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW) VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW FCOF=3D0*RADC IF(I.EQ.6) WID2=WIDS(6,1) ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN C...Z_R0 -> l+ + l- AF=-(1D0-2D0*XW) VF=-1D0+4D0*XW FCOF=1D0 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN C...Z0 -> nu_L + nu_Lbar, assumed Majorana. AF=-2D0*XW VF=0D0 FCOF=1D0 SYMMET=0.5D0 ELSEIF(I.LE.15) THEN C...Z0 -> nu_R + nu_R, assumed Majorana. AF=2D0*XW1 VF=0D0 FCOF=1D0 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1) SYMMET=0.5D0 ENDIF WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))* & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 490 CONTINUE ELSEIF(KFLA.EQ.9900024) THEN C...W_R+/-: FAC=(AEM/(24D0*XW))*SHR DO 500 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 500 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500 WID2=1D0 IF(I.LE.9) THEN C...W_R+/- -> q + qbar' FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1) IF(KFLR.GT.0) THEN IF(MOD(I,3).EQ.0) WID2=WIDS(6,2) ELSE IF(MOD(I,3).EQ.0) WID2=WIDS(6,3) ENDIF ELSEIF(I.LE.12) THEN C...W_R+/- -> l+/- + nu_R FCOF=1D0 ENDIF WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 500 CONTINUE ELSEIF(KFLA.EQ.9900041) THEN C...H_L++/--: FAC=(1D0/(8D0*PARU(1)))*SHR DO 510 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 510 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510 WID2=1D0 IF(I.LE.6) THEN C...H_L++/-- -> l+/- + l'+/- FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+ & (IABS(KFDP(IDC,2))-9)/2)**2 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF ELSEIF(I.EQ.7) THEN C...H_L++/-- -> W_L+/- + W_L+/- FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2* & (3D0*RM1+0.25D0/RM1-1D0) WID2=WIDS(24,4+(1-KFLS)/2) ENDIF WDTP(I)=FAC*FCOF* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 510 CONTINUE ELSEIF(KFLA.EQ.9900042) THEN C...H_R++/--: FAC=(1D0/(8D0*PARU(1)))*SHR DO 520 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 520 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520 WID2=1D0 IF(I.LE.6) THEN C...H_R++/-- -> l+/- + l'+/- FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+ & (IABS(KFDP(IDC,2))-9)/2)**2 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF ELSEIF(I.EQ.7) THEN C...H_R++/-- -> W_R+/- + W_R+/- FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0) WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2) ENDIF WDTP(I)=FAC*FCOF* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) WDTP(I)=FUDGE*WDTP(I) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 520 CONTINUE ENDIF MINT(61)=0 MINT(62)=0 MINT(63)=0 RETURN END C*********************************************************************** C...PYOFSH C...Calculates partial width and differential cross-section maxima C...of channels/processes not allowed on mass-shell, and selects C...masses in such channels/processes. SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT2/,/PYINT5/ C...Local arrays. DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2), &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100), &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:300), &WDTE(0:300,0:5) C...Find if particles equal, maximum mass, matrix elements, etc. MINT(51)=0 ISUB=MINT(1) KFD(1)=IABS(KFD1) KFD(2)=IABS(KFD2) MEQL=0 IF(KFD(1).EQ.KFD(2)) MEQL=1 MLM=0 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0)) IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN NOFF=44 PMMX=PMMO ELSE NOFF=40 PMMX=VINT(1) IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1)) ENDIF MMED=0 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND. &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR. &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR. &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3 LOOP=1 C...Find where Breit-Wigners are required, else select discrete masses. 100 DO 110 I=1,2 KFCA=PYCOMP(KFD(I)) IF(KFCA.GT.0) THEN PMD(I)=PMAS(KFCA,1) PGD(I)=PMAS(KFCA,2) ELSE PMD(I)=0D0 PGD(I)=0D0 ENDIF IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN MBW(I)=0 PMG(I)=PMD(I) RMG(I)=(PMG(I)/PMMX)**2 ELSE MBW(I)=1 ENDIF 110 CONTINUE C...Find allowed mass range and Breit-Wigner parameters. DO 120 I=1,2 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN PML(I)=PARP(42) PMU(I)=PMMX-PARP(42) IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I)) IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN ILM=I IF(MLM.EQ.2) ILM=3-I PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42)) IF(MBW(3-I).EQ.0) THEN PMU(I)=PMMX-PMD(3-I) ELSE PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42)) ENDIF IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)= & MIN(PMU(I),CKIN(NOFF+2*ILM)) IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX) IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX) IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1 IF(MBW(I).EQ.1) THEN ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I))) ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I))) IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)* & PGD(I))) ENDIF ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN ILM=I IF(MLM.EQ.2) ILM=3-I PML(I)=MAX(CKIN(48+I),PARP(42)) PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42)) IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I)) IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX) IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX) IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1 IF(MBW(I).EQ.1) THEN ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I))) ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I))) IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)* & PGD(I))) ENDIF ENDIF 120 CONTINUE IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0)) &THEN CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses') MINT(51)=1 RETURN ENDIF C...Calculation of partial width of resonance. IF(MOFSH.EQ.1) THEN C..If only one integration, pick that to be the inner. IF(MBW(1).EQ.0) THEN PM2=PMD(1) PMD(1)=PMD(2) PGD(1)=PGD(2) PML(1)=PML(2) PMU(1)=PMU(2) ELSEIF(MBW(2).EQ.0) THEN PM2=PMD(2) ENDIF C...Start outer loop of integration. IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2))) ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2))) NPT2=1 XPT2(1)=1D0 INX2(1)=0 FMAX2=0D0 ENDIF 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2)) PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S)))) ENDIF RM2=(PM2/PMMX)**2 C...Start inner loop of integration. PML1=PML(1) PMU1=MIN(PMU(1),PMMX-PM2) IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2) ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1))) ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1))) IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN FUNC2=0D0 GOTO 180 ENDIF NPT1=1 XPT1(1)=1D0 INX1(1)=0 FMAX1=0D0 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1)) PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S)))) RM1=(PM1/PMMX)**2 C...Evaluate function value - inner loop. FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2) IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+ & RM2**2+10D0*RM1*RM2) IF(FUNC1.GT.FMAX1) FMAX1=FUNC1 FPT1(NPT1)=FUNC1 C...Go to next position in inner loop. IF(NPT1.EQ.1) THEN NPT1=NPT1+1 XPT1(NPT1)=0D0 INX1(NPT1)=1 GOTO 140 ELSEIF(NPT1.LE.8) THEN NPT1=NPT1+1 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1 ISH1=ISH1+1 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1))) INX1(NPT1)=INX1(ISH1) INX1(ISH1)=NPT1 GOTO 140 ELSEIF(NPT1.LT.100) THEN ISN1=ISH1 150 ISH1=ISH1+1 IF(ISH1.GT.NPT1) ISH1=2 IF(ISH1.EQ.ISN1) GOTO 160 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1))) IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150 NPT1=NPT1+1 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1))) INX1(NPT1)=INX1(ISH1) INX1(ISH1)=NPT1 GOTO 140 ENDIF C...Calculate integral over inner loop. 160 FSUM1=0D0 DO 170 IPT1=2,NPT1 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))* & (XPT1(INX1(IPT1))-XPT1(IPT1)) 170 CONTINUE FUNC2=FSUM1*(ATU1-ATL1)/PARU(1) 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN IF(FUNC2.GT.FMAX2) FMAX2=FUNC2 FPT2(NPT2)=FUNC2 C...Go to next position in outer loop. IF(NPT2.EQ.1) THEN NPT2=NPT2+1 XPT2(NPT2)=0D0 INX2(NPT2)=1 GOTO 130 ELSEIF(NPT2.LE.8) THEN NPT2=NPT2+1 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1 ISH2=ISH2+1 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2))) INX2(NPT2)=INX2(ISH2) INX2(ISH2)=NPT2 GOTO 130 ELSEIF(NPT2.LT.100) THEN ISN2=ISH2 190 ISH2=ISH2+1 IF(ISH2.GT.NPT2) ISH2=2 IF(ISH2.EQ.ISN2) GOTO 200 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2))) IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190 NPT2=NPT2+1 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2))) INX2(NPT2)=INX2(ISH2) INX2(ISH2)=NPT2 GOTO 130 ENDIF C...Calculate integral over outer loop. 200 FSUM2=0D0 DO 210 IPT2=2,NPT2 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))* & (XPT2(INX2(IPT2))-XPT2(IPT2)) 210 CONTINUE FSUM2=FSUM2*(ATU2-ATL2)/PARU(1) IF(MEQL.EQ.1) FSUM2=2D0*FSUM2 ELSE FSUM2=FUNC2 ENDIF C...Save result; second integration for user-selected mass range. IF(LOOP.EQ.1) WIDW=FSUM2 WID2=FSUM2 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47) & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN LOOP=2 GOTO 100 ENDIF RET1=WIDW RET2=WID2/WIDW C...Select two decay product masses of a resonance. ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN 220 DO 230 I=1,2 IF(MBW(I).EQ.0) GOTO 230 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)* & (ATU(I)-ATL(I))) PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW)))) RMG(I)=(PMG(I)/PMMX)**2 230 CONTINUE IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR. & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220 C...Weight with matrix element (if none known, use beta factor). FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2))) IF(MMED.EQ.1) THEN WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2)) ELSEIF(MMED.EQ.2) THEN WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+ & RMG(2)**2+10D0*RMG(1)*RMG(2)) ELSEIF(MMED.EQ.3) THEN WTBE=FLAM*(RMG(1)+FLAM**2/12D0) ELSE WTBE=FLAM ENDIF IF(WTBE.LT.PYR(0)) GOTO 220 RET1=PMG(1) RET2=PMG(2) C...Find suitable set of masses for initialization of 2 -> 2 processes. ELSEIF(MOFSH.EQ.3) THEN IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1))) PMG(2)=PMD(2) ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN PMG(1)=PMD(1) PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2))) ELSE IDIV=-1 240 IDIV=IDIV+1 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1))) PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2))) IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240 ENDIF RET1=PMG(1) RET2=PMG(2) C...Evaluate importance of excluded tails of Breit-Wigners. IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2) & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2 IF(MEQL.LE.1) THEN VINT(80)=1D0 DO 250 I=1,2 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/ & PARU(1) 250 CONTINUE ELSE VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))* & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2))) ENDIF IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND. & MSTP(43).NE.2) VINT(80)=2D0*VINT(80) IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80) IF(MEQL.GE.1) VINT(80)=2D0*VINT(80) C...Pick one particle to be the lighter (if improves efficiency). ELSEIF(MOFSH.EQ.4) THEN IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2) & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0)) C...Select two masses according to Breit-Wigner + flat in s + 1/s. DO 270 I=1,2 IF(MBW(I).EQ.0) GOTO 270 PMV=PMU(I) IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I) ATV=ATU(I) IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I) RBR=PYR(0) IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR. & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR IF(RBR.LT.0.8D0) THEN PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I))) PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR)))) ELSEIF(RBR.LT.0.9D0) THEN PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2))) ELSEIF(RBR.LT.1.5D0) THEN PMG(I)=PML(I)*(PMV/PML(I))**PYR(0) ELSE PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)* & (PMV**2-PML(I)**2)))) ENDIF 270 CONTINUE IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR. & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN IF(MINT(48).EQ.1) THEN NGEN(0,1)=NGEN(0,1)+1 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1 GOTO 260 ELSE MINT(51)=1 RETURN ENDIF ENDIF RET1=PMG(1) RET2=PMG(2) C...Give weight for selected mass distribution. VINT(80)=1D0 DO 280 I=1,2 IF(MBW(I).EQ.0) GOTO 280 PMV=PMU(I) IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I) ATV=ATU(I) IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I) F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+ & (PMD(I)*PGD(I))**2)/PARU(1) F1=1D0 F2=1D0/PMG(I)**2 F3=1D0/PMG(I)**4 FI0=(ATV-ATL(I))/PARU(1) FI1=PMV**2-PML(I)**2 FI2=2D0*LOG(PMV/PML(I)) FI3=1D0/PML(I)**2-1D0/PMV**2 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR. & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+ & 5D0*F3/FI3)) ELSE VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2)) ENDIF VINT(80)=VINT(80)*FI0 280 CONTINUE IF(MEQL.GE.1) VINT(80)=2D0*VINT(80) ENDIF RETURN END C*********************************************************************** C...PYRECO C...Handles the possibility of colour reconnection in W+W- events, C...Based on the main scenarios of the Sjostrand and Khoze study: C...I, II, II', intermediate and instantaneous; plus one model C...along the lines of the Gustafson and Hakkinen: GH. C...Note: also handles Z0 Z0 and W-W+ events, but notation below C...is as if first resonance is W+ and second W-. SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter value; number of points in MC integration. PARAMETER (NPT=100) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ C...Local arrays. DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3), &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3), &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3), &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20), &TMC(20),IJOIN(100) C...Functions to give four-product and to do determinants. FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+ &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+ &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3) C...Only allow fraction of recoupling for GH, intermediate and C...instantaneous. IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN IF(PYR(0).GT.PARP(120)) RETURN ENDIF ISUB=MINT(1) C...Common part for scenarios I, II, II', and GH. IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR. &MSTP(115).EQ.5) THEN C...Read out frequently-used parameters. PI=PARU(1) HBAR=PARU(3) PMW=PMAS(24,1) IF(ISUB.EQ.22) PMW=PMAS(23,1) PGW=PMAS(24,2) IF(ISUB.EQ.22) PGW=PMAS(23,2) TFRAG=PARP(115) RHAD=PARP(116) FACT=PARP(117) BLOWR=PARP(118) BLOWT=PARP(119) C...Find range of decay products of the W's. C...Background: the W's are stored in IW1 and IW2. C...Their direct decay products in NSD1+1 through NSD1+4. C...Products after shower (if any) in NSD1+5 through NAFT1 C...for first W and in NAFT1+1 through N for the second. IF(NAFT1.GT.NSD1+4) THEN NBEG(1)=NSD1+5 NEND(1)=NAFT1 ELSE NBEG(1)=NSD1+1 NEND(1)=NSD1+2 ENDIF IF(N.GT.NAFT1) THEN NBEG(2)=NAFT1+1 NEND(2)=N ELSE NBEG(2)=NSD1+3 NEND(2)=NSD1+4 ENDIF C...Rearrange parton shower products along strings. NOLD=N CALL PYPREP(NSD1+1) C...Find partons pointing back to W+ and W-; store them with quark C...end of string first. NNP=0 NNM=0 ISGP=0 ISGM=0 DO 120 I=NOLD+1,N IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120 IF(IABS(K(I,2)).GE.22) GOTO 120 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2)) NNP=NNP+1 IF(ISGP.EQ.1) THEN INP(NNP)=I ELSE DO 100 I1=NNP,2,-1 INP(I1)=INP(I1-1) 100 CONTINUE INP(1)=I ENDIF IF(K(I,1).EQ.1) ISGP=0 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2)) NNM=NNM+1 IF(ISGM.EQ.1) THEN INM(NNM)=I ELSE DO 110 I1=NNM,2,-1 INM(I1)=INM(I1-1) 110 CONTINUE INM(1)=I ENDIF IF(K(I,1).EQ.1) ISGM=0 ENDIF 120 CONTINUE C...Boost to W+W- rest frame (not strictly needed). DO 130 J=1,3 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4)) 130 CONTINUE CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3)) CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3)) CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3)) C...Select decay vertices of W+ and W-. TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/ & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2) TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/ & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2) GTMAX=MAX(TP,TM) DO 140 J=1,3 XP(J)=TP*P(IW1,J)/P(IW1,4) XM(J)=TM*P(IW2,J)/P(IW2,4) 140 CONTINUE C...Begin scenario I specifics. IF(MSTP(115).EQ.1) THEN C...Reconstruct velocity and direction of W+ string pieces. DO 170 IIP=1,NNP-1 IF(K(INP(IIP),2).LT.0) GOTO 170 I1=INP(IIP) I2=INP(IIP+1) P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2) P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2) DO 150 J=1,3 V1(J)=P(I1,J)/P1A V2(J)=P(I2,J)/P2A BETP(IIP,J)=0.5D0*(V1(J)+V2(J)) DIRP(IIP,J)=V1(J)-V2(J) 150 CONTINUE BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2- & BETP(IIP,3)**2) DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2) DO 160 J=1,3 DIRP(IIP,J)=DIRP(IIP,J)/DIRL 160 CONTINUE 170 CONTINUE C...Reconstruct velocity and direction of W- string pieces. DO 200 IIM=1,NNM-1 IF(K(INM(IIM),2).LT.0) GOTO 200 I1=INM(IIM) I2=INM(IIM+1) P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2) P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2) DO 180 J=1,3 V1(J)=P(I1,J)/P1A V2(J)=P(I2,J)/P2A BETM(IIM,J)=0.5D0*(V1(J)+V2(J)) DIRM(IIM,J)=V1(J)-V2(J) 180 CONTINUE BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2- & BETM(IIM,3)**2) DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2) DO 190 J=1,3 DIRM(IIM,J)=DIRM(IIM,J)/DIRL 190 CONTINUE 200 CONTINUE C...Loop over number of space-time points. NACC=0 SUM=0D0 DO 250 IPT=1,NPT C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively). R=SQRT(-LOG(PYR(0))) PHI=2D0*PI*PYR(0) X=BLOWR*RHAD*R*COS(PHI) Y=BLOWR*RHAD*R*SIN(PHI) R=SQRT(-LOG(PYR(0))) PHI=2D0*PI*PYR(0) Z=BLOWR*RHAD*R*COS(PHI) T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI)) C...Reject impossible points. Weight for sample distribution. IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)* & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2) C...Loop over W+ string pieces and find one with largest weight. IMAXP=0 WTMAXP=1D-10 XD(1)=X-XP(1) XD(2)=Y-XP(2) XD(3)=Z-XP(3) XD(4)=T-TP DO 220 IIP=1,NNP-1 IF(K(INP(IIP),2).LT.0) GOTO 220 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3) BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4)) DO 210 J=1,3 XB(J)=XD(J)+BEDG*BETP(IIP,J) 210 CONTINUE XB(4)=BETP(IIP,4)*(XD(4)-BED) SR2=XB(1)**2+XB(2)**2+XB(3)**2 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+ & DIRP(IIP,3)*XB(3))**2 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/ & TFRAG**2) IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0 IF(WTP.GT.WTMAXP) THEN IMAXP=IIP WTMAXP=WTP ENDIF 220 CONTINUE C...Loop over W- string pieces and find one with largest weight. IMAXM=0 WTMAXM=1D-10 XD(1)=X-XM(1) XD(2)=Y-XM(2) XD(3)=Z-XM(3) XD(4)=T-TM DO 240 IIM=1,NNM-1 IF(K(INM(IIM),2).LT.0) GOTO 240 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3) BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4)) DO 230 J=1,3 XB(J)=XD(J)+BEDG*BETM(IIM,J) 230 CONTINUE XB(4)=BETM(IIM,4)*(XD(4)-BED) SR2=XB(1)**2+XB(2)**2+XB(3)**2 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+ & DIRM(IIM,3)*XB(3))**2 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/ & TFRAG**2) IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0 IF(WTM.GT.WTMAXM) THEN IMAXM=IIM WTMAXM=WTM ENDIF 240 CONTINUE C...Result of integration. WT=0D0 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN WT=WTMAXP*WTMAXM/WTSMP SUM=SUM+WT NACC=NACC+1 IAP(NACC)=IMAXP IAM(NACC)=IMAXM WTA(NACC)=WT ENDIF 250 CONTINUE RES=BLOWR**3*BLOWT*SUM/NPT C...Decide whether to reconnect and, if so, where. IACC=0 PREC=1D0-EXP(-FACT*RES) IF(PREC.GT.PYR(0)) THEN RSUM=PYR(0)*SUM DO 260 IA=1,NACC IACC=IA RSUM=RSUM-WTA(IA) IF(RSUM.LE.0D0) GOTO 270 260 CONTINUE 270 IIP=IAP(IACC) IIM=IAM(IACC) ENDIF C...Begin scenario II and II' specifics. ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN C...Loop through all string pieces, one from W+ and one from W-. NCROSS=0 TC(0)=0D0 DO 340 IIP=1,NNP-1 IF(K(INP(IIP),2).LT.0) GOTO 340 I1P=INP(IIP) I2P=INP(IIP+1) DO 330 IIM=1,NNM-1 IF(K(INM(IIM),2).LT.0) GOTO 330 I1M=INM(IIM) I2M=INM(IIM+1) C...Find endpoint velocity vectors. DO 280 J=1,3 V1P(J)=P(I1P,J)/P(I1P,4) V2P(J)=P(I2P,J)/P(I2P,4) V1M(J)=P(I1M,J)/P(I1M,4) V2M(J)=P(I2M,J)/P(I2M,4) 280 CONTINUE C...Define q matrix and find t. DO 290 J=1,3 Q(1,J)=V2P(J)-V1P(J) Q(2,J)=-(V2M(J)-V1M(J)) Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J) Q(4,J)=V1P(J)-V1M(J) 290 CONTINUE T=-DETER(1,2,3)/DETER(1,2,4) C...Find alpha and beta; i.e. coordinates of crossing point. S11=Q(1,1)*(T-TP) S12=Q(2,1)*(T-TM) S13=Q(3,1)+Q(4,1)*T S21=Q(1,2)*(T-TP) S22=Q(2,2)*(T-TM) S23=Q(3,2)+Q(4,2)*T DEN=S11*S22-S12*S21 ALP=(S12*S23-S22*S13)/DEN BET=(S21*S13-S11*S23)/DEN C...Check if solution acceptable. IANSW=1 IF(T.LT.GTMAX) IANSW=0 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0 C...Find point of crossing and check that not inconsistent. DO 300 J=1,3 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP) XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM) 300 CONTINUE D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+ & (XPP(3)-XMM(3))**2 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1 C...Find string eigentimes at crossing. IF(IANSW.EQ.1) THEN TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2- & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2)) TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2- & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2)) ELSE TAUP=0D0 TAUM=0D0 ENDIF C...Order crossings by time. End loop over crossings. IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN NCROSS=NCROSS+1 DO 310 I1=NCROSS,1,-1 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN IPC(I1)=IIP IMC(I1)=IIM TC(I1)=T TPC(I1)=TAUP TMC(I1)=TAUM GOTO 320 ELSE IPC(I1)=IPC(I1-1) IMC(I1)=IMC(I1-1) TC(I1)=TC(I1-1) TPC(I1)=TPC(I1-1) TMC(I1)=TMC(I1-1) ENDIF 310 CONTINUE 320 CONTINUE ENDIF 330 CONTINUE 340 CONTINUE C...Loop over crossings; find first (if any) acceptable one. IACC=0 IF(NCROSS.GE.1) THEN DO 350 IC=1,NCROSS PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2) IF(PNFRAG.GT.PYR(0)) THEN C...Scenario II: only compare with fragmentation time. IF(MSTP(115).EQ.2) THEN IACC=IC IIP=IPC(IACC) IIM=IMC(IACC) GOTO 360 C...Scenario II': also require that string length decreases. ELSE IIP=IPC(IC) IIM=IMC(IC) I1P=INP(IIP) I2P=INP(IIP+1) I1M=INM(IIM) I2M=INM(IIM+1) ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M) ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P) IF(ELNEW.LT.ELOLD) THEN IACC=IC IIP=IPC(IACC) IIM=IMC(IACC) GOTO 360 ENDIF ENDIF ENDIF 350 CONTINUE 360 CONTINUE ENDIF C...Begin scenario GH specifics. ELSEIF(MSTP(115).EQ.5) THEN C...Loop through all string pieces, one from W+ and one from W-. IACC=0 ELMIN=1D0 DO 380 IIP=1,NNP-1 IF(K(INP(IIP),2).LT.0) GOTO 380 I1P=INP(IIP) I2P=INP(IIP+1) DO 370 IIM=1,NNM-1 IF(K(INM(IIM),2).LT.0) GOTO 370 I1M=INM(IIM) I2M=INM(IIM+1) C...Look for largest decrease of (exponent of) Lambda measure. ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M) ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P) ELDIF=ELNEW/MAX(1D-10,ELOLD) IF(ELDIF.LT.ELMIN) THEN IACC=IIP+IIM ELMIN=ELDIF IPC(1)=IIP IMC(1)=IIM ENDIF 370 CONTINUE 380 CONTINUE IIP=IPC(1) IIM=IMC(1) ENDIF C...Common for scenarios I, II, II' and GH: reconnect strings. IF(IACC.NE.0) THEN MINT(32)=1 NJOIN=0 DO 390 IS=1,NNP+NNM NJOIN=NJOIN+1 IF(IS.LE.IIP) THEN I=INP(IS) ELSEIF(IS.LE.IIP+NNM-IIM) THEN I=INM(IS-IIP+IIM) ELSEIF(IS.LE.IIP+NNM) THEN I=INM(IS-IIP-NNM+IIM) ELSE I=INP(IS-NNM) ENDIF IJOIN(NJOIN)=I IF(K(I,2).LT.0) THEN CALL PYJOIN(NJOIN,IJOIN) NJOIN=0 ENDIF 390 CONTINUE C...Restore original event record if no reconnection. ELSE DO 400 I=NSD1+1,NOLD IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN K(I,4)=MOD(K(I,4),MSTU(5)**2) K(I,5)=MOD(K(I,5),MSTU(5)**2) ENDIF 400 CONTINUE DO 410 I=NOLD+1,N K(K(I,3),1)=3 410 CONTINUE N=NOLD ENDIF C...Boost back system. CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3)) CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3)) IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0, & BEWW(1),BEWW(2),BEWW(3)) C...Common part for intermediate and instantaneous scenarios. ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN MINT(32)=1 C...Remove old shower products and reset showering ones. N=NSD1+4 DO 420 I=NSD1+1,NSD1+4 K(I,1)=3 K(I,4)=MOD(K(I,4),MSTU(5)**2) K(I,5)=MOD(K(I,5),MSTU(5)**2) 420 CONTINUE C...Identify quark-antiquark pairs. IQ1=NSD1+1 IQ2=NSD1+2 IQ3=NSD1+3 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4 IQ4=2*NSD1+7-IQ3 C...Reconnect strings. IJOIN(1)=IQ1 IJOIN(2)=IQ4 CALL PYJOIN(2,IJOIN) IJOIN(1)=IQ3 IJOIN(2)=IQ2 CALL PYJOIN(2,IJOIN) C...Do new parton showers in intermediate scenario. IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN MSTJ50=MSTJ(50) MSTJ(50)=0 CALL PYSHOW(IQ1,IQ2,P(IW1,5)) CALL PYSHOW(IQ3,IQ4,P(IW2,5)) MSTJ(50)=MSTJ50 C...Do new parton showers in instantaneous scenario. ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2- & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2 PPM=SQRT(MAX(0D0,PPM2)) CALL PYSHOW(IQ1,IQ4,PPM) PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2- & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2 PPM=SQRT(MAX(0D0,PPM2)) CALL PYSHOW(IQ3,IQ2,PPM) ENDIF ENDIF RETURN END C*********************************************************************** C...PYKLIM C...Checks generated variables against pre-set kinematical limits; C...also calculates limits on variables used in generation. SUBROUTINE PYKLIM(ILIM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/, &/PYINT1/,/PYINT2/ C...Common kinematical expressions. MINT(51)=0 ISUB=MINT(1) ISTSB=ISET(ISUB) IF(ISUB.EQ.96) GOTO 100 SQM3=VINT(63) SQM4=VINT(64) IF(ILIM.NE.0) THEN IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN CKIN09=MAX(CKIN(9),CKIN(13)) CKIN10=MIN(CKIN(10),CKIN(14)) CKIN11=MAX(CKIN(11),CKIN(15)) CKIN12=MIN(CKIN(12),CKIN(16)) ELSE CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13))) CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14))) CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15))) CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16))) ENDIF ENDIF IF(ILIM.NE.1) THEN TAU=VINT(21) RM3=SQM3/(TAU*VINT(2)) RM4=SQM4/(TAU*VINT(2)) BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) ENDIF PTHMIN=CKIN(3) IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3) &PTHMIN=MAX(CKIN(3),CKIN(5)) IF(ILIM.EQ.0) THEN C...Check generated values of tau, y*, cos(theta-hat), and tau' against C...pre-set kinematical limits. YST=VINT(22) CTH=VINT(23) TAUP=VINT(26) TAUE=TAU IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP X1=SQRT(TAUE)*EXP(YST) X2=SQRT(TAUE)*EXP(-YST) XF=X1-X2 IF(MINT(47).NE.1) THEN IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1 ENDIF IF(MINT(45).NE.1) THEN IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1 ENDIF IF(MINT(46).NE.1) THEN IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1 ENDIF IF(MINT(45).EQ.2) THEN IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1 ENDIF IF(MINT(46).EQ.2) THEN IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1 ENDIF IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2)) EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/ & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH))) EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/ & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH))) Y3=YST+0.5D0*LOG(EXPY3) Y4=YST+0.5D0*LOG(EXPY4) YLARGE=MAX(Y3,Y4) YSMALL=MIN(Y3,Y4) ETALAR=20D0 ETASMA=-20D0 STH=SQRT(MAX(0D0,1D0-CTH**2)) EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)* & CTH)**2-4D0*RM3)) EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)* & CTH)**2-4D0*RM4)) IF(STH.GE.1D-10) THEN EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/ & (BE34*STH) EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/ & (BE34*STH) ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3))) ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4))) ETALAR=MAX(ETA3,ETA4) ETASMA=MIN(ETA3,ETA4) ENDIF CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4)) CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4)) SH=TAU*VINT(2) RPTS=4D0*VINT(71)**2/SH BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS)) RM34=MAX(1D-20,2D0*RM3*RM4) IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0) & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2))) RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L) THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH) UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH) IF(PTH.LT.PTHMIN) MINT(51)=1 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1 IF(THA.LT.CKIN(35)) MINT(51)=1 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1 IF(UHA.LT.CKIN(37)) MINT(51)=1 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1 ENDIF IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1 ENDIF C...Additional cuts on W2 (approximately) in DIS. IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN XBJ=X2 IF(IABS(MINT(12)).LT.20) XBJ=X1 Q2BJ=THA W2BJ=Q2BJ*(1D0-XBJ)/XBJ IF(W2BJ.LT.CKIN(39)) MINT(51)=1 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1 ENDIF ELSEIF(ILIM.EQ.1) THEN C...Calculate limits on tau C...0) due to definition TAUMN0=0D0 TAUMX0=1D0 C...1) due to limits on subsystem mass TAUMN1=CKIN(1)**2/VINT(2) TAUMX1=1D0 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2) C...2) due to limits on pT-hat (and non-overlapping rapidity intervals) TM3=SQRT(SQM3+PTHMIN**2) TM4=SQRT(SQM4+PTHMIN**2) YDCOSH=1D0 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12) TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2) TAUMX2=1D0 C...3) due to limits on pT-hat and cos(theta-hat) CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2) CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2) TAUMN3=0D0 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3= & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+ & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2) TAUMX3=1D0 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3= & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+ & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2) C...4) due to limits on x1 and x2 TAUMN4=CKIN(21)*CKIN(23) TAUMX4=CKIN(22)*CKIN(24) C...5) due to limits on xF TAUMN5=0D0 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26)) C...6) due to limits on that and uhat TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2) TAUMX6=1D0 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6= & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2) C...Net effect of all separate limits. VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6) VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6) IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN VINT(11)=1D0-1D-9 VINT(31)=1D0+1D-9 ELSEIF(MINT(47).EQ.5) THEN VINT(31)=MIN(VINT(31),1D0-2D-10) ELSEIF(MINT(47).GE.6) THEN VINT(31)=MIN(VINT(31),1D0-1D-10) ENDIF IF(VINT(31).LE.VINT(11)) MINT(51)=1 ELSEIF(ILIM.EQ.2) THEN C...Calculate limits on y* TAUE=TAU IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26) TAURT=SQRT(TAUE) C...0) due to kinematics YSTMN0=LOG(TAURT) YSTMX0=-YSTMN0 C...1) due to explicit limits YSTMN1=CKIN(7) YSTMX1=CKIN(8) C...2) due to limits on x1 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT) YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT) C...3) due to limits on x2 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT) YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT) C...4) due to limits on xF YEPMN4=0.5D0*ABS(CKIN(25))/TAURT YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25)) YEPMX4=0.5D0*ABS(CKIN(26))/TAURT YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26)) C...5) due to simultaneous limits on y-large and y-small YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11) YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12) YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN))) YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX))) YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN) YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX) C...6) due to simultaneous limits on cos(theta-hat) and y-large or C... y-small CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2)))) RZMN=BE34*MAX(CKIN(27),-CTHLIM) RZMX=BE34*MIN(CKIN(28),CTHLIM) YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX) YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN) YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN) YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX) YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX)) YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN)) C...Net effect of all separate limits. VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6) VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6) IF(MINT(47).EQ.1) THEN VINT(12)=-1D-9 VINT(32)=1D-9 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN VINT(12)=(1D0-1D-9)*YSTMX0 VINT(32)=(1D0+1D-9)*YSTMX0 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN VINT(12)=-(1D0+1D-9)*YSTMX0 VINT(32)=-(1D0-1D-9)*YSTMX0 ELSEIF(MINT(47).EQ.5) THEN YSTEE=LOG((1D0-1D-10)/TAURT) VINT(12)=MAX(VINT(12),-YSTEE) VINT(32)=MIN(VINT(32),YSTEE) ENDIF IF(VINT(32).LE.VINT(12)) MINT(51)=1 ELSEIF(ILIM.EQ.3) THEN C...Calculate limits on cos(theta-hat) YST=VINT(22) C...0) due to definition CTNMN0=-1D0 CTNMX0=0D0 CTPMN0=0D0 CTPMX0=1D0 C...1) due to explicit limits CTNMN1=MIN(0D0,CKIN(27)) CTNMX1=MIN(0D0,CKIN(28)) CTPMN1=MAX(0D0,CKIN(27)) CTPMX1=MAX(0D0,CKIN(28)) C...2) due to limits on pT-hat CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2)))) CTPMX2=-CTNMN2 CTNMX2=0D0 CTPMN2=0D0 IF(CKIN(4).GE.0D0) THEN CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/ & (BE34**2*TAU*VINT(2)))) CTPMN2=-CTNMX2 ENDIF C...3) due to limits on y-large and y-small CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST), & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST))) CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST), & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST)) CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST), & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST)) CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST), & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST))) C...4) due to limits on that CTNMN4=-1D0 CTNMX4=0D0 CTPMN4=0D0 CTPMX4=1D0 SH=TAU*VINT(2) IF(CKIN(35).GT.0D0) THEN CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34 IF(CTLIM.GT.0D0) THEN CTPMX4=CTLIM ELSE CTPMX4=0D0 CTNMX4=CTLIM ENDIF ENDIF IF(CKIN(36).GT.0D0) THEN CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34 IF(CTLIM.LT.0D0) THEN CTNMN4=CTLIM ELSE CTNMN4=0D0 CTPMN4=CTLIM ENDIF ENDIF C...5) due to limits on uhat CTNMN5=-1D0 CTNMX5=0D0 CTPMN5=0D0 CTPMX5=1D0 IF(CKIN(37).GT.0D0) THEN CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34 IF(CTLIM.LT.0D0) THEN CTNMN5=CTLIM ELSE CTNMN5=0D0 CTPMN5=CTLIM ENDIF ENDIF IF(CKIN(38).GT.0D0) THEN CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34 IF(CTLIM.GT.0D0) THEN CTPMX5=CTLIM ELSE CTPMX5=0D0 CTNMX5=CTLIM ENDIF ENDIF C...Net effect of all separate limits. VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5) VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5) VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5) VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5) IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1 ELSEIF(ILIM.EQ.4) THEN C...Calculate limits on tau' C...0) due to kinematics TAPMN0=TAU IF(ISTSB.EQ.5.AND.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)=1D0-1D-9 VINT(36)=1D0+1D-9 ELSEIF(MINT(47).EQ.5) THEN VINT(36)=MIN(VINT(36),1D0-2D-10) ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN VINT(36)=MIN(VINT(36),1D0-1D-10) ENDIF IF(VINT(36).LE.VINT(16)) MINT(51)=1 ENDIF RETURN C...Special case for low-pT and multiple interactions: C...effective kinematical limits for tau, y*, cos(theta-hat). 100 IF(ILIM.EQ.0) THEN ELSEIF(ILIM.EQ.1) THEN IF(MSTP(82).LE.1) THEN VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/ & VINT(2) ELSE VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2) ENDIF VINT(31)=1D0 ELSEIF(ILIM.EQ.2) THEN VINT(12)=0.5D0*LOG(VINT(21)) VINT(32)=-VINT(12) ELSEIF(ILIM.EQ.3) THEN IF(MSTP(82).LE.1) THEN ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/ & (VINT(21)*VINT(2)) ELSE ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/ & (VINT(21)*VINT(2)) ENDIF VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF)) VINT(33)=0D0 VINT(14)=0D0 VINT(34)=-VINT(13) ENDIF RETURN END C********************************************************************* C...PYKMAP C...Maps a uniform distribution into a distribution of a kinematical C...variable according to one of the possibilities allowed. It is C...assumed that kinematical limits have been set by a PYKLIM call. SUBROUTINE PYKMAP(IVAR,MVAR,VVAR) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/ C...Convert VVAR to tau variable. ISUB=MINT(1) ISTSB=ISET(ISUB) IF(IVAR.EQ.1) THEN TAUMIN=VINT(11) TAUMAX=VINT(31) IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN TAURE=VINT(73) GAMRE=VINT(74) ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN TAURE=VINT(75) GAMRE=VINT(76) ENDIF IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN TAU=1D0 ELSEIF(MVAR.EQ.1) THEN TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR ELSEIF(MVAR.EQ.2) THEN TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR) ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5) THEN RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN) ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6) THEN AUPP=ATAN((TAUMAX-TAURE)/GAMRE) ALOW=ATAN((TAUMIN-TAURE)/GAMRE) TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR) ELSEIF(MINT(47).EQ.5) THEN AUPP=LOG(MAX(2D-10,1D0-TAUMAX)) ALOW=LOG(MAX(2D-10,1D0-TAUMIN)) TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP)) ELSE AUPP=LOG(MAX(1D-10,1D0-TAUMAX)) ALOW=LOG(MAX(1D-10,1D0-TAUMIN)) TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP)) ENDIF VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU)) C...Convert VVAR to y* variable. ELSEIF(IVAR.EQ.2) THEN YSTMIN=VINT(12) YSTMAX=VINT(32) TAUE=VINT(21) IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26) IF(MINT(47).EQ.1) THEN YST=0D0 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN YST=-0.5D0*LOG(TAUE) ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN YST=0.5D0*LOG(TAUE) ELSEIF(MVAR.EQ.1) THEN YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR) ELSEIF(MVAR.EQ.2) THEN YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR) ELSEIF(MVAR.EQ.3) THEN AUPP=ATAN(EXP(YSTMAX)) ALOW=ATAN(EXP(YSTMIN)) YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR)) ELSEIF(MVAR.EQ.4) THEN YST0=-0.5D0*LOG(TAUE) AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)) ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0)) YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW))) ELSE YST0=-0.5D0*LOG(TAUE) AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0)) ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)) YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0 ENDIF VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST)) C...Convert VVAR to cos(theta-hat) variable. ELSEIF(IVAR.EQ.3) THEN RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2) RSQM=1D0+RM34 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0) & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2))) CTNMIN=VINT(13) CTNMAX=VINT(33) CTPMIN=VINT(14) CTPMAX=VINT(34) IF(MVAR.EQ.1) THEN ANEG=CTNMAX-CTNMIN APOS=CTPMAX-CTPMIN IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN VCTN=VVAR*(ANEG+APOS)/ANEG CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN ELSE VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP ENDIF ELSEIF(MVAR.EQ.2) THEN RMNMIN=MAX(RM34,RSQM-CTNMIN) RMNMAX=MAX(RM34,RSQM-CTNMAX) RMPMIN=MAX(RM34,RSQM-CTPMIN) RMPMAX=MAX(RM34,RSQM-CTPMAX) ANEG=LOG(RMNMIN/RMNMAX) APOS=LOG(RMPMIN/RMPMAX) IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN VCTN=VVAR*(ANEG+APOS)/ANEG CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN ELSE VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP ENDIF ELSEIF(MVAR.EQ.3) THEN RMNMIN=MAX(RM34,RSQM+CTNMIN) RMNMAX=MAX(RM34,RSQM+CTNMAX) RMPMIN=MAX(RM34,RSQM+CTPMIN) RMPMAX=MAX(RM34,RSQM+CTPMAX) ANEG=LOG(RMNMAX/RMNMIN) APOS=LOG(RMPMAX/RMPMIN) IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN VCTN=VVAR*(ANEG+APOS)/ANEG CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM ELSE VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM ENDIF ELSEIF(MVAR.EQ.4) THEN RMNMIN=MAX(RM34,RSQM-CTNMIN) RMNMAX=MAX(RM34,RSQM-CTNMAX) RMPMIN=MAX(RM34,RSQM-CTPMIN) RMPMAX=MAX(RM34,RSQM-CTPMAX) ANEG=1D0/RMNMAX-1D0/RMNMIN APOS=1D0/RMPMAX-1D0/RMPMIN IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN VCTN=VVAR*(ANEG+APOS)/ANEG CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN) ELSE VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP) ENDIF ELSEIF(MVAR.EQ.5) THEN RMNMIN=MAX(RM34,RSQM+CTNMIN) RMNMAX=MAX(RM34,RSQM+CTNMAX) RMPMIN=MAX(RM34,RSQM+CTPMIN) RMPMAX=MAX(RM34,RSQM+CTPMAX) ANEG=1D0/RMNMIN-1D0/RMNMAX APOS=1D0/RMPMIN-1D0/RMPMAX IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN VCTN=VVAR*(ANEG+APOS)/ANEG CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM ELSE VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM ENDIF ENDIF IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH)) IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH)) VINT(23)=CTH C...Convert VVAR to tau' variable. ELSEIF(IVAR.EQ.4) THEN TAU=VINT(21) TAUPMN=VINT(16) TAUPMX=VINT(36) IF(MINT(47).EQ.1) THEN TAUP=1D0 ELSEIF(MVAR.EQ.1) THEN TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR ELSEIF(MVAR.EQ.2) THEN AUPP=(1D0-TAU/TAUPMX)**4 ALOW=(1D0-TAU/TAUPMN)**4 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0) ELSEIF(MINT(47).EQ.5) THEN AUPP=LOG(MAX(2D-10,1D0-TAUPMX)) ALOW=LOG(MAX(2D-10,1D0-TAUPMN)) TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP)) ELSE AUPP=LOG(MAX(1D-10,1D0-TAUPMX)) ALOW=LOG(MAX(1D-10,1D0-TAUPMN)) TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP)) ENDIF VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP)) C...Selection of extra variables needed in 2 -> 3 process: C...pT1, pT2, phi1, phi2, y3 for three outgoing particles. C...Since no options are available, the functions of PYKLIM C...and PYKMAP are joint for these choices. ELSEIF(IVAR.EQ.5) THEN C...Read out total energy and particle masses. MINT(51)=0 MPTPK=1 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352) & MPTPK=2 SHP=VINT(26)*VINT(2) SHPR=SQRT(SHP) PM1=VINT(201) PM2=VINT(206) PM3=SQRT(VINT(21))*VINT(1) IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN MINT(51)=1 RETURN ENDIF PMRS1=VINT(204)**2 PMRS2=VINT(209)**2 C...Specify coefficients of pT choice; upper and lower limits. IF(MPTPK.EQ.1) THEN HWT1=0.4D0 HWT2=0.4D0 ELSE HWT1=0.05D0 HWT2=0.05D0 ENDIF HWT3=1D0-HWT1-HWT2 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/ & (4D0*SHP) IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2) PTSMN1=CKIN(51)**2 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/ & (4D0*SHP) IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2) PTSMN2=CKIN(53)**2 C...Select transverse momenta according to C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2). HMX=PMRS1+PTSMX1 HMN=PMRS1+PTSMN1 IF(HMX.LT.1.0001D0*HMN) THEN MINT(51)=1 RETURN ENDIF HDE=PTSMX1-PTSMN1 RPT=PYR(0) IF(RPT.LT.HWT1) THEN PTS1=PTSMN1+PYR(0)*HDE ELSEIF(RPT.LT.HWT1+HWT2) THEN PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1) ELSE PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1) ENDIF WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+ & HWT3*HMN*HMX/(PMRS1+PTS1)**2) HMX=PMRS2+PTSMX2 HMN=PMRS2+PTSMN2 IF(HMX.LT.1.0001D0*HMN) THEN MINT(51)=1 RETURN ENDIF HDE=PTSMX2-PTSMN2 RPT=PYR(0) IF(RPT.LT.HWT1) THEN PTS2=PTSMN2+PYR(0)*HDE ELSEIF(RPT.LT.HWT1+HWT2) THEN PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2) ELSE PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2) ENDIF WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+ & HWT3*HMN*HMX/(PMRS2+PTS2)**2) C...Select azimuthal angles and check pT choice. PHI1=PARU(2)*PYR(0) PHI2=PARU(2)*PYR(0) PHIR=PHI2-PHI1 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR)) IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT. & CKIN(56)**2)) THEN MINT(51)=1 RETURN ENDIF C...Calculate transverse masses and check phase space not closed. PMS1=PM1**2+PTS1 PMS2=PM2**2+PTS2 PMS3=PM3**2+PTS3 PMT1=SQRT(PMS1) PMT2=SQRT(PMS2) PMT3=SQRT(PMS3) PM12=(PMT1+PMT2)**2 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN MINT(51)=1 RETURN ENDIF C...Select rapidity for particle 3 and check phase space not closed. Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2- & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3)) IF(Y3MAX.LT.1D-6) THEN MINT(51)=1 RETURN ENDIF Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX PZ3=PMT3*SINH(Y3) PE3=PMT3*COSH(Y3) C...Find momentum transfers in two mirror solutions (in 1-2 frame). PZ12=-PZ3 PE12=SHPR-PE3 PMS12=PE12**2-PZ12**2 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2)) IF(SQL12.LT.1D-6*SHP) THEN MINT(51)=1 RETURN ENDIF PMM1=PMS12+PMS1-PMS2 PMM2=PMS12+PMS2-PMS1 TFAC=-SHPR/(2D0*PMS12) T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12) T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12) T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12) T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12) C...Construct relative mirror weights and make choice. IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN WTPU=1D0 WTNU=1D0 ELSE WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2 ENDIF WTP=WTPU/(WTPU+WTNU) WTN=WTNU/(WTPU+WTNU) EPS=1D0 IF(WTN.GT.PYR(0)) EPS=-1D0 C...Store result of variable choice and associated weights. VINT(202)=PTS1 VINT(207)=PTS2 VINT(203)=PHI1 VINT(208)=PHI2 VINT(205)=WTPTS1 VINT(210)=WTPTS2 VINT(211)=Y3 VINT(212)=Y3MAX VINT(213)=EPS IF(EPS.GT.0D0) THEN VINT(214)=1D0/WTP VINT(215)=T1P VINT(216)=T2P ELSE VINT(214)=1D0/WTN VINT(215)=T1N VINT(216)=T2N ENDIF VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12) VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12) VINT(219)=0.5D0*(PMS12-PTS3) VINT(220)=SQL12 ENDIF RETURN END C*********************************************************************** C...PYSIGH C...Differential matrix elements for all included subprocesses C...Note that what is coded is (disregarding the COMFAC factor) C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where, C...when d(sigma-hat) is given in the zero-width limit, the delta C...function in tau is replaced by a (modified) Breit-Wigner: C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2), C...where H_res = s-hat/m_res*Gamma_res(s-hat); C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat); C...i.e., dimensionless quantities C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) * C...(2pi)^4 delta^4(P - sum p_i) C...COMFAC contains the factor pi/s (or equivalent) and C...the conversion factor from GeV^-2 to mb SUBROUTINE PYSIGH(NCHN,SIGS) C...Double precision and integer declarations IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT7/SIGT(0:6,0:6,0:5) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/, &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/, &/PYMSSM/,/PYSSMT/ C...Local arrays and complex variables DIMENSION X(2),XPQ(-25:25),KFAC(2,-40:40),WDTP(0:300), &WDTE(0:300,0:5),HGZ(6,3),HL3(3),HR3(3),HL4(3),HR4(3) COMPLEX*16 A004,A204,A114,A00U,A20U,A11U COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF, &COULCK,COULCP,COULCD,COULCR,COULCS REAL*8 A00L,A11L,A20L,COULXX COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME COMPLEX*16 DAA,DZZ,DAZ COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU COMPLEX*16 DQQS,DQQT,DQQU,DQTS COMPLEX*16 DVVS,DVVT,DVVU COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2) INTEGER INDX(6) 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 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113 ENDIF CMRENNA++ C...Convert almost equivalent SUSY processes into each other C...Extract differences in flavours and couplings IF(ISUB.GE.200.AND.ISUB.LE.301) 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=4D0 C...Stops ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN ILR=0 IF(ISUB.EQ.262) ILR=1 ISUB=261 ELSEIF(ISUB.EQ.265) THEN ISUB=264 C...Squarks ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN ILR=0 IF(ISUB.LE.273) THEN IF(ISUB.EQ.273) ILR=1 ISUB=271 RKF=16D0 ELSEIF(ISUB.LE.276) THEN IF(ISUB.EQ.276) ILR=1 ISUB=274 RKF=16D0 ELSEIF(ISUB.LE.278) THEN IF(ISUB.EQ.278) ILR=1 ISUB=277 RKF=4D0 ELSE IF(ISUB.EQ.280) ILR=1 ISUB=279 RKF=4D0 ENDIF C...Sbottoms ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN ILR=0 IF(ISUB.LE.283) THEN IF(ISUB.EQ.283) ILR=1 ISUB=271 RKF=4D0 ELSEIF(ISUB.LE.286) THEN IF(ISUB.EQ.286) ILR=1 ISUB=274 RKF=4D0 ELSEIF(ISUB.LE.288) THEN IF(ISUB.EQ.288) ILR=1 ISUB=277 RKF=1D0 ELSEIF(ISUB.LE.290) THEN IF(ISUB.EQ.290) ILR=1 ISUB=279 RKF=1D0 ELSEIF(ISUB.LE.293) THEN IF(ISUB.EQ.293) ILR=1 ISUB=271 RKF=1D0 ELSEIF(ISUB.EQ.296) THEN ILR=1 ISUB=274 RKF=1D0 C...Squark + gluino ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN ISUB=258 RKF=1D0 ENDIF C...H+/- + H0 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN IF(ISUB.EQ.297) THEN RKF=.5D0*PARU(195)**2 ELSEIF(ISUB.EQ.298) THEN RKF=.5D0*(1D0-PARU(195)**2) ENDIF ISUB=210 C...A0 + H0 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN IF(ISUB.EQ.299) THEN RKF=PARU(186)**2 KFID=25 ELSEIF(ISUB.EQ.300) THEN RKF=PARU(187)**2 KFID=35 ENDIF ISUB=213 C...H+ + H- ELSEIF(ISUB.EQ.301) THEN KFID=37 RKF=1D0 ISUB=201 ENDIF C...Convert almost equivalent technicolor processes into C...a few basic processes, and set distinguishing parameters. ELSEIF(ISUB.GE.361.AND.ISUB.LE.379) THEN SQTV=PARP(137)**2 SQTA=PARP(138)**2 TANW=SQRT(PARU(102)/(1D0-PARU(102))) CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW) CSXI=COS(ASIN(PARP(141))) CSXIP=COS(ASIN(PARP(139))) QUPD=2D0*PARP(143)-1D0 C... rho_tc0 -> W_L W_L IF(ISUB.EQ.361) THEN KFA=24 KFB=24 CAB2=PARP(141)**4 C... rho_tc0 -> W_L pi_tc- ELSEIF(ISUB.EQ.362) THEN KFA=24 KFB=KTECHN+211 ISUB=361 CAB2=PARP(141)**2*(1D0-PARP(141)**2) C... pi_tc pi_tc ELSEIF(ISUB.EQ.363) THEN KFA=KTECHN+211 KFB=KTECHN+211 ISUB=361 CAB2=(1D0-PARP(141)**2)**2 C... rho_tc0/omega_tc -> gamma pi_tc ELSEIF(ISUB.EQ.364) THEN KFA=22 KFB=KTECHN+111 VOGP=CSXI VRGP=VOGP*QUPD AOGP=0D0 ARGP=0D0 C... gamma pi_tc' ELSEIF(ISUB.EQ.365) THEN KFA=22 KFB=KTECHN+221 ISUB=364 VRGP=CSXIP VOGP=VRGP*QUPD AOGP=0D0 ARGP=0D0 C... Z pi_tc ELSEIF(ISUB.EQ.366) THEN KFA=23 KFB=KTECHN+111 ISUB=364 VOGP=CSXI*CT2W VRGP=-QUPD*CSXI*TANW AOGP=0D0 ARGP=0D0 C... Z pi_tc' ELSEIF(ISUB.EQ.367) THEN KFA=23 KFB=KTECHN+221 ISUB=364 VRGP=CSXIP*CT2W VOGP=-QUPD*CSXIP*TANW AOGP=0D0 ARGP=0D0 C... W_T pi_tc ELSEIF(ISUB.EQ.368) THEN KFA=24 KFB=KTECHN+211 ISUB=364 VOGP=CSXI/(2D0*SQRT(PARU(102))) VRGP=0D0 AOGP=0D0 ARGP=-VOGP C... rho_tc+ -> W_L Z_L ELSEIF(ISUB.EQ.370) THEN KFA=24 KFB=23 CAB2=PARP(141)**4 C... W_L pi_tc0 ELSEIF(ISUB.EQ.371) THEN KFA=24 KFB=KTECHN+111 ISUB=370 CAB2=PARP(141)**2*(1D0-PARP(141)**2) C... Z_L pi_tc+ ELSEIF(ISUB.EQ.372) THEN KFA=KTECHN+211 KFB=23 ISUB=370 CAB2=PARP(141)**2*(1D0-PARP(141)**2) C... pi_tc+ pi_tc0 ELSEIF(ISUB.EQ.373) THEN KFA=KTECHN+211 KFB=KTECHN+111 ISUB=370 CAB2=(1D0-PARP(141)**2)**2 C... gamma pi_tc+ ELSEIF(ISUB.EQ.374) THEN KFA=KTECHN+211 KFB=22 VRGP=QUPD*CSXI ARGP=0D0 C... Z_T pi_tc+ ELSEIF(ISUB.EQ.375) THEN KFA=KTECHN+211 KFB=23 ISUB=374 VRGP=-QUPD*CSXI*TANW ARGP=CSXI/(2D0*SQRT(PARU(102)*(1D0-PARU(102)))) C... W_T pi_tc0 ELSEIF(ISUB.EQ.376) THEN KFA=24 KFB=KTECHN+111 ISUB=374 VRGP=0D0 ARGP=-CSXI/(2D0*SQRT(PARU(102))) C... W_T pi_tc0' ELSEIF(ISUB.EQ.377) THEN KFA=24 KFB=KTECHN+221 ISUB=374 ARGP=0D0 VRGP=CSXIP/(2D0*SQRT(PARU(102))) 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.1D0-1D-7) RETURN ELSEIF(MINT(45).EQ.3) THEN X(1)=MIN(1D0-1.1D-10,X(1)) ENDIF IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN IF(X(2).GT.1D0-1D-7) RETURN ELSEIF(MINT(46).EQ.3) THEN X(2)=MIN(1D0-1.1D-10,X(2)) ENDIF SH=MAX(1D0,TAU*VINT(2)) SQM3=VINT(63) SQM4=VINT(64) RM3=SQM3/SH RM4=SQM4/SH BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) RPTS=4D0*VINT(71)**2/SH BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS)) RM34=MAX(1D-20,2D0*RM3*RM4) RSQM=1D0+RM34 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0) &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2))) RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L) IF(ISTSB.EQ.0) THEN TH=VINT(45) UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH) SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2) ELSE C...Kinematics with incoming masses tricky: now depends on how C...subprocess has been set up w.r.t. order of incoming partons. RM1=0D0 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH RM2=0D0 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH IF(ISUB.EQ.35) THEN RM2=MIN(RM1,RM2) RM1=0D0 ENDIF BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4) TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3- & BE12*BE34*CTH) UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+ & BE12*BE34*CTH) SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2)) ENDIF SHR=SQRT(SH) SH2=SH**2 TH2=TH**2 UH2=UH**2 C...Choice of Q2 scale: hard, parton distributions, parton showers IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN Q2=SH ELSEIF(ISTSB.EQ.8) THEN IF(MINT(107).EQ.4) Q2=VINT(307) IF(MINT(108).EQ.4) Q2=VINT(308) ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN Q2IN1=0D0 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2 Q2IN2=0D0 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2 IF(MSTP(32).EQ.1) THEN Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2) ELSEIF(MSTP(32).EQ.2) THEN Q2=SQPTH+0.5D0*(SQM3+SQM4) ELSEIF(MSTP(32).EQ.3) THEN Q2=MIN(-TH,-UH) ELSEIF(MSTP(32).EQ.4) THEN Q2=SH ELSEIF(MSTP(32).EQ.5) THEN Q2=-TH ELSEIF(MSTP(32).EQ.6) THEN XSF1=X(1) IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143) XSF2=X(2) IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144) Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)* & (SQPTH+0.5D0*(SQM3+SQM4)) ELSEIF(MSTP(32).EQ.7) THEN Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4)) ELSEIF(MSTP(32).EQ.8) THEN Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4) ELSEIF(MSTP(32).EQ.9) THEN Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4 ELSEIF(MSTP(32).EQ.10) THEN Q2=VINT(2) ENDIF IF(ISTSB.EQ.9) Q2=SQPTH IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+ & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2 ENDIF 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.OR. & ISUB.EQ.351) Q2SF=PMAS(24,1)**2 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2 IF(ISUB.EQ.121.OR.ISUB.EQ.122) 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) IF(MSTP(39).EQ.5) Q2SF=PMAS(KFHIGG,1)**2 ENDIF ENDIF Q2PS=Q2SF Q2SF=Q2SF*PARP(34) IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2) IF(MSTP(69).GE.2) Q2SF=VINT(2) 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).EQ.1.AND.(ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR. &ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR. &ISUBSV.EQ.144.OR.ISUBSV.EQ.152.OR.ISUBSV.EQ.157)) THEN Q2PS=VINT(2) ELSEIF(MSTP(68).GE.2.AND.(ISUBSV.NE.11.AND.ISUBSV.NE.12.AND. &ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.ISUBSV.NE.53.AND. &ISUBSV.NE.68)) THEN Q2PS=VINT(2) ENDIF C...Store derived kinematical quantities VINT(41)=X(1) VINT(42)=X(2) VINT(44)=SH VINT(43)=SQRT(SH) VINT(45)=TH VINT(46)=UH IF(ISTSB.NE.8) VINT(48)=SQPTH IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH) VINT(50)=TAUP*VINT(2) VINT(49)=SQRT(MAX(0D0,VINT(50))) VINT(52)=Q2 VINT(51)=SQRT(Q2) VINT(54)=Q2SF VINT(53)=SQRT(Q2SF) VINT(56)=Q2PS VINT(55)=SQRT(Q2PS) C...Calculate parton distributions IF(ISTSB.LE.0) GOTO 160 IF(MINT(47).GE.2) THEN DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46)) XSF=X(I) IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I) IF(ISUB.EQ.99) THEN XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308)) Q2SF=VINT(309-I) ENDIF MINT(105)=MINT(102+I) MINT(109)=MINT(106+I) VINT(120)=VINT(2+I) C.... ALICE C.... Store side in MINT(124) MINT(124)=I C.... IF(MSTP(57).LE.1) THEN CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ) ELSE CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ) ENDIF DO 100 KFL=-25,25 XSFX(I,KFL)=XPQ(KFL) 100 CONTINUE 110 CONTINUE ENDIF C...Calculate alpha_em, alpha_strong and K-factor XW=PARU(102) XWV=XW IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW= &1D0-(PMAS(24,1)/PMAS(23,1))**2 XW1=1D0-XW XWC=1D0/(16D0*XW*XW1) AEM=PYALEM(Q2) IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1) IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2) FACK=1D0 FACA=1D0 IF(MSTP(33).EQ.1) THEN FACK=PARP(31) ELSEIF(MSTP(33).EQ.2) THEN FACK=PARP(31) FACA=PARP(32)/PARP(31) ELSEIF(MSTP(33).EQ.3) THEN Q2AS=PARP(33)*Q2 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+ & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90) AS=PYALPS(Q2AS) ENDIF VINT(138)=1D0 VINT(57)=AEM VINT(58)=AS C...Set flags for allowed reacting partons/leptons DO 140 I=1,2 DO 120 J=-25,25 KFAC(I,J)=0 120 CONTINUE IF(MINT(44+I).EQ.1) THEN KFAC(I,MINT(10+I))=1 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN KFAC(I,MINT(10+I))=1 KFAC(I,22)=1 KFAC(I,24)=1 KFAC(I,-24)=1 ELSE DO 130 J=-25,25 KFAC(I,J)=KFIN(I,J) IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0 130 CONTINUE ENDIF 140 CONTINUE C...Lower and upper limit for fermion flavour loops MMIN1=0 MMAX1=0 MMIN2=0 MMAX2=0 DO 150 J=-20,20 IF(KFAC(1,-J).EQ.1) MMIN1=-J IF(KFAC(1,J).EQ.1) MMAX1=J IF(KFAC(2,-J).EQ.1) MMIN2=-J IF(KFAC(2,J).EQ.1) MMAX2=J 150 CONTINUE MMINA=MIN(MMIN1,MMIN2) MMAXA=MAX(MMAX1,MMAX2) C...Common resonance mass and width combinations SQMZ=PMAS(23,1)**2 SQMW=PMAS(24,1)**2 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) CT2W=(1D0-2D0*XW)/(2D0*XW/TANW) C...MRENNA--- C...Polarization factors...implemented so far for W+W-(25) POLR=(1D0+PARJ(132))*(1D0-PARJ(131)) POLL=(1D0-PARJ(132))*(1D0+PARJ(131)) POLRR=(1D0+PARJ(132))*(1D0+PARJ(131)) POLLL=(1D0-PARJ(132))*(1D0-PARJ(131)) C...Phase space integral in tau COMFAC=PARU(1)*PARU(5)/VINT(2) IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND. &ISTSB.NE.8.AND.ISTSB.NE.9) THEN ATAU1=LOG(TAUMAX/TAUMIN) ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN) H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU IF(MINT(72).GE.1) THEN TAUR1=VINT(73) GAMR1=VINT(74) ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1)) ATAU3=ATAUD/TAUR1 IF(ATAUD.GT.1D-10) H1=H1+ & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1) ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1) ATAU4=ATAUD/GAMR1 IF(ATAUD.GT.1D-10) H1=H1+ & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2) ENDIF IF(MINT(72).EQ.2) THEN TAUR2=VINT(75) GAMR2=VINT(76) ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2)) ATAU5=ATAUD/TAUR2 IF(ATAUD.GT.1D-10) H1=H1+ & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2) ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2) ATAU6=ATAUD/GAMR2 IF(ATAUD.GT.1D-10) H1=H1+ & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2) ENDIF IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX)) IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/ & MAX(2D-10,1D0-TAU) ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX)) IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/ & MAX(1D-10,1D0-TAU) ENDIF COMFAC=COMFAC*ATAU1/(TAU*H1) ENDIF C...Phase space integral in y* IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9) &THEN AYST0=YSTMAX-YSTMIN IF(AYST0.LT.1D-10) THEN COMFAC=0D0 ELSE AYST1=0.5D0*(YSTMAX-YSTMIN)**2 AYST2=AYST1 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN))) H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+ & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+ & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST) IF(MINT(45).EQ.3) THEN YST0=-0.5D0*LOG(TAUE) AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/ & MAX(1D-10,EXP(YST0-YSTMAX)-1D0)) IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/ & MAX(1D-10,1D0-EXP(YST-YST0)) ENDIF IF(MINT(46).EQ.3) THEN YST0=-0.5D0*LOG(TAUE) AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/ & MAX(1D-10,EXP(YST0+YSTMIN)-1D0)) IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/ & MAX(1D-10,1D0-EXP(-YST-YST0)) ENDIF COMFAC=COMFAC*AYST0/H2 ENDIF ENDIF C...2 -> 1 processes: reduction in angular part of phase space integral C...for case of decaying resonance ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR. & KFPR(ISUB,1).EQ.39) THEN COMFAC=COMFAC*0.5D0*ACTH0 ELSE COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+ & CTPMAX**3-CTPMIN**3) ENDIF ENDIF C...2 -> 2 processes: angular part of phase space integral ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/ & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX))) ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/ & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN))) ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+ & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN) ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+ & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX) H3=COEF(ISUBSV,13)+ & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+ & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+ & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+ & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3 C...2 -> 2 processes: take into account final state Breit-Wigners COMFAC=COMFAC*VINT(80) ENDIF C...2 -> 3, 4 processes: phace space integral in tau' IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN ATAUP1=LOG(TAUPMX/TAUPMN) ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU) H4=COEF(ISUBSV,18)+ & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP IF(MINT(47).EQ.5) THEN ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX)) H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP) ELSEIF(MINT(47).GE.6) THEN ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX)) H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP) ENDIF COMFAC=COMFAC*ATAUP1/H4 ENDIF C...2 -> 3, 4 processes: effective W/Z parton distributions IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN IF(1D0-TAU/TAUP.GT.1D-4) THEN FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP) ELSE FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP ENDIF COMFAC=COMFAC*FZW ENDIF C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror IF(ISTSB.EQ.5) THEN COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/ & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP) ENDIF C...Phase space integral for low-pT and multiple interactions IF(ISTSB.EQ.9) THEN COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0) ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2) H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU) COMFAC=COMFAC*ATAU1/H1 AYST0=YSTMAX-YSTMIN AYST1=0.5D0*(YSTMAX-YSTMIN)**2 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN))) H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+ & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+ & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST) COMFAC=COMFAC*AYST0/H2 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0) C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is C...introduced to make cross-section finite for xT2 -> 0 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)* & (1D0+VINT(149))) ENDIF C...Real gamma + gamma: include factor 2 when different nature 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND. &MSTP(14).LE.10) COMFAC=2D0*COMFAC C...Extra factors to include the effects of C...longitudinal resolved photons (but not direct or DIS ones). DO 170 ISDE=1,2 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND. & MINT(106+ISDE).LE.3) THEN VINT(314+ISDE)=1D0 XY=PARP(166+ISDE) IF(MSTP(16).EQ.0) THEN IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0) & XY=VINT(304+ISDE) ELSE IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0) & XY=VINT(308+ISDE) ENDIF Q2GA=VINT(306+ISDE) IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND. & Q2GA.GT.0D0) THEN REDUCE=0D0 IF(MSTP(17).EQ.1) THEN REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2 ELSEIF(MSTP(17).EQ.2) THEN REDUCE=4D0*Q2GA/(Q2+Q2GA) ELSEIF(MSTP(17).EQ.3) THEN PMVIRT=PMAS(PYCOMP(113),1) REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA) ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN PMVIRT=PMAS(PYCOMP(113),1) REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN PMVIRT=PMAS(PYCOMP(113),1) REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN PMVSMN=4D0*PARP(15)**2 PMVSMX=4D0*VINT(154)**2 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA) REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3- & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN PMVIRT=PMAS(PYCOMP(113),1) REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA) ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN PMVIRT=PMAS(PYCOMP(113),1) REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA) ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN PMVSMN=4D0*PARP(15)**2 PMVSMX=4D0*VINT(154)**2 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA) REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA ENDIF BEAMAS=PYMASS(11) IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE) FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)* & (1D0-2D0*BEAMAS**2/Q2GA)) VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT ENDIF ELSE VINT(314+ISDE)=1D0 ENDIF COMFAC=COMFAC*VINT(314+ISDE) 170 CONTINUE C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ. &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN C...Calculate M_R and N_R functions for Higgs-like and QCD-like models IF(MSTP(46).LE.4) THEN HDTLH=LOG(PMAS(25,1)/PARP(44)) HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0 HDTNR=-1D0/18D0+HDTLH/6D0 ELSE HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2) HDTLQ=LOG(PARP(45)/PARP(44)) HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0 ENDIF C...Calculate lowest and next-to-lowest order partial wave amplitudes HDTV=1D0/(16D0*PARU(1)*PARP(47)**2) A00L=DBLE(HDTV*SH) A20L=-0.5D0*A00L A11L=A00L/6D0 HDTLS=LOG(SH/PARP(44)**2) A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))* & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0- & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1))) A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))* & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0- & (20D0/9D0)*HDTLS),DBLE(PARU(1))) A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))* & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0)) C...Unitarize partial wave amplitudes with Pade or K-matrix method IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN A00U=A00L/(1D0-A004/A00L) A20U=A20L/(1D0-A204/A20L) A11U=A11L/(1D0-A114/A11L) ELSE A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004))) A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204))) A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114))) ENDIF ENDIF C...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.301.AND.MSTP(42).GT.0) THEN DO 180 I=1,2 KFLW=KFPR(ISUBSV,I) KCW=PYCOMP(KFLW) IF(PMAS(KCW,2).LT.PARP(41)) GOTO 180 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) 180 CONTINUE ENDIF C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange. IF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR. $ISUB.EQ.68.OR.ISUB.EQ.81.OR.ISUB.EQ.82) THEN IF(MSTP(5).LE.4) THEN SQDQQS=1D0/SH2 SQDQQT=1D0/TH2 SQDQQU=1D0/UH2 SQDGGS=SQDQQS SQDGGT=SQDQQT SQDGGU=SQDQQU REDGGS=1D0/SH REDGGT=1D0/TH REDGGU=1D0/UH REDGTU=1D0/UH/TH REDGSU=1D0/SH/UH REDGST=1D0/SH/TH REDQST=1D0/SH/TH REDQTU=1D0/UH/TH SQDLGS=0D0 SQDLGT=0D0 SQDQTS=SQDQQS ELSEIF(MSTP(5).EQ.5) THEN TANT3=ABS(PARP(155)) IF(PARP(155).GT.0) THEN IMDL=1 ELSE IMDL=2 ENDIF ALPRHT=2.91D0*(3D0/PARP(144)) SIN2T=2D0*TANT3/(TANT3**2+1D0) SINT3=TANT3/SQRT(TANT3**2+1D0) XIG=SQRT(PYALPS(SH)/ALPRHT) X12=(1D0/SQRT(2D0)*1D0/SQRT(2D0)+ & 1D0/SQRT(2D0)*1D0/SQRT(2D0))/SQRT(2D0)/SIN2T X21=1D-3 X11=(.25D0*((1D0/SQRT(2D0))**2+(1D0/SQRT(2D0))**2+2D0)- & SINT3**2)*2D0/SIN2T X22=(.25D0*((1D0/SQRT(2D0))**2+(1D0/SQRT(2D0))**2)- & SINT3**2)*2D0/SIN2T IF(PARP(156).GT.0.5D0) THEN SM1122=1D-6 SM1112=1D-6 SM1121=1D-6 SM2212=1D-6 SM2221=1D-6 SM1221=1D-6 X12=1D-6 X21=1D-6 X11=(1D0-SINT3**2)*2D0/SIN2T X22=-SINT3**2*2D0/SIN2T ELSE SM1122=100D0**2 SM1112=150D0**2 SM1121=150D0**2 SM2212=150D0**2 SM2221=75D0**2 SM1221=50D0**2 ENDIF C.........SH LOOP ZTC(1,1)=DCMPLX(SH,0D0) CALL PYWIDT(3100021,SH,WDTP,WDTE) ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0)) CALL PYWIDT(3100113,SH,WDTP,WDTE) ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0)) CALL PYWIDT(3400113,SH,WDTP,WDTE) ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0)) CALL PYWIDT(3200113,SH,WDTP,WDTE) ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0)) CALL PYWIDT(3300113,SH,WDTP,WDTE) ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0)) ZTC(1,2)=(0D0,0D0) ZTC(1,3)=DCMPLX(SH*XIG,0D0) ZTC(1,4)=ZTC(1,3) ZTC(1,5)=ZTC(1,2) ZTC(1,6)=ZTC(1,2) ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0) ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0) ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0) ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0) ZTC(3,4)=-SM1122 ZTC(3,5)=-SM1112 ZTC(3,6)=-SM1121 ZTC(4,5)=-SM2212 ZTC(4,6)=-SM2221 ZTC(5,6)=-SM1221 DO 200 I=1,5 DO 190 J=I+1,6 ZTC(J,I)=ZTC(I,J) 190 CONTINUE 200 CONTINUE CALL PYLDCM(ZTC,6,6,INDX,D) DO 220 I=1,6 DO 210 J=1,6 YTC(I,J)=(0D0,0D0) IF(I.EQ.J) YTC(I,J)=(1D0,0D0) 210 CONTINUE 220 CONTINUE DO 230 I=1,6 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I)) 230 CONTINUE DGGS=YTC(1,1) DVVS=YTC(2,2) XIG=SQRT(PYALPS(-TH)/ALPRHT) C.........TH LOOP ZTC(1,1)=DCMPLX(TH) ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2) ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2) ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2) ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2) ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2) ZTC(1,2)=(0D0,0D0) ZTC(1,3)=DCMPLX(TH*XIG,0D0) ZTC(1,4)=ZTC(1,3) ZTC(1,5)=ZTC(1,2) ZTC(1,6)=ZTC(1,2) ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0) ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0) ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0) ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0) ZTC(3,4)=-SM1122 ZTC(3,5)=-SM1112 ZTC(3,6)=-SM1121 ZTC(4,5)=-SM2212 ZTC(4,6)=-SM2221 ZTC(5,6)=-SM1221 DO 250 I=1,5 DO 240 J=I+1,6 ZTC(J,I)=ZTC(I,J) 240 CONTINUE 250 CONTINUE CALL PYLDCM(ZTC,6,6,INDX,D) DO 270 I=1,6 DO 260 J=1,6 YTC(I,J)=(0D0,0D0) IF(I.EQ.J) YTC(I,J)=(1D0,0D0) 260 CONTINUE 270 CONTINUE DO 280 I=1,6 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I)) 280 CONTINUE DGGT=YTC(1,1) DVVT=YTC(2,2) XIG=SQRT(PYALPS(-UH)/ALPRHT) C.........UH LOOP ZTC(1,1)=DCMPLX(UH,0D0) ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2) ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2) ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2) ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2) ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2) ZTC(1,2)=(0D0,0D0) ZTC(1,3)=DCMPLX(UH*XIG,0D0) ZTC(1,4)=ZTC(1,3) ZTC(1,5)=ZTC(1,2) ZTC(1,6)=ZTC(1,2) ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0) ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0) ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0) ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0) ZTC(3,4)=-SM1122 ZTC(3,5)=-SM1112 ZTC(3,6)=-SM1121 ZTC(4,5)=-SM2212 ZTC(4,6)=-SM2221 ZTC(5,6)=-SM1221 DO 300 I=1,5 DO 290 J=I+1,6 ZTC(J,I)=ZTC(I,J) 290 CONTINUE 300 CONTINUE CALL PYLDCM(ZTC,6,6,INDX,D) DO 320 I=1,6 DO 310 J=1,6 YTC(I,J)=(0D0,0D0) IF(I.EQ.J) YTC(I,J)=(1D0,0D0) 310 CONTINUE 320 CONTINUE DO 330 I=1,6 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I)) 330 CONTINUE DGGU=YTC(1,1) DVVU=YTC(2,2) IF(IMDL.EQ.1) THEN DQQS=DGGS+DVVS*DCMPLX(TANT3**2) DQQT=DGGT+DVVT*DCMPLX(TANT3**2) DQQU=DGGU+DVVU*DCMPLX(TANT3**2) DQTS=DGGS-DVVS ELSE DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2) DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2) DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2) DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2) ENDIF SQDQTS=ABS(DQTS)**2 SQDQQS=ABS(DQQS)**2 SQDQQT=ABS(DQQT)**2 SQDQQU=ABS(DQQU)**2 SQDLGS=ABS(DCMPLX(SH)*DGGS-DCMPLX(1D0))**2 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2 SQDGGS=ABS(DGGS)**2 SQDGGT=ABS(DGGT)**2 SQDGGU=ABS(DGGU)**2 REDGGS=DBLE(DGGS) REDGGT=DBLE(DGGT) REDGGU=DBLE(DGGU) REDGTU=DBLE(DGGU*DCONJG(DGGT)) REDGSU=DBLE(DGGU*DCONJG(DGGS)) REDGST=DBLE(DGGS*DCONJG(DGGT)) REDQST=DBLE(DQQS*DCONJG(DQQT)) REDQTU=DBLE(DQQT*DCONJG(DQQU)) ENDIF ENDIF C...A: 2 -> 1, tree diagrams 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 340 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 340 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)) 340 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 360 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 360 IA=IABS(I) DO 350 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 350 JA=IABS(J) IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 350 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 350 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 350 CONTINUE 360 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 370 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370 IA=IABS(I) RMQ=PYMRUN(IA,SH)**2/SH HI=HP*RMQ IF(IA.LE.10) HI=HP*RMQ*FACA/3D0 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN IKFI=1 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2 IF(IA.GT.10) IKFI=3 HI=HI*PARU(150+10*IHIGG+IKFI)**2 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN HI=HI/(1D0+RMSS(41))**2 IF(IHIGG.NE.3) THEN HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/ & PARU(151+10*IHIGG))**2 ENDIF ENDIF ENDIF NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=HI*FACBW*HF 370 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 390 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 390 DO 380 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 380 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 380 CONTINUE 390 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 410 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1) DO 400 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1) IF(EI*EJ.GT.0D0) GOTO 400 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 400 CONTINUE 410 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 430 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 430 IA=IABS(I) DO 420 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 420 JA=IABS(J) C...Electroweak couplings EI=KCHG(IA,1)*ISIGN(1,I)/3D0 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I) VI=AI-4D0*EI*XWV EJ=KCHG(JA,1)*ISIGN(1,J)/3D0 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J) VJ=AJ-4D0*EJ*XWV EPSIJ=ISIGN(1,I*J) C...gamma/Z exchange, only gamma exchange, or only Z exchange IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ* & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+ & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+ & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2)) ELSEIF(MSTP(21).EQ.2) THEN FACNCF=FACGGF*EI**2*EJ**2 ELSE FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)* & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2)) ENDIF C...Extrafactor 2 for only one incoming neutrino spin state. IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACNCF ENDIF C...W exchange IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN FACCCF=FACWWF*VINT(180+I)*VINT(180+J) IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=2 SIGH(NCHN)=FACCCF ENDIF 420 CONTINUE 430 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)*SQDQQT FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA- & MSTP(34)*2D0/3D0*UH2*REDQST) FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH) RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2) IF(MSTP(5).GE.1.AND.MSTP(5).LE.4) 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) RATCII=(FACCI1*FACCI2+FACQQI)/(FACCI1+FACCI2) ELSEIF(MSTP(5).EQ.5) THEN FACCI1=FACQQ1 FACCIB=FACQQB FACCI2=FACQQ2 FACCI3=FACQQ1 RATCII=1D0 ENDIF DO 450 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450 DO 440 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440 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 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-1)=0.5D0*FACQQ1*RATQQI SIGH(NCHN)=0.5D0*FACQQ2*RATQQI ELSE SIGH(NCHN-1)=0.5D0*FACCI1*RATCII SIGH(NCHN)=0.5D0*FACCI2*RATCII ENDIF ENDIF 440 CONTINUE 450 CONTINUE ELSEIF(ISUB.EQ.12) THEN C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only) CALL PYWIDT(21,SH,WDTP,WDTE) C.........Do not use for b bbar in Standard TC2 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)*SQDQQS* & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) IF(MSTP(5).EQ.1) THEN C...Modifications from contact interactions (compositeness) FACCIB=FACQQB DO 460 I=1,2 FACCIB=FACCIB+COMFAC*(UH2/PARU(155)**4)*(WDTE(I,1)+ & WDTE(I,2)+WDTE(I,4)) 460 CONTINUE ELSEIF(MSTP(5).GE.2.AND.MSTP(5).LE.4) THEN FACCIB=FACQQB+COMFAC*(UH2/PARU(155)**4)* & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) ENDIF DO 470 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 IF(MSTP(5).LE.0.OR.(MSTP(5).EQ.1.AND.IABS(I).GE.3)) THEN SIGH(NCHN)=FACQQB ELSE SIGH(NCHN)=FACCIB ENDIF 470 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+9D0/4D0*TH*UH/SH2*SQDLGS) FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS) DO 480 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 480 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 480 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 490 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 490 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 490 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 500 I=1,MIN(16,MDCY(23,3)) IDC=I+MDCY(23,2)-1 IF(MDME(IDC,1).LT.0) GOTO 500 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 500 CONTINUE C...Propagators: as simulated in PYOFSH and as desired HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) MINT15=MINT(15) MINT(15)=1 MINT(61)=1 CALL PYWIDT(23,SQM4,WDTP,WDTE) MINT(15)=MINT15 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) HFGG=HFGG*HFAEM*VINT(111)/SQM4 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4 C...Loop over flavours; consider full gamma/Z structure DO 510 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 510 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 510 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 530 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 530 DO 520 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 520 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 520 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 520 CONTINUE 530 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 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 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 540 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 550 I=1,MIN(16,MDCY(23,3)) IDC=I+MDCY(23,2)-1 IF(MDME(IDC,1).LT.0) GOTO 550 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 550 CONTINUE C...Propagators: as simulated in PYOFSH and as desired HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) MINT15=MINT(15) MINT(15)=1 MINT(61)=1 CALL PYWIDT(23,SQM4,WDTP,WDTE) MINT(15)=MINT15 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) HFGG=HFGG*HFAEM*VINT(111)/SQM4 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4 C...Loop over flavours; consider full gamma/Z structure DO 560 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 560 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 560 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.AND.MSTP(5).LE.4) 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 580 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 580 DO 570 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 570 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 570 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 570 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 570 CONTINUE 580 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 600 I=1,6 DO 590 J=1,3 HGZ(I,J)=0D0 590 CONTINUE 600 CONTINUE RADC3=1D0+PYALPS(SQM3)/PARU(1) 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) 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 610 CONTINUE C...Propagators: as simulated in PYOFSH and as desired HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2) HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) MINT15=MINT(15) MINT(15)=1 MINT(61)=1 CALL PYWIDT(23,SQM3,WDTP,WDTE) MINT(15)=MINT15 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) DO 620 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 620 CONTINUE MINT15=MINT(15) MINT(15)=1 MINT(61)=1 CALL PYWIDT(23,SQM4,WDTP,WDTE) MINT(15)=MINT15 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) DO 630 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 630 CONTINUE C...Loop over flavours; separate left- and right-handed couplings DO 650 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 650 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 640 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) 640 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) 650 CONTINUE ELSEIF(ISUB.EQ.23) THEN C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.) FACZW=COMFAC*0.5D0*(AEM/XW)**2 FACZW=FACZW*WIDS(23,2) THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) FACBW=1D0/((SH-SQMW)**2+GMMW**2) DO 670 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 670 DO 660 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 660 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 660 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 660 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 EI=KCHG(IA,1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV EJ=KCHG(JA,1)/3D0 AJ=SIGN(1D0,EJ+0.1D0) VJ=AJ-4D0*EJ*XWV IF(VI+AI.GT.0) THEN VISAV=VI AISAV=AI VI=VJ AI=AJ VJ=VISAV AJ=AISAV ENDIF FCKM=1D0 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) FCOI=1D0 IF(IA.LE.10) FCOI=FACA/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+ & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))* & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+ & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+ & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))* & WIDS(24,(5-KCHW)/2) C***Protect against slightly negative cross sections. (Reason yet to be C***sorted out. One possibility: addition of width to the W propagator.) SIGH(NCHN)=MAX(0D0,SIGH(NCHN)) 660 CONTINUE 670 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 680 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 680 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) 680 CONTINUE ELSEIF(ISUB.EQ.25) THEN C...f + fbar -> W+ + W- C...Propagators: Z0, W+- as simulated in PYOFSH and as desired GMMZC=GMMZ HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2) HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2) CALL PYWIDT(24,SQM3,WDTP,WDTE) GMMW3=SQRT(SQM3)*WDTP(0) HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2) HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2) CALL PYWIDT(24,SQM4,WDTP,WDTE) GMMW4=SQRT(SQM4)*WDTP(0) HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2) C...Kinematical functions THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4) GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2 GT=THUH34+4D0*THUH/TH2 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH GU=THUH34+4D0*THUH/UH2 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH C...Common factors and couplings FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4) FACWW=FACWW*WIDS(24,1) CGG=AEM**2/2D0 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH) CZZ=AEM**2/(32D0*XW**2)*HBWZC CNG=AEM**2/(4D0*XW) CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH) CNN=AEM**2/(16D0*XW**2) C...Coulomb factor for W+W- pair IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1)) COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH)) IF(COULE.LT.100D0*PMAS(24,2)) THEN COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+ & PMAS(24,2)**2)-COULE)) ELSE COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE)) ENDIF IF(COULE.GT.-100D0*PMAS(24,2)) THEN COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+ & PMAS(24,2)**2)+COULE)) ELSE COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/ & ABS(COULE))) ENDIF IF(MSTP(40).EQ.1) THEN COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/ & MAX(1D-10,2D0*COULP*COULP1)) FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34) ELSEIF(MSTP(40).EQ.2) THEN COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2)) COULCP=DCMPLX(0D0,DBLE(COULP)) COULCD=(COULCK+COULCP)/(COULCK-COULCP) COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/ & (4D0*COULCP)*LOG(COULCD) COULCS=DCMPLX(0D0,0D0) NSTP=100 DO 690 ISTP=1,NSTP COULXX=(ISTP-0.5)/NSTP COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/ & (1D0+COULXX/COULCD)) 690 CONTINUE COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)* & (COULCS/NSTP) FACCOU=ABS(COULCR)**2 ELSEIF(MSTP(40).EQ.3) THEN COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+ & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1)) FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34) ENDIF ELSEIF(MSTP(40).EQ.4) THEN FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34) ELSE FACCOU=1D0 ENDIF VINT(95)=FACCOU FACWW=FACWW*FACCOU C...Loop over allowed flavours DO 700 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 700 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV FCOI=1D0 IF(IABS(I).LE.10) FCOI=FACA/3D0 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN IF(AI.LT.0D0) THEN DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+ & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT ELSE DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS- & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU ENDIF ELSE XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH BET=SQRT(1D0-4D0*XMW02/SH) GAT=1D0/SQRT(1D0-BET**2) STHE2=1D0-CTH**2 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2) AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+ & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2) AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+ & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/ & (1D0-2D0*BET*CTH+BET**2)) PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH) PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG ATOT=ATOT*CNN/SQMW*SH/BET*2D0 DSIGWW=ATOT ENDIF NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACWW*FCOI*DSIGWW 700 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 720 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 720 DO 710 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 710 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 710 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 710 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) 710 CONTINUE 720 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-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2- & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT) DO 740 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 740 DO 730 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 730 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 730 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 730 CONTINUE 740 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 760 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 760 EI=KCHG(IABS(I),1)/3D0 FACGQ=FGQ*EI**2 DO 750 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 750 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 750 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACGQ 750 CONTINUE 760 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 770 I=1,MIN(16,MDCY(23,3)) IDC=I+MDCY(23,2)-1 IF(MDME(IDC,1).LT.0) GOTO 770 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 770 CONTINUE C...Propagators: as simulated in PYOFSH and as desired HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) MINT15=MINT(15) MINT(15)=1 MINT(61)=1 CALL PYWIDT(23,SQM4,WDTP,WDTE) MINT(15)=MINT15 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) HFGG=HFGG*HFAEM*VINT(111)/SQM4 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4 C...Loop over flavours; consider full gamma/Z structure DO 790 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 790 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 780 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 780 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 780 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACZQ 780 CONTINUE 790 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 810 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 810 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 800 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 800 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 800 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC 800 CONTINUE 810 CONTINUE ELSEIF(ISUB.EQ.32) THEN C...f + g -> f + h0 (q + g -> q + h0 only) SQMHC=PMAS(25,1)**2 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0 DO 830 I=MMINA,MMAXA IA=IABS(I) IF(IA.NE.5) GOTO 830 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=SQML FACHCQ=FHCQ*SQML/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 820 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 820 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 820 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2) 820 CONTINUE 830 CONTINUE ELSEIF(ISUB.EQ.33) THEN C...f + gamma -> f + g (q + gamma -> q + g only) FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH) DO 850 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 850 EI=KCHG(IABS(I),1)/3D0 FACGQ=FGQ*EI**2 DO 840 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 840 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 840 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACGQ 840 CONTINUE 850 CONTINUE ELSEIF(ISUB.EQ.34) THEN C...f + gamma -> f + gamma FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH) DO 870 I=MMINA,MMAXA IF(I.EQ.0) GOTO 870 EI=KCHG(IABS(I),1)/3D0 FACGQ=FGQ*EI**4 DO 860 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 860 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 860 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACGQ 860 CONTINUE 870 CONTINUE ELSEIF(ISUB.EQ.35) THEN C...f + gamma -> f + (gamma*/Z0) IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2) ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2) ELSE FZQN=SH2+UH2+2D0*SQM4*TH FZQDTM=-SH*UH ENDIF FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN) C...gamma, gamma/Z interference and Z couplings to final fermion pairs HFGG=0D0 HFGZ=0D0 HFZZ=0D0 RADC4=1D0+PYALPS(SQM4)/PARU(1) DO 880 I=1,MIN(16,MDCY(23,3)) IDC=I+MDCY(23,2)-1 IF(MDME(IDC,1).LT.0) GOTO 880 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 880 CONTINUE C...Propagators: as simulated in PYOFSH and as desired HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) MINT15=MINT(15) MINT(15)=1 MINT(61)=1 CALL PYWIDT(23,SQM4,WDTP,WDTE) MINT(15)=MINT15 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) HFGG=HFGG*HFAEM*VINT(111)/SQM4 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4 C...Loop over flavours; consider full gamma/Z structure DO 900 I=MMINA,MMAXA IF(I.EQ.0) GOTO 900 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+ & (VI**2+AI**2)*HFZZ)/HBW4 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM) DO 890 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 890 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 890 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACZQ*FZQN/FZQD 890 CONTINUE 900 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 920 I=MMINA,MMAXA IF(I.EQ.0) GOTO 920 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 910 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 910 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 910 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC 910 CONTINUE 920 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) IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 940 IDC0=MDCY(21,2)-1 C...Begin by d, u, s flavours. FLAVWT=0D0 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+ & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH)) IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+ & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH)) IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+ & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH)) FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=2 SIGH(NCHN)=FACQQ2 C...Next c and b flavours: modified that and uhat for fixed C...cos(theta-hat). DO 930 IFL=4,5 SQMAVG=PMAS(IFL,1)**2 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN BE34=SQRT(1D0-4D0*SQMAVG/SH) THQ=-0.5D0*SH*(1D0-BE34*CTH) UHQ=-0.5D0*SH*(1D0+BE34*CTH) THUHQ=THQ*UHQ-SQMAVG*SH IF(MSTP(34).EQ.0) THEN FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2 ELSE FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ) FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ) ENDIF IF(MSTP(5).GE.5) THEN FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDGGS+ & 2.25D0*THQ*UHQ/SH2*SQDLGS FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDGGS+ & 2.25D0*THQ*UHQ/SH2*SQDLGS ENDIF FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1+2*(IFL-3) SIGH(NCHN)=FACQQ1 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=2+2*(IFL-3) SIGH(NCHN)=FACQQ2 ENDIF 930 CONTINUE 940 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 950 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)) 950 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 960 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)) 960 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 IF(MSTP(5).LE.4) THEN FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+ & 2D0*TH/SH+TH2/SH2)*FACA FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+ & 2D0*SH/UH+SH2/UH2)*FACA FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+ & 2D0*UH/TH+UH2/TH2) ELSE GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 + & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+ & 4D0*REDGST*(SH + 2D0*TH)* & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 + & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) + & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2- & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) + & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH + & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 + & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+ & 4D0*REDGSU*(SH + 2D0*UH)* & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 + & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) + & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2- & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) + & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH + & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 + & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 - & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 + & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 - & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 + & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 + & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+ & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 + & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+ & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH + & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) + & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 + & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA FACGG3=COMFAC*AS**2*9D0/4D0*GUT ENDIF IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 970 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 970 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 980 NCHN=NCHN+1 ISIG(NCHN,1)=22 ISIG(NCHN,2)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACWW 980 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 1000 KCHW=1,-1,-2 DO 990 ISDE=1,2 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 990 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) 990 CONTINUE 1000 CONTINUE ENDIF ELSEIF(ISUB.LE.80) THEN IF(ISUB.EQ.71) THEN C...Z0 + Z0 -> Z0 + Z0 IF(SH.LE.4.01D0*SQMZ) GOTO 1030 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 1030 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)* & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2) IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+ & (ASHIM+ATHIM+AUHIM)**2) IF(MSTP(46).EQ.2) FACZZ=0D0 ELSE C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)* & ABS(A00U+2D0*A20U)**2 ENDIF FACZZ=FACZZ*WIDS(23,1) DO 1020 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1020 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV AVI=AI**2+VI**2 DO 1010 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1010 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 1010 CONTINUE 1020 CONTINUE 1030 CONTINUE ELSEIF(ISUB.EQ.72) THEN C...Z0 + Z0 -> W+ + W- IF(SH.LE.4.01D0*SQMZ) GOTO 1060 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 1060 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 1050 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1050 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV AVI=AI**2+VI**2 DO 1040 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1040 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 1040 CONTINUE 1050 CONTINUE 1060 CONTINUE ELSEIF(ISUB.EQ.73) THEN C...Z0 + W+/- -> Z0 + W+/- IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 1090 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 1090 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH) ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+ & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+ & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH- & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2) ASWIM=0D0 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)* & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)* & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)- & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0* & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+ & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2* & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)* & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)* & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2* & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2* & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW* & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2) AUWIM=0D0 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)- & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2) A4IM=0D0 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4* & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2 IF(MSTP(46).LE.0) FACZW=0D0 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+ & (ATHIM+ASWIM+AUWIM+A4IM)**2) IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+ & (ASWIM+AUWIM+A4IM)**2) ELSE C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0* & ABS(A20U+3D0*A11U*DBLE(CTH))**2 ENDIF FACZW=FACZW*WIDS(23,2) DO 1080 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1080 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 1070 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1070 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 1070 CONTINUE 1080 CONTINUE 1090 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 1120 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 1120 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 1110 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1110 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1) DO 1100 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1100 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1) IF(EI*EJ.GT.0D0) GOTO 1100 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) 1100 CONTINUE 1110 CONTINUE 1120 CONTINUE ELSEIF(ISUB.EQ.77) THEN C...W+/- + W+/- -> W+/- + W+/- IF(SH.LE.4.01D0*SQMW) GOTO 1150 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 1150 SHANG=(1D0+BE2)**2 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG THANG=(BE2-CTH)**2 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG UHANG=(BE2+CTH)**2 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH ASGRE=XW*SGZANG ASGIM=0D0 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG ASZIM=0D0 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+ & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3) ATGRE=0.5D0*XW*SH/TH*TGZANG ATGIM=0D0 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG ATZIM=0D0 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+ & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3) AUGRE=0.5D0*XW*SH/UH*UGZANG AUGIM=0D0 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG AUZIM=0D0 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2) A4AIM=0D0 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2) A4SIM=0D0 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4* & (SH/SQMW)**2*SH2 IF(MSTP(46).LE.0) THEN AWWARE=ASHRE AWWAIM=ASHIM AWWSRE=0D0 AWWSIM=0D0 ELSEIF(MSTP(46).EQ.1) THEN AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM ELSE AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM ENDIF AWWA2=AWWARE**2+AWWAIM**2 AWWS2=AWWSRE**2+AWWSIM**2 ELSE C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)* & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2 ENDIF DO 1140 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1140 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1) DO 1130 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1130 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1) IF(EI*EJ.LT.0D0) THEN C...W+W- IF(MSTP(45).EQ.1) GOTO 1130 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 1130 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) 1130 CONTINUE 1140 CONTINUE 1150 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 1170 I=MAX(-2,MMINA),MIN(2,MMAXA) IF(I.EQ.0) GOTO 1170 EI=KCHG(IABS(I),1)/3D0 EJ=SIGN(1D0-ABS(EI),EI) DO 1160 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1160 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1160 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2 1160 CONTINUE 1170 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 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH THQ=-0.5D0*SH*(1D0-BE34*CTH) UHQ=-0.5D0*SH*(1D0+BE34*CTH) FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+ & 2D0*SQMAVG/SH) IF(MSTP(5).GE.5) FACQQB=FACQQB*SH2*SQDQTS IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0) WID2=1D0 IF(MINT(55).EQ.6) WID2=WIDS(6,1) IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1) FACQQB=FACQQB*WID2 DO 1180 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1180 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQB 1180 CONTINUE ELSEIF(ISUB.EQ.82) THEN C...g + g -> Q + Qbar SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH THQ=-0.5D0*SH*(1D0-BE34*CTH) UHQ=-0.5D0*SH*(1D0+BE34*CTH) THUHQ=THQ*UHQ-SQMAVG*SH IF(MSTP(34).EQ.0) THEN FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2 ELSE FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ) FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ) ENDIF IF(MSTP(5).GE.5) THEN FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDGGS+ & 2.25D0*THQ*UHQ/SH2*SQDLGS FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDGGS+ & 2.25D0*THQ*UHQ/SH2*SQDLGS ENDIF FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2 IF(MSTP(35).GE.1) THEN FATRE=PYHFTH(SH,SQMAVG,2D0/7D0) FACQQ1=FACQQ1*FATRE FACQQ2=FACQQ2*FATRE ENDIF WID2=1D0 IF(MINT(55).EQ.6) WID2=WIDS(6,1) IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1) FACQQ1=FACQQ1*WID2 FACQQ2=FACQQ2*WID2 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1190 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 1190 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 1210 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1210 DO 1200 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1200 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 1200 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 1200 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 1200 CONTINUE 1210 CONTINUE ELSEIF(ISUB.EQ.84) THEN C...g + gamma -> Q + Qbar SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH THQ=-0.5D0*SH*(1D0-BE34*CTH) UHQ=-0.5D0*SH*(1D0+BE34*CTH) FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2* & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/ & (THQ*UHQ) IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0) WID2=1D0 IF(MINT(55).EQ.6) WID2=WIDS(6,1) IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1) FACQQ=FACQQ*WID2 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ ENDIF IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=22 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ ENDIF ELSEIF(ISUB.EQ.85) THEN C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton) SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH THQ=-0.5D0*SH*(1D0-BE34*CTH) UHQ=-0.5D0*SH*(1D0+BE34*CTH) FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0* & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)* & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))* & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1) & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0) WID2=1D0 IF(MINT(56).EQ.6) WID2=WIDS(6,1) IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1) IF(MINT(56).EQ.17) WID2=WIDS(17,1) FACFF=FACFF*WID2 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=22 ISIG(NCHN,2)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACFF ENDIF ELSEIF(ISUB.EQ.86) THEN C...g + g -> J/Psi + g FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)* & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/ & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQG ENDIF ELSEIF(ISUB.EQ.87) THEN C...g + g -> chi_0c + g PGTW=(SH*TH+TH*UH+UH*SH)/SH2 QGTW=(SH*TH*UH)/SH**3 RGTW=SQM3/SH FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)* & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)- & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)- & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+ & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/ & (QGTW*(QGTW-RGTW*PGTW)**4) IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQG ENDIF ELSEIF(ISUB.EQ.88) THEN C...g + g -> chi_1c + g PGTW=(SH*TH+TH*UH+UH*SH)/SH2 QGTW=(SH*TH*UH)/SH**3 RGTW=SQM3/SH FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)* & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+ & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/ & (QGTW-RGTW*PGTW)**4 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQG ENDIF ELSEIF(ISUB.EQ.89) THEN C...g + g -> chi_2c + g PGTW=(SH*TH+TH*UH+UH*SH)/SH2 QGTW=(SH*TH*UH)/SH**3 RGTW=SQM3/SH FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)* & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)- & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+ & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+ & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2* & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4) IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQG ENDIF ENDIF C...D: Mimimum bias processes ELSEIF(ISUB.LE.100) THEN IF(ISUB.EQ.91) THEN C...Elastic scattering SIGS=VINT(315)*VINT(316)*SIGT(0,0,1) ELSEIF(ISUB.EQ.92) THEN C...Single diffractive scattering (first side, i.e. XB) SIGS=VINT(315)*VINT(316)*SIGT(0,0,2) ELSEIF(ISUB.EQ.93) THEN C...Single diffractive scattering (second side, i.e. AX) SIGS=VINT(315)*VINT(316)*SIGT(0,0,3) ELSEIF(ISUB.EQ.94) THEN C...Double diffractive scattering SIGS=VINT(315)*VINT(316)*SIGT(0,0,4) ELSEIF(ISUB.EQ.95) THEN C...Low-pT scattering SIGS=VINT(315)*VINT(316)*SIGT(0,0,5) ELSEIF(ISUB.EQ.96) THEN C...Multiple interactions: sum of QCD processes CALL PYWIDT(21,SH,WDTP,WDTE) C...q + q' -> q + q' FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA- & MSTP(34)*2D0/3D0*UH2/(SH*TH)) FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH) RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2) DO 1230 I=-5,5 IF(I.EQ.0) GOTO 1230 DO 1220 J=-5,5 IF(J.EQ.0) GOTO 1220 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=111 SIGH(NCHN)=FACQQ1 IF(I.EQ.-J) SIGH(NCHN)=FACQQB IF(I.EQ.J) THEN SIGH(NCHN)=0.5D0*FACQQ1*RATQQI NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=112 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI ENDIF 1220 CONTINUE 1230 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 1240 I=-5,5 IF(I.EQ.0) GOTO 1240 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 1240 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 1260 I=-5,5 IF(I.EQ.0) GOTO 1260 DO 1250 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 1250 CONTINUE 1260 CONTINUE C...g + g -> q + qbar (only d, u, s) IDC0=MDCY(21,2)-1 FLAVWT=0D0 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+ & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH)) IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+ & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH)) IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+ & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH)) FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* & UH2/SH2)*FLAVWT*FACA FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* & TH2/SH2)*FLAVWT*FACA NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=531 SIGH(NCHN)=FACQQ1 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=532 SIGH(NCHN)=FACQQ2 C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed C...cos(theta-hat) DO 1270 IFL=4,5 SQMAVG=PMAS(IFL,1)**2 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN BE34=SQRT(1D0-4D0*SQMAVG/SH) THQ=-0.5D0*SH*(1D0-BE34*CTH) UHQ=-0.5D0*SH*(1D0+BE34*CTH) THUHQ=THQ*UHQ-SQMAVG*SH IF(MSTP(34).EQ.0) THEN FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2 ELSE FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ) FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ) ENDIF IF(MSTP(5).GE.5) THEN FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDGGS+ & 2.25D0*THQ*UHQ/SH2*SQDLGS FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDGGS+ & 2.25D0*THQ*UHQ/SH2*SQDLGS ENDIF FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=531+2*(IFL-3) SIGH(NCHN)=FACQQ1 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=532+2*(IFL-3) SIGH(NCHN)=FACQQ2 ENDIF 1270 CONTINUE C...g + g -> g + g FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+ & 2D0*TH/SH+TH2/SH2)*FACA FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+ & 2D0*SH/UH+SH2/UH2)*FACA FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+ & 2D0*UH/TH+UH2/TH2) NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=681 SIGH(NCHN)=0.5D0*FACGG1 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=682 SIGH(NCHN)=0.5D0*FACGG2 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=683 SIGH(NCHN)=0.5D0*FACGG3 ELSEIF(ISUB.EQ.99) THEN C...f + gamma* -> f. IF(MINT(107).EQ.4) THEN Q2GA=VINT(307) P2GA=VINT(308) ISDE=2 ELSE Q2GA=VINT(308) P2GA=VINT(307) ISDE=1 ENDIF COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316) PM2RHO=PMAS(PYCOMP(113),1)**2 IF(MSTP(19).EQ.0) THEN COMFAC=COMFAC/Q2GA ELSEIF(MSTP(19).EQ.1) THEN COMFAC=COMFAC/(Q2GA+PM2RHO) ELSEIF(MSTP(19).EQ.2) THEN COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2 ELSE COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2 W2GA=VINT(2) IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2* & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2)) XGA=Q2GA/(W2GA+VINT(307)+VINT(308)) ELSE RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2* & Q2GA**0.57D0) XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2) ENDIF COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS)) IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA) ENDIF DO 1280 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 1280 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 1280 EI=KCHG(IABS(I),1)/3D0 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=COMFAC*EI**2 1280 CONTINUE 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 1290 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=HI*FACBW*HF 1290 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 1300 NCHN=NCHN+1 ISIG(NCHN,1)=22 ISIG(NCHN,2)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=HI*FACBW*HF 1300 CONTINUE ELSEIF(ISUB.EQ.104) THEN C...g + g -> chi_c0. KC=PYCOMP(10441) FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/ & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2) IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACBW ENDIF ELSEIF(ISUB.EQ.105) THEN C...g + g -> chi_c2. KC=PYCOMP(445) FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/ & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2) IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACBW ENDIF 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=DCMPLX(0D0,0D0) CIZTOT=DCMPLX(0D0,0D0) JMAX=3*MSTP(1)+1 DO 1310 J=1,JMAX IF(J.LE.2*MSTP(1)) THEN FNC=1D0 EJ=KCHG(J,1)/3D0 AJ=SIGN(1D0,EJ+0.1D0) VJ=AJ-4D0*EJ*XWV BALP=SQM4/(2D0*PMAS(J,1))**2 BBET=SH/(2D0*PMAS(J,1))**2 ELSEIF(J.LE.3*MSTP(1)) THEN FNC=3D0 JL=2*(J-2*MSTP(1))-1 EJ=KCHG(10+JL,1)/3D0 AJ=SIGN(1D0,EJ+0.1D0) VJ=AJ-4D0*EJ*XWV BALP=SQM4/(2D0*PMAS(10+JL,1))**2 BBET=SH/(2D0*PMAS(10+JL,1))**2 ELSE BALP=SQM4/(2D0*PMAS(24,1))**2 BBET=SH/(2D0*PMAS(24,1))**2 ENDIF BABI=1D0/(BALP-BBET) IF(BALP.LT.1D0) THEN F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0) F1ALP=F0ALP**2 ELSE F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))), & -DBLE(0.5D0*PARU(1))) F1ALP=-F0ALP**2 ENDIF F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP IF(BBET.LT.1D0) THEN F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0) F1BET=F0BET**2 ELSE F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))), & -DBLE(0.5D0*PARU(1))) F1BET=-F0BET**2 ENDIF F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET IF(J.LE.3*MSTP(1)) THEN FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+ & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP)) CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF ELSE TXW=XW/XW1 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)* & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+ & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP))) CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP* & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+ & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))* & (F1BET-F1ALP)) ENDIF 1310 CONTINUE CIGTOT=CIGTOT/DBLE(SH) CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ)) C...Loop over initial flavours DO 1320 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1320 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI) VI=AI-4D0*EI*XWV FCOI=1D0 IF(IABS(I).LE.10) FCOI=FACA/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)* & CIZTOT)**2+AI**2*ABS(CIZTOT)**2) 1320 CONTINUE ENDIF ELSEIF(ISUB.LE.120) THEN IF(ISUB.EQ.111) THEN C...f + fbar -> g + h0 (q + qbar -> g + h0 only) IF(MSTP(38).NE.0) THEN C...Simple case: only do gg <-> h exactly. CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE) FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))* & (TH**2+UH**2)/(SH*SQM4) C...Propagators: as simulated in PYOFSH and as desired HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) GMMHC=SQRT(SQM4)*WDTP(0) HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/ & ((SQM4-SQMH)**2+GMMHC**2) FACGH=FACGH*HBW4C/HBW4 ELSE C...Messy case: do full loop integrals A5STUR=0D0 A5STUI=0D0 DO 1330 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)) 1330 CONTINUE FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW* & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2) FACGH=FACGH*WIDS(25,2) ENDIF DO 1340 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1340 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACGH 1340 CONTINUE ELSEIF(ISUB.EQ.112) THEN C...f + g -> f + h0 (q + g -> q + h0 only) IF(MSTP(38).NE.0) THEN C...Simple case: only do gg <-> h exactly. CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE) FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))* & (SH**2+UH**2)/(-TH*SQM4) C...Propagators: as simulated in PYOFSH and as desired HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) GMMHC=SQRT(SQM4)*WDTP(0) HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/ & ((SQM4-SQMH)**2+GMMHC**2) FACQH=FACQH*HBW4C/HBW4 ELSE C...Messy case: do full loop integrals A5TSUR=0D0 A5TSUI=0D0 DO 1350 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)) 1350 CONTINUE FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW* & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2) FACQH=FACQH*WIDS(25,2) ENDIF DO 1370 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1370 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 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQH 1360 CONTINUE 1370 CONTINUE ELSEIF(ISUB.EQ.113) THEN C...g + g -> g + h0 IF(MSTP(38).NE.0) THEN C...Simple case: only do gg <-> h exactly. CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE) FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))* & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4) C...Propagators: as simulated in PYOFSH and as desired HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) GMMHC=SQRT(SQM4)*WDTP(0) HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/ & ((SQM4-SQMH)**2+GMMHC**2) FACGH=FACGH*HBW4C/HBW4 ELSE C...Messy case: do full loop integrals A2STUR=0D0 A2STUI=0D0 A2USTR=0D0 A2USTI=0D0 A2TUSR=0D0 A2TUSI=0D0 A4STUR=0D0 A4STUI=0D0 DO 1380 I=1,2*MSTP(1) SQMQ=PMAS(I,1)**2 EPSS=4D0*SQMQ/SH EPST=4D0*SQMQ/TH EPSU=4D0*SQMQ/UH EPSH=4D0*SQMQ/SQMH IF(EPSH.LT.1D-6) GOTO 1380 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 1380 CONTINUE FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3* & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+ & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2) FACGH=FACGH*WIDS(25,2) ENDIF IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1390 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACGH 1390 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 1400 I=1,IMAX EI=KCHG(IABS(I),1)/3D0 EIWT=EI**2 IF(ISUB.EQ.115) EIWT=EI SQMQ=PMAS(I,1)**2 EPSS=4D0*SQMQ/SH EPST=4D0*SQMQ/TH EPSU=4D0*SQMQ/UH IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+ & PARU(1)**2) B0STUI=0D0 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU) B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST) B1STUR=-1D0 B1STUI=0D0 B2STUR=-1D0 B2STUI=0D0 ELSE CALL PYWAUX(1,EPSS,W1SR,W1SI) CALL PYWAUX(1,EPST,W1TR,W1TI) CALL PYWAUX(1,EPSU,W1UR,W1UI) CALL PYWAUX(2,EPSS,W2SR,W2SI) CALL PYWAUX(2,EPST,W2TR,W2TI) CALL PYWAUX(2,EPSU,W2UR,W2UI) CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI) CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI) CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI) CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI) CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI) CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI) B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+ & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)- & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)- & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+ & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+ & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR) B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+ & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)- & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)- & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+ & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+ & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI) B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+ & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)- & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)- & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+ & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+ & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR) B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+ & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)- & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)- & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+ & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+ & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI) B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+ & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)- & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)- & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+ & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+ & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR) B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+ & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)- & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)- & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+ & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+ & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI) B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+ & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+ & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+ & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR) B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+ & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+ & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+ & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI) B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+ & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+ & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR) B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+ & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+ & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI) ENDIF A0STUR=A0STUR+EIWT*B0STUR A0STUI=A0STUI+EIWT*B0STUI A0TSUR=A0TSUR+EIWT*B0TSUR A0TSUI=A0TSUI+EIWT*B0TSUI A0UTSR=A0UTSR+EIWT*B0UTSR A0UTSI=A0UTSI+EIWT*B0UTSI A1STUR=A1STUR+EIWT*B1STUR A1STUI=A1STUI+EIWT*B1STUI A2STUR=A2STUR+EIWT*B2STUR A2STUI=A2STUI+EIWT*B2STUI 1400 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 1410 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 1410 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 1420 IA=KFPR(ISUBSV,2) PMF=PYMRUN(IA,SH) FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2* & (0.5D0*PMF/PMAS(24,1))**2 WID2=1D0 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1) FACQQH=FACQQH*WID2 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN IKFI=1 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2 IF(IA.GT.10) IKFI=3 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN FACQQH=FACQQH/(1D0+RMSS(41))**2 IF(IHIGG.NE.3) THEN FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/ & PARU(151+10*IHIGG))**2 ENDIF ENDIF ENDIF CALL PYQQBH(WTQQBH) CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) HS=SHR*WDTP(0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2) IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) & FACBW=0D0 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQH*WTQQBH*FACBW 1420 CONTINUE ELSEIF(ISUB.EQ.122) THEN C...q + qbar -> Q + Qbar + h0 IA=KFPR(ISUBSV,2) PMF=PYMRUN(IA,SH) FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2* & (0.5D0*PMF/PMAS(24,1))**2 WID2=1D0 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1) FACQQH=FACQQH*WID2 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN IKFI=1 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2 IF(IA.GT.10) IKFI=3 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN FACQQH=FACQQH/(1D0+RMSS(41))**2 IF(IHIGG.NE.3) THEN FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/ & PARU(151+10*IHIGG))**2 ENDIF ENDIF ENDIF CALL PYQQBH(WTQQBH) CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) HS=SHR*WDTP(0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2) IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) & FACBW=0D0 DO 1430 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1430 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQH*WTQQBH*FACBW 1430 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 1450 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1450 IA=IABS(I) DO 1440 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1440 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 1440 CONTINUE 1450 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 1470 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1470 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1) DO 1460 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1460 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1) IF(EI*EJ.GT.0D0) GOTO 1460 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 1460 CONTINUE 1470 CONTINUE ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only) PH=0D0 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0) & PH=VINT(3)**2 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0) & PH=VINT(4)**2 IF(ISUB.EQ.131) THEN FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2* & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2) ELSE FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH) ENDIF DO 1490 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 1490 EI=KCHG(IABS(I),1)/3D0 FACGQ=FGQ*EI**2 DO 1480 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1480 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1480 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACGQ 1480 CONTINUE 1490 CONTINUE ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN C...f + gamma*_(T,L) -> f + gamma PH=0D0 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0) & PH=VINT(3)**2 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0) & PH=VINT(4)**2 IF(ISUB.EQ.133) THEN FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2* & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2) ELSE FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH) ENDIF DO 1510 I=MMINA,MMAXA IF(I.EQ.0) GOTO 1510 EI=KCHG(IABS(I),1)/3D0 FACGQ=FGQ*EI**4 DO 1500 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1500 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1500 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACGQ 1500 CONTINUE 1510 CONTINUE ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only) PH=0D0 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0) & PH=VINT(3)**2 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0) & PH=VINT(4)**2 CALL PYWIDT(21,SH,WDTP,WDTE) WDTESU=0D0 DO 1520 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)) 1520 CONTINUE IF(ISUB.EQ.135) THEN FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2* & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2) ELSE FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH ENDIF IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ ENDIF IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=22 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ ENDIF ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar PH1=0D0 IF(VINT(3).LT.0D0) PH1=VINT(3)**2 PH2=0D0 IF(VINT(4).LT.0D0) PH2=VINT(4)**2 CALL PYWIDT(22,SH,WDTP,WDTE) WDTESU=0D0 DO 1530 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)) 1530 CONTINUE DLAMB2=(TH+UH)**2-4D0*PH1*PH2 IF(ISUB.EQ.137) THEN FPARAM=-SH*(TH+UH)/DLAMB2 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)* & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))- & 2D0*PH1*PH2*FPARAM**2) ELSEIF(ISUB.EQ.138) THEN FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)* & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+ & 2D0*PH1**2*(TH-UH)**2) ELSEIF(ISUB.EQ.139) THEN FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)* & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+ & 2D0*PH2**2*(TH-UH)**2) ELSE FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)* & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2 ENDIF IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=22 ISIG(NCHN,2)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=FACFF ENDIF ENDIF 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 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) VI=AI-4D0*EI*XWV IA=IABS(I) IF(IA.LT.10) THEN IF(IA.LE.2) THEN VPI=PARU(123-2*MOD(IABS(I),2)) API=PARU(124-2*MOD(IABS(I),2)) ELSEIF(IA.LE.4) THEN VPI=PARJ(182-2*MOD(IABS(I),2)) API=PARJ(183-2*MOD(IABS(I),2)) ELSE VPI=PARJ(190-2*MOD(IABS(I),2)) API=PARJ(191-2*MOD(IABS(I),2)) ENDIF ELSE IF(IA.LE.12) THEN VPI=PARU(127-2*MOD(IABS(I),2)) API=PARU(128-2*MOD(IABS(I),2)) ELSEIF(IA.LE.14) THEN VPI=PARJ(186-2*MOD(IABS(I),2)) API=PARJ(187-2*MOD(IABS(I),2)) ELSE VPI=PARJ(194-2*MOD(IABS(I),2)) API=PARJ(195-2*MOD(IABS(I),2)) ENDIF ENDIF HI0=HP0 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0 HI1=HP1 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0 HI2=HP2 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI* & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)* & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)* & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/ & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)* & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)* & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+ & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116)) 1540 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 1560 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1560 IA=IABS(I) DO 1550 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1550 JA=IABS(J) IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1550 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 1550 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 1550 CONTINUE 1560 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 1580 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1580 IA=IABS(I) IM=(MOD(IA,10)+1)/2 DO 1570 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1570 JA=IABS(J) JM=(MOD(JA,10)+1)/2 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 1570 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 1570 IF(MOD(IA,2).EQ.0) THEN IU=IA IL=JA ELSE IU=JA IL=IA ENDIF RML=PYMRUN(IL,SH)**2/SH RMU=PYMRUN(IU,SH)**2/SH HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2) IF(IA.LE.10) HI=HI*FACA/3D0 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4)) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=HI*FACBW*HF 1570 CONTINUE 1580 CONTINUE ELSEIF(ISUB.EQ.144) THEN C...f + fbar' -> R SQMR=PMAS(41,1)**2 CALL PYWIDT(41,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0 HP=AEM/(12D0*XW)*SH DO 1600 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1600 IA=IABS(I) DO 1590 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1590 JA=IABS(J) IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 1590 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 1590 CONTINUE 1600 CONTINUE ELSEIF(ISUB.EQ.145) THEN C...q + l -> LQ (leptoquark) SQMLQ=PMAS(42,1)**2 CALL PYWIDT(42,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2) IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0 HP=AEM/4D0*SH KFLQQ=KFDP(MDCY(42,2),1) KFLQL=KFDP(MDCY(42,2),2) DO 1620 I=MMIN1,MMAX1 IF(KFAC(1,I).EQ.0) GOTO 1620 IA=IABS(I) IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 1620 DO 1610 J=MMIN2,MMAX2 IF(KFAC(2,J).EQ.0) GOTO 1610 JA=IABS(J) IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 1610 IF(I*J.NE.KFLQQ*KFLQL) GOTO 1610 IF(JA.EQ.IA) GOTO 1610 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 1610 CONTINUE 1620 CONTINUE ELSEIF(ISUB.EQ.146) THEN C...e + gamma* -> e* (excited lepton) KFQSTR=KFPR(ISUB,1) KCQSTR=PYCOMP(KFQSTR) KFQEXC=MOD(KFQSTR,KEXCIT) CALL PYWIDT(KFQSTR,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2) QF=-PARU(157)/2D0-PARU(158)/2D0 FACBW=FACBW*AEM*QF**2*SH/PARU(155)**2 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2)) & FACBW=0D0 HP=SH DO 1640 I=-KFQEXC,KFQEXC,2*KFQEXC DO 1630 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 1630 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 1630 HI=HP IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4)) NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=22 ISIG(NCHN,3)=1 SIGH(NCHN)=HI*FACBW*HF 1630 CONTINUE 1640 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 1660 I=-KFQEXC,KFQEXC,2*KFQEXC DO 1650 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1650 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1650 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 1650 CONTINUE 1660 CONTINUE ELSEIF(ISUB.EQ.149) THEN C...g + g -> eta_tc KCTC=PYCOMP(KTECHN+331) CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2) IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0 HP=SH IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1670 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 1670 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) FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24 C...H propagator: as simulated in PYOFSH and as desired SQMHC=PMAS(37,1)**2 GMMHC=PMAS(37,1)*PMAS(37,2) HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2) CALL PYWIDT(37,SQM4,WDTP,WDTE) GMMHCC=SQRT(SQM4)*WDTP(0) HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2) FHCQ=FHCQ*HBW4C/HBW4 DO 1690 I=MMINA,MMAXA IA=IABS(I) IF(IA.NE.5) GOTO 1690 SQML=PYMRUN(IA,SH)**2 IUA=IA+MOD(IA,2) SQMQ=PYMRUN(IUA,SH)**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 1680 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1680 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,1).EQ.0) GOTO 1680 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2) 1680 CONTINUE 1690 CONTINUE ELSEIF(ISUB.EQ.162) THEN C...q + g -> LQ + lbar; LQ=leptoquark SQMLQ=PMAS(42,1)**2 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)* & (UH2+SQMLQ**2)/(UH-SQMLQ)**2 KFLQQ=KFDP(MDCY(42,2),1) DO 1710 I=MMINA,MMAXA IF(IABS(I).NE.KFLQQ) GOTO 1710 KCHLQ=ISIGN(1,I) DO 1700 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 1700 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 1700 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2) 1700 CONTINUE 1710 CONTINUE ELSEIF(ISUB.EQ.163) THEN C...g + g -> LQ + LQbar; LQ=leptoquark SQMLQ=PMAS(42,1)**2 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)* & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/ & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/ & ((TH-SQMLQ)*(UH-SQMLQ))) IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 1720 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 1720 CONTINUE ELSEIF(ISUB.EQ.164) THEN C...q + qbar -> LQ + LQbar; LQ=leptoquark DELTA=0.25D0*(SQM3-SQM4)**2/SH SQMLQ=0.5D0*(SQM3+SQM4)-DELTA TH=TH-DELTA UH=UH-DELTA C SQMLQ=PMAS(42,1)**2 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)* & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)* & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)* & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH)) KFLQQ=KFDP(MDCY(42,2),1) DO 1730 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1730 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 1730 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 1740 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1740 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 1740 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 1760 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1760 IA=IABS(I) DO 1750 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1750 JA=IABS(J) IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1750 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 1750 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 1750 CONTINUE 1760 CONTINUE ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks) KFQSTR=KFPR(ISUB,2) KCQSTR=PYCOMP(KFQSTR) KFQEXC=MOD(KFQSTR,KEXCIT) FACQSA=COMFAC*(SH/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 C...Branching ratios. BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0) BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0) DO 1780 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1780 DO 1770 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1770 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=2 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=2 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG ELSEIF(I.EQ.-J) THEN NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=2 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG ENDIF 1770 CONTINUE 1780 CONTINUE ELSEIF(ISUB.EQ.169) THEN C...q + qbar -> e + e* (excited lepton) KFQSTR=KFPR(ISUB,2) KCQSTR=PYCOMP(KFQSTR) KFQEXC=MOD(KFQSTR,KEXCIT) FACQSB=(COMFAC/6D0)*(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) FACQSB=FACQSB*HBW4C/HBW4 C...Branching ratios. BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0) BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0) DO 1790 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 1790 J=-I JA=IABS(J) IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 1790 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=2 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG 1790 CONTINUE ELSEIF(ISUB.EQ.191) THEN C...q + qbar -> rho_tc0. KCTC=PYCOMP(KTECHN+113) SQMRHT=PMAS(KCTC,1)**2 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2) IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) ALPRHT=2.91D0*(3D0/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 1800 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1800 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 1800 CONTINUE ELSEIF(ISUB.EQ.192) THEN C...q + qbar' -> rho_tc+/-. KCTC=PYCOMP(KTECHN+213) SQMRHT=PMAS(KCTC,1)**2 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2) IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0 ALPRHT=2.91D0*(3D0/PARP(144)) HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)* & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2) DO 1820 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1820 IA=IABS(I) DO 1810 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1810 JA=IABS(J) IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1810 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 1810 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 1810 CONTINUE 1820 CONTINUE ELSEIF(ISUB.EQ.193) THEN C...q + qbar -> omega_tc0. KCTC=PYCOMP(KTECHN+223) SQMOMT=PMAS(KCTC,1)**2 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2) IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) ALPRHT=2.91D0*(3D0/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 1830 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1830 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 1830 CONTINUE ELSEIF(ISUB.EQ.194) THEN C...f + fbar -> f' + fbar' via s-channel rho_tc and omega_tc. KFA=KFPR(ISUBSV,1) ALPRHT=2.91D0*(3D0/PARP(144)) HP=AEM**2*COMFAC TANW=SQRT(PARU(102)/(1D0-PARU(102))) CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW) QUPD=2D0*PARP(143)-1D0 FAR=SQRT(AEM/ALPRHT) FAO=FAR*QUPD FZR=FAR*CT2W FZO=-FAO*TANW SFAR=FAR**2 SFAO=FAO**2 SFZR=FZR**2 SFZO=FZO**2 CALL PYWIDT(23,SH,WDTP,WDTE) SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR) CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE) SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR) CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE) SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR) DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO- $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ DAA=(-Sfzr*SSMO - Sfzo*SSMR + SSMO*SSMR*SSMZ)/DETD/SH DZZ=(-Sfar*SSMO - Sfao*SSMR + SSMO*SSMR)/DETD/SH DAZ=(far*fzr*SSMO + fao*fzo*SSMR)/DETD/SH XWRHT=1D0/(4D0*XW*(1D0-XW)) KFF=IABS(KFPR(ISUB,1)) EF=KCHG(KFF,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV VALF=0.5D0*(VF+AF) VARF=0.5D0*(VF-AF) FCOF=1D0 IF(KFF.LE.10) FCOF=3D0 WID2=1D0 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1) IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1) DZZ=DZZ*DCMPLX(XWRHT,0D0) DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0) DO 1840 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1840 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV VALI=0.5D0*(VI+AI) VARI=0.5D0*(VI-AI) FCOI=FCOF IF(IABS(I).LE.10) FCOI=FCOI/3D0 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+ & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=HP*FCOI*FACSIG*WID2 1840 CONTINUE ELSEIF(ISUB.EQ.195) THEN C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+ KFA=KFPR(ISUBSV,1) KFB=KFA+1 ALPRHT=2.91D0*(3D0/PARP(144)) FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW)) CALL PYWIDT(24,SH,WDTP,WDTE) SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR) CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE) SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR) FCOF=1D0 IF(KFA.LE.8) FCOF=3D0 DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0) HP=FACTC*ABS(SSMR/DETD)**2/SH**2*FCOF DO 1860 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 1860 IA=IABS(I) DO 1850 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 1850 JA=IABS(J) IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1850 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 1850 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 HI=HP IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2) 1850 CONTINUE 1860 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 1890 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1890 EI=KCHG(IA,1)/3D0 TT3I=SIGN(1D0,EI+1D-6)/2D0 EJ=-1D0 TT3J=-1D0/2D0 FCOL=1D0 C...Color factor for e+ e- IF(IA.GE.11) FCOL=3D0 IF(ISUBSV.EQ.301) THEN A1=1D0 A2=0D0 ELSEIF(ILR.EQ.1) THEN A1=SFMIX(KFID,3)**2 A2=SFMIX(KFID,4)**2 ELSEIF(ILR.EQ.0) THEN A1=SFMIX(KFID,1)**2 A2=SFMIX(KFID,2)**2 ENDIF XLQ=(TT3J-EJ*XW)*A1 XRQ=(-EJ*XW)*A2 XLF=(TT3I-EI*XW) XRF=(-EI*XW) TAA=(EI*EJ)**2*(POLL+POLR) TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2) TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH) TNN=0.0D0 TAN=0.0D0 TZN=0.0D0 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN FAC2=SQRT(2D0) TNN1=0D0 TNN2=0D0 TNN3=0D0 DO 1880 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 1870 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) 1870 CONTINUE 1880 CONTINUE TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+ & A2**2*TNN2**2*POLR) TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+ & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)* & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR) TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)* & (1D0-SQMZ/SH)/SH TZN=TZN/XW**2/XW1 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+ & A2*TNN2*POLR)/XW ENDIF FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1+FACQQ2 1890 CONTINUE ELSEIF(ISUB.EQ.203) THEN C...f + fbar -> e_L + e_Rbar DO 1920 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1920 EI=KCHG(IABS(I),1)/3D0 TT3I=SIGN(1D0,EI)/2D0 EJ=-1 TT3J=-1D0/2D0 FCOL=1D0 C...Color factor for e+ e- IF(IA.GE.11) FCOL=3D0 A1=SFMIX(KFID,1)**2 A2=SFMIX(KFID,2)**2 XLQ=(TT3J-EJ*XW) XRQ=(-EJ*XW) XLF=(TT3I-EI*XW) XRF=(-EI*XW) TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2 & /XW**2/XW1**2*A1*A2 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2) TNN=0.0D0 TZN=0.0D0 TNNA=0D0 TNNB=0D0 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN FAC2=SQRT(2D0) TNN1=0D0 TNN2=0D0 TNN3=0D0 DO 1910 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 1900 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) 1900 CONTINUE 1910 CONTINUE TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL) TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0 TZN=(UH*TH-SQM3*SQM4)*A1*A2 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)* & (1D0-SQMZ/SH)/SH ENDIF FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0 C%%%%%%%%%%% NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),3) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=2 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) 1920 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 1940 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 1940 DO 1930 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 1930 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 1930 FCKM=3D0 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J) KCHW=2 IF(KCHSUM.LT.0) KCHW=3 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) ELSE FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW) ENDIF SIGH(NCHN)=FAC0*FAC1*FCKM*FACR 1930 CONTINUE 1940 CONTINUE ENDIF ELSEIF(ISUB.LE.220) THEN IF(ISUB.EQ.213) THEN C...f + fbar -> ~nu_L + ~nu_Lbar IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) ELSE FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1) ENDIF COMFAC=COMFAC*FACR PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ XLL=0.5D0 XLR=0.0D0 DO 1950 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1950 EI=KCHG(IA,1)/3D0 FCOL=1D0 C...Color factor for e+ e- IF(IA.GE.11) FCOL=3D0 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0 XRQ=-EI*XW TZC=0.0D0 TCC=0.0D0 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/ & (TH-SMW(2)**2) TCC=TZC**2 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL ENDIF FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2 FACQQ2=TZC+TCC/4D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC & *AEM**2*FCOL/3D0/XW**2 1950 CONTINUE ELSEIF(ISUB.EQ.216) THEN C...q + qbar -> ~chi0_1 + ~chi0_1 IF(IZID1.EQ.IZID2) THEN COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) ELSE COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) ENDIF FACXX=COMFAC*AEM**2/3D0/XW**2 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0 ZM12=SQM3 ZM22=SQM4 WU2 = (UH-ZM12)*(UH-ZM22) WT2 = (TH-ZM12)*(TH-ZM22) WS2 = SMZ(IZID1)*SMZ(IZID2)*SH PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2) DO 1960 I=1,4 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I)) IF(IZID2.NE.IZID1) THEN ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I)) ENDIF 1960 CONTINUE OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))- & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0 ORPP=DCONJG(OLPP) DO 1970 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1970 EI=KCHG(IABS(I),1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))* & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1)) GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2) QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ) & /DCMPLX(TH-XML2) QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2) QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ & -DCONJG(GRIJ)/DCMPLX(UH-XMR2) FCOL=1D0 IF(IABS(I).GE.11) FCOL=3D0 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+ & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+ & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+ & QRL*DCONJG(QRR)*POLR)*WS2 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACXX*FACGG1*FCOL 1970 CONTINUE ENDIF ELSEIF(ISUB.LE.230) THEN IF(ISUB.EQ.226) THEN C...f + fbar -> ~chi+_1 + ~chi-_1 FACXX=COMFAC*AEM**2/3D0 ZM12=SQM3 ZM22=SQM4 WU2 = (UH-ZM12)*(UH-ZM22) WT2 = (TH-ZM12)*(TH-ZM22) WS2 = SMW(IZID1)*SMW(IZID2)*SH PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2) DIFF=0D0 IF(IZID1.EQ.IZID2) DIFF=1D0 DO 1980 I=1,2 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I)) UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I)) IF(IZID2.NE.IZID1) THEN VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I)) UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I)) ENDIF 1980 CONTINUE OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))- & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF) ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))- & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF) DO 1990 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 1990 EI=KCHG(IABS(I),1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP IF(MOD(I,2).EQ.0) THEN XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)* & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))* & DCMPLX(T3I/XW/(TH-XML2)) ELSE XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)* & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))* & DCMPLX(T3I/XW/(TH-XML2)) ENDIF FCOL=1D0 IF(IABS(I).GE.11) FCOL=3D0 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+ & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+ & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+ & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 IF(IZID1.EQ.IZID2) THEN SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) ELSE SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=2 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),3) ENDIF 1990 CONTINUE ELSEIF(ISUB.EQ.229) THEN C...q + qbar' -> ~chi0_1 + ~chi+-_1 FACXX=COMFAC*AEM**2/6D0/XW**2 ZM12=SQM3 ZM22=SQM4 WU2 = (UH-ZM12)*(UH-ZM22) WT2 = (TH-ZM12)*(TH-ZM22) WS2 = SMW(IZID1)*SMZ(IZID2)*SH RT2I = 1D0/SQRT(2D0) PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/ & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0) DO 2000 I=1,2 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I)) UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I)) 2000 CONTINUE DO 2010 I=1,4 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I)) 2010 CONTINUE OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)- & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+ & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW DO 2030 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 2030 EI=KCHG(IA,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 DO 2020 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 2020 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2020 EJ=KCHG(JA,1)/3D0 T3J=SIGN(1D0,EJ+1D-6)/2D0 FCKM=3D0 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J) KCHW=2 IF(KCHSUM.LT.0) KCHW=3 IF(MOD(IA,2).EQ.0) THEN ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)* & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2) QLR=OR-DCONJG(UMIXC(IZID1,1))*( & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J) & /DCMPLX(TH-ZMJ2) ELSE ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)* & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2) QLR=OR-DCONJG(UMIXC(IZID1,1))*( & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I) & /DCMPLX(TH-ZMI2) ENDIF ZINTR=DBLE(QLR*DCONJG(QLL)) FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+ & 2D0*ZINTR*WS2) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW) 2020 CONTINUE 2030 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 2040 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2040 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) 2040 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 2060 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 2060 DO 2050 J=MMIN2,MMAX2 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 2050 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2050 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) 2050 CONTINUE 2060 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 2070 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2070 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) 2070 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 2080 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 2080 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 2100 I=-KFNSQ,KFNSQ,2*KFNSQ IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 2100 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2100 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 2090 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2090 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2090 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) 2090 CONTINUE 2100 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 2120 I=-KFNSQ,KFNSQ,2*KFNSQ IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 2120 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2120 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 2110 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2110 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2110 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) 2110 CONTINUE 2120 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 2140 I=-KFNSQ,KFNSQ,2*KFNSQ IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 2140 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 2140 KCHQ=2 IF(I.LT.0) KCHQ=3 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) DO 2130 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2130 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2130 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 2130 CONTINUE 2140 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 2150 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2150 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 2150 CONTINUE ELSEIF(ISUB.EQ.263) THEN C...f + fbar -> ~t1 + ~t2bar DO 2160 I=MMIN1,MMAX1 IA=IABS(I) IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2160 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) 2160 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 2170 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 2170 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 2190 I=-KFNSQI,KFNSQI,2*KFNSQI IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 2190 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 2190 KCHQ=2 IF(I.LT.0) KCHQ=3 DO 2180 J=-KFNSQJ,KFNSQJ,2*KFNSQJ IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 2180 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 2180 IF(I*J.LT.0) GOTO 2180 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ) IF(I.EQ.J) THEN IF(ILR.EQ.0) THEN SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF* & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2) ELSE SIGH(NCHN)=0.5D0*FACQQ1*RKF* & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ) ENDIF NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=2 IF(ILR.EQ.0) THEN SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF* & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2) ELSE SIGH(NCHN)=0.5D0*FACQQ2*RKF* & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ) ENDIF ENDIF 2180 CONTINUE 2190 CONTINUE ELSEIF(ISUB.EQ.274) THEN C...q + qbar' -> ~q + ~qbar' XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2 XMT=XMG2-TH XMU=XMG2-UH IF(ILR.EQ.0) THEN C...Mrenna...Normalization.and.1/XMT FACQQ1=COMFAC*AS**2*2D0/9D0*( & (UH*TH-SQM3*SQM4)/XMT**2 ) FACQQB=COMFAC*AS**2*2D0/9D0*( & (UH*TH-SQM3*SQM4)/SH2*(2D0-2D0/3D0*SH/XMT)) 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 2210 I=-KFNSQI,KFNSQI,2*KFNSQI IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 2210 IA=IABS(I) IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 2210 KCHQ=2 IF(I.LT.0) KCHQ=3 DO 2200 J=-KFNSQJ,KFNSQJ,2*KFNSQJ IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 2200 JA=IABS(J) IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 2200 IF(I*J.GT.0) GOTO 2200 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) 2200 CONTINUE 2210 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 2220 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 2220 IF(IA.EQ.KFNSQ) GOTO 2220 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) 2220 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 2230 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) 2230 CONTINUE ENDIF CMRENNA-- ELSEIF(ISUB.LE.340) THEN ELSEIF(ISUB.LE.360) THEN IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN C...l + l -> H_L++/-- or H_R++/--. KFRES=KFPR(ISUB,1) KFREC=PYCOMP(KFRES) CALL PYWIDT(KFRES,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2) DO 2250 I=MMIN1,MMAX1 IA=IABS(I) IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0) & GOTO 2250 DO 2240 J=MMIN2,MMAX2 JA=IABS(J) IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0) & GOTO 2240 IF(I*J.LT.0) GOTO 2240 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1)) HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4)) SIGH(NCHN)=HI*FACBW*HF 2240 CONTINUE 2250 CONTINUE ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'. KFRES=KFPR(ISUB,1) KFREC=PYCOMP(KFRES) C...Propagators: as simulated in PYOFSH and as desired HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+ & (PMAS(KFREC,1)*PMAS(KFREC,2))**2) CALL PYWIDT(KFRES,SQM3,WDTP,WDTE) GMMC=SQRT(SQM3)*WDTP(0) HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2) FHCC=COMFAC*AEM*HBW3C/HBW3 DO 2270 I=MMINA,MMAXA IA=IABS(I) IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 2270 SQML=PMAS(IA,1)**2 J=ISIGN(KFPR(ISUB,2),-I) KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I)) WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0) SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/ & (UH-SQM3)**2 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH- & (TH-SQM4)*SH)/(TH-SQM4)**2 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)* & SH)/(SH-SQML)**2 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3- & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/ & ((UH-SQM3)*(TH-SQM4)) SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)* & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/ & ((UH-SQM3)*(SH-SQML)) SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)- & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/ & ((SH-SQML)*(TH-SQM4)) SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)* & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1)) DO 2260 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 2260 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 2260 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=22 ISIG(NCHN,3)=0 SIGH(NCHN)=FHCC*SMM*WIDSC 2260 CONTINUE 2270 CONTINUE ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R-- KFRES=KFPR(ISUB,1) KFREC=PYCOMP(KFRES) SQMH=PMAS(KFREC,1)**2 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2) C...Propagators: H++/-- as simulated in PYOFSH and as desired HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2) CALL PYWIDT(KFRES,SQM3,WDTP,WDTE) GMMH3=SQRT(SQM3)*WDTP(0) HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2) HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) CALL PYWIDT(KFRES,SQM4,WDTP,WDTE) GMMH4=SQRT(SQM4)*WDTP(0) HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2) C...Kinematical and coupling functions FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4) XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV)) C...Loop over allowed flavours DO 2280 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2280 EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV FCOI=1D0 IF(IABS(I).LE.10) FCOI=FACA/3D0 IF(ISUB.EQ.349) THEN HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2) IF(IABS(I).LT.10) THEN DSIGHH=8D0*AEM**2*(EI**2/SH2+ & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+ & (VI**2+AI**2)*XWHH**2*HBWZ) ELSE IAOFF=181+3*((IABS(I)-11)/2) HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/ & (4D0*PARU(1)) DSIGHH=8D0*AEM**2*(EI**2/SH2+ & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+ & (VI**2+AI**2)*XWHH**2*HBWZ)+ & 8D0*AEM*(EI*HSUM/(SH*TH)+ & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+ & 4D0*HSUM**2/TH2 ENDIF ELSE IF(IABS(I).LT.10) THEN DSIGHH=8D0*AEM**2*EI**2/SH2 ELSE IAOFF=181+3*((IABS(I)-11)/2) HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/ & (4D0*PARU(1)) DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+ & 4D0*HSUM**2/TH2 ENDIF ENDIF NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACHH*FCOI*DSIGHH 2280 CONTINUE ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process) KFRES=KFPR(ISUB,1) KFREC=PYCOMP(KFRES) SQMH=PMAS(KFREC,1)**2 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0* & PMAS(PYCOMP(9900024),1)**2 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219) FACPRT=1D0/((VINT(204)**2-VINT(215))* & (VINT(209)**2-VINT(216))) FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))* & (VINT(209)**2+2D0*VINT(218))) CALL PYWIDT(KFRES,SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2) IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2)) & FACBW=0D0 DO 2300 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2300 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 2300 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I) DO 2290 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2290 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 2290 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J) KCHH=KCHWI+KCHWJ IF(IABS(KCHH).NE.2) GOTO 2290 FACLR=VINT(180+I)*VINT(180+J) HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4)) IF(I.EQ.J.AND.IABS(I).GT.10) THEN FACPRP=0.5D0*(FACPRT+FACPRU)**2 ELSE FACPRP=FACPRT**2 ENDIF NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF 2290 CONTINUE 2300 CONTINUE ELSEIF(ISUB.EQ.353) THEN C...f + fbar -> Z_R0 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH DO 2310 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2310 IF(IABS(I).LE.8) THEN EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW) VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW ELSE AI=-(1D0-2D0*XW) VI=-1D0+4D0*XW ENDIF HI=HP*(VI**2+AI**2) IF(IABS(I).LE.10) HI=HI*FACA/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=HI*FACBW*HF 2310 CONTINUE ELSEIF(ISUB.EQ.354) THEN C...f + fbar' -> W_R+/- SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE) HS=SHR*WDTP(0) FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0 HP=AEM/(24D0*XW)*SH DO 2330 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2330 IA=IABS(I) DO 2320 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2320 JA=IABS(J) IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2320 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 2320 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 2320 CONTINUE 2330 CONTINUE ENDIF ELSEIF(ISUB.LE.380) THEN IF(ISUB.EQ.361) THEN C...f + fbar -> W_L W_L, W_L pi_tc, pi_tc pi_tc FACA=(SH**2*BE34**2-(TH-UH)**2) ALPRHT=2.91D0*(3D0/PARP(144)) HP=(1D0/12D0)*AEM*ALPRHT*CAB2*COMFAC*FACA*3D0 FAR=SQRT(AEM/ALPRHT) FAO=FAR*QUPD FZR=FAR*CT2W FZO=-FAO*TANW SFAR=FAR**2 SFAO=FAO**2 SFZR=FZR**2 SFZO=FZO**2 CALL PYWIDT(23,SH,WDTP,WDTE) SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR) CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE) SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR) CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE) SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR) DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO- $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH DO 2340 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2340 IA=IABS(I) EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV VALI=0.25D0*(VI+AI) VARI=0.25D0*(VI-AI) F2L=EI*DARHO+VALI*DZRHO/SQRT(XW*XW1) F2R=EI*DARHO+VARI*DZRHO/SQRT(XW*XW1) HI=ABS(F2L)**2+ABS(F2R)**2 IF(IA.LE.10) HI=HI/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 IF(KFA.EQ.KFB) THEN SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1) ELSE SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=2 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2) ENDIF 2340 CONTINUE ELSEIF(ISUB.EQ.364) THEN C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc', C...W pi_tc VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)/SQTV*SH AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*SH ALPRHT=2.91D0*(3D0/PARP(144)) HP=(1D0/24D0)*AEM**2*COMFAC*3D0 FAR=SQRT(AEM/ALPRHT) FAO=FAR*QUPD FZR=FAR*CT2W FZO=-FAO*TANW SFAR=FAR**2 SFAO=FAO**2 SFZR=FZR**2 SFZO=FZO**2 CALL PYWIDT(23,SH,WDTP,WDTE) SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR) CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE) SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR) CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE) SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR) DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO- $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ DARHO=(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)/DETD/SH DZRHO=(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH DAOME=(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)/DETD/SH DZOME=(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH DO 2350 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2350 IA=IABS(I) EI=KCHG(IABS(I),1)/3D0 AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*XWV VALI=0.25D0*(VI+AI) VARI=0.25D0*(VI-AI) F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC HI=HI+HJ IF(IA.LE.10) HI=HI/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 IF(ISUBSV.NE.368) THEN SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2) ELSE SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3) NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=2 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2) ENDIF 2350 CONTINUE ELSEIF(ISUB.EQ.370) THEN C...f + fbar' -> W_L Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc FACA=(SH**2*BE34**2-(TH-UH)**2) ALPRHT=2.91D0*(3D0/PARP(144)) HP=(1D0/24D0)*AEM*ALPRHT*CAB2*COMFAC*FACA*3D0/XW FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW)) CALL PYWIDT(24,SH,WDTP,WDTE) SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR) CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE) SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR) DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0) HP=HP*FWR**2/ABS(DETD)**2/SH**2 DO 2370 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2370 IA=IABS(I) DO 2360 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2360 JA=IABS(J) IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2360 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 2360 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 HI=HP IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)* & WIDS(PYCOMP(KFB),2) 2360 CONTINUE 2370 CONTINUE ELSEIF(ISUB.EQ.374) THEN C...f + fbar' -> gamma pi_tc VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)/SQTV*VRGP**2 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)/SQTA*ARGP**2 ALPRHT=2.91D0*(3D0/PARP(144)) HP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*(VFAC+AFAC)*SH FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW)) CALL PYWIDT(24,SH,WDTP,WDTE) SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR) CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE) SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR) DETD=SSMZ*SSMR-DCMPLX(FWR**2,0D0) HP=HP*FWR**2/ABS(DETD)**2/SH**2 DO 2390 I=MMIN1,MMAX1 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 2390 IA=IABS(I) DO 2380 J=MMIN2,MMAX2 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 2380 JA=IABS(J) IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 2380 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) & GOTO 2380 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 HI=HP IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=J ISIG(NCHN,3)=1 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)* & WIDS(PYCOMP(KFB),2) 2380 CONTINUE 2390 CONTINUE ENDIF ELSEIF(ISUB.LE.400) THEN IF(ISUB.EQ.391) THEN C...f + fbar -> G*. KFGSTR=KFPR(ISUB,1) KCGSTR=PYCOMP(KFGSTR) CALL PYWIDT(KFGSTR,SH,WDTP,WDTE) HS=SHR*WDTP(0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/ & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2) DO 2400 I=MMINA,MMAXA IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2400 HI=1D0 IF(IABS(I).LE.10) HI=HI*FACA/3D0 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACG*HI 2400 CONTINUE ELSEIF(ISUB.EQ.392) THEN C...g + g -> G*. KFGSTR=KFPR(ISUB,1) KCGSTR=PYCOMP(KFGSTR) CALL PYWIDT(KFGSTR,SH,WDTP,WDTE) HS=SHR*WDTP(0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/ & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2) IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 2410 NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACG 2410 CONTINUE ELSEIF(ISUB.EQ.393) THEN C...q + qbar -> g + G*. KFGSTR=KFPR(ISUB,2) KCGSTR=PYCOMP(KFGSTR) FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)* & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+ & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+ & 2D0*SH2/(TH*UH)) C...Propagators: as simulated in PYOFSH and as desired GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2) HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2) CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE) HS=SQRT(SQM4)*WDTP(0) HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2) FACG=FACG*HBW4C/HBW4 DO 2420 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2420 NCHN=NCHN+1 ISIG(NCHN,1)=I ISIG(NCHN,2)=-I ISIG(NCHN,3)=1 SIGH(NCHN)=FACG 2420 CONTINUE ELSEIF(ISUB.EQ.394) THEN C...q + g -> q + G*. KFGSTR=KFPR(ISUB,2) KCGSTR=PYCOMP(KFGSTR) FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)* & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+ & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+ & 2D0*TH2*TH/(UH*SH2)) C...Propagators: as simulated in PYOFSH and as desired GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2) HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2) CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE) HS=SQRT(SQM4)*WDTP(0) HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2) FACG=FACG*HBW4C/HBW4 DO 2440 I=MMINA,MMAXA IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2440 DO 2430 ISDE=1,2 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2430 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2430 NCHN=NCHN+1 ISIG(NCHN,ISDE)=I ISIG(NCHN,3-ISDE)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACG 2430 CONTINUE 2440 CONTINUE ELSEIF(ISUB.EQ.395) THEN C...g + g -> g + G*. KFGSTR=KFPR(ISUB,2) KCGSTR=PYCOMP(KFGSTR) FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)* & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+ & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH)) C...Propagators: as simulated in PYOFSH and as desired GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2) HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2) CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE) HS=SQRT(SQM4)*WDTP(0) HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2) FACG=FACG*HBW4C/HBW4 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN NCHN=NCHN+1 ISIG(NCHN,1)=21 ISIG(NCHN,2)=21 ISIG(NCHN,3)=1 SIGH(NCHN)=FACG ENDIF ENDIF ENDIF C...Multiply with parton distributions IF(ISUB.LE.90.OR.ISUB.GE.96) THEN DO 2450 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) 2450 CONTINUE ENDIF RETURN END C********************************************************************* C...PYPDFU C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon C...parton distributions according to a few different parametrizations. C...Note that what is coded is x times the probability distribution, C...i.e. xq(x,Q2) etc. SUBROUTINE PYPDFU(KF,X,Q2,XPQ) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/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.13.AND.KFA.NE.15.AND.KFA.NE.22.AND. &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND. &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND. &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND. &KFA.NE.310.AND.KFA.NE.130) THEN WRITE(MSTU(11),5100) KF RETURN ENDIF C...Electron (or muon or tau) parton distribution call. IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN CALL PYPDEL(KFA,X,Q2,XPEL) DO 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 P2=0D0 IF(VINT(120).LT.0D0) P2=VINT(120)**2 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,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 P2=0D0 IF(VINT(120).LT.0D0) P2=VINT(120)**2 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,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 QQ2=MAX(0D0,Q2MIN,Q2) IF(MSTP(57).EQ.0) QQ2=Q2MIN P2=0D0 IF(VINT(120).LT.0D0) P2=VINT(120)**2 IP2=MSTP(60) IF(MSTP(55).EQ.5004) THEN IF(5D0*P2.LT.QQ2.AND. & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND. & P2.GE.0D0.AND.P2.LT.10D0.AND. & XX.GT.1D-4.AND.XX.LT.1D0) THEN CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM, & BOT,TOP,GLU) ELSE UPV=0D0 DNV=0D0 USEA=0D0 DSEA=0D0 STR=0D0 CHM=0D0 BOT=0D0 TOP=0D0 GLU=0D0 ENDIF ELSE IF(P2.LT.QQ2) THEN CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM, & BOT,TOP,GLU) ELSE UPV=0D0 DNV=0D0 USEA=0D0 DSEA=0D0 STR=0D0 CHM=0D0 BOT=0D0 TOP=0D0 GLU=0D0 ENDIF ENDIF VINT(231)=Q2MIN XPQ(0)=GLU XPQ(1)=DNV XPQ(-1)=DNV XPQ(2)=UPV XPQ(-2)=UPV XPQ(3)=STR XPQ(-3)=STR XPQ(4)=CHM XPQ(-4)=CHM XPQ(5)=BOT XPQ(-5)=BOT XPQ(6)=TOP XPQ(-6)=TOP ELSE WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55) ENDIF C...Pion/gammaVDM parton distribution call. ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR. &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND. & MSTP(55).LE.12) THEN ISET=1+MOD(MSTP(55)-1,4) Q2MX=Q2 P2MX=0.36D0 IF(ISET.GE.3) P2MX=4.0D0 IF(MSTP(57).EQ.0) Q2MX=P2MX P2=0D0 IF(VINT(120).LT.0D0) P2=VINT(120)**2 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA) DO 150 KFL=-6,6 XPQ(KFL)=XPVMD(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 P2=0D0 IF(VINT(120).LT.0D0) P2=VINT(120)**2 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA) DO 170 KFL=-6,6 XPQ(KFL)=XPANL(KFL)+XPANH(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 P2=0D0 IF(VINT(120).LT.0D0) P2=VINT(120)**2 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,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.20) 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 C .... ALICE CALL PDFSET_ALICE(PARM,VALUE) MINT(93)=1000000+MSTP(51) ENDIF XX=X QQ=SQRT(MAX(0D0,Q2MIN,Q2)) IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN) C .... ALICE CALL STRUCTM_ALICE + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU) VINT(231)=Q2MIN XPQ(0)=GLU XPQ(1)=DNV+DSEA XPQ(-1)=DSEA XPQ(2)=UPV+USEA XPQ(-2)=USEA XPQ(3)=STR XPQ(-3)=STR XPQ(4)=CHM XPQ(-4)=CHM XPQ(5)=BOT XPQ(-5)=BOT XPQ(6)=TOP XPQ(-6)=TOP 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. C+++Do not rescale? IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN DO 250 KFL=-6,6 XPQ(KFL)=VINT(281)*XPQ(KFL) 250 CONTINUE VINT(232)=VINT(281)*XPV ENDIF C...Simple recipes for kaons. ELSEIF(KFA.EQ.321) THEN XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1) XPQ(-1)=XPQ(1) ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN XPS=0.5D0*(XPQ(1)+XPQ(-2)) XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS XPQ(2)=XPS XPQ(-1)=XPS XPQ(1)=XPQ(1)+0.5D0*XPV XPQ(-1)=XPQ(-1)+0.5D0*XPV XPQ(3)=XPQ(3)+0.5D0*XPV XPQ(-3)=XPQ(-3)+0.5D0*XPV 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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ C...Local arrays. DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3) DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/ C...Send everything but protons/neutrons/VMD pions directly to PYPDFU. MINT(92)=0 KFA=IABS(KF) IACC=0 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1 IF(IACC.EQ.0) THEN CALL PYPDFU(KF,X,Q2,XPQ) RETURN ENDIF C...Reset. Check x. DO 100 KFL=-25,25 XPQ(KFL)=0D0 100 CONTINUE IF(X.LE.0D0.OR.X.GE.1D0) THEN WRITE(MSTU(11),5000) X RETURN ENDIF C...Define valence content. KFC=KF NV1=2 NV2=1 IF(KF.EQ.2212) THEN KFV1=2 KFV2=1 ELSEIF(KF.EQ.-2212) THEN KFV1=-2 KFV2=-1 ELSEIF(KF.EQ.2112) THEN KFV1=1 KFV2=2 ELSEIF(KF.EQ.-2112) THEN KFV1=-1 KFV2=-2 ELSEIF(KF.EQ.211) THEN NV1=1 KFV1=2 KFV2=-1 ELSEIF(KF.EQ.-211) THEN NV1=1 KFV1=-2 KFV2=1 ELSEIF(MINT(105).LE.223) THEN KFV1=1 WTV1=0.2D0 KFV2=2 WTV2=0.8D0 ELSEIF(MINT(105).EQ.333) THEN KFV1=3 WTV1=1.0D0 KFV2=1 WTV2=0.0D0 ELSEIF(MINT(105).EQ.443) THEN KFV1=4 WTV1=1.0D0 KFV2=1 WTV2=0.0D0 ENDIF C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0. 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 (or muon, or tau) parton distribution. SUBROUTINE PYPDEL(KFA,X,Q2,XPEL) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ C...Local arrays. DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6) C...Interface to PDFLIB. COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX SAVE /W50513/ DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU, &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX CHARACTER*20 PARM(20) DATA VALUE/20*0D0/,PARM/20*' '/ C...Some common constants. DO 100 KFL=-25,25 XPEL(KFL)=0D0 100 CONTINUE AEM=PARU(101) PME=PMAS(11,1) IF(KFA.EQ.13) PME=PMAS(13,1) IF(KFA.EQ.15) PME=PMAS(15,1) XL=LOG(MAX(1D-10,X)) X1L=LOG(MAX(1D-10,1D0-X)) HLE=LOG(MAX(3D0,Q2/PME**2)) HBE2=(AEM/PARU(1))*(HLE-1D0) C...Electron inside electron, see R. Kleiss et al., in Z physics at C...LEP 1, CERN 89-08, p. 34 IF(MSTP(59).LE.1) THEN HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2* & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0) HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))- & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)- & 4D0*XL/(1D0-X)-5D0-X) ELSE HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/ & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)* & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X) ENDIF C...Zero distribution for very large x and rescale it for intermediate. IF(X.GT.1D0-1D-10) THEN HEE=0D0 ELSEIF(X.GT.1D0-1D-7) THEN HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0) ENDIF XPEL(KFA)=X*HEE C...Photon and (transverse) W- inside electron. AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2) IF(MSTP(13).LE.1) THEN HLG=HLE ELSE HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2)) ENDIF XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2) HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102)) XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2) C...Electron or positron inside photon inside electron. IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+ & 2D0*X*(1D0+X)*XL) XPEL(11)=XPEL(11)+XFSEA XPEL(-11)=XFSEA C...Initialize PDFLIB photon parton distributions. IF(MSTP(56).EQ.2) THEN PARM(1)='NPTYPE' VALUE(1)=3 PARM(2)='NGROUP' VALUE(2)=MSTP(55)/1000 PARM(3)='NSET' VALUE(3)=MOD(MSTP(55),1000) IF(MINT(93).NE.3000000+MSTP(55)) THEN CALL PDFSET(PARM,VALUE) MINT(93)=3000000+MSTP(55) ENDIF ENDIF C...Quarks and gluons inside photon inside electron: C...numerical convolution required. DO 110 KFL=0,6 SXP(KFL)=0D0 110 CONTINUE SUMXPP=0D0 ITER=-1 120 ITER=ITER+1 SUMXP=SUMXPP NSTP=2**(ITER-1) IF(ITER.EQ.0) NSTP=2 DO 130 KFL=0,6 SXP(KFL)=0.5D0*SXP(KFL) 130 CONTINUE WTSTP=0.5D0/NSTP IF(ITER.EQ.0) WTSTP=0.5D0 C...Pick grid of x_{gamma} values logarithmically even. DO 150 ISTP=1,NSTP IF(ITER.EQ.0) THEN XLE=XL*(ISTP-1) ELSE XLE=XL*(ISTP-0.5D0)/NSTP ENDIF XE=MIN(1D0-1D-10,EXP(XLE)) XG=MIN(1D0-1D-10,X/XE) C...Evaluate photon inside electron parton distribution for convolution. XPGP=1D0+(1D0-XE)**2 IF(MSTP(13).LE.1) THEN XPGP=XPGP*HLE ELSE XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2)) ENDIF C...Evaluate photon parton distributions for convolution. IF(MSTP(56).EQ.1) THEN 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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYDAT1/,/PYPARS/,/PYINT1/ C...Local arrays. DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3), &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3), &DGCS(4,3),DGDS(4,3),DGES(4,3) C...The following data lines are coefficients needed in the C...Drees and Grassie photon parton distribution parametrization. DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0, &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/ DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0, &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/ DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0, &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/ DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0, &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/ DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0, &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/ DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1, &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/ DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0, &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/ DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0, &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/ DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0, &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/ DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0, &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/ DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0, &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/ DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0, &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/ DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0, &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/ C...Photon parton distribution from Drees and Grassie. C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2. DO 100 KFL=-6,6 XPGA(KFL)=0D0 100 CONTINUE VINT(231)=1D0 IF(MSTP(57).LE.0) THEN T=LOG(1D0/0.16D0) ELSE T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0) ENDIF X1=1D0-X NF=3 IF(Q2.GT.25D0) NF=4 IF(Q2.GT.300D0) NF=5 NFE=NF-2 AEM=PARU(101) C...Evaluate gluon content. DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE)) DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE)) DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE)) XPGL=DGA*X**DGB*X1**DGC C...Evaluate up- and down-type quark content. DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE)) DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE)) DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE)) DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE)) DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE)) XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE)) DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE)) DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE)) DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE)) DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE)) DGF=9D0 IF(NF.EQ.4) DGF=10D0 IF(NF.EQ.5) DGF=55D0/6D0 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE IF(NF.LE.3) THEN XPQU=(XPQS+9D0*XPQN)/6D0 XPQD=(XPQS-4.5D0*XPQN)/6D0 ELSEIF(NF.EQ.4) THEN XPQU=(XPQS+6D0*XPQN)/8D0 XPQD=(XPQS-6D0*XPQN)/8D0 ELSE XPQU=(XPQS+7.5D0*XPQN)/10D0 XPQD=(XPQS-5D0*XPQN)/10D0 ENDIF C...Put into output arrays. XPGA(0)=AEM*XPGL XPGA(1)=AEM*XPQD XPGA(2)=AEM*XPQU XPGA(3)=AEM*XPQD IF(NF.GE.4) XPGA(4)=AEM*XPQU IF(NF.GE.5) XPGA(5)=AEM*XPQD DO 110 KFL=1,6 XPGA(-KFL)=XPGA(KFL) 110 CONTINUE RETURN END C********************************************************************* C...PYGGAM C...Constructs the F2 and parton distributions of the photon C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms. C...For F2, c and b are included by the Bethe-Heitler formula; C...in the 'MSbar' scheme additionally a Cgamma term is added. C...Contains the SaS sets 1D, 1M, 2D and 2M. C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6), &XPDIR(-6:6) COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6) SAVE /PYINT8/,/PYINT9/ C...Local arrays. DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6) C...Charm and bottom masses (low to compensate for J/psi etc.). DATA PMC/1.3D0/, PMB/4.6D0/ C...alpha_em and alpha_em/(2*pi). DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/ C...Lambda value for 4 flavours. DATA ALAM/0.20D0/ C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum. DATA FRACU/0.8D0/ C...VMD couplings f_V**2/(4*pi). DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/ C...Masses for rho (=omega) and phi. DATA PMRHO/0.770D0/, PMPHI/1.020D0/ C...Number of points in integration for IP2=1. DATA NSTEP/100/ C...Reset output. F2GM=0D0 DO 100 KFL=-6,6 XPDFGM(KFL)=0D0 XPVMD(KFL)=0D0 XPANL(KFL)=0D0 XPANH(KFL)=0D0 XPBEH(KFL)=0D0 XPDIR(KFL)=0D0 VXPVMD(KFL)=0D0 VXPANL(KFL)=0D0 VXPANH(KFL)=0D0 VXPDGM(KFL)=0D0 100 CONTINUE C...Set Q0 cut-off parameter as function of set used. IF(ISET.LE.2) THEN Q0=0.6D0 ELSE Q0=2D0 ENDIF Q02=Q0**2 C...Scale choice for off-shell photon; common factors. Q2A=Q2 FACNOR=1D0 IF(IP2.EQ.1) THEN P2MX=P2+Q02 Q2A=Q2+P2*Q02/MAX(Q02,Q2) FACNOR=LOG(Q2/Q02)/NSTEP ELSEIF(IP2.EQ.2) THEN P2MX=MAX(P2,Q02) ELSEIF(IP2.EQ.3) THEN P2MX=P2+Q02 Q2A=Q2+P2*Q02/MAX(Q02,Q2) ELSEIF(IP2.EQ.4) THEN P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/ & ((Q2+P2)*(Q02+P2))) ELSEIF(IP2.EQ.5) THEN P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/ & ((Q2+P2)*(Q02+P2))) P2MX=Q0*SQRT(P2MXA) FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX) ELSEIF(IP2.EQ.6) THEN P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/ & ((Q2+P2)*(Q02+P2))) P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02) ELSE P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/ & ((Q2+P2)*(Q02+P2))) P2MX=Q0*SQRT(P2MXA) P2MXB=P2MX P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02) P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA IF(ABS(Q2-Q02).GT.1D-6) THEN FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB) ELSEIF(P2.LT.Q02) THEN FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0) ELSE FACNOR=1D0 ENDIF ENDIF C...Call VMD parametrization for d quark and use to give rho, omega, C...phi. Note dipole dampening for off-shell photon. CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA) XFVAL=VXPGA(1) XPGA(1)=XPGA(2) XPGA(-1)=XPGA(-2) FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2 DO 110 KFL=-5,5 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL) 110 CONTINUE XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL XPVMD(3)=XPVMD(3)+FACS*XFVAL XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL XPVMD(-3)=XPVMD(-3)+FACS*XFVAL VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL VXPVMD(2)=FRACU*FACUD*XFVAL VXPVMD(3)=FACS*XFVAL VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL VXPVMD(-2)=FRACU*FACUD*XFVAL VXPVMD(-3)=FACS*XFVAL IF(IP2.NE.1) THEN C...Anomalous parametrizations for different strategies C...for off-shell photons; except full integration. C...Call anomalous parametrization for d + u + s. CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA) DO 120 KFL=-5,5 XPANL(KFL)=FACNOR*XPGA(KFL) VXPANL(KFL)=FACNOR*VXPGA(KFL) 120 CONTINUE C...Call anomalous parametrization for c and b. CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA) DO 130 KFL=-5,5 XPANH(KFL)=FACNOR*XPGA(KFL) VXPANH(KFL)=FACNOR*VXPGA(KFL) 130 CONTINUE CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA) DO 140 KFL=-5,5 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL) VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL) 140 CONTINUE ELSE C...Special option: loop over flavours and integrate over k2. DO 170 KF=1,5 DO 160 ISTEP=1,NSTEP Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP) IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR. & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA) FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0) IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0) DO 150 KFL=-5,5 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL) IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL) IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL) IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL) 150 CONTINUE 160 CONTINUE 170 CONTINUE ENDIF C...Call Bethe-Heitler term expression for charm and bottom. CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH) XPBEH(4)=XPBH XPBEH(-4)=XPBH CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH) XPBEH(5)=XPBH XPBEH(-5)=XPBH C...For MSbar subtraction call C^gamma term expression for d, u, s. IF(ISET.EQ.2.OR.ISET.EQ.4) THEN CALL PYGDIR(X,Q2,P2,Q02,XPGA) DO 180 KFL=-5,5 XPDIR(KFL)=XPGA(KFL) 180 CONTINUE ENDIF C...Store result in output array. DO 190 KFL=-5,5 CHSQ=1D0/9D0 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL) IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL) VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL) 190 CONTINUE RETURN END C********************************************************************* C...PYGVMD C...Evaluates the VMD parton distributions of a photon, C...evolved homogeneously from an initial scale P2 to Q2. C...Does not include dipole suppression factor. C...ISET is parton distribution set, see above; C...additionally ISET=0 is used for the evolution of an anomalous photon C...which branched at a scale P2 and then evolved homogeneously to Q2. C...ALAM is the 4-flavour Lambda, which is automatically converted C...to 3- and 5-flavour equivalents as needed. C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Local arrays and data. DIMENSION XPGA(-6:6), VXPGA(-6:6) DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/ C...Reset output. DO 100 KFL=-6,6 XPGA(KFL)=0D0 VXPGA(KFL)=0D0 100 CONTINUE KFA=IABS(KF) C...Calculate Lambda; protect against unphysical Q2 and P2 input. ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0) ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0) P2EFF=MAX(P2,1.2D0*ALAM3**2) IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2) IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2) Q2EFF=MAX(Q2,P2EFF) C...Find number of flavours at lower and upper scale. NFP=4 IF(P2EFF.LT.PMC**2) NFP=3 IF(P2EFF.GT.PMB**2) NFP=5 NFQ=4 IF(Q2EFF.LT.PMC**2) NFQ=3 IF(Q2EFF.GT.PMB**2) NFQ=5 C...Find s as sum of 3-, 4- and 5-flavour parts. S=0D0 IF(NFP.EQ.3) THEN Q2DIV=PMC**2 IF(NFQ.EQ.3) Q2DIV=Q2EFF S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2)) ENDIF IF(NFP.LE.4.AND.NFQ.GE.4) THEN P2DIV=P2EFF IF(NFP.EQ.3) P2DIV=PMC**2 Q2DIV=Q2EFF IF(NFQ.EQ.5) Q2DIV=PMB**2 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2)) ENDIF IF(NFQ.EQ.5) THEN P2DIV=PMB**2 IF(NFP.EQ.5) P2DIV=P2EFF S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2)) ENDIF C...Calculate frequent combinations of x and s. X1=1D0-X XL=-LOG(X) S2=S**2 S3=S**3 S4=S**4 C...Evaluate homogeneous anomalous parton distributions below or C...above threshold. IF(ISET.EQ.0) THEN IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN XVAL = X * 1.5D0 * (X**2+X1**2) XGLU = 0D0 XSEA = 0D0 ELSE XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 + & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 + & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) * & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S) XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) * & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) * & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL) XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) * & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) * & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL + & (2D0*X-1D0)*X*XL**2) ENDIF C...Evaluate set 1D parton distributions below or above threshold. ELSEIF(ISET.EQ.1) THEN IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0 XSEA = 0.100D0 * X1**3.76D0 ELSE XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) * & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S) XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) * & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 * & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) * & X**0.40D0 * X1**(1.76D0+3D0*S) XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/ & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) * & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S)) XSEA0 = 0.100D0 * X1**3.76D0 ENDIF C...Evaluate set 1M parton distributions below or above threshold. ELSEIF(ISET.EQ.2) THEN IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0 XSEA = 0D0 ELSE XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) * & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S) XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) * & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) * & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 * & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S) XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) * & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) * & XL**(2.8D0*S) XSEA0 = 0D0 ENDIF C...Evaluate set 2D parton distributions below or above threshold. ELSEIF(ISET.EQ.3) THEN IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X XGLU = 1.925D0 * X1**2 XSEA = 0.242D0 * X1**4 ELSE XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) * & X**(0.46D0+0.25D0*S) * & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) + & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S) XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) * & EXP(-18.67D0*S) * & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2)) & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) * & XL**(9.3D0*S/(1D0+1.7D0*S)) XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/ & (1D0-0.607D0*S+21.95D0*S2) * & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S XSEA0 = 0.242D0 * X1**4 ENDIF C...Evaluate set 2M parton distributions below or above threshold. ELSEIF(ISET.EQ.4) THEN IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X XGLU = 1.808D0 * X1**2 XSEA = 0.209D0 * X1**4 ELSE XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) * & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) * & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) * & XL**(5.15D0*S/(1D0+2D0*S)) + & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S) XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) * & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) * & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) * & XL**(10.9D0*S/(1D0+2.5D0*S)) XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) * & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) * & X1**(4D0+S) * XL**(0.45D0*S) XSEA0 = 0.209D0 * X1**4 ENDIF ENDIF C...Threshold factors for c and b sea. SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2)) XCHM=0D0 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2))) IF(ISET.EQ.0) THEN XCHM=XSEA*(1D0-(SCH/SLL)**2) ELSE XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL) ENDIF ENDIF XBOT=0D0 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2))) IF(ISET.EQ.0) THEN XBOT=XSEA*(1D0-(SBT/SLL)**2) ELSE XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL) ENDIF ENDIF C...Fill parton distributions. XPGA(0)=XGLU XPGA(1)=XSEA XPGA(2)=XSEA XPGA(3)=XSEA XPGA(4)=XCHM XPGA(5)=XBOT XPGA(KFA)=XPGA(KFA)+XVAL DO 110 KFL=1,5 XPGA(-KFL)=XPGA(KFL) 110 CONTINUE VXPGA(KFA)=XVAL VXPGA(-KFA)=XVAL RETURN END C********************************************************************* C...PYGANO C...Evaluates the parton distributions of the anomalous photon, C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2. C...KF=0 gives the sum over (up to) 5 flavours, C...KF<0 limits to flavours up to abs(KF), C...KF>0 is for flavour KF only. C...ALAM is the 4-flavour Lambda, which is automatically converted C...to 3- and 5-flavour equivalents as needed. C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Local arrays and data. DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5) DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/ C...Reset output. DO 100 KFL=-6,6 XPGA(KFL)=0D0 VXPGA(KFL)=0D0 100 CONTINUE IF(Q2.LE.P2) RETURN KFA=IABS(KF) C...Calculate Lambda; protect against unphysical Q2 and P2 input. ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2 ALAMSQ(4)=ALAM**2 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2 P2EFF=MAX(P2,1.2D0*ALAMSQ(3)) IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2) IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2) Q2EFF=MAX(Q2,P2EFF) XL=-LOG(X) C...Find number of flavours at lower and upper scale. NFP=4 IF(P2EFF.LT.PMC**2) NFP=3 IF(P2EFF.GT.PMB**2) NFP=5 NFQ=4 IF(Q2EFF.LT.PMC**2) NFQ=3 IF(Q2EFF.GT.PMB**2) NFQ=5 C...Define range of flavour loop. IF(KF.EQ.0) THEN KFLMN=1 KFLMX=5 ELSEIF(KF.LT.0) THEN KFLMN=1 KFLMX=KFA ELSE KFLMN=KFA KFLMX=KFA ENDIF C...Loop over flavours the photon can branch into. DO 110 KFL=KFLMN,KFLMX C...Light flavours: calculate t range and (approximate) s range. IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN TDIFF=LOG(Q2EFF/P2EFF) S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/ & LOG(P2EFF/ALAMSQ(NFQ))) IF(NFQ.GT.NFP) THEN Q2DIV=PMB**2 IF(NFQ.EQ.4) Q2DIV=PMC**2 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/ & LOG(P2EFF/ALAMSQ(NFQ))) SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/ & LOG(P2EFF/ALAMSQ(NFQ-1))) S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ) ENDIF IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN Q2DIV=PMC**2 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/ & LOG(P2EFF/ALAMSQ(4))) SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/ & LOG(P2EFF/ALAMSQ(3))) S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4) ENDIF C...u and s quark do not need a separate treatment when d has been done. ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN C...Charm: as above, but only include range above c threshold. ELSEIF(KFL.EQ.4) THEN IF(Q2.LE.PMC**2) GOTO 110 P2EFF=MAX(P2EFF,PMC**2) Q2EFF=MAX(Q2EFF,P2EFF) TDIFF=LOG(Q2EFF/P2EFF) S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/ & LOG(P2EFF/ALAMSQ(NFQ))) IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN Q2DIV=PMB**2 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/ & LOG(P2EFF/ALAMSQ(NFQ))) SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/ & LOG(P2EFF/ALAMSQ(NFQ-1))) S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ) ENDIF C...Bottom: as above, but only include range above b threshold. ELSEIF(KFL.EQ.5) THEN IF(Q2.LE.PMB**2) GOTO 110 P2EFF=MAX(P2EFF,PMB**2) Q2EFF=MAX(Q2,P2EFF) TDIFF=LOG(Q2EFF/P2EFF) S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/ & LOG(P2EFF/ALAMSQ(NFQ))) ENDIF C...Evaluate flavour-dependent prefactor (charge^2 etc.). CHSQ=1D0/9D0 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0 FAC=AEM2PI*2D0*CHSQ*TDIFF C...Evaluate parton distributions (normalized to unit momentum sum). IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 + & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 + & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) * & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S)) XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) * & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) * & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL) XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) * & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) * & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 + & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2) C...Threshold factors for c and b sea. SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2)) XCHM=0D0 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2))) XCHM=XSEA*(1D0-(SCH/SLL)**3) ENDIF XBOT=0D0 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2))) XBOT=XSEA*(1D0-(SBT/SLL)**3) ENDIF ENDIF C...Add contribution of each valence flavour. XPGA(0)=XPGA(0)+FAC*XGLU XPGA(1)=XPGA(1)+FAC*XSEA XPGA(2)=XPGA(2)+FAC*XSEA XPGA(3)=XPGA(3)+FAC*XSEA XPGA(4)=XPGA(4)+FAC*XCHM XPGA(5)=XPGA(5)+FAC*XBOT XPGA(KFL)=XPGA(KFL)+FAC*XVAL VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL 110 CONTINUE DO 120 KFL=1,5 XPGA(-KFL)=XPGA(KFL) VXPGA(-KFL)=VXPGA(KFL) 120 CONTINUE RETURN END C********************************************************************* C...PYGBEH C...Evaluates the Bethe-Heitler cross section for heavy flavour C...production. C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Local data. DATA AEM2PI/0.0011614D0/ C...Reset output. XPBH=0D0 SIGBH=0D0 C...Check kinematics limits. IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN W2=Q2*(1D0-X)/X-P2 BETA2=1D0-4D0*PM2/W2 IF(BETA2.LT.1D-10) RETURN BETA=SQRT(BETA2) RMQ=4D0*PM2/Q2 C...Simple case: P2 = 0. IF(P2.LT.1D-4) THEN IF(BETA.LT.0.99D0) THEN XBL=LOG((1D0+BETA)/(1D0-BETA)) ELSE XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2)) ENDIF SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+ & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2) C...Complicated case: P2 > 0, based on approximation of C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373 ELSE RPQ=1D0-4D0*X**2*P2/Q2 IF(RPQ.GT.1D-10) THEN RPBE=SQRT(RPQ*BETA2) IF(RPBE.LT.0.99D0) THEN XBL=LOG((1D0+RPBE)/(1D0-RPBE)) XBI=2D0*RPBE/(1D0-RPBE**2) ELSE RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2 XBL=LOG((1D0+RPBE)**2/RPBESN) XBI=2D0*RPBE/RPBESN ENDIF SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+ & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+ & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X) ENDIF ENDIF C...Multiply by charge-squared etc. to get parton distribution. CHSQ=1D0/9D0 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH RETURN END C********************************************************************* C...PYGDIR C...Evaluates the direct contribution, i.e. the C^gamma term, C...as needed in MSbar parametrizations. C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Local array and data. DIMENSION XPGA(-6:6) DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/ C...Reset output. DO 100 KFL=-6,6 XPGA(KFL)=0D0 100 CONTINUE C...Evaluate common x-dependent expression. XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X)) C...d, u, s part by simple charge factor. XPGA(1)=(1D0/9D0)*CGAM XPGA(2)=(4D0/9D0)*CGAM XPGA(3)=(1D0/9D0)*CGAM C...Also fill for antiquarks. DO 110 KF=1,5 XPGA(-KF)=XPGA(KF) 110 CONTINUE RETURN END C********************************************************************* C...PYPDPI C...Gives pi+ parton distribution according to two different C...parametrizations. SUBROUTINE PYPDPI(X,Q2,XPPI) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYDAT1/,/PYPARS/,/PYINT1/ C...Local arrays. DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6) C...The following data lines are coefficients needed in the C...Owens pion parton distribution parametrizations, see below. C...Expansion coefficients for up and down valence quark distributions. DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/ &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00, &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00, &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/ DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/ &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00, &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00, &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/ C...Expansion coefficients for gluon distribution. DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/ &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00, &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01, &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/ DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/ &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00, &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00, &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/ C...Expansion coefficients for (up+down+strange) quark sea distribution. DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/ &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00, &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00, &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/ DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/ &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00, &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01, &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/ C...Expansion coefficients for charm quark sea distribution. DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/ &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00, &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00, &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/ DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/ &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00, &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01, &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/ C...Euler's beta function, requires ordinary Gamma function EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y) C...Reset output array. DO 100 KFL=-6,6 XPPI(KFL)=0D0 100 CONTINUE IF(MSTP(53).LE.2) THEN C...Pion parton distributions from Owens. C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2. C...Determine set, Lambda and s expansion variable. NSET=MSTP(53) IF(NSET.EQ.1) ALAM=0.2D0 IF(NSET.EQ.2) ALAM=0.4D0 VINT(231)=4D0 IF(MSTP(57).LE.0) THEN SD=0D0 ELSE Q2IN=MIN(2D3,MAX(4D0,Q2)) SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2)) ENDIF C...Calculate parton distributions. DO 120 KFL=1,4 DO 110 IS=1,5 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+ & COW(3,IS,KFL,NSET)*SD**2 110 CONTINUE IF(KFL.EQ.1) THEN XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0) ELSE XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+ & TS(5)*X**2) ENDIF 120 CONTINUE C...Put into output array. XPPI(0)=XQ(2) XPPI(1)=XQ(3)/6D0 XPPI(2)=XQ(1)+XQ(3)/6D0 XPPI(3)=XQ(3)/6D0 XPPI(4)=XQ(4) XPPI(-1)=XQ(1)+XQ(3)/6D0 XPPI(-2)=XQ(3)/6D0 XPPI(-3)=XQ(3)/6D0 XPPI(-4)=XQ(4) C...Leading order pion parton distributions from Glueck, Reya and Vogt. C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and C...10^-5 < x < 1. ELSE C...Determine s expansion variable and some x expressions. VINT(231)=0.25D0 IF(MSTP(57).LE.0) THEN SD=0D0 ELSE Q2IN=MIN(1D8,MAX(0.25D0,Q2)) SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2)) ENDIF SD2=SD**2 XL=-LOG(X) XS=SQRT(X) C...Evaluate valence, gluon and sea distributions. XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)* & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD) XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0* & SD-0.175D0*SD2)+ & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+ & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0* & XL)))* & (1D0-X)**(0.390D0+1.053D0*SD) XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0- & X)**3.359D0* & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0* & XL))/ & XL**(2.538D0-0.763D0*SD) IF(SD.LE.0.888D0) THEN XFCHM=0D0 ELSE XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+ & 0.771D0*SD)* & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0* & XL)) ENDIF IF(SD.LE.1.351D0) THEN XFBOT=0D0 ELSE XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)* & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0* & XL)) ENDIF C...Put into output array. XPPI(0)=XFGLU XPPI(1)=XFSEA XPPI(2)=XFSEA XPPI(3)=XFSEA XPPI(4)=XFCHM XPPI(5)=XFBOT DO 130 KFL=1,5 XPPI(-KFL)=XPPI(KFL) 130 CONTINUE XPPI(2)=XPPI(2)+XFVAL XPPI(-1)=XPPI(-1)+XFVAL ENDIF RETURN END C********************************************************************* C...PYPDPR C...Gives proton parton distributions according to a few different C...parametrizations. SUBROUTINE PYPDPR(X,Q2,XPPR) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ C...Arrays and data. DIMENSION XPPR(-6:6),Q2MIN(16) DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0, &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/ C...Reset output array. DO 100 KFL=-6,6 XPPR(KFL)=0D0 100 CONTINUE C...Common preliminaries. NSET=MAX(1,MIN(16,MSTP(51))) IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6 VINT(231)=Q2MIN(NSET) IF(MSTP(57).EQ.0) THEN Q2L=Q2MIN(NSET) ELSE Q2L=MAX(Q2MIN(NSET),Q2) ENDIF IF(NSET.GE.1.AND.NSET.LE.3) THEN C...Interface to the CTEQ 3 parton distributions. QRT=SQRT(MAX(1D0,Q2L)) C...Loop over flavours. DO 110 I=-6,6 IF(I.LE.0) THEN XPPR(I)=PYCTEQ(NSET,I,X,QRT) ELSEIF(I.LE.2) THEN XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I) ELSE XPPR(I)=XPPR(-I) ENDIF 110 CONTINUE ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN C...Interface to the GRV 94 distributions. IF(NSET.EQ.4) THEN CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL) ELSEIF(NSET.EQ.5) THEN CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL) ELSE CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL) ENDIF C...Put into output array. XPPR(0)=GL XPPR(-1)=0.5D0*(UDB+DEL) XPPR(-2)=0.5D0*(UDB-DEL) XPPR(-3)=SB XPPR(-4)=CHM XPPR(-5)=BOT XPPR(1)=DV+XPPR(-1) XPPR(2)=UV+XPPR(-2) XPPR(3)=SB XPPR(4)=CHM XPPR(5)=BOT ELSEIF(NSET.EQ.7) THEN C...Interface to the CTEQ 5L parton distributions. C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by C...freezing x*f(x,Q2) at borders. QRT=SQRT(MAX(1D0,MIN(1D8,Q2L))) XIN=MAX(1D-6,MIN(1D0,X)) C...Loop over flavours (with u <-> d notation mismatch). SUMUDB=PYCT5L(-1,XIN,QRT) RATUDB=PYCT5L(-2,XIN,QRT) DO 120 I=-5,2 IF(I.EQ.1) THEN XPPR(I)=XIN*PYCT5L(2,XIN,QRT) ELSEIF(I.EQ.2) THEN XPPR(I)=XIN*PYCT5L(1,XIN,QRT) ELSEIF(I.EQ.-1) THEN XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB) ELSEIF(I.EQ.-2) THEN XPPR(I)=XIN*SUMUDB/(1D0+RATUDB) ELSE XPPR(I)=XIN*PYCT5L(I,XIN,QRT) IF(I.LT.0) XPPR(-I)=XPPR(I) ENDIF 120 CONTINUE ELSEIF(NSET.EQ.8) THEN C...Interface to the CTEQ 5M1 parton distributions. QRT=SQRT(MAX(1D0,MIN(1D8,Q2L))) XIN=MAX(1D-6,MIN(1D0,X)) C...Loop over flavours (with u <-> d notation mismatch). SUMUDB=PYCT5M(-1,XIN,QRT) RATUDB=PYCT5M(-2,XIN,QRT) DO 130 I=-5,2 IF(I.EQ.1) THEN XPPR(I)=XIN*PYCT5M(2,XIN,QRT) ELSEIF(I.EQ.2) THEN XPPR(I)=XIN*PYCT5M(1,XIN,QRT) ELSEIF(I.EQ.-1) THEN XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB) ELSEIF(I.EQ.-2) THEN XPPR(I)=XIN*SUMUDB/(1D0+RATUDB) ELSE XPPR(I)=XIN*PYCT5M(I,XIN,QRT) IF(I.LT.0) XPPR(-I)=XPPR(I) ENDIF 130 CONTINUE ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions: C...obsolete but offers backwards compatibility. CALL PYPDPO(X,Q2L,XPPR) C...Symmetric choice for debugging only ELSEIF(NSET.EQ.16) THEN XPPR(0)=.5D0/X XPPR(1)=.05D0/X XPPR(2)=.05D0/X XPPR(3)=.05D0/X XPPR(4)=.05D0/X XPPR(5)=.05D0/X XPPR(-1)=.05D0/X XPPR(-2)=.05D0/X XPPR(-3)=.05D0/X XPPR(-4)=.05D0/X XPPR(-5)=.05D0/X ENDIF RETURN END C********************************************************************* C...PYCTEQ C...Gives the CTEQ 3 parton distribution function sets in C...parametrized form, of October 24, 1994. C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens, C...J. Qiu, W.K. Tung and H. Weerts. FUNCTION PYCTEQ (ISET, IPRT, X, Q) C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...Data on Lambda values of fits, minimum Q and quark masses. DIMENSION ALM(3), QMS(4:6) DATA ALM / 0.177D0, 0.239D0, 0.247D0 / DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 / C....Check flavour thresholds. Set up QI for SB. IP = IABS(IPRT) IF(IP .GE. 4) THEN IF(Q .LE. QMS(IP)) THEN PYCTEQ = 0D0 RETURN ENDIF QI = QMS(IP) ELSE QI = QMN ENDIF C...Use "standard lambda" of parametrization program for expansion. ALAM = ALM (ISET) SBL = LOG(Q/ALAM) / LOG(QI/ALAM) SB = LOG (SBL) SB2 = SB*SB SB3 = SB2*SB C...Expansion for CTEQ3L. IF(ISET .EQ. 1) THEN IF(IPRT .EQ. 2) THEN A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2- & 0.3171D+00*SB3) A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3 ELSEIF(IPRT .EQ. 1) THEN A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+ & 0.7728D+00*SB3) A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3 ELSEIF(IPRT .EQ. 0) THEN A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+ & 0.5343D+00*SB3) A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3 ELSEIF(IPRT .EQ. -1) THEN A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2- & 0.2031D+01*SB3) A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3 ELSEIF(IPRT .EQ. -2) THEN A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2- & 0.9872D-01*SB3) A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3 ELSEIF(IPRT .EQ. -3) THEN A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+ & 0.8390D+00*SB3) A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3 ELSEIF(IPRT .EQ. -4) THEN A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB + & 0.1651D-01*SB2) A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3 ELSEIF(IPRT .EQ. -5) THEN A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB + & 0.3702D+01*SB2) A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3 ELSEIF(IPRT .EQ. -6) THEN A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB - & 0.6943D+00*SB2) A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3 ENDIF C...Expansion for CTEQ3M. ELSEIF(ISET .EQ. 2) THEN IF(IPRT .EQ. 2) THEN A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2- & 0.2935D+00*SB3) A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3 ELSEIF(IPRT .EQ. 1) THEN A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2- & 0.4305D-01*SB3) A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3 ELSEIF(IPRT .EQ. 0) THEN A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+ & 0.1037D-01*SB3) A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3 ELSEIF(IPRT .EQ. -1) THEN A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2- & 0.1602D+01*SB3) A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3 ELSEIF(IPRT .EQ. -2) THEN A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+ & 0.2496D+00*SB3) A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3 ELSEIF(IPRT .EQ. -3) THEN A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+ & 0.1936D+01*SB3) A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3 ELSEIF(IPRT .EQ. -4) THEN A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB + & 0.5348D+00*SB2) A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3 ELSEIF(IPRT .EQ. -5) THEN A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB + & 0.1569D+01*SB2) A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3 ELSEIF(IPRT .EQ. -6) THEN A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB + & 0.8838D+01*SB2) A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3 ENDIF C...Expansion for CTEQ3D. ELSEIF(ISET .EQ. 3) THEN IF(IPRT .EQ. 2) THEN A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2- & 0.2902D+00*SB3) A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3 ELSEIF(IPRT .EQ. 1) THEN A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+ & 0.7257D+00*SB3) A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3 ELSEIF(IPRT .EQ. 0) THEN A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2- & 0.2734D-04*SB3) A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3 ELSEIF(IPRT .EQ. -1) THEN A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2- & 0.1671D+01*SB3) A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3 ELSEIF(IPRT .EQ. -2) THEN A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+ & 0.2223D+00*SB3) A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3 ELSEIF(IPRT .EQ. -3) THEN A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+ & 0.1937D+01*SB3) A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3 ELSEIF(IPRT .EQ. -4) THEN A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB + & 0.5137D+00*SB2) A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3 ELSEIF(IPRT .EQ. -5) THEN A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB + & 0.2143D+01*SB2) A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3 ELSEIF(IPRT .EQ. -6) THEN A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB + & 0.9998D+01*SB2) A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3 ENDIF ENDIF C...Calculation of x * f(x, Q). PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4)) & *(LOG(1D0+1D0/X))**A5 ) RETURN END C********************************************************************* C...PYGRVL C...Gives the GRV 94 L (leading order) parton distribution function set C...in parametrized form. C...Authors: M. Glueck, E. Reya and A. Vogt. SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL) C...Double precision declaration. IMPLICIT DOUBLE PRECISION (A - Z) C...Common expressions. MU2 = 0.23D0 LAM2 = 0.2322D0 * 0.2322D0 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2)) DS = SQRT (S) S2 = S * S S3 = S2 * S C...uv : NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2 AKU = 0.590D0 - 0.024D0 * S BKU = 0.131D0 + 0.063D0 * S AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU) C...dv : ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2 AKD = 0.376D0 BKD = 0.486D0 + 0.062D0 * S AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD) C...del : NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2 AKE = 0.409D0 - 0.005D0 * S BKE = 0.799D0 + 0.071D0 * S AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2 CE = 0.0D0 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE) C...udb : ALX = 1.451D0 BEX = 0.271D0 AKX = 0.410D0 - 0.232D0 * S BKX = 0.534D0 - 0.457D0 * S AGX = 0.890D0 - 0.140D0 * S BGX = -0.981D0 CX = 0.320D0 + 0.683D0 * S DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2 EX = 4.119D0 + 1.713D0 * S ESX = 0.682D0 + 2.978D0 * S UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX, & DX, EX, ESX) C...sb : STS = 0D0 ALS = 0.914D0 BES = 0.577D0 AKS = 1.798D0 - 0.596D0 * S AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2 EST = 3.981D0 + 1.638D0 * S ESS = 6.402D0 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS) C...cb : STC = 0.888D0 ALC = 1.01D0 BEC = 0.37D0 AKC = 0D0 AC = 0D0 BC = 4.24D0 - 0.804D0 * S DCT = 3.46D0 - 1.076D0 * S ECT = 4.61D0 + 1.49D0 * S ESC = 2.555D0 + 1.961D0 * S CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC) C...bb : STB = 1.351D0 ALB = 1.00D0 BEB = 0.51D0 AKB = 0D0 AB = 0D0 BB = 1.848D0 DBT = 2.929D0 + 1.396D0 * S EBT = 4.71D0 + 1.514D0 * S ESB = 4.02D0 + 1.239D0 * S BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB) C...gl : ALG = 0.524D0 BEG = 1.088D0 AKG = 1.742D0 - 0.930D0 * S BKG = - 0.399D0 * S2 AG = 7.486D0 - 2.185D0 * S BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3 EG = 0.807D0 + 2.005D0 * S ESG = 3.841D0 + 0.316D0 * S GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, & DG, EG, ESG) RETURN END C********************************************************************* C...PYGRVM C...Gives the GRV 94 M (MSbar) parton distribution function set C...in parametrized form. C...Authors: M. Glueck, E. Reya and A. Vogt. SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL) C...Double precision declaration. IMPLICIT DOUBLE PRECISION (A - Z) C...Common expressions. MU2 = 0.34D0 LAM2 = 0.248D0 * 0.248D0 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2)) DS = SQRT (S) S2 = S * S S3 = S2 * S C...uv : NU = 1.304D0 + 0.863D0 * S AKU = 0.558D0 - 0.020D0 * S BKU = 0.183D0 * S AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU) C...dv : ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2 AKD = 0.270D0 - 0.019D0 * S BKD = 0.260D0 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD) C...del : NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3 AKE = 0.409D0 - 0.007D0 * S BKE = 0.782D0 + 0.082D0 * S AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2 CE = 0.0D0 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE) C...udb : ALX = 0.877D0 BEX = 0.561D0 AKX = 0.275D0 BKX = 0.0D0 AGX = 0.997D0 BGX = 3.210D0 - 1.866D0 * S CX = 7.300D0 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2 EX = 3.077D0 + 1.446D0 * S ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX, & DX, EX, ESX) C...sb : STS = 0D0 ALS = 0.756D0 BES = 0.216D0 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S AS = -4.329D0 + 1.131D0 * S BS = 9.568D0 - 1.744D0 * S DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2 EST = 3.031D0 + 1.639D0 * S ESS = 5.837D0 + 0.815D0 * S SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS) C...cb : STC = 0.820D0 ALC = 0.98D0 BEC = 0D0 AKC = -0.625D0 - 0.523D0 * S AC = 0D0 BC = 1.896D0 + 1.616D0 * S DCT = 4.12D0 + 0.683D0 * S ECT = 4.36D0 + 1.328D0 * S ESC = 0.677D0 + 0.679D0 * S CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC) C...bb : STB = 1.297D0 ALB = 0.99D0 BEB = 0D0 AKB = - 0.193D0 * S AB = 0D0 BB = 0D0 DBT = 3.447D0 + 0.927D0 * S EBT = 4.68D0 + 1.259D0 * S ESB = 1.892D0 + 2.199D0 * S BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB) C...gl : ALG = 1.014D0 BEG = 1.738D0 AKG = 1.724D0 + 0.157D0 * S BKG = 0.800D0 + 1.016D0 * S AG = 7.517D0 - 2.547D0 * S BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S CG = 4.039D0 + 1.491D0 * S DG = 3.404D0 + 0.830D0 * S EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2 ESG = 3.256D0 - 0.436D0 * S GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG) RETURN END C********************************************************************* C...PYGRVD C...Gives the GRV 94 D (DIS) parton distribution function set C...in parametrized form. C...Authors: M. Glueck, E. Reya and A. Vogt. SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL) C...Double precision declaration. IMPLICIT DOUBLE PRECISION (A - Z) C...Common expressions. MU2 = 0.34D0 LAM2 = 0.248D0 * 0.248D0 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2)) DS = SQRT (S) S2 = S * S S3 = S2 * S C...uv : NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2 AKU = 0.563D0 - 0.025D0 * S BKU = 0.054D0 + 0.154D0 * S AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU) C...dv : ND = 0.156D0 - 0.017D0 * S AKD = 0.299D0 - 0.022D0 * S BKD = 0.259D0 - 0.015D0 * S AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD) C...del : NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2 AKE = 0.419D0 - 0.013D0 * S BKE = 1.064D0 - 0.038D0 * S AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE) C...udb : ALX = 1.215D0 BEX = 0.466D0 AKX = 0.326D0 + 0.150D0 * S BKX = 0.956D0 + 0.405D0 * S AGX = 0.272D0 BGX = 3.794D0 - 2.359D0 * DS CX = 2.014D0 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2 EX = 3.049D0 + 1.597D0 * S ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX, & DX, EX, ESX) C...sb : STS = 0D0 ALS = 0.175D0 BES = 0.344D0 AKS = 1.415D0 - 0.641D0 * DS AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3 EST = 4.546D0 + 0.372D0 * S2 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS) C...cb : STC = 0.820D0 ALC = 0.98D0 BEC = 0D0 AKC = -0.625D0 - 0.523D0 * S AC = 0D0 BC = 1.896D0 + 1.616D0 * S DCT = 4.12D0 + 0.683D0 * S ECT = 4.36D0 + 1.328D0 * S ESC = 0.677D0 + 0.679D0 * S CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC) C...bb : STB = 1.297D0 ALB = 0.99D0 BEB = 0D0 AKB = - 0.193D0 * S AB = 0D0 BB = 0D0 DBT = 3.447D0 + 0.927D0 * S EBT = 4.68D0 + 1.259D0 * S ESB = 1.892D0 + 2.199D0 * S BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB) C...gl : ALG = 1.258D0 BEG = 1.846D0 AKG = 2.423D0 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2 AG = 25.09D0 - 7.935D0 * S BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S CG = 590.3D0 - 173.8D0 * S DG = 5.196D0 + 1.857D0 * S EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2 ESG = 3.232D0 - 0.542D0 * S GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG) RETURN END C********************************************************************* C...PYGRVV C...Auxiliary for the GRV 94 parton distribution functions C...for u and d valence and d-u sea. C...Authors: M. Glueck, E. Reya and A. Vogt. FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D) C...Double precision declaration. IMPLICIT DOUBLE PRECISION (A - Z) C...Evaluation. DX = SQRT (X) PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) * & (1D0- X)**D RETURN END C********************************************************************* C...PYGRVW C...Auxiliary for the GRV 94 parton distribution functions C...for d+u sea and gluon. C...Authors: M. Glueck, E. Reya and A. Vogt. FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES) C...Double precision declaration. IMPLICIT DOUBLE PRECISION (A - Z) C...Evaluation. LX = LOG (1D0/X) PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D RETURN END C********************************************************************* C...PYGRVS C...Auxiliary for the GRV 94 parton distribution functions C...for s, c and b sea. C...Authors: M. Glueck, E. Reya and A. Vogt. FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES) C...Double precision declaration. IMPLICIT DOUBLE PRECISION (A - Z) C...Evaluation. IF(S.LE.STH) THEN PYGRVS = 0D0 ELSE DX = SQRT (X) LX = LOG (1D0/X) PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) * & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX)) ENDIF RETURN END C********************************************************************* C...PYCT5L C...Auxiliary function for parametrization of CTEQ5L. C...Author: J. Pumplin 9/99. C...CTEQ5M1 and CTEQ5L Parton Distribution Functions C...in Parametrized Form C... September 15, 1999 C C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON: C... CTEQ5 PPARTON DISTRIBUTIONS" C...hep-ph/9903282 C...The CTEQ5M1 set given here is an updated version of the original C...CTEQ5M set posted, in the table version, on the Web page of CTEQ. C...The differences between CTEQ5M and CTEQ5M1 are insignificant for C...almost all applications. C...The improvement is in the QCD evolution which is now more C...accurate, and which agrees completely with the benchmark work C...of the HERA 96/97 Workshop. C...The differences between the parametrized and the corresponding C...table versions (on which it is based) are of similar order as C...between the two version. C...!! Because accurate parametrizations over a wide range of (x,Q) C...is hard to obtain, only the most widely used sets CTEQ5M and C...CTEQ5L are available in parametrized form for now. C...These parametrizations were obtained by Jon Pumplin. C Iset PDF Description Alpha_s(Mz) Lam4 Lam5 C ------------------------------------------------------------------- C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226 C 3 CTEQ5L Leading Order 0.127 192 146 C ------------------------------------------------------------------- C...Note the Qcd-lambda values given for CTEQ5L is for the leading C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute C...calibration. C...The two Iset value are adopted to agree with the standard table C...versions. C...Range of validity: C...The range of (x, Q) covered by this parametrization of the QCD C...evolved parton distributions is 1E-6 < x < 1 ; C...1.1 GeV < Q < 10 TeV. Of course, the PDF's are constrained by C...data only in a subset of that region; and the assumed DGLAP C...evolution is unlikely to be valid for all of it either. C...The range of (x, Q) used in the CTEQ5 round of global analysis is C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data. FUNCTION PYCT5L(IFL,X,Q) C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) PARAMETER (NEX=8, NLF=2) DIMENSION AM(0:NEX,0:NLF,-5:2) DIMENSION ALFVEC(-5:2), QMAVEC(-5:2) DIMENSION MEXVEC(-5:2), MLFVEC(-5:2) DIMENSION UT1VEC(-5:2), UT2VEC(-5:2) DIMENSION AF(0:NEX) DATA MEXVEC( 2) / 8 / DATA MLFVEC( 2) / 2 / DATA UT1VEC( 2) / 0.4971265E+01 / DATA UT2VEC( 2) / -0.1105128E+01 / DATA ALFVEC( 2) / 0.2987216E+00 / DATA QMAVEC( 2) / 0.0000000E+00 / DATA (AM( 0,K, 2),K=0, 2) & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 / DATA (AM( 1,K, 2),K=0, 2) & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 / DATA (AM( 2,K, 2),K=0, 2) & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 / DATA (AM( 3,K, 2),K=0, 2) & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 / DATA (AM( 4,K, 2),K=0, 2) & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 / DATA (AM( 5,K, 2),K=0, 2) & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 / DATA (AM( 6,K, 2),K=0, 2) & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 / DATA (AM( 7,K, 2),K=0, 2) & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 / DATA (AM( 8,K, 2),K=0, 2) & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 / DATA MEXVEC( 1) / 8 / DATA MLFVEC( 1) / 2 / DATA UT1VEC( 1) / 0.2612618E+01 / DATA UT2VEC( 1) / -0.1258304E+06 / DATA ALFVEC( 1) / 0.3407552E+00 / DATA QMAVEC( 1) / 0.0000000E+00 / DATA (AM( 0,K, 1),K=0, 2) & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 / DATA (AM( 1,K, 1),K=0, 2) & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 / DATA (AM( 2,K, 1),K=0, 2) & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 / DATA (AM( 3,K, 1),K=0, 2) & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 / DATA (AM( 4,K, 1),K=0, 2) & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 / DATA (AM( 5,K, 1),K=0, 2) & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 / DATA (AM( 6,K, 1),K=0, 2) & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 / DATA (AM( 7,K, 1),K=0, 2) & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 / DATA (AM( 8,K, 1),K=0, 2) & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 / DATA MEXVEC( 0) / 8 / DATA MLFVEC( 0) / 2 / DATA UT1VEC( 0) / -0.4656819E+00 / DATA UT2VEC( 0) / -0.2742390E+03 / DATA ALFVEC( 0) / 0.4491863E+00 / DATA QMAVEC( 0) / 0.0000000E+00 / DATA (AM( 0,K, 0),K=0, 2) & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 / DATA (AM( 1,K, 0),K=0, 2) & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 / DATA (AM( 2,K, 0),K=0, 2) & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 / DATA (AM( 3,K, 0),K=0, 2) & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 / DATA (AM( 4,K, 0),K=0, 2) & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 / DATA (AM( 5,K, 0),K=0, 2) & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 / DATA (AM( 6,K, 0),K=0, 2) & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 / DATA (AM( 7,K, 0),K=0, 2) & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 / DATA (AM( 8,K, 0),K=0, 2) & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 / DATA MEXVEC(-1) / 8 / DATA MLFVEC(-1) / 2 / DATA UT1VEC(-1) / 0.3862583E+01 / DATA UT2VEC(-1) / -0.1265969E+01 / DATA ALFVEC(-1) / 0.2457668E+00 / DATA QMAVEC(-1) / 0.0000000E+00 / DATA (AM( 0,K,-1),K=0, 2) & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 / DATA (AM( 1,K,-1),K=0, 2) & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 / DATA (AM( 2,K,-1),K=0, 2) & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 / DATA (AM( 3,K,-1),K=0, 2) & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 / DATA (AM( 4,K,-1),K=0, 2) & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 / DATA (AM( 5,K,-1),K=0, 2) & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 / DATA (AM( 6,K,-1),K=0, 2) & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 / DATA (AM( 7,K,-1),K=0, 2) & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 / DATA (AM( 8,K,-1),K=0, 2) & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 / DATA MEXVEC(-2) / 7 / DATA MLFVEC(-2) / 2 / DATA UT1VEC(-2) / 0.1895615E+00 / DATA UT2VEC(-2) / -0.3069097E+01 / DATA ALFVEC(-2) / 0.5293999E+00 / DATA QMAVEC(-2) / 0.0000000E+00 / DATA (AM( 0,K,-2),K=0, 2) & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 / DATA (AM( 1,K,-2),K=0, 2) & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 / DATA (AM( 2,K,-2),K=0, 2) & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 / DATA (AM( 3,K,-2),K=0, 2) & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 / DATA (AM( 4,K,-2),K=0, 2) & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 / DATA (AM( 5,K,-2),K=0, 2) & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 / DATA (AM( 6,K,-2),K=0, 2) & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 / DATA (AM( 7,K,-2),K=0, 2) & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 / DATA MEXVEC(-3) / 7 / DATA MLFVEC(-3) / 2 / DATA UT1VEC(-3) / 0.3753257E+01 / DATA UT2VEC(-3) / -0.1113085E+01 / DATA ALFVEC(-3) / 0.3713141E+00 / DATA QMAVEC(-3) / 0.0000000E+00 / DATA (AM( 0,K,-3),K=0, 2) & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 / DATA (AM( 1,K,-3),K=0, 2) & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 / DATA (AM( 2,K,-3),K=0, 2) & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 / DATA (AM( 3,K,-3),K=0, 2) & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 / DATA (AM( 4,K,-3),K=0, 2) & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 / DATA (AM( 5,K,-3),K=0, 2) & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 / DATA (AM( 6,K,-3),K=0, 2) & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 / DATA (AM( 7,K,-3),K=0, 2) & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 / DATA MEXVEC(-4) / 7 / DATA MLFVEC(-4) / 2 / DATA UT1VEC(-4) / 0.4400772E+01 / DATA UT2VEC(-4) / -0.1356116E+01 / DATA ALFVEC(-4) / 0.3712017E-01 / DATA QMAVEC(-4) / 0.1300000E+01 / DATA (AM( 0,K,-4),K=0, 2) & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 / DATA (AM( 1,K,-4),K=0, 2) & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 / DATA (AM( 2,K,-4),K=0, 2) & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 / DATA (AM( 3,K,-4),K=0, 2) & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 / DATA (AM( 4,K,-4),K=0, 2) & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 / DATA (AM( 5,K,-4),K=0, 2) & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 / DATA (AM( 6,K,-4),K=0, 2) & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 / DATA (AM( 7,K,-4),K=0, 2) & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 / DATA MEXVEC(-5) / 6 / DATA MLFVEC(-5) / 2 / DATA UT1VEC(-5) / 0.5562568E+01 / DATA UT2VEC(-5) / -0.1801317E+01 / DATA ALFVEC(-5) / 0.4952010E-02 / DATA QMAVEC(-5) / 0.4500000E+01 / DATA (AM( 0,K,-5),K=0, 2) & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 / DATA (AM( 1,K,-5),K=0, 2) & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 / DATA (AM( 2,K,-5),K=0, 2) & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 / DATA (AM( 3,K,-5),K=0, 2) & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 / DATA (AM( 4,K,-5),K=0, 2) & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 / DATA (AM( 5,K,-5),K=0, 2) & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 / DATA (AM( 6,K,-5),K=0, 2) & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 / IF(Q .LE. QMAVEC(IFL)) THEN PYCT5L = 0.D0 RETURN ENDIF IF(X .GE. 1.D0) THEN PYCT5L = 0.D0 RETURN ENDIF TMP = LOG(Q/ALFVEC(IFL)) IF(TMP .LE. 0.D0) THEN PYCT5L = 0.D0 RETURN ENDIF SB = LOG(TMP) SB1 = SB - 1.2D0 SB2 = SB1*SB1 DO 110 I = 0, NEX AF(I) = 0.D0 SBX = 1.D0 DO 100 K = 0, MLFVEC(IFL) AF(I) = AF(I) + SBX*AM(I,K,IFL) SBX = SB1*SBX 100 CONTINUE 110 CONTINUE Y = -LOG(X) U = LOG(X/0.00001D0) PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U) PART2 = AF(0)*(1.D0 - X) + AF(3)*X PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X)) PART4 = UT1VEC(IFL)*LOG(1.D0-X) + & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X) PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4) C...Include threshold factor. PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q) RETURN END C********************************************************************* C...PYCT5M C...Auxiliary function for parametrization of CTEQ5M1. C...Author: J. Pumplin 9/99. FUNCTION PYCT5M(IFL,X,Q) C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) PARAMETER (NEX=8, NLF=2) DIMENSION AM(0:NEX,0:NLF,-5:2) DIMENSION ALFVEC(-5:2), QMAVEC(-5:2) DIMENSION MEXVEC(-5:2), MLFVEC(-5:2) DIMENSION UT1VEC(-5:2), UT2VEC(-5:2) DIMENSION AF(0:NEX) DATA MEXVEC( 2) / 8 / DATA MLFVEC( 2) / 2 / DATA UT1VEC( 2) / 0.5141718E+01 / DATA UT2VEC( 2) / -0.1346944E+01 / DATA ALFVEC( 2) / 0.5260555E+00 / DATA QMAVEC( 2) / 0.0000000E+00 / DATA (AM( 0,K, 2),K=0, 2) & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 / DATA (AM( 1,K, 2),K=0, 2) & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 / DATA (AM( 2,K, 2),K=0, 2) & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 / DATA (AM( 3,K, 2),K=0, 2) & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 / DATA (AM( 4,K, 2),K=0, 2) & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 / DATA (AM( 5,K, 2),K=0, 2) & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 / DATA (AM( 6,K, 2),K=0, 2) & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 / DATA (AM( 7,K, 2),K=0, 2) & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 / DATA (AM( 8,K, 2),K=0, 2) & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 / DATA MEXVEC( 1) / 8 / DATA MLFVEC( 1) / 2 / DATA UT1VEC( 1) / 0.4138426E+01 / DATA UT2VEC( 1) / -0.3221374E+01 / DATA ALFVEC( 1) / 0.4960962E+00 / DATA QMAVEC( 1) / 0.0000000E+00 / DATA (AM( 0,K, 1),K=0, 2) & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 / DATA (AM( 1,K, 1),K=0, 2) & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 / DATA (AM( 2,K, 1),K=0, 2) & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 / DATA (AM( 3,K, 1),K=0, 2) & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 / DATA (AM( 4,K, 1),K=0, 2) & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 / DATA (AM( 5,K, 1),K=0, 2) & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 / DATA (AM( 6,K, 1),K=0, 2) & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 / DATA (AM( 7,K, 1),K=0, 2) & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 / DATA (AM( 8,K, 1),K=0, 2) & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 / DATA MEXVEC( 0) / 8 / DATA MLFVEC( 0) / 2 / DATA UT1VEC( 0) / -0.1026789E+01 / DATA UT2VEC( 0) / -0.9051707E+01 / DATA ALFVEC( 0) / 0.9462977E+00 / DATA QMAVEC( 0) / 0.0000000E+00 / DATA (AM( 0,K, 0),K=0, 2) & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 / DATA (AM( 1,K, 0),K=0, 2) & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 / DATA (AM( 2,K, 0),K=0, 2) & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 / DATA (AM( 3,K, 0),K=0, 2) & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 / DATA (AM( 4,K, 0),K=0, 2) & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 / DATA (AM( 5,K, 0),K=0, 2) & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 / DATA (AM( 6,K, 0),K=0, 2) & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 / DATA (AM( 7,K, 0),K=0, 2) & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 / DATA (AM( 8,K, 0),K=0, 2) & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 / DATA MEXVEC(-1) / 8 / DATA MLFVEC(-1) / 2 / DATA UT1VEC(-1) / 0.5243571E+01 / DATA UT2VEC(-1) / -0.2870513E+01 / DATA ALFVEC(-1) / 0.6701448E+00 / DATA QMAVEC(-1) / 0.0000000E+00 / DATA (AM( 0,K,-1),K=0, 2) & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 / DATA (AM( 1,K,-1),K=0, 2) & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 / DATA (AM( 2,K,-1),K=0, 2) & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 / DATA (AM( 3,K,-1),K=0, 2) & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 / DATA (AM( 4,K,-1),K=0, 2) & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 / DATA (AM( 5,K,-1),K=0, 2) & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 / DATA (AM( 6,K,-1),K=0, 2) & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 / DATA (AM( 7,K,-1),K=0, 2) & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 / DATA (AM( 8,K,-1),K=0, 2) & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 / DATA MEXVEC(-2) / 7 / DATA MLFVEC(-2) / 2 / DATA UT1VEC(-2) / 0.4782210E+01 / DATA UT2VEC(-2) / -0.1976856E+02 / DATA ALFVEC(-2) / 0.7558374E+00 / DATA QMAVEC(-2) / 0.0000000E+00 / DATA (AM( 0,K,-2),K=0, 2) & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 / DATA (AM( 1,K,-2),K=0, 2) & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 / DATA (AM( 2,K,-2),K=0, 2) & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 / DATA (AM( 3,K,-2),K=0, 2) & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 / DATA (AM( 4,K,-2),K=0, 2) & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 / DATA (AM( 5,K,-2),K=0, 2) & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 / DATA (AM( 6,K,-2),K=0, 2) & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 / DATA (AM( 7,K,-2),K=0, 2) & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 / DATA MEXVEC(-3) / 7 / DATA MLFVEC(-3) / 2 / DATA UT1VEC(-3) / 0.4518239E+01 / DATA UT2VEC(-3) / -0.2690590E+01 / DATA ALFVEC(-3) / 0.6124079E+00 / DATA QMAVEC(-3) / 0.0000000E+00 / DATA (AM( 0,K,-3),K=0, 2) & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 / DATA (AM( 1,K,-3),K=0, 2) & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 / DATA (AM( 2,K,-3),K=0, 2) & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 / DATA (AM( 3,K,-3),K=0, 2) & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 / DATA (AM( 4,K,-3),K=0, 2) & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 / DATA (AM( 5,K,-3),K=0, 2) & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 / DATA (AM( 6,K,-3),K=0, 2) & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 / DATA (AM( 7,K,-3),K=0, 2) & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 / DATA MEXVEC(-4) / 7 / DATA MLFVEC(-4) / 2 / DATA UT1VEC(-4) / 0.2783230E+01 / DATA UT2VEC(-4) / -0.1746328E+01 / DATA ALFVEC(-4) / 0.1115653E+01 / DATA QMAVEC(-4) / 0.1300000E+01 / DATA (AM( 0,K,-4),K=0, 2) & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 / DATA (AM( 1,K,-4),K=0, 2) & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 / DATA (AM( 2,K,-4),K=0, 2) & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 / DATA (AM( 3,K,-4),K=0, 2) & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 / DATA (AM( 4,K,-4),K=0, 2) & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 / DATA (AM( 5,K,-4),K=0, 2) & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 / DATA (AM( 6,K,-4),K=0, 2) & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 / DATA (AM( 7,K,-4),K=0, 2) & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 / DATA MEXVEC(-5) / 6 / DATA MLFVEC(-5) / 2 / DATA UT1VEC(-5) / 0.1619654E+02 / DATA UT2VEC(-5) / -0.3367346E+01 / DATA ALFVEC(-5) / 0.5109891E-02 / DATA QMAVEC(-5) / 0.4500000E+01 / DATA (AM( 0,K,-5),K=0, 2) & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 / DATA (AM( 1,K,-5),K=0, 2) & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 / DATA (AM( 2,K,-5),K=0, 2) & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 / DATA (AM( 3,K,-5),K=0, 2) & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 / DATA (AM( 4,K,-5),K=0, 2) & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 / DATA (AM( 5,K,-5),K=0, 2) & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 / DATA (AM( 6,K,-5),K=0, 2) & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 / IF(Q .LE. QMAVEC(IFL)) THEN PYCT5M = 0.D0 RETURN ENDIF IF(X .GE. 1.D0) THEN PYCT5M = 0.D0 RETURN ENDIF TMP = LOG(Q/ALFVEC(IFL)) IF(TMP .LE. 0.D0) THEN PYCT5M = 0.D0 RETURN ENDIF SB = LOG(TMP) SB1 = SB - 1.2D0 SB2 = SB1*SB1 DO 110 I = 0, NEX AF(I) = 0.D0 SBX = 1.D0 DO 100 K = 0, MLFVEC(IFL) AF(I) = AF(I) + SBX*AM(I,K,IFL) SBX = SB1*SBX 100 CONTINUE 110 CONTINUE Y = -LOG(X) U = LOG(X/0.00001D0) PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U) PART2 = AF(0)*(1.D0 - X) + AF(3)*X PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X)) PART4 = UT1VEC(IFL)*LOG(1.D0-X) + & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X) PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4) C...Include threshold factor. PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q) RETURN END C********************************************************************* C...PYPDPO C...Auxiliary to PYPDPR. Gives proton parton distributions according to C...a few older parametrizations, now obsolete but convenient for C...backwards checks. SUBROUTINE PYPDPO(X,Q2,XPPR) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2), &CEHLQ(6,6,2,8,2),CDO(3,6,5,2) C...The following data lines are coefficients needed in the C...Eichten, Hinchliffe, Lane, Quigg proton structure function C...parametrizations, see below. C...Powers of 1-x in different cases. DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/ C...Expansion coefficients for up valence quark distribution. DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/ 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04, 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03, 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03, 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03, 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03, 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04, 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04, 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03, 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04, 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04, 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05, 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/ DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/ 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04, 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03, 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03, 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03, 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03, 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04, 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04, 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03, 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04, 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04, 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05, 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/ C...Expansion coefficients for down valence quark distribution. DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/ 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04, 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03, 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03, 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03, 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04, 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04, 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04, 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03, 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04, 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04, 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05, 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/ DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/ 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04, 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03, 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03, 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03, 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04, 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04, 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04, 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03, 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04, 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04, 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05, 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/ C...Expansion coefficients for up and down sea quark distributions. DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/ 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04, 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03, 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05, 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04, 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04, 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05, 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04, 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03, 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04, 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05, 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00, 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/ DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/ 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04, 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03, 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04, 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04, 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04, 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04, 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03, 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03, 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04, 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05, 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05, 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/ C...Expansion coefficients for gluon distribution. DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/ 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02, 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02, 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02, 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03, 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04, 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03, 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02, 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02, 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02, 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03, 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03, 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/ DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/ 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02, 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02, 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02, 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02, 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02, 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02, 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02, 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01, 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02, 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03, 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03, 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/ C...Expansion coefficients for strange sea quark distribution. DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/ 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04, 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03, 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04, 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04, 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04, 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05, 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04, 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03, 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04, 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05, 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00, 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/ DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/ 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04, 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03, 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04, 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04, 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04, 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04, 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03, 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03, 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04, 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05, 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05, 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/ C...Expansion coefficients for charm sea quark distribution. DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/ 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03, 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03, 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04, 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05, 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05, 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05, 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04, 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03, 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04, 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04, 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05, 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/ DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/ 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03, 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03, 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04, 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05, 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05, 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05, 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03, 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03, 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04, 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04, 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05, 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/ C...Expansion coefficients for bottom sea quark distribution. DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/ 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03, 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04, 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04, 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05, 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05, 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05, 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03, 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03, 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04, 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05, 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05, 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/ DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/ 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03, 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04, 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04, 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05, 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00, 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05, 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03, 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03, 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04, 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05, 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05, 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/ C...Expansion coefficients for top sea quark distribution. DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/ 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04, 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04, 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04, 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00, 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05, 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00, 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03, 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03, 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04, 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05, 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00, 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/ DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/ 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04, 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04, 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04, 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00, 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05, 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00, 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03, 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03, 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04, 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05, 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00, 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/ C...The following data lines are coefficients needed in the C...Duke, Owens proton structure function parametrizations, see below. C...Expansion coefficients for (up+down) valence quark distribution. DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/ 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00, 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00, 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/ DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/ 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00, 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00, 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/ C...Expansion coefficients for down valence quark distribution. DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/ 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00, 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/ DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/ 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00, 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/ C...Expansion coefficients for (up+down+strange) sea quark distribution. DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/ 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00, 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01, 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/ DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/ 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00, 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02, 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/ C...Expansion coefficients for charm sea quark distribution. DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/ 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00, 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01, 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/ DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/ 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00, 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01, 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/ C...Expansion coefficients for gluon distribution. DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/ 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00, 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01, 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/ DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/ 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00, 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01, 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/ C...Euler's beta function, requires ordinary Gamma function EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y) C...Leading order proton parton distributions from Glueck, Reya and C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and C...10^-5 < x < 1. IF(MSTP(51).EQ.11) THEN C...Determine s expansion variable and some x expressions. Q2IN=MIN(1D8,MAX(0.25D0,Q2)) SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2)) SD2=SD**2 XL=-LOG(X) XS=SQRT(X) C...Evaluate valence, gluon and sea distributions. XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)* & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+ & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)* & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2) XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)* & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+ & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2) XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+ & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD- & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+ & SQRT(4.066D0*SD**1.218D0*XL)))* & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2) XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+ & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+ & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0* & XL)))*(1D0-X)**(4.696D0+2.109D0*SD) XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+ & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0* & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)* & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD) IF(SD.LE.0.888D0) THEN XFCHM=0D0 ELSE XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)* & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+ & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL)) ENDIF IF(SD.LE.1.351D0) THEN XFBOT=0D0 ELSE XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+ & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+ & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL)) ENDIF C...Put into output array. XPPR(0)=XFGLU XPPR(1)=XFVDD+XFSEA XPPR(2)=XFVUD-XFVDD+XFSEA XPPR(3)=XFSTR XPPR(4)=XFCHM XPPR(5)=XFBOT XPPR(-1)=XFSEA XPPR(-2)=XFSEA XPPR(-3)=XFSTR XPPR(-4)=XFCHM XPPR(-5)=XFBOT C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg. C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN C...Determine set, Lambda and x and t expansion variables. NSET=MSTP(51)-11 IF(NSET.EQ.1) ALAM=0.2D0 IF(NSET.EQ.2) ALAM=0.29D0 TMIN=LOG(5D0/ALAM**2) TMAX=LOG(1D8/ALAM**2) T=LOG(MAX(1D0,Q2/ALAM**2)) VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN))) NX=1 IF(X.LE.0.1D0) NX=2 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0) C...Chebyshev polynomials for x and t expansion. TX(1)=1D0 TX(2)=VX TX(3)=2D0*VX**2-1D0 TX(4)=4D0*VX**3-3D0*VX TX(5)=8D0*VX**4-8D0*VX**2+1D0 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX TT(1)=1D0 TT(2)=VT TT(3)=2D0*VT**2-1D0 TT(4)=4D0*VT**3-3D0*VT TT(5)=8D0*VT**4-8D0*VT**2+1D0 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT C...Calculate structure functions. DO 120 KFL=1,6 XQSUM=0D0 DO 110 IT=1,6 DO 100 IX=1,6 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT) 100 CONTINUE 110 CONTINUE XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET) 120 CONTINUE C...Put into output array. XPPR(0)=XQ(4) XPPR(1)=XQ(2)+XQ(3) XPPR(2)=XQ(1)+XQ(3) XPPR(3)=XQ(5) XPPR(4)=XQ(6) XPPR(-1)=XQ(3) XPPR(-2)=XQ(3) XPPR(-3)=XQ(5) XPPR(-4)=XQ(6) C...Special expansion for bottom (threshold effects). IF(MSTP(58).GE.5) THEN IF(NSET.EQ.1) TMIN=8.1905D0 IF(NSET.EQ.2) TMIN=7.4474D0 IF(T.GT.TMIN) THEN VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN))) TT(1)=1D0 TT(2)=VT TT(3)=2D0*VT**2-1D0 TT(4)=4D0*VT**3-3D0*VT TT(5)=8D0*VT**4-8D0*VT**2+1D0 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT XQSUM=0D0 DO 140 IT=1,6 DO 130 IX=1,6 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT) 130 CONTINUE 140 CONTINUE XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET) XPPR(-5)=XPPR(5) ENDIF ENDIF C...Special expansion for top (threshold effects). IF(MSTP(58).GE.6) THEN IF(NSET.EQ.1) TMIN=11.5528D0 IF(NSET.EQ.2) TMIN=10.8097D0 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0) TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0) IF(T.GT.TMIN) THEN VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN))) TT(1)=1D0 TT(2)=VT TT(3)=2D0*VT**2-1D0 TT(4)=4D0*VT**3-3D0*VT TT(5)=8D0*VT**4-8D0*VT**2+1D0 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT XQSUM=0D0 DO 160 IT=1,6 DO 150 IX=1,6 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT) 150 CONTINUE 160 CONTINUE XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET) XPPR(-6)=XPPR(6) ENDIF ENDIF C...Proton parton distributions from Duke, Owens. C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2. ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN C...Determine set, Lambda and s expansion parameter. NSET=MSTP(51)-13 IF(NSET.EQ.1) ALAM=0.2D0 IF(NSET.EQ.2) ALAM=0.4D0 Q2IN=MIN(1D6,MAX(4D0,Q2)) SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2)) C...Calculate structure functions. DO 180 KFL=1,5 DO 170 IS=1,6 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+ & CDO(3,IS,KFL,NSET)*SD**2 170 CONTINUE IF(KFL.LE.2) THEN XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1), & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0))) ELSE XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+ & TS(5)*X**2+TS(6)*X**3) ENDIF 180 CONTINUE C...Put into output arrays. XPPR(0)=XQ(5) XPPR(1)=XQ(2)+XQ(3)/6D0 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0 XPPR(3)=XQ(3)/6D0 XPPR(4)=XQ(4) XPPR(-1)=XQ(3)/6D0 XPPR(-2)=XQ(3)/6D0 XPPR(-3)=XQ(3)/6D0 XPPR(-4)=XQ(4) ENDIF RETURN END C********************************************************************* C...PYHFTH C...Gives threshold attractive/repulsive factor for heavy flavour C...production. FUNCTION PYHFTH(SH,SQM,FRATT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYDAT1/,/PYPARS/,/PYINT1/ C...Value for alpha_strong. IF(MSTP(35).LE.1) THEN ALSSG=PARP(35) ELSE MST115=MSTU(115) MSTU(115)=MSTP(36) Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+ & PARP(36)**2))) ALSSG=PYALPS(Q2BN) MSTU(115)=MST115 ENDIF C...Evaluate attractive and repulsive factors. XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH))) FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR))) XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH))) FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0) PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU VINT(138)=PYHFTH RETURN END C********************************************************************* C...PYSPLI C...Splits a hadron remnant into two (partons or hadron + parton) C...in case it is more complicated than just a quark or a diquark. SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. PYDAT1 temporary COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYPARS/,/PYINT1/,/PYDAT1/ C...Local array. DIMENSION KFL(3) C...Preliminaries. Parton composition. KFA=IABS(KF) KFS=ISIGN(1,KF) KFL(1)=MOD(KFA/1000,10) KFL(2)=MOD(KFA/100,10) KFL(3)=MOD(KFA/10,10) IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN KFL(2)=INT(1.5D0+PYR(0)) IF(MINT(105).EQ.333) KFL(2)=3 IF(MINT(105).EQ.443) KFL(2)=4 KFL(3)=KFL(2) ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN KFL(2)=2 KFL(3)=2 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN KFL(2)=1 KFL(3)=1 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN KFL(2)=MOD(KFA/10,10) KFL(3)=MOD(KFA/100,10) ENDIF IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN KFLR=KFLIN*KFS ELSE KFLR=KFLIN ENDIF KFLCH=0 C...Subdivide lepton. IF(KFA.GE.11.AND.KFA.LE.18) THEN IF(KFLR.EQ.KFA) THEN KFLSP=KFS*22 ELSEIF(KFLR.EQ.22) THEN KFLSP=KFA ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN KFLSP=KFA+1 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN KFLSP=KFA-1 ELSEIF(KFLR.EQ.21) THEN KFLSP=KFA KFLCH=KFS*21 ELSE KFLSP=KFA KFLCH=-KFLR ENDIF C...Subdivide photon. ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN IF(KFLR.NE.21) THEN KFLSP=-KFLR ELSE RAGR=0.75D0*PYR(0) KFLSP=1 IF(RAGR.GT.0.125D0) KFLSP=2 IF(RAGR.GT.0.625D0) KFLSP=3 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP KFLCH=-KFLSP ENDIF C...Subdivide Reggeon or Pomeron. ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN IF(KFLIN.EQ.21) THEN KFLSP=KFS*21 ELSE KFLSP=-KFLIN ENDIF C...Subdivide meson. ELSEIF(KFL(1).EQ.0) THEN KFL(2)=KFL(2)*(-1)**KFL(2) KFL(3)=-KFL(3)*(-1)**IABS(KFL(2)) IF(KFLR.EQ.KFL(2)) THEN KFLSP=KFL(3) ELSEIF(KFLR.EQ.KFL(3)) THEN KFLSP=KFL(2) ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN KFLSP=KFL(2) KFLCH=KFL(3) ELSEIF(KFLR.EQ.21) THEN KFLSP=KFL(3) KFLCH=KFL(2) ELSEIF(KFLR*KFL(2).GT.0) THEN NTRY=0 100 NTRY=NTRY+1 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH) IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN GOTO 100 ELSEIF(KFLCH.EQ.0) THEN CALL PYERRM(14,'(PYSPLI:) caught in infinite loop') MINT(51)=1 RETURN ENDIF KFLSP=KFL(3) ELSE NTRY=0 110 NTRY=NTRY+1 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH) IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN GOTO 110 ELSEIF(KFLCH.EQ.0) THEN CALL PYERRM(14,'(PYSPLI:) caught in infinite loop') MINT(51)=1 RETURN ENDIF KFLSP=KFL(2) ENDIF C...Subdivide baryon. ELSE NAGR=0 DO 120 J=1,3 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1 120 CONTINUE IF(NAGR.GE.1) THEN RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0) IAGR=0 DO 130 J=1,3 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J 130 CONTINUE ELSE IAGR=1.00001D0+2.99998D0*PYR(0) ENDIF ID1=1 IF(IAGR.EQ.1) ID1=2 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3 ID2=6-IAGR-ID1 KSP=3 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1 ELSEIF(MOD(KFA,10).EQ.2) THEN IF(IAGR.EQ.1) KSP=1 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1 ENDIF KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP IF(KFLR.EQ.21) THEN KFLCH=KFL(IAGR) ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN NTRY=0 140 NTRY=NTRY+1 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH) IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN GOTO 140 ELSEIF(KFLCH.EQ.0) THEN CALL PYERRM(14,'(PYSPLI:) caught in infinite loop') MINT(51)=1 RETURN ENDIF ELSEIF(NAGR.EQ.0) THEN NTRY=0 150 NTRY=NTRY+1 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH) IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN GOTO 150 ELSEIF(KFLCH.EQ.0) THEN CALL PYERRM(14,'(PYSPLI:) caught in infinite loop') MINT(51)=1 RETURN ENDIF KFLSP=KFL(IAGR) ENDIF ENDIF C...Add on correct sign for result. KFLCH=KFLCH*KFS KFLSP=KFLSP*KFS RETURN END C********************************************************************* C...PYGAMM C...Gives ordinary Gamma function Gamma(x) for positive, real arguments; C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions C...(Dover, 1965) 6.1.36. FUNCTION PYGAMM(X) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Local array and data. DIMENSION B(8) DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0, &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/ NX=INT(X) DX=X-NX PYGAMM=1D0 DXP=1D0 DO 100 I=1,8 DXP=DXP*DX PYGAMM=PYGAMM+B(I)*DXP 100 CONTINUE IF(X.LT.1D0) THEN PYGAMM=PYGAMM/X ELSE DO 110 IX=1,NX-1 PYGAMM=(X-IX)*PYGAMM 110 CONTINUE ENDIF RETURN END C*********************************************************************** C...PYWAUX C...Calculates real and imaginary parts of the auxiliary functions W1 C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van C...der Bij, Nucl. Phys. B297 (1988) 221. SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ ASINH(X)=LOG(X+SQRT(X**2+1D0)) ACOSH(X)=LOG(X+SQRT(X**2-1D0)) IF(EPS.LT.0D0) THEN IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS)) IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2 WIM=0D0 ELSEIF(EPS.LT.1D0) THEN IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS)) IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS) IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS)) ELSE IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS)) IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2 WIM=0D0 ENDIF RETURN END C*********************************************************************** C...PYI3AU C...Calculates real and imaginary parts of the auxiliary function I3; C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij, C...Nucl. Phys. B297 (1988) 221. SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS)) IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS)) IF(EPS.LT.0D0) THEN IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)- & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+ & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)- & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2- & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)* & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+ & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)* & EPS)) ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)- & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+ & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)- & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+ & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+ & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+ & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS)) ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)- & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+ & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)- & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+ & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+ & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+ & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS)) ELSE F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)- & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)- & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2- & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+ & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0)) ENDIF F3IM=0D0 ELSEIF(EPS.LT.1D0) THEN IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)- & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+ & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)- & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/ & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/ & (0.25D0*(RAT+1D0)*EPS)) F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/ & (0.25D0*(RAT+1D0)*EPS)) ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)- & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+ & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)- & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+ & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))* & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS)) F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS)) ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)- & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+ & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)- & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+ & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/ & (1D0+0.25D0*RAT*EPS-GA)) F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/ & (1D0+0.25D0*RAT*EPS-GA)) ELSE F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)- & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)- & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))* & LOG((GA+BE-1D0)/(BE-GA)) F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA)) ENDIF ELSE RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2) RCTHE=RSQ*(1D0-2D0*BE/EPS) RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2)) RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS) RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2)) R=SQRT(RSQ) THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R))) PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R))) F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)- & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+ & (PHI-THE)*(PHI+THE-PARU(1)) F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)- & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2) ENDIF Y3RE=2D0/(2D0*BE-1D0)*F3RE Y3IM=2D0/(2D0*BE-1D0)*F3IM RETURN END C*********************************************************************** C...PYSPEN C...Calculates real and imaginary part of Spence function; see C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365. FUNCTION PYSPEN(XREIN,XIMIN,IREIM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Local array and data. DIMENSION B(0:14) DATA B/ &1.000000D+00, -5.000000D-01, 1.666667D-01, &0.000000D+00, -3.333333D-02, 0.000000D+00, &2.380952D-02, 0.000000D+00, -3.333333D-02, &0.000000D+00, 7.575757D-02, 0.000000D+00, &-2.531135D-01, 0.000000D+00, 1.166667D+00/ XRE=XREIN XIM=XIMIN IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0 IF(IREIM.EQ.2) PYSPEN=0D0 RETURN ENDIF XMOD=SQRT(XRE**2+XIM**2) IF(XMOD.LT.1D-6) THEN IF(IREIM.EQ.1) PYSPEN=0D0 IF(IREIM.EQ.2) PYSPEN=0D0 RETURN ENDIF XARG=SIGN(ACOS(XRE/XMOD),XIM) SP0RE=0D0 SP0IM=0D0 SGN=1D0 IF(XMOD.GT.1D0) THEN ALGXRE=LOG(XMOD) ALGXIM=XARG-SIGN(PARU(1),XARG) SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0 SP0IM=-ALGXRE*ALGXIM SGN=-1D0 XMOD=1D0/XMOD XARG=-XARG XRE=XMOD*COS(XARG) XIM=XMOD*SIN(XARG) ENDIF IF(XRE.GT.0.5D0) THEN ALGXRE=LOG(XMOD) ALGXIM=XARG XRE=1D0-XRE XIM=-XIM XMOD=SQRT(XRE**2+XIM**2) XARG=SIGN(ACOS(XRE/XMOD),XIM) ALGYRE=LOG(XMOD) ALGYIM=XARG SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM)) SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE) SGN=-SGN ENDIF XRE=1D0-XRE XIM=-XIM XMOD=SQRT(XRE**2+XIM**2) XARG=SIGN(ACOS(XRE/XMOD),XIM) ZRE=-LOG(XMOD) ZIM=-XARG SPRE=0D0 SPIM=0D0 SAVERE=1D0 SAVEIM=0D0 DO 100 I=0,14 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1) TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1) SAVERE=TERMRE SAVEIM=TERMIM SPRE=SPRE+B(I)*TERMRE SPIM=SPIM+B(I)*TERMIM 100 CONTINUE 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM RETURN END C*********************************************************************** C...PYQQBH C...Calculates the matrix element for the processes C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t). C...REDUCE output and part of the rest courtesy Z. Kunszt, see C...Z. Kunszt, Nucl. Phys. B247 (1984) 339. SUBROUTINE PYQQBH(WTQQBH) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/ C...Local arrays and function. DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8) DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)- &PP(I,3)*PP(J,3) C...Mass parameters. WTQQBH=0D0 ISUB=MINT(1) SHPR=SQRT(VINT(26))*VINT(1) PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1) PH=SQRT(VINT(21))*VINT(1) SPQ=PQ**2 SPH=PH**2 C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H. DO 100 I=1,2 PT=SQRT(MAX(0D0,VINT(197+5*I))) PP(I,1)=PT*COS(VINT(198+5*I)) PP(I,2)=PT*SIN(VINT(198+5*I)) 100 CONTINUE PP(3,1)=-PP(1,1)-PP(2,1) PP(3,2)=-PP(1,2)-PP(2,2) PMS1=SPQ+PP(1,1)**2+PP(1,2)**2 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2 PMS3=SPH+PP(3,1)**2+PP(3,2)**2 PMT3=SQRT(PMS3) PP(3,3)=PMT3*SINH(VINT(211)) PP(3,4)=PMT3*COSH(VINT(211)) PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+ &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12) PP(2,3)=-PP(1,3)-PP(3,3) PP(1,4)=SQRT(PMS1+PP(1,3)**2) PP(2,4)=SQRT(PMS2+PP(2,3)**2) C...Set up incoming kinematics and derived momentum combinations. DO 110 I=4,5 PP(I,1)=0D0 PP(I,2)=0D0 PP(I,3)=-0.5D0*SHPR*(-1)**I PP(I,4)=-0.5D0*SHPR 110 CONTINUE DO 120 J=1,4 PP(6,J)=PP(1,J)+PP(2,J) PP(7,J)=PP(1,J)+PP(3,J) PP(8,J)=PP(1,J)+PP(4,J) PP(9,J)=PP(1,J)+PP(5,J) PP(10,J)=-PP(2,J)-PP(3,J) PP(11,J)=-PP(2,J)-PP(4,J) PP(12,J)=-PP(2,J)-PP(5,J) PP(13,J)=-PP(4,J)-PP(5,J) 120 CONTINUE C...Derived kinematics invariants. X1=DOT(1,2) X2=DOT(1,3) X3=DOT(1,4) X4=DOT(1,5) X5=DOT(2,3) X6=DOT(2,4) X7=DOT(2,5) X8=DOT(3,4) X9=DOT(3,5) X10=DOT(4,5) C...Propagators. SS1=DOT(7,7)-SPQ SS2=DOT(8,8)-SPQ SS3=DOT(9,9)-SPQ SS4=DOT(10,10)-SPQ SS5=DOT(11,11)-SPQ SS6=DOT(12,12)-SPQ SS7=DOT(13,13) DX(1)=SS1*SS6 DX(2)=SS2*SS6 DX(3)=SS2*SS4 DX(4)=SS1*SS5 DX(5)=SS3*SS5 DX(6)=SS3*SS4 DX(7)=SS7*SS1 DX(8)=SS7*SS4 C...Define colour coefficients for g + g -> Q + Qbar + H. IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN DO 140 I=1,3 DO 130 J=1,3 CLR(I,J)=16D0/3D0 CLR(I+3,J+3)=16D0/3D0 CLR(I,J+3)=-2D0/3D0 CLR(I+3,J)=-2D0/3D0 130 CONTINUE 140 CONTINUE DO 160 L=1,2 DO 150 I=1,3 CLR(I,6+L)=-6D0 CLR(I+3,6+L)=6D0 CLR(6+L,I)=-6D0 CLR(6+L,I+3)=6D0 150 CONTINUE 160 CONTINUE DO 180 K1=1,2 DO 170 K2=1,2 CLR(6+K1,6+K2)=12D0 170 CONTINUE 180 CONTINUE C...Evaluate matrix elements for g + g -> Q + Qbar + H. FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2* & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2* & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2* & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+ & X10) FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4* & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+ & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6) FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10- & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+ & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2* & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6) FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1* & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1* & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1** & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4* & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5- & X4*X6*X5) FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4- & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3* & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5 & +X4*X9*X5+X4*X5**2) FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2* & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1* & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3* & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7* & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7- & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5) FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2* & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+ & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8* & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8* & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4* & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2* & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+ & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2) FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*( & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3* & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+ & X6) FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1* & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1* & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3* & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6* & X5+X4*X6*X5) FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3- & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4- & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1* & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4* & X6**2) FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1* & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1* & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4* & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1** & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4* & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5- & X4*X6*X5) FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3- & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2* & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3* & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*( & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1* & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1* & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3* & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5) FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3- & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2* & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2* & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5- & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*( & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9- & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10* & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3* & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5) FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3* & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3- & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3* & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5 & +X3*X8*X5+X3*X5**2) FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1* & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1* & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3* & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7* & X5+X4*X6*X5) FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+ & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2* & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2* & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10) FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2* & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4* & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+ & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4* & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+ & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3* & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5) FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2* & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+ & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9* & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8) FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2* & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2* & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+ & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+ & X10) FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2* & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+ & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7) FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1* & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3* & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7* & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2* & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5) FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4* & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9* & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2) FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*( & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4* & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+ & X7) FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+ & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2* & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+ & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+ & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+ & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(- & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10* & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2* & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5) FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+ & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2* & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+ & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2* & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+ & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*( & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3* & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10* & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+ & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5) FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4* & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+ & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+ & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5) FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1* & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12* & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2* & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8) FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9* & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7* & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8 & *X6) FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+ & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4* & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9* & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3* & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+ & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5) FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2* & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4* & X8) FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+ & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6 & )+2*X2*(-X10*X5+X9*X6+X8*X7) FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2* & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3* & X9*X5) FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2* & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4* & X8*X5) FM(9,10)=0.5D0*(FMXX+FM(9,10)) FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+ & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6 & )+2*X5*(-X10*X2+X9*X3+X8*X4) C...Repackage matrix elements. DO 200 I=1,8 DO 190 J=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/9D0 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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) COMMON/PYHTRI/HHH(7) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT4/,/PYMSSM/, &/PYMSRV/,/PYSSMT/ C...Local variables. DOUBLE PRECISION ALFA,BETA DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW INTEGER I,J,J1,I1,K1 INTEGER KC,LKNT,IDLAM(300,3) DOUBLE PRECISION XLAM(0:300) DOUBLE PRECISION WDTP(0:300),WDTE(0:300,0:5) DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2 DOUBLE PRECISION DELM,XMDIF DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2 DOUBLE PRECISION ARG,SGNMU,R INTEGER IMSSM INTEGER IRPRTY INTEGER KFSUSY(36),MWIDSU(36),MDCYSU(36) SAVE MWIDSU,MDCYSU DATA KFSUSY/ &1000001,2000001,1000002,2000002,1000003,2000003, &1000004,2000004,1000005,2000005,1000006,2000006, &1000011,2000011,1000012,2000012,1000013,2000013, &1000014,2000014,1000015,2000015,1000016,2000016, &1000021,1000022,1000023,1000025,1000035,1000024, &1000037,1000039, 25, 35, 36, 37/ DATA INIT/0/ C...Do nothing if SUSY not requested. IMSSM=IMSS(1) IF(IMSSM.EQ.0) RETURN C...Save copy of MWID(KC) and MDCY(KC,1) values before C...they are set to zero for the LSP. IF(INIT.EQ.0) THEN INIT=1 DO 100 I=1,36 KF=KFSUSY(I) KC=PYCOMP(KF) MWIDSU(I)=MWID(KC) MDCYSU(I)=MDCY(KC,1) 100 CONTINUE ENDIF C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP. DO 110 I=1,36 KF=KFSUSY(I) KC=PYCOMP(KF) IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN MWID(KC)=MWIDSU(I) MDCY(KC,1)=MDCYSU(I) ENDIF 110 CONTINUE C...First part of routine: set masses and couplings. C...Reset mixing values in sfermion sector to pure left/right. DO 120 I=1,16 SFMIX(I,1)=1D0 SFMIX(I,4)=1D0 SFMIX(I,2)=0D0 SFMIX(I,3)=0D0 120 CONTINUE C...Common couplings. TANB=RMSS(5) BETA=ATAN(TANB) COSB=COS(BETA) SINB=TANB*COSB COS2B=COS(2D0*BETA) ALFA=RMSS(18) XMW2=PMAS(24,1)**2 XMZ2=PMAS(23,1)**2 XW=PARU(102) C...Define sparticle masses for a general MSSM simulation. IF(IMSSM.EQ.1) THEN IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9) DO 130 I=1,5,2 KC=PYCOMP(KSUSY1+I) PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0) KC=PYCOMP(KSUSY2+I) PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0) KC=PYCOMP(KSUSY1+I+1) PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0) KC=PYCOMP(KSUSY2+I+1) PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0) 130 CONTINUE XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA)) IF(XARG.LT.0D0) THEN WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'// & ' FROM THE SUM RULE. ' WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). ' RETURN ELSE XARG=SQRT(XARG) ENDIF DO 140 I=11,15,2 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6) PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7) PMAS(PYCOMP(KSUSY1+I+1),1)=XARG PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0 140 CONTINUE IF(IMSS(8).EQ.1) THEN RMSS(13)=RMSS(6) RMSS(14)=RMSS(7) ENDIF C...Alternatively derive masses from SUGRA relations. ELSEIF(IMSSM.EQ.2) THEN 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 150 I=1,5,2 KC=PYCOMP(KSUSY1+I) PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2) KC=PYCOMP(KSUSY2+I) PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2) KC=PYCOMP(KSUSY1+I+1) PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2) KC=PYCOMP(KSUSY2+I+1) PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2) 150 CONTINUE DO 160 I=11,15,2 KC=PYCOMP(KSUSY1+I) PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2) KC=PYCOMP(KSUSY2+I) PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2) KC=PYCOMP(KSUSY1+I+1) PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2) 160 CONTINUE IF(RMSS(4)**2+DMU2.LT.0D0) THEN WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE ' STOP ENDIF SGNMU=SIGN(1D0,RMSS(4)) RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2) ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG) ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG) ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG) ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG) ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG) IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW ' STOP ENDIF RMSS(19)=SQRT(RMSS(19)**2+DMA2) RMSS(6)=SQRT(RMSS(6)**2+DL2) RMSS(7)=SQRT(RMSS(7)**2+DE2) WRITE(MSTU(11),*) ' MTL = ',RMSS(10) WRITE(MSTU(11),*) ' MBR = ',RMSS(11) WRITE(MSTU(11),*) ' MTR = ',RMSS(12) WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13) WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14) ENDIF C...Fix the third generation sfermions. CALL PYTHRG 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),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2), & UMIXI(2,1),UMIXI(2,2) WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2), & VMIX(2,1),VMIX(2,2) WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2), & VMIXI(2,1),VMIXI(2,2) WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4) WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4) WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4) WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4) WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4) WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4) WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4) WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4) WRITE(MSTU(11),*) ' ALFA = ',ALFA WRITE(MSTU(11),*) ' BETA = ',BETA WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4) WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4) WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' ENDIF C...Set up the Higgs couplings - needed here since initialization C...in PYINRE did not yet occur when PYWIDT is called below. AL=ALFA BE=BETA SINA=SIN(AL) COSA=COS(AL) COSB=COS(BE) SINB=TANB*COSB SBMA=SIN(BE-AL) SAPB=SIN(AL+BE) CAPB=COS(AL+BE) CBMA=COS(BE-AL) C2A=COS(2D0*AL) C2B=COSB**2-SINB**2 C...tanb (used for H+) PARU(141)=TANB C...Firstly: h C...Coupling to d-type quarks PARU(161)=SINA/COSB C...Coupling to u-type quarks PARU(162)=-COSA/SINB C...Coupling to leptons PARU(163)=PARU(161) C...Coupling to Z PARU(164)=SBMA C...Coupling to W PARU(165)=PARU(164) C...Secondly: H C...Coupling to d-type quarks PARU(171)=-COSA/COSB C...Coupling to u-type quarks PARU(172)=-SINA/SINB C...Coupling to leptons PARU(173)=PARU(171) C...Coupling to Z PARU(174)=CBMA C...Coupling to W PARU(175)=PARU(174) C...Coupling to h IF(IMSS(4).EQ.2) THEN PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL) ELSE HHH(3)=HHH(3)+HHH(4)+HHH(5) PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+ 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB- 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+ 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB)) ENDIF C...Coupling to H+ C...Define later IF(IMSS(4).EQ.2) THEN PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW) ELSE PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA- 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+ 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)- 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA) ENDIF C...Coupling to A IF(IMSS(4).EQ.2) THEN PARU(177)=COS(2D0*BE)*COS(BE+AL) ELSE PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+ 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)- 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+ 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B)) ENDIF C...Coupling to H+ IF(IMSS(4).EQ.2) THEN PARU(178)=PARU(177) ELSE PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA ENDIF C...Thirdly, A C...Coupling to d-type quarks PARU(181)=TANB C...Coupling to u-type quarks PARU(182)=1D0/PARU(181) C...Coupling to leptons PARU(183)=PARU(181) PARU(184)=0D0 PARU(185)=0D0 C...Coupling to Z h PARU(186)=COS(BE-AL) C...Coupling to Z H PARU(187)=SIN(BE-AL) PARU(188)=0D0 PARU(189)=0D0 PARU(190)=0D0 C...Finally: H+ C...Coupling to W h PARU(195)=COS(BE-AL) C...Tell that all Higgs couplings have been set. MSTP(4)=1 C...Set R-Violating couplings C...Set lambda couplings to common value or "natural values". IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN VIR3=1D0/(126D0)**3 DO 190 IRI=1,3 DO 180 IRJ=1,3 DO 170 IRK=1,3 IF (IRI.NE.IRJ) THEN RVLAM(IRI,IRJ,IRK)=RMSS(51) IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51) & *SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*PMAS(9+2 & *IRK,1)*VIR3) ENDIF IF (IRI.GT.IRJ) RVLAM(IRI,IRJ,IRK)=-RVLAM(IRI,IRJ,IRK) 170 CONTINUE 180 CONTINUE 190 CONTINUE ENDIF C...Set lambda' couplings to common value or "natural values". IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN VIR3=1D0/(126D0)**3 DO 220 IRI=1,3 DO 210 IRJ=1,3 DO 200 IRK=1,3 RVLAMP(IRI,IRJ,IRK)=RMSS(52) IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52) & *SQRT(PMAS(9+2*IRI,1)*0.5*(PMAS(2*IRJ,1)+PMAS(2*IRJ & -1,1))*PMAS(2*IRK-1,1)*VIR3) 200 CONTINUE 210 CONTINUE 220 CONTINUE ENDIF C...Second part of routine: set decay modes and branching ratios. C...Allow chi10 -> gravitino + gamma or not. KC=PYCOMP(KSUSY1+39) IF( IMSS(11) .NE. 0 ) THEN PMAS(KC,1)=RMSS(21)/1000000000D0 PMAS(KC,2)=0.0001D0 IRPRTY=0 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS ' ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1) THEN IRPRTY=0 WRITE(MSTU(11),*) ' ALLOWING L-VIOLATING DECAYS ' ELSE PMAS(KC,1)=9999D0 IRPRTY=1 ENDIF C...Loop over sparticle and Higgs species. PMCHI1=PMAS(PYCOMP(KSUSY1+22),1) C...Find the LSP or NLSP for a gravitino LSP ILSP=0 PMLSP=1D20 DO 230 I=1,36 KF=KFSUSY(I) IF(KF.EQ.1000039) GOTO 230 KC=PYCOMP(KF) IF(PMAS(KC,1).LT.PMLSP) THEN ILSP=I PMLSP=PMAS(KC,1) ENDIF 230 CONTINUE DO 300 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) IF(I.EQ.ILSP) LKNT=0 C...Neutralino decays. ELSEIF(I.GE.26.AND.I.LE.29) THEN CALL PYNJDC(KF,XLAM,IDLAM,LKNT) C...chi10 stable or chi10 -> gravitino + gamma. IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN PMAS(KC,2)=1D-6 MDCY(KC,1)=0 MWID(KC)=0 ENDIF C...Chargino decays. ELSEIF(I.GE.30.AND.I.LE.31) THEN CALL PYCJDC(KF,XLAM,IDLAM,LKNT) C...Gravitino is stable. ELSEIF(I.EQ.32) THEN MDCY(KC,1)=0 MWID(KC)=0 C...Higgs decays. ELSEIF(I.GE.33.AND.I.LE.36) THEN C...Calculate decays to non-SUSY particles. CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE) LKNT=0 DO 240 I1=0,100 XLAM(I1)=0D0 240 CONTINUE DO 260 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 260 XLAM(I1)=WDTP(I1) XLAM(0)=XLAM(0)+XLAM(I1) DO 250 J1=1,3 IDLAM(I1,J1)=KFDP(K1,J1) 250 CONTINUE LKNT=LKNT+1 260 CONTINUE C...Add the decays to SUSY particles. CALL PYHEXT(KF,XLAM,IDLAM,LKNT) ENDIF C...Zero the branching ratios for use in loop mode C...thanks to K. Matchev (FNAL) DO 270 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 BRAT(IDC)=0D0 270 CONTINUE C...Set stable particles. IF(LKNT.EQ.0) THEN MDCY(KC,1)=0 MWID(KC)=0 PMAS(KC,2)=1D-6 PMAS(KC,3)=1D-5 PMAS(KC,4)=0D0 C...Store branching ratios in the standard tables. ELSE IDC=MDCY(KC,2)+MDCY(KC,3)-1 DELM=1D6 DO 290 IL=1,LKNT IDCSV=IDC 280 IDC=IDC+1 BRAT(IDC)=0D0 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2) IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ. & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN BRAT(IDC)=XLAM(IL)/XLAM(0) XMDIF=PMAS(KC,1) IF(MDME(IDC,1).GE.1) THEN XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)- & PMAS(PYCOMP(KFDP(IDC,2)),1) IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF- & PMAS(PYCOMP(KFDP(IDC,3)),1) ENDIF IF(I.LE.32) THEN IF(XMDIF.GE.0D0) THEN DELM=MIN(DELM,XMDIF) ELSE WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF WRITE(MSTU(11),*) ' KF = ',KF WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3) ENDIF ENDIF GOTO 290 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 290 ELSE GOTO 280 ENDIF 290 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 300 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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/ IMSS(5)=0 XMT=PMAS(6,1) XMZ2=PMAS(23,1)**2 XMW2=PMAS(24,1)**2 TANB=RMSS(5) BETA=ATAN(TANB) XW=PARU(102) XMG=RMSS(1) XMG2=XMG*XMG XM0=RMSS(8) XM02=XM0*XM0 AT=-RMSS(16) RMSS(15)=AT RMSS(17)=AT COSB=COS(BETA) SINB=TANB/SQRT(TANB**2+1D0) COSB=SINB/TANB DTERM=XMZ2*COS(2D0*BETA) XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM) XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM) RMSS(6)=XMEL RMSS(7)=XMER XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM)) XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM)) XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM)) XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM)) DO 100 I=1,5,2 PMAS(PYCOMP(KSUSY1+I),1)=XMDL PMAS(PYCOMP(KSUSY2+I),1)=XMDR PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR 100 CONTINUE XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA)) IF(XARG.LT.0D0) THEN WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'// & ' FROM THE SUM RULE. ' WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). ' RETURN ELSE XARG=SQRT(XARG) ENDIF DO 110 I=11,15,2 PMAS(PYCOMP(KSUSY1+I),1)=XMEL PMAS(PYCOMP(KSUSY2+I),1)=XMER PMAS(PYCOMP(KSUSY1+I+1),1)=XARG PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0 110 CONTINUE C 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 C XMU2=-XM02-0.52D0*XMG2-0.5D0*XMZ2+XTOP/(1D0-1D0/TANB**2) C..... XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)- &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2) C XMA2=(XMNU**2+XMU2-XBOT-XTAU/3D0)/SINB**2 C..... XMA2=2D0*(XM02+.52D0*XMG2)-XTOP-XBOT-XTAU/3D0+2D0*XMU2 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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblock. COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) SAVE /PYMSSM/ C...Local variables. DOUBLE PRECISION PI,R DOUBLE PRECISION TOL DOUBLE PRECISION CI(3) EXTERNAL PYALPS DOUBLE PRECISION PYALPS DATA TOL/0.001D0/ DATA PI,R/3.141592654D0,.61803399D0/ DATA CI/0.47D0,0.07D0,0.02D0/ C=1D0-R CA=CI(ID) AG=(0.71D0)**2/4D0/PI AG=RMSS(20) XM0=RMSS(8) XMG=RMSS(1) XM02=XM0*XM0 XMG2=XMG*XMG AS=PYALPS(XM02+6D0*XMG2) CG=8D0/9D0*((AS/AG)**2-1D0) BX=XM02+(CA+CG)*XMG2+DTERM AX=MIN(50D0**2,0.5D0*BX) CX=MAX(2000D0**2,2D0*BX) X0=AX X3=CX IF(ABS(CX-BX).GT.ABS(BX-AX))THEN X1=BX X2=BX+C*(CX-BX) ELSE X2=BX X1=BX-C*(BX-AX) ENDIF AS1=PYALPS(X1) CG=8D0/9D0*((AS1/AG)**2-1D0) F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1) AS2=PYALPS(X2) CG=8D0/9D0*((AS2/AG)**2-1D0) F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2) 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN IF(F2.LT.F1) THEN X0=X1 X1=X2 X2=R*X1+C*X3 F1=F2 AS2=PYALPS(X2) CG=8D0/9D0*((AS2/AG)**2-1D0) F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2) ELSE X3=X2 X2=X1 X1=R*X2+C*X0 F2=F1 AS1=PYALPS(X1) CG=8D0/9D0*((AS1/AG)**2-1D0) F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1) ENDIF GOTO 100 ENDIF IF(F1.LT.F2) THEN PYRNMQ=X1 XMIN=X1 ELSE PYRNMQ=X2 XMIN=X2 ENDIF RETURN END C********************************************************************* C...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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblock. COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) SAVE /PYMSSM/ C...Local variables. DOUBLE PRECISION XMT DOUBLE PRECISION PI,R DOUBLE PRECISION TOL EXTERNAL PYALPS DOUBLE PRECISION 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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ C...Local variables. DOUBLE PRECISION BETA DOUBLE PRECISION 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 ATR,AMQR,AMQL INTEGER ID1(3),ID2(3),ID3(3),ID4(3) INTEGER IF,I,J,II,JJ,IT,L LOGICAL DTERM DATA SMALL/1D-3/ DATA ID1/10,10,13/ DATA ID2/5,6,15/ DATA ID3/15,16,17/ DATA ID4/11,12,14/ DATA DTERM/.TRUE./ XMZ2=PMAS(23,1)**2 XMW2=PMAS(24,1)**2 TANB=RMSS(5) XMU=-RMSS(4) BETA=ATAN(TANB) COS2B=COS(2D0*BETA) C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS IOPT=IMSS(5) IF(IOPT.EQ.1) THEN CTT=DCOS(RMSS(27)) CTT2=CTT**2 STT=DSIN(RMSS(27)) STT2=STT**2 XM12=RMSS(10)**2 XM22=RMSS(12)**2 XMQL2=CTT2*XM12+STT2*XM22 XMQR2=STT2*XM12+CTT2*XM22 XMFR=PMAS(6,1) XMF2=PYRNMT(XMFR)**2 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2) c ATMT=SQRT(XMF2)*(ATOP+XMU/TANB) c XTEST=(XMQL2-XMQR2)*(CTT2-STT2) c IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN c STT=-STT c ATOP=-XMU/TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2) c 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 BOTTOM SQUARK CTT=DCOS(RMSS(26)) CTT2=CTT**2 STT=DSIN(RMSS(26)) STT2=STT**2 XMF=3D00 XMF2=XMF**2 XM12=RMSS(11)**2 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2 IF(ABS(CTT).GE..9999D0) THEN ABOT=-XMU*TANB XMQR2=RMSS(11)**2 ELSEIF(ABS(CTT).LE.1D-4) THEN ABOT=-XMU*TANB XMQR2=RMSS(11)**2 ELSE XM22=(XMQL2-CTT2*XM12)/STT2 XMQR2=STT2*XM12+CTT2*XM22 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2) ENDIF c ATMT=SQRT(XMF2)*(ABOT+XMU*TANB) c XTEST=(XMQL2-XMQR2)*(CTT2-STT2) c IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN c STT=-STT c ABOT=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2) c ENDIF RMSS(15)=ABOT C......SUBTRACT OUT D-TERM AND FERMION MASS XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2 IF(XMQR2.GE.0D0) THEN RMSS(11)=SQRT(XMQR2) ELSE RMSS(11)=-SQRT(-XMQR2) ENDIF C SAME FOR TAU SLEPTON CTT=DCOS(RMSS(28)) CTT2=CTT**2 STT=DSIN(RMSS(28)) STT2=STT**2 XM12=RMSS(13)**2 XM22=RMSS(14)**2 XMQL2=CTT2*XM12+STT2*XM22 XMQR2=STT2*XM12+CTT2*XM22 XMFR=PMAS(15,1) XMF2=XMFR**2 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2) c ATMT=SQRT(XMF2)*(ATAU+XMU*TANB) c XTEST=(XMQL2-XMQR2)*(CTT2-STT2) c IF(XTEST.GT.4D0*STT*CTT*ATMT) THEN c STT=-STT c ATAU=-XMU*TANB+CTT*STT*(XM22-XM12)/SQRT(XMF2) c ENDIF RMSS(17)=ATAU C......SUBTRACT OUT D-TERM AND FERMION MASS XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B IF(XMQL2.GE.0D0) THEN RMSS(13)=SQRT(XMQL2) ELSE RMSS(13)=-SQRT(-XMQL2) ENDIF IF(XMQR2.GE.0D0) THEN RMSS(14)=SQRT(XMQR2) ELSE RMSS(14)=-SQRT(-XMQR2) ENDIF ENDIF DO 170 L=1,3 AMQL=RMSS(ID1(L)) IF(AMQL.LT.0D0) THEN XMQL2=-AMQL**2 ELSE XMQL2=AMQL**2 ENDIF 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(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0 IF(DTERM) THEN IF(L.EQ.1) THEN AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0 AM2(1,2)=XMF*(ATR+XMU*TANB) ELSEIF(L.EQ.2) THEN AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0 AM2(1,2)=XMF*(ATR+XMU/TANB) ELSEIF(L.EQ.3) THEN IF(IMSS(8).EQ.1) THEN AM2(1,1)=RMSS(6)**2 AM2(2,2)=RMSS(7)**2 AM2(1,2)=0D0 RMSS(13)=RMSS(6) RMSS(14)=RMSS(7) ELSE AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B AM2(1,2)=XMF*(ATR+XMU*TANB) ENDIF ENDIF ENDIF AM2(2,1)=AM2(1,2) DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2 IF(DETM.LT.0D0) THEN WRITE(MSTU(11),*) ID2(L),DETM,AM2 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ') ENDIF SAME=0.5D0*(AM2(1,1)+AM2(2,2)) DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1)) XMF12=SAME-DIFF XMF22=SAME+DIFF IT=0 IF(XMF22-XMF12.GT.0D0) THEN RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12))) RT(2,2) = RT(1,1) RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)), & AM2(1,2)/(XMF22-XMF12)) RT(2,1) = -RT(1,2) ELSE RT(1,1) = 1D0 RT(2,2) = RT(1,1) RT(1,2) = 0D0 RT(2,1) = -RT(1,2) ENDIF 100 CONTINUE IT=IT+1 DO 140 I=1,2 DO 130 JJ=1,2 DI(I,JJ)=0D0 DO 120 II=1,2 DO 110 J=1,2 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II) 110 CONTINUE 120 CONTINUE 130 CONTINUE 140 CONTINUE IF(DI(1,1).GT.DI(2,2)) THEN WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION ' WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22) WRITE(MSTU(11),*) AM2 WRITE(MSTU(11),*) DI WRITE(MSTU(11),*) RT DI(1,1)=-RT(2,1) DI(2,2)=RT(1,2) DI(1,2)=-RT(2,2) DI(2,1)=RT(1,1) DO 160 I=1,2 DO 150 J=1,2 RT(I,J)=DI(I,J) 150 CONTINUE 160 CONTINUE GOTO 100 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'// & ' OFF DIAGONAL ELEMENTS ' WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22) WRITE(MSTU(11),*) DI WRITE(MSTU(11),*) ' ROTATION = ',RT C...STOP ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'// & ' NEGATIVE MASSES ' STOP ENDIF PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12) PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22) SFMIX(IF,1)=RT(1,1) SFMIX(IF,2)=RT(1,2) SFMIX(IF,3)=RT(2,1) SFMIX(IF,4)=RT(2,2) 170 CONTINUE RETURN END C********************************************************************* C...PYINOM C...Finds the mass eigenstates and mixing matrices for neutralinos C...and charginos. SUBROUTINE PYINOM C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ C...Local variables. DOUBLE PRECISION XMW,XMZ,XM(4) DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),AI(4,4) DOUBLE PRECISION WI(4),FV1(4),FV2(4),FV3(4) DOUBLE PRECISION COSW,SINW DOUBLE PRECISION XMU DOUBLE PRECISION TANB,COSB,SINB DOUBLE PRECISION XM1,XM2,XM3,BETA DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1 DOUBLE PRECISION PYALPS,PYALEM DOUBLE PRECISION PYRNM3 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4) DATA KFNCHI/1000022,1000023,1000025,1000035/ IOPT=IMSS(2) IF(IMSS(1).EQ.2) THEN IOPT=1 ENDIF C...M1, M2, AND M3 ARE INDEPENDENT IF(IOPT.EQ.0) THEN XM1=RMSS(1) XM2=RMSS(2) XM3=RMSS(3) ELSEIF(IOPT.GE.1) THEN Q2=PMAS(23,1)**2 AEM=PYALEM(Q2) A2=AEM/PARU(102) A1=AEM/(1D0-PARU(102)) XM1=RMSS(1) XM2=RMSS(2) IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0 IF(IOPT.EQ.1) THEN XM2=XM1*A2/A1*3D0/5D0 RMSS(2)=XM2 ELSEIF(IOPT.EQ.3) THEN XM1=XM2*5D0/3D0*A1/A2 RMSS(1)=XM1 ENDIF XM3=PYRNM3(XM2/A2) RMSS(3)=XM3 IF(XM3.LE.0D0) THEN WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3 STOP ENDIF ENDIF C...GLUINO MASS IF(IMSS(3).EQ.1) THEN PMAS(PYCOMP(KSUSY1+21),1)=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 DO 150 I=1,4 DO 140 J=1,4 AI(I,J)=0D0 140 CONTINUE 150 CONTINUE XMZ=PMAS(23,1) XMW=PMAS(24,1) XMU=RMSS(4) SINW=SQRT(PARU(102)) COSW=SQRT(1D0-PARU(102)) TANB=RMSS(5) BETA=ATAN(TANB) COSB=COS(BETA) SINB=TANB*COSB C... Definitions: C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0)) C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c. AR(1,1) = XM1*COS(RMSS(30)) AI(1,1) = XM1*SIN(RMSS(30)) AR(2,2) = XM2*COS(RMSS(31)) AI(2,2) = XM2*SIN(RMSS(31)) AR(3,3) = 0D0 AR(4,4) = 0D0 AR(1,2) = 0D0 AR(2,1) = 0D0 AR(1,3) = -XMZ*SINW*COSB AR(3,1) = AR(1,3) AR(1,4) = XMZ*SINW*SINB AR(4,1) = AR(1,4) AR(2,3) = XMZ*COSW*COSB AR(3,2) = AR(2,3) AR(2,4) = -XMZ*COSW*SINB AR(4,2) = AR(2,4) AR(3,4) = -XMU*COS(RMSS(33)) AI(3,4) = -XMU*SIN(RMSS(33)) AR(4,3) = -XMU*COS(RMSS(33)) AI(4,3) = -XMU*SIN(RMSS(33)) C CALL PYEIG4(AR,WR,ZR) CALL PYEICG(4,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR) IF(IERR.NE.0) THEN WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM ' ENDIF DO 160 I=1,4 INDEX(I)=I XM(I)=ABS(WR(I)) 160 CONTINUE DO 180 I=2,4 K=I DO 170 J=I-1,1,-1 IF(XM(K).LT.XM(J)) THEN ITMP=INDEX(J) XTMP=XM(J) INDEX(J)=INDEX(K) XM(J)=XM(K) INDEX(K)=ITMP XM(K)=XTMP K=K-1 ELSE GOTO 180 ENDIF 170 CONTINUE 180 CONTINUE DO 210 I=1,4 K=INDEX(I) SMZ(I)=WR(K) PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I)) S=0D0 DO 190 J=1,4 S=S+ZR(J,K)**2+ZI(J,K)**2 190 CONTINUE DO 200 J=1,4 ZMIX(I,J)=ZR(J,K)/SQRT(S) ZMIXI(I,J)=ZI(J,K)/SQRT(S) IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0 200 CONTINUE 210 CONTINUE C...CHARGINO MASSES C.....Find eigenvectors of X X^* AI(1,1) = 0D0 AI(2,2) = 0D0 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+ &XMU*COS(RMSS(33))*SINB) AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB- &XMU*SIN(RMSS(33))*SINB) AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+ &XMU*COS(RMSS(33))*SINB) AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+ &XMU*SIN(RMSS(33))*SINB) CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR) IF(IERR.NE.0) THEN WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM ' ENDIF INDEX(1)=1 INDEX(2)=2 IF(WR(2).LT.WR(1)) THEN INDEX(1)=2 INDEX(2)=1 ENDIF DO 240 I=1,2 K=INDEX(I) SMW(I)=SQRT(WR(K)) S=0D0 DO 220 J=1,2 S=S+ZR(J,K)**2+ZI(J,K)**2 220 CONTINUE DO 230 J=1,2 UMIX(I,J)=ZR(J,K)/SQRT(S) UMIXI(I,J)=-ZI(J,K)/SQRT(S) IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0 230 CONTINUE 240 CONTINUE IF(ABS(SMW(1)).LT.ABS(SMZ(1))) THEN SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1)) ENDIF PMAS(PYCOMP(KSUSY1+24),1)=SMW(1) PMAS(PYCOMP(KSUSY1+37),1)=SMW(2) C.....Find eigenvectors of X^* X AI(1,1) = 0D0 AI(2,2) = 0D0 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+ &XMU*COS(RMSS(33))*COSB) AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+ &XMU*SIN(RMSS(33))*COSB) AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+ &XMU*COS(RMSS(33))*COSB) AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB- &XMU*SIN(RMSS(33))*COSB) CALL PYEICG(4,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR) IF(IERR.NE.0) THEN WRITE(MSTU(11),*) ' PROBLEM WITH PYEICG IN PYINOM ' ENDIF INDEX(1)=1 INDEX(2)=2 IF(WR(2).LT.WR(1)) THEN INDEX(1)=2 INDEX(2)=1 ENDIF DO 270 I=1,2 K=INDEX(I) S=0D0 DO 250 J=1,2 S=S+ZR(J,K)**2+ZI(J,K)**2 250 CONTINUE DO 260 J=1,2 VMIX(I,J)=ZR(J,K)/SQRT(S) VMIXI(I,J)=-ZI(J,K)/SQRT(S) IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0 260 CONTINUE 270 CONTINUE RETURN END C********************************************************************* C...PYRNM3 C...Calculates the running of M3, the SU(3) gluino mass parameter. FUNCTION PYRNM3(RGUT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DOUBLE PRECISION R DOUBLE PRECISION TOL EXTERNAL PYALPS DOUBLE PRECISION PYALPS DATA TOL/0.001D0/ DATA R/0.61803399D0/ C=1D0-R BX=RGUT*PYALPS(RGUT**2) AX=MIN(50D0,BX*0.5D0) CX=MAX(2000D0,2D0*BX) X0=AX X3=CX IF(ABS(CX-BX).GT.ABS(BX-AX))THEN X1=BX X2=BX+C*(CX-BX) ELSE X2=BX X1=BX-C*(BX-AX) ENDIF AS1=PYALPS(X1**2) F1=ABS(X1-RGUT*AS1) AS2=PYALPS(X2**2) F2=ABS(X2-RGUT*AS2) 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN IF(F2.LT.F1) THEN X0=X1 X1=X2 X2=R*X1+C*X3 F1=F2 AS2=PYALPS(X2**2) F2=ABS(X2-RGUT*AS2) ELSE X3=X2 X2=X1 X1=R*X2+C*X0 F2=F1 AS1=PYALPS(X1**2) F1=ABS(X1-RGUT*AS1) ENDIF GOTO 100 ENDIF IF(F1.LT.F2) THEN PYRNM3=X1 XMIN=X1 ELSE PYRNM3=X2 XMIN=X2 ENDIF RETURN END C********************************************************************* C...PYEIG4 C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix. C...Specific application: mixing in neutralino sector. SUBROUTINE PYEIG4(A,W,Z) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Arrays: in call and local. DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4) C...Coefficients of fourth-degree equation from matrix. C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0. B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4)) B2=0D0 DO 110 I=1,3 DO 100 J=I+1,4 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I) 100 CONTINUE 110 CONTINUE B1=0D0 B0=0D0 DO 120 I=1,4 I1=MOD(I,4)+1 I2=MOD(I+1,4)+1 I3=MOD(I+2,4)+1 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+ & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))- & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I) B0=B0+(-1D0)**(I+1)*A(1,I)*( & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+ & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+ & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1))) 120 CONTINUE C...Coefficients of third-degree equation needed for C...separation into two second-degree equations. C...u**3 + c2 * u**2 + c1 * u + c0 = 0. C2=-B2 C1=B1*B3-4D0*B0 C0=-B1**2-B0*B3**2+4D0*B0*B2 CQ=C1/3D0-C2**2/9D0 CR=C1*C2/6D0-C0/2D0-C2**3/27D0 CQR=CQ**3+CR**2 C...Cases with one or three real roots. IF(CQR.GE.0D0) THEN S1=(CR+SQRT(CQR))**(1D0/3D0) S2=(CR-SQRT(CQR))**(1D0/3D0) U=S1+S2-C2/3D0 ELSE SABS=SQRT(-CQ) THE=ACOS(CR/SABS**3)/3D0 SRE=SABS*COS(THE) U=2D0*SRE-C2/3D0 ENDIF C...Find and solve two second-degree equations. P1=B3/2D0-SQRT(B3**2/4D0+U-B2) P2=B3/2D0+SQRT(B3**2/4D0+U-B2) Q1=U/2D0+SQRT(U**2/4D0-B0) Q2=U/2D0-SQRT(U**2/4D0-B0) IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN QSAV=Q1 Q1=Q2 Q2=QSAV ENDIF X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1) X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1) X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2) X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2) C...Order eigenvalues in asceding mass. W(1)=X(1) DO 150 I1=2,4 DO 130 I2=I1-1,1,-1 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140 W(I2+1)=W(I2) 130 CONTINUE 140 W(I2+1)=X(I1) 150 CONTINUE C...Find equation system for eigenvectors. DO 250 I=1,4 DO 170 J1=1,4 D(J1,J1)=A(J1,J1)-W(I) DO 160 J2=J1+1,4 D(J1,J2)=A(J1,J2) D(J2,J1)=A(J2,J1) 160 CONTINUE 170 CONTINUE C...Find largest element in matrix. DAMAX=0D0 DO 190 J1=1,4 DO 180 J2=1,4 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180 JA=J1 JB=J2 DAMAX=ABS(D(J1,J2)) 180 CONTINUE 190 CONTINUE C...Subtract others by multiple of row selected above. DAMAX=0D0 DO 210 J3=JA+1,JA+3 J1=J3-4*((J3-1)/4) RL=D(J1,JB)/D(JA,JB) DO 200 J2=1,4 D(J1,J2)=D(J1,J2)-RL*D(JA,J2) IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200 JC=J1 JD=J2 DAMAX=ABS(D(J1,J2)) 200 CONTINUE 210 CONTINUE C...Do one more subtraction of a row. DAMAX=0D0 DO 230 J3=JC+1,JC+3 J1=J3-4*((J3-1)/4) IF(J1.EQ.JA) GOTO 230 RL=D(J1,JD)/D(JC,JD) DO 220 J2=1,4 IF(J2.EQ.JB) GOTO 220 D(J1,J2)=D(J1,J2)-RL*D(JC,J2) IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220 JE=J1 DAMAX=ABS(D(J1,J2)) 220 CONTINUE 230 CONTINUE C...Construct unnormalized eigenvector. JF1=JD+1-4*(JD/4) JF2=JD+2-4*((JD+1)/4) IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4) IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4) E(JF1)=-D(JE,JF2) E(JF2)=D(JE,JF1) E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD) E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/ & D(JA,JB) C...Normalize and fill in final array. EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2) SGN=(-1D0)**INT(PYR(0)+0.5D0) DO 240 J=1,4 Z(I,J)=SGN*E(J)/EA 240 CONTINUE 250 CONTINUE RETURN END C********************************************************************* C...PYHGGM C...Determines the Higgs boson mass spectrum using several inputs. SUBROUTINE PYHGGM(ALPHA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/ C...Local variables. DOUBLE PRECISION AT,AB,XMU,TANB DOUBLE PRECISION ALPHA INTEGER IHOPT DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2 IHOPT=IMSS(4) IF(IHOPT.EQ.2) THEN ALPHA=RMSS(18) RETURN ENDIF AT=RMSS(16) AB=RMSS(15) DMGL=RMSS(3) XMU=RMSS(4) TANB=RMSS(5) DMA=RMSS(19) DTANB=TANB DMQ=RMSS(10) DMUR=RMSS(12) DMDR=RMSS(11) DMTOP=PMAS(6,1) DMC=PMAS(PYCOMP(KSUSY1+37),1) DAU=AT DAD=AB DMU=XMU RMSS(40)=0D0 RMSS(41)=0D0 IF(IHOPT.EQ.0) THEN CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM, & DMHCH,DSA,DCA,DTANBA) ELSEIF(IHOPT.EQ.1) THEN CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM, & DMHCH,DSA,DCA,DTANBA) CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU, & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA, & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB) RMSS(40)=DDT RMSS(41)=DDB DMH=DMHP DHM=DHMP DMA=DAMP IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM ' WRITE(MSTU(11),*) ' STOP1 MASSES = ', & PMAS(PYCOMP(1000006),1),DSTOP2 ENDIF IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM ' WRITE(MSTU(11),*) ' STOP2 MASSES = ', & PMAS(PYCOMP(2000006),1),DSTOP1 ENDIF IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM ' WRITE(MSTU(11),*) ' SBOT1 MASSES = ', & PMAS(PYCOMP(1000005),1),DSBOT2 ENDIF IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM ' WRITE(MSTU(11),*) ' SBOT2 MASSES = ', & PMAS(PYCOMP(2000005),1),DSBOT1 ENDIF ENDIF ALPHA=ACOS(DCA) PMAS(25,1)=DMH PMAS(35,1)=DHM PMAS(36,1)=DMA PMAS(37,1)=DMHCH RETURN END C********************************************************************* C...PYSUBH C...This routine computes the renormalization group improved C...values of Higgs masses and couplings in the MSSM. C...Program based on the work by M. Carena, J.R. Espinosa, c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45 C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU C...All masses in GeV units. MA is the CP-odd Higgs mass, C...MTOP is the physical top mass, MQ and MUR are the soft C...supersymmetry breaking mass parameters of left handed C...and right handed stops respectively, AU and AD are the C...stop and sbottom trilinear soft breaking terms, C...respectively, and MU is the supersymmetric C...Higgs mass parameter. We use the conventions from C...the physics report of Haber and Kane: left right C...stop mixing term proportional to (AU - MU/TANB) C...We use as input TANB defined at the scale MTOP C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA C...where MH and HM are the lightest and heaviest CP-even C...Higgs masses, MHCH is the charged Higgs mass and C...ALPHA is the Higgs mixing angle C...TANBA is the angle TANB at the CP-odd Higgs mass scale C...Range of validity: C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5 C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5 C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and C...are the sbottom mass eigenvalues, respectively. This C...range automatically excludes the existence of tachyons. C...For the charged Higgs mass computation, the method is C...valid if C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2 C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2 C...where M_SUSY**2 is the average of the squared stop mass C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom C...masses have been assumed to be of order of the stop ones C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM, &XMHCH,SA,CA,TANBA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYHTRI/HHH(7) SAVE /PYDAT1/,/PYDAT2/ C...Local variables. DOUBLE PRECISION PYALEM,PYALPS DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM DOUBLE PRECISION XMHCH,SA,CA DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI DOUBLE PRECISION Q02 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3 XMZ = PMAS(23,1) Q02=XMZ**2 AEM=PYALEM(Q02) ALP1=AEM/(1D0-PARU(102)) ALP2=AEM/PARU(102) ALPH3Z=PYALPS(Q02) ALP1 = 0.0101D0 ALP2 = 0.0337D0 ALPH3Z = 0.12D0 V = 174.1D0 PI = PARU(1) TANBA = TANB TANBT = TANB C...MBOTTOM(MTOP) = 3. GEV XMB = 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) C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0) G1 = SQRT(ALP1*4D0*PI) G2 = SQRT(ALP2*4D0*PI) G3 = SQRT(ALP3*4D0*PI) HU = RMTOP/V/SINBT HD = XMB/V/COSBT HU2=HU*HU HD2=HD*HD HU4=HU2*HU2 HD4=HD2*HD2 AU2=AU**2 AD2=AD**2 XMS2=XMS**2 XMS3=XMS**3 XMS4=XMS2*XMS2 XMU2=XMU*XMU PI2=PI*PI XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2) XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2) AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4 &+ 3D0*(AU + AD)**2/XMS2)/6D0 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2) &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2) &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2 &- 16D0*G3**2) *T/16D0/PI2) XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2) &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2) &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2 &- 16D0*G3**2) *T/16D0/PI2) XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0* &(HU2 + HD2)*T/16D0/PI2) &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2) &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/ &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0 &- 16D0*G3**2) *T/16D0/PI2) &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/ &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2 &- 16D0*G3**2) *T/16D0/PI2) XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2) &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2) &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/ &XMS4)* &(1+ (6D0*HU2 -2D0* HD2 &- 16D0*G3**2) *T/16D0/PI2) &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/ &XMS4)* &(1+ (6D0*HD2 -2D0* HU2/2D0 &- 16D0*G3**2) *T/16D0/PI2) XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) * &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2) &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) * &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2) XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) * &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2) &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) * &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2) XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) * &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2) &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) * &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2) HHH(1)=XLAM1 HHH(2)=XLAM2 HHH(3)=XLAM3 HHH(4)=XLAM4 HHH(5)=XLAM5 HHH(6)=XLAM6 HHH(7)=XLAM7 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 + &2D0* XLAM6*SINBT*COSBT &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT &+ XLAM5*COSBT**2) DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) + &XLAM6*COSBT**2 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 + &2D0* XLAM6* COSBT*SINBT &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 * &((XLAM1* COSBT**2 +2D0* &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 + &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2) &*SINBT**2 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3 &+ XLAM4) + XLAM6*COSBT**2 &+ XLAM7* SINBT**2)) XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0 XHM = SQRT(XHM2) XMH = SQRT(XMH2) XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2 XMHCH = SQRT(XMHCH2) SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) - &((2D0*V**2*(XLAM1* COSBT**2 + 2D0* &XLAM6* COSBT*SINBT &+ XLAM5*SINBT**2) + XMA**2*SINBT**2) &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/ &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) + &XLAM6*COSBT**2 + XLAM7* SINBT**2) - &XMA**2*SINBT*COSBT))/2D0**0.5D0/ &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)* &(((TRM2**2 - 4D0* DETM2)**0.5D0) - &((2D0*V**2*(XLAM1* COSBT**2 + 2D0* &XLAM6* COSBT*SINBT &+ XLAM5*SINBT**2) + XMA**2*SINBT**2) &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))) SA = -SINALP CA = -COSALP 100 CONTINUE RETURN END C********************************************************************* C...PYPOLE C...This subroutine computes the CP-even higgs and CP-odd pole c...Higgs masses and mixing angles. C...Program based on the work by M. Carena, M. Quiros C...and C.E.M. Wagner, "Effective potential methods and C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157 C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP, C...AT,AB,MU C...where MCHI is the largest chargino mass, MA is the running C...CP-odd higgs mass, TANB is the value of the ratio of vacuum C...expectaion values at the scale MTOP, MQ is the third generation C...left handed squark mass parameter, MUR is the third generation C...right handed stop mass parameter, MDR is the third generation C...right handed sbottom mass parameter, MTOP is the pole top quark C...mass; AT,AB are the soft supersymmetry breaking trilinear C...couplings of the stop and sbottoms, respectively, and MU is the C...supersymmetric mass parameter C...The parameter IHIGGS=0,1,2,3 corresponds to the number of C...Higgses whose pole mass is computed. If IHIGGS=0 only running C...masses are given, what makes the running of the program c...much faster and it is quite generally a good approximation c...(for a theoretical discussion see ref. above). If IHIGGS=1, C...only the pole mass for H is computed. If IHIGGS=2, then h and H, c...and if IHIGGS=3, then h,H,A polarizations are computed C...Output: MH and MHP which are the lightest CP-even Higgs running C...and pole masses, respectively; HM and HMP are the heaviest CP-even C...Higgs running and pole masses, repectively; SA and CA are the C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2 C...are the stop and sbottom mass eigenvalues. Finally, TANBA is C...the value of TANB at the CP-odd Higgs mass scale C...This subroutine makes use of CERN library subroutine C...integration package, which makes the computation of the C...pole Higgs masses somewhat faster. We thank P. Janot for this C...improvement. Those who are not able to call the CERN C...libraries, please use the subroutine SUBHPOLE2.F, which C...although somewhat slower, gives identical results SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU, &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...Parameters. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2), &SSBOT2(2),B(2,2),COUPB(2,2), &HCOUPT(2,2),HCOUPB(2,2), &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3) DELTA(1,1) = 1D0 DELTA(2,2) = 1D0 DELTA(1,2) = 0D0 DELTA(2,1) = 0D0 V = 174.1D0 XMZ=91.18D0 PI=PARU(1) C ALP3Z=0.12D0 C ALP3=1D0/(1D0/ALP3Z+23D0/6D0/PI*LOG(XMT/XMZ)) C RXMT = XMT/(1D0+4*ALP3/3D0/PI) RXMT = PYRNMT(XMT) CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB, &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB) SINB = TANB/(TANB**2+1D0)**0.5D0 COSB = 1D0/(TANB**2+1D0)**0.5D0 COS2B = SINB**2 - COSB**2 SINBPA = SINB*CA + COSB*SA COSBPA = COSB*CA - SINB*SA RMBOT = 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 C WMST11 = RXMT**2 + XMQ2 C WMST22 = RXMT**2 + XMUR2 XMST12 = RXMT*(AT - XMU/TANB) XMSB12 = RMBOT*(AB - XMU*TANB) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C...STOP EIGENVALUES CALCULATION CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC STOP12 = 0.5D0*(XMST11+XMST22) + &0.5D0*((XMST11+XMST22)**2 - &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0 STOP22 = 0.5D0*(XMST11+XMST22) - &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 - &XMST12**2))**0.5D0 IF(STOP22.LT.0D0) GOTO 500 SSTOP2(1) = STOP12 SSTOP2(2) = STOP22 STOP1 = STOP12**0.5D0 STOP2 = STOP22**0.5D0 C STOP1W = STOP1 C STOP2W = STOP2 IF(XMST12.EQ.0D0) XST11 = 1D0 IF(XMST12.EQ.0D0) XST12 = 0D0 IF(XMST12.EQ.0D0) XST21 = 0D0 IF(XMST12.EQ.0D0) XST22 = 1D0 IF(XMST12.EQ.0D0) GOTO 110 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0 110 T(1,1) = XST11 T(2,2) = XST22 T(1,2) = XST12 T(2,1) = XST21 SBOT12 = 0.5D0*(XMSB11+XMSB22) + &0.5D0*((XMSB11+XMSB22)**2 - &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0 SBOT22 = 0.5D0*(XMSB11+XMSB22) - &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 - &XMSB12**2))**0.5D0 IF(SBOT22.LT.0D0) GOTO 500 SBOT1 = SBOT12**0.5D0 SBOT2 = SBOT22**0.5D0 SSBOT2(1) = SBOT12 SSBOT2(2) = SBOT22 IF(XMSB12.EQ.0D0) XSB11 = 1D0 IF(XMSB12.EQ.0D0) XSB12 = 0D0 IF(XMSB12.EQ.0D0) XSB21 = 0D0 IF(XMSB12.EQ.0D0) XSB22 = 1D0 IF(XMSB12.EQ.0D0) GOTO 130 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0 130 B(1,1) = XSB11 B(2,2) = XSB22 B(1,2) = XSB12 B(2,1) = XSB21 SINT = 0.2320D0 SQR = DSQRT(2D0) VP = 174.1D0*SQR CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C...STARTING OF LIGHT HIGGS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IF(IHIGGS.EQ.0) GOTO 490 DO 150 I = 1,2 DO 140 J = 1,2 COUPT(I,J) = & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) + & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J)) & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J) & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) + & T(1,J)*T(2,I)) 140 CONTINUE 150 CONTINUE DO 170 I = 1,2 DO 160 J = 1,2 COUPB(I,J) = & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) + & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J)) & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J) & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) + & B(1,J)*B(2,I)) 160 CONTINUE 170 CONTINUE PRUN = XMH EPS = 1D-4*PRUN ITER = 0 180 ITER = ITER + 1 DO 230 I3 = 1,3 PR(I3)=PRUN+(I3-2)*EPS/2 P2=PR(I3)**2 POLT = 0D0 DO 200 I = 1,2 DO 190 J = 1,2 POLT = POLT + COUPT(I,J)**2*3D0* & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2 190 CONTINUE 200 CONTINUE POLB = 0D0 DO 220 I = 1,2 DO 210 J = 1,2 POLB = POLB + COUPB(I,J)**2*3D0* & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2 210 CONTINUE 220 CONTINUE C RXMT2 = RXMT**2 XMT2=XMT**2 POLTT = & 3D0*RXMT**2/8D0/PI**2/ V **2* & CA**2/SINB**2 * & (-2D0*XMT**2+0.5D0*P2)* & PYFINT(P2,XMT2,XMT2) POL = POLT + POLB + POLTT POLAR(I3) = P2 - XMH**2 - POL 230 CONTINUE DERIV = (POLAR(3)-POLAR(1))/EPS DRUN = - POLAR(2)/DERIV PRUN = PRUN + DRUN P2 = PRUN**2 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240 GOTO 180 240 CONTINUE XMHP = DSQRT(P2) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C...END OF LIGHT HIGGS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 250 IF(IHIGGS.EQ.1) GOTO 490 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C... STARTING OF HEAVY HIGGS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC DO 270 I = 1,2 DO 260 J = 1,2 HCOUPT(I,J) = & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) + & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J)) & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J) & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) + & T(1,J)*T(2,I)) 260 CONTINUE 270 CONTINUE DO 290 I = 1,2 DO 280 J = 1,2 HCOUPB(I,J) = & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) + & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J)) & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J) & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) + & B(1,J)*B(2,I)) HCOUPB(I,J)=0D0 280 CONTINUE 290 CONTINUE PRUN = HM EPS = 1D-4*PRUN ITER = 0 300 ITER = ITER + 1 DO 350 I3 = 1,3 PR(I3)=PRUN+(I3-2)*EPS/2 HP2=PR(I3)**2 HPOLT = 0D0 DO 320 I = 1,2 DO 310 J = 1,2 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0* & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2 310 CONTINUE 320 CONTINUE HPOLB = 0D0 DO 340 I = 1,2 DO 330 J = 1,2 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0* & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2 330 CONTINUE 340 CONTINUE C RXMT2 = RXMT**2 XMT2 = XMT**2 HPOLTT = & 3D0*RXMT**2/8D0/PI**2/ V **2* & SA**2/SINB**2 * & (-2D0*XMT**2+0.5D0*HP2)* & PYFINT(HP2,XMT2,XMT2) HPOL = HPOLT + HPOLB + HPOLTT POLAR(I3) =HP2-HM**2-HPOL 350 CONTINUE DERIV = (POLAR(3)-POLAR(1))/EPS DRUN = - POLAR(2)/DERIV PRUN = PRUN + DRUN HP2 = PRUN**2 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360 GOTO 300 360 CONTINUE 370 CONTINUE HMP = HP2**0.5D0 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C... END OF HEAVY HIGGS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IF(IHIGGS.EQ.2) GOTO 490 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C...BEGINNING OF PSEUDOSCALAR HIGGS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC DO 390 I = 1,2 DO 380 J = 1,2 ACOUPT(I,J) = & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)* & (T(1,I)*T(2,J) -T(1,J)*T(2,I)) 380 CONTINUE 390 CONTINUE DO 410 I = 1,2 DO 400 J = 1,2 ACOUPB(I,J) = & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)* & (B(1,I)*B(2,J) -B(1,J)*B(2,I)) 400 CONTINUE 410 CONTINUE PRUN = XMA EPS = 1D-4*PRUN ITER = 0 420 ITER = ITER + 1 DO 470 I3 = 1,3 PR(I3)=PRUN+(I3-2)*EPS/2 AP2=PR(I3)**2 APOLT = 0D0 DO 440 I = 1,2 DO 430 J = 1,2 APOLT = APOLT + ACOUPT(I,J)**2*3D0* & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2 430 CONTINUE 440 CONTINUE APOLB = 0D0 DO 460 I = 1,2 DO 450 J = 1,2 APOLB = APOLB + ACOUPB(I,J)**2*3D0* & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2 450 CONTINUE 460 CONTINUE C RXMT2 = RXMT**2 XMT2=XMT**2 APOLTT = & 3D0*RXMT**2/8D0/PI**2/ V **2* & COSB**2/SINB**2 * & (-0.5D0*AP2)* & PYFINT(AP2,XMT2,XMT2) APOL = APOLT + APOLB + APOLTT POLAR(I3) = AP2 - XMA**2 -APOL 470 CONTINUE DERIV = (POLAR(3)-POLAR(1))/EPS DRUN = - POLAR(2)/DERIV PRUN = PRUN + DRUN AP2 = PRUN**2 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480 GOTO 420 480 CONTINUE AMP = DSQRT(AP2) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C...END OF PSEUDOSCALAR HIGGS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IF(IHIGGS.EQ.3) GOTO 490 490 CONTINUE RETURN 500 CONTINUE WRITE(MSTU(11),*) ' EXITING IN PYPOLE ' WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22 STOP END C********************************************************************* C...PYRGHM C...Auxiliary to PYPOLE. SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU, * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB) IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z) DIMENSION VH(2,2),M2(2,2),M2P(2,2) C...Parameters. INTEGER MSTU,MSTJ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ MZ = 91.18D0 PI = PARU(1) V = 174.1D0 ALPHA1 = 0.0101D0 ALPHA2 = 0.0337D0 ALPHA3Z = 0.12D0 TANBA = TANB TANBT = TANB C MBOTTOM(MTOP) = 3. GEV MB = 3D0 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z* *LOG(MTOP**2/MZ**2)) C RMTOP= RUNNING TOP QUARK MASS RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI) TQ = LOG((MQ**2+MTOP**2)/MTOP**2) TU = LOG((MUR**2 + MTOP**2)/MTOP**2) TD = LOG((MD**2 + MTOP**2)/MTOP**2) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C NEW DEFINITION, TGLU. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC TGLU = LOG(MGLU**2/MTOP**2) SINB = TANB/DSQRT(1D0 + TANB**2) COSB = SINB/TANB IF(MA.GT.MTOP) *TANBA = TANB*(1D0-3D0/32D0/PI**2* *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)* *LOG(MA**2/MTOP**2)) IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA SINB = TANBT/SQRT(1D0 + TANBT**2) COSB = 1D0/DSQRT(1D0 + TANBT**2) G1 = SQRT(ALPHA1*4D0*PI) G2 = SQRT(ALPHA2*4D0*PI) G3 = SQRT(ALPHA3*4D0*PI) HU = RMTOP/V/SINB HD = MB/V/COSB CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2, *SBOT1,SBOT2,DELTAMT,DELTAMB) IF(MQ.GT.MUR) TP = TQ - TU IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ IF(MQ.GT.MUR) TDP = TU IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ IF(MQ.GT.MD) TPD = TQ - TD IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ IF(MQ.GT.MD) TDPD = TD IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2* * HD**2*(G1**2/3D0+G2**2)*TPD IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2* * HU**2*(-G1**2/3D0+G2**2)*TP CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL, C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE C TWO STOPS. C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2) ENDIF IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2) ENDIF IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2) ENDIF IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2) ENDIF IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2) ENDIF IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2) ENDIF ENDIF DLAMBDA3 = 0D0 DLAMBDA4 = 0D0 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2* *(G2**2-G1**2/3D0)*TPD IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 - *1D0/16D0/PI**2*G1**2*HU**2*TP IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 + * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2* *HD**2*TPD LAMBDA1 = ((G1**2 + G2**2)/4D0)* * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2) *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0 *+ (3D0*HD**2/2D0 + HU**2/2D0 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2) *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2* *(TP + TDP)/8D0/PI**2) *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0 *+ (3D0*HU**2/2D0 + HD**2/2D0 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2) *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0* *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0* *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3 LAMBDA4 = (- G2**2/2D0)*(1D0 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4 LAMBDA5 = 0D0 LAMBDA6 = 0D0 LAMBDA7 = 0D0 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6* *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7* *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)* *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB M2(2,1) = M2(1,2) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2) IF(MCHI.GT.MSSUSY) GOTO 100 IF(MCHI.LT.MTOP) MCHI=MTOP TCHAR=LOG(MSSUSY**2/MCHI**2) DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR DELTAM112=2D0*DELTAL12*V**2*COSB**2 DELTAM222=2D0*DELTAL12*V**2*SINB**2 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB M2(1,1)=M2(1,1)+DELTAM112 M2(2,2)=M2(2,2)+DELTAM222 M2(1,2)=M2(1,2)+DELTAM122 M2(2,1)=M2(2,1)+DELTAM122 100 CONTINUE CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCC END OF CHARGINOS/NEUTRALINOS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC DO 120 I = 1,2 DO 110 J = 1,2 M2P(I,J) = M2(I,J) + VH(I,J) 110 CONTINUE 120 CONTINUE TRM2P = M2P(1,1) + M2P(2,2) DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1) MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0 HMP = DSQRT(HM2P) MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2 MCH=DSQRT(MCH2) IF(MH2P.LT.0.) GOTO 130 MHP = SQRT(MH2P) SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P) COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P) IF(COS2ALPHA.GT.0.) ALPHA = ASIN(SIN2ALPHA)/2D0 IF(COS2ALPHA.LT.0.) ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0 SA = SIN(ALPHA) CA = COS(ALPHA) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK. C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB)) CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB)) 130 CONTINUE RETURN END C********************************************************************* C...PYGFXX C...Auxiliary to PYRGHM. SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH, * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB) IMPLICIT DOUBLE PRECISION(A-H,M,O-Z) DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2) C...Commonblocks. INTEGER MSTU,MSTJ,KCHG COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y) T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2) * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2)) IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0 MQ2 = MQ**2 MUR2 = MUR**2 MD2 = MD**2 TANBA = TANB SINBA = TANBA/DSQRT(TANBA**2+1D0) COSBA = SINBA/TANBA SINB = TANB/DSQRT(TANB**2+1D0) COSB = SINB/TANB PI = PARU(1) MZ = PMAS(23,1) MW = PMAS(24,1) SW = 1D0-MW**2/MZ**2 V = 174.1D0 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2)) G2 = DSQRT(0.0336D0*4D0*PI) G1 = DSQRT(0.0101D0*4D0*PI) MB = 3D0 IF(MQ.GT.MUR) MST = MQ IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR MSUSYT = DSQRT(MST**2 + MTOP**2) IF(MQ.GT.MD) MSB = MQ IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD MSUSYB = DSQRT(MSB**2 + MB**2) TT = LOG(MSUSYT**2/MTOP**2) TB = LOG(MSUSYB**2/MTOP**2) RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI) HT = RMTOP/(V*SINB) HTST = RMTOP/V HB = MB/V/COSB G32 = ALPHA3*4D0*PI BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2 AL2 = 3D0/8D0/PI**2*HT**2 C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2 C ALST = 3./8./PI**2*HTST**2 AL1 = 3D0/8D0/PI**2*HB**2 AL(1,1) = AL1 AL(1,2) = (AL2+AL1)/2D0 AL(2,1) = (AL2+AL1)/2D0 AL(2,2) = AL2 IF(MA.GT.MTOP) THEN VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2* * LOG(MTOP**2/MA**2)) H1I = VI* COSBA H2I = VI*SINBA H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0 ELSE VI = V H1I = VI*COSB H2I = VI*SINB H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0 ENDIF TANBST = H2T/H1T SINBT = TANBST/DSQRT(1D0+TANBST**2) TANBSB = H2B/H1B SINBB = TANBSB/DSQRT(1D0+TANBSB**2) COSBB = SINBB/TANBSB DELTAMT = 0D0 DELTAMB = 0D0 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT) MTOP2 = DSQRT(MTOP4) MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB) * /(1D0+DELTAMB)**4 MBOT2 = DSQRT(MBOT4) STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2) STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + * MQ2 - MUR2)**2*0.25D0 * + MTOP2*(AT-XMU/TANBST)**2) IF(STOP22.LT.0.) GOTO 120 SBOT12 = (MQ2 + MD2)*.5D0 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2) SBOT22 = (MQ2 + MD2)*.5D0 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2) IF(SBOT22.LT.0.) SBOT22 = 10000D0 STOP1 = DSQRT(STOP12) STOP2 = DSQRT(STOP22) SBOT1 = DSQRT(SBOT12) SBOT2 = DSQRT(SBOT22) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING C INDUCED CORRECTIONS. C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC X=SBOT1 Y=SBOT2 Z=XMGL IF(X.EQ.Y) X = X - 0.00001D0 IF(X.EQ.Z) X = X - 0.00002D0 IF(Y.EQ.Z) Y = Y - 0.00003D0 T1=T(X,Y,Z) X=STOP1 Y=STOP2 Z=XMU IF(X.EQ.Y) X = X - 0.00001D0 IF(X.EQ.Z) X = X - 0.00002D0 IF(Y.EQ.Z) Y = Y - 0.00003D0 T2=T(X,Y,Z) DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2 X=STOP1 Y=STOP2 Z=XMGL IF(X.EQ.Y) X = X - 0.00001D0 IF(X.EQ.Z) X = X - 0.00002D0 IF(Y.EQ.Z) Y = Y - 0.00003D0 T3=T(X,Y,Z) DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB. C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA, C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA, C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES ! C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT) MTOP2 = DSQRT(MTOP4) MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB) * /(1D0+DELTAMB)**4 MBOT2 = DSQRT(MBOT4) STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2) STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + * MQ2 - MUR2)**2*0.25D0 * + MTOP2*(AT-XMU/TANBST)**2) IF(STOP22.LT.0.) GOTO 120 SBOT12 = (MQ2 + MD2)*.5D0 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2) SBOT22 = (MQ2 + MD2)*.5D0 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2) IF(SBOT22.LT.0.) GOTO 120 STOP1 = DSQRT(STOP12) STOP2 = DSQRT(STOP22) SBOT1 = DSQRT(SBOT12) SBOT2 = DSQRT(SBOT22) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCC D-TERMS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC STW=SW F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)* * LOG(STOP1/STOP2) * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2)) * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2)) F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)* * LOG(SBOT1/SBOT2) * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2)) * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2)) F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)* * (-.5D0*LOG(STOP12/STOP22) * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)* * G(STOP12,STOP22)) F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)* * (.5D0*LOG(SBOT12/SBOT22) * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)* * G(SBOT12,SBOT22)) VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/ * (MQ2+MBOT2)/(MD2+MBOT2)) * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))* * LOG(SBOT1**2/SBOT2**2)) + * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/ * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22) VH3T(1,1) = * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2 * -STOP2**2))**2*G(STOP12,STOP22) VH3B(1,1)=VH3B(1,1)+ * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B) VH3T(1,1) = VH3T(1,1) + * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T) VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/ * (MQ2+MTOP2)/(MUR2+MTOP2)) * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))* * LOG(STOP1**2/STOP2**2)) + * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/ * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22) VH3B(2,2) = * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2 * -SBOT2**2))**2*G(SBOT12,SBOT22) VH3T(2,2)=VH3T(2,2)+ * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T) VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B VH3T(1,2) = - * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/ * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT* * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22)) VH3B(1,2) = * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/ * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB* * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22)) VH3T(1,2)=VH3T(1,2) + *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T) VH3B(1,2)=VH3B(1,2) + *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B) VH3T(2,1) = VH3T(1,2) VH3B(2,1) = VH3B(1,2) C TQ = LOG((MQ2 + MTOP2)/MTOP2) C TU = LOG((MUR2+MTOP2)/MTOP2) C TQD = LOG((MQ2 + MB**2)/MB**2) C TD = LOG((MD2+MB**2)/MB**2) DO 110 I = 1,2 DO 100 J = 1,2 VH(I,J) = * 6D0/(8D0*PI**2*(H1T**2+H2T**2)) * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) + * 6D0/(8D0*PI**2*(H1B**2+H2B**2)) * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0) 100 CONTINUE 110 CONTINUE GOTO 150 120 DO 140 I =1,2 DO 130 J = 1,2 VH(I,J) = -1D15 130 CONTINUE 140 CONTINUE 150 RETURN END C********************************************************************* C...PYFINT C...Auxiliary routine to PYPOLE for SUSY Higgs calculations. FUNCTION PYFINT(A,B,C) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblock. COMMON/PYINTS/XXM(20) SAVE/PYINTS/ C...Local variables. EXTERNAL PYFISB DOUBLE PRECISION PYFISB XXM(1)=A XXM(2)=B XXM(3)=C XLO=0D0 XHI=1D0 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3) RETURN END C********************************************************************* C...PYFISB C...Auxiliary routine to PYFINT for SUSY Higgs calculations. FUNCTION PYFISB(X) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblock. COMMON/PYINTS/XXM(20) SAVE/PYINTS/ PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/ &(X*(XXM(2)-XXM(3))+XXM(3))) RETURN END C********************************************************************* C...PYSFDC C...Calculates decays of sfermions. SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ C...Local variables. COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2) COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB INTEGER KFIN,KCIN DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP DOUBLE PRECISION PYLAMF,XL DOUBLE PRECISION TANW,XW,AEM,C1,AS DOUBLE PRECISION AL,AR,BL,BR DOUBLE PRECISION CH1,CH2,CH3,CH4 DOUBLE PRECISION XMBOT,XMTOP DOUBLE PRECISION XLAM(0:300) INTEGER IDLAM(300,3) INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II DOUBLE PRECISION SR2 DOUBLE PRECISION CBETA,SBETA DOUBLE PRECISION CW DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL DOUBLE PRECISION COSA,SINA,TANB DOUBLE PRECISION PYALEM,PI,PYALPS,EI,PYRNMT DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR INTEGER IG,KF1,KF2 INTEGER IGG(4),KFNCHI(4),KFCCHI(2) DATA IGG/23,25,35,36/ DATA PI/3.141592654D0/ DATA SR2/1.4142136D0/ DATA KFNCHI/1000022,1000023,1000025,1000035/ DATA KFCCHI/1000024,1000037/ C...COUNT THE NUMBER OF DECAY MODES LKNT=0 C...NO NU_R DECAYS IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR. &KFIN.EQ.KSUSY2+16) RETURN XMW=PMAS(24,1) XMW2=XMW**2 XMZ=PMAS(23,1) XW=PARU(102) TANW = SQRT(XW/(1D0-XW)) CW=SQRT(1D0-XW) DO 110 I=1,4 DO 100 J=1,4 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I)) 100 CONTINUE 110 CONTINUE DO 130 I=1,2 DO 120 J=1,2 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I)) UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I)) 120 CONTINUE 130 CONTINUE C...KCIN KCIN=PYCOMP(KFIN) C...ILR is 1 for left and 2 for right. ILR=KFIN/KSUSY1 C...IFL is matching non-SUSY flavour. IFL=MOD(KFIN,KSUSY1) C...IDU is weak isospin, 1 for down and 2 for up. IDU=2-MOD(IFL,2) XMI=PMAS(KCIN,1) XMI2=XMI**2 AEM=PYALEM(XMI2) AS =PYALPS(XMI2) C1=AEM/XW XMI3=XMI**3 EI=KCHG(IFL,1)/3D0 XMBOT=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(29) IDG=39+KSUSY1 XMGR=PMAS(PYCOMP(IDG),1) XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI IF(IFL.EQ.5) THEN XMF=XMBOT ELSEIF(IFL.EQ.6) THEN XMF=XMTOP ELSE XMF=PMAS(IFL,1) ENDIF IF(XMI.GT.XMGR+XMF) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=IFL IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4 ENDIF ENDIF C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO C...CHARGED DECAYS: DO 140 IX=1,2 C...DI -> U CHI1-,CHI2- IF(IDU.EQ.1) THEN XMFP=PMAS(IFL+1,1) XMF =PMAS(IFL,1) C...UI -> D CHI1+,CHI2+ ELSE XMFP=PMAS(IFL-1,1) XMF =PMAS(IFL,1) ENDIF XMJ=SMW(IX) AXMJ=ABS(XMJ) IF(XMI.GE.AXMJ+XMFP) THEN XMA2=XMJ**2 XMB2=XMFP**2 IF(IDU.EQ.2) THEN IF(IFL.EQ.6) THEN XMFP=XMBOT XMF =XMTOP ELSEIF(IFL.LT.6) THEN XMF=0D0 XMFP=0D0 ENDIF CBL=VMIXC(IX,1) CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA CAR=0D0 ELSE IF(IFL.EQ.5) THEN XMF =XMBOT XMFP=XMTOP ELSEIF(IFL.LT.5) THEN XMF=0D0 XMFP=0D0 ENDIF CBL=UMIXC(IX,1) CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA CAR=0D0 ENDIF CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL CAL=CALP CBL=CBLP CAR=CARP CBR=CBRP C...F1 -> F` CHI IF(ILR.EQ.1) THEN CA=CAL CB=CBL C...F2 -> F` CHI ELSE CA=CAR CB=CBR ENDIF LKNT=LKNT+1 XL=PYLAMF(XMI2,XMA2,XMB2) C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)* & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP) IDLAM(LKNT,3)=0 IF(IDU.EQ.1) THEN IDLAM(LKNT,1)=-KFCCHI(IX) IDLAM(LKNT,2)=IFL+1 ELSE IDLAM(LKNT,1)=KFCCHI(IX) IDLAM(LKNT,2)=IFL-1 ENDIF ENDIF 140 CONTINUE C...NEUTRAL DECAYS DO 150 IX=1,4 C...DI -> D CHI10 XMF=PMAS(IFL,1) XMJ=SMZ(IX) AXMJ=ABS(XMJ) IF(XMI.GE.AXMJ+XMF) THEN XMA2=XMJ**2 XMB2=XMF**2 IF(IDU.EQ.1) THEN IF(IFL.EQ.5) THEN XMF=XMBOT ELSEIF(IFL.LT.5) THEN XMF=0D0 ENDIF CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1) CAL=XMF*ZMIXC(IX,3)/XMW/CBETA CAR=-2D0*EI*TANW*ZMIXC(IX,1) CBR=CAL ELSE IF(IFL.EQ.6) THEN XMF=XMTOP ELSEIF(IFL.LT.5) THEN XMF=0D0 ENDIF CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1) CAL=XMF*ZMIXC(IX,4)/XMW/SBETA CAR=-2D0*EI*TANW*ZMIXC(IX,1) CBR=CAL ENDIF CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL CAL=CALP CBL=CBLP CAR=CARP CBR=CBRP C...F1 -> F CHI IF(ILR.EQ.1) THEN CA=CAL CB=CBL C...F2 -> F CHI ELSE CA=CAR CB=CBR ENDIF LKNT=LKNT+1 XL=PYLAMF(XMI2,XMA2,XMB2) C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)* & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF) IDLAM(LKNT,1)=KFNCHI(IX) IDLAM(LKNT,2)=IFL IDLAM(LKNT,3)=0 ENDIF 150 CONTINUE C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS C...IG=23,25,35,36 DO 160 II=1,4 IG=IGG(II) IF(ILR.EQ.1) GOTO 160 XMB=PMAS(IG,1) XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1) IF(XMI.LT.XMSF1+XMB) GOTO 160 IF(IG.EQ.23) THEN BL=-SIGN(.5D0,EI)/CW+EI*XW/CW BR=EI*XW/CW BLR=0D0 ELSEIF(IG.EQ.25) THEN IF(IFL.EQ.5) THEN XMF=XMBOT ELSEIF(IFL.EQ.6) THEN XMF=XMTOP ELSEIF(IFL.LT.5) THEN XMF=0D0 ELSE XMF=PMAS(IFL,1) ENDIF IF(IDU.EQ.2) THEN GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+ & XMF**2/XMW*COSA/SBETA GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+ & XMF**2/XMW*COSA/SBETA ELSE GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+ & XMF**2/XMW*(-SINA)/CBETA GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+ & XMF**2/XMW*(-SINA)/CBETA ENDIF IF(IFL.EQ.5) THEN AT=ATRIB ELSEIF(IFL.EQ.6) THEN AT=ATRIT ELSEIF(IFL.EQ.15) THEN AT=ATRIL ELSE AT=0D0 ENDIF C.........need to complexify IF(IDU.EQ.2) THEN GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+ & AT*COSA) ELSE GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA- & AT*SINA) ENDIF BL=GHLL BR=GHRR BLR=-GHLR ELSEIF(IG.EQ.35) THEN IF(IFL.EQ.5) THEN XMF=XMBOT ELSEIF(IFL.EQ.6) THEN XMF=XMTOP ELSEIF(IFL.LT.5) THEN XMF=0D0 ELSE XMF=PMAS(IFL,1) ENDIF IF(IDU.EQ.2) THEN GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+ & XMF**2/XMW*SINA/SBETA GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+ & XMF**2/XMW*SINA/SBETA ELSE GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+ & XMF**2/XMW*COSA/CBETA GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+ & XMF**2/XMW*COSA/CBETA ENDIF IF(IFL.EQ.5) THEN AT=ATRIB ELSEIF(IFL.EQ.6) THEN AT=ATRIT ELSEIF(IFL.EQ.15) THEN AT=ATRIL ELSE AT=0D0 ENDIF C.........Need to complexify IF(IDU.EQ.2) THEN GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+ & AT*SINA) ELSE GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+ & AT*COSA) ENDIF BL=GHLL BR=GHRR BLR=GHLR ELSEIF(IG.EQ.36) THEN GHLL=0D0 GHRR=0D0 IF(IFL.EQ.5) THEN XMF=XMBOT ELSEIF(IFL.EQ.6) THEN XMF=XMTOP ELSEIF(IFL.LT.5) THEN XMF=0D0 ELSE XMF=PMAS(IFL,1) ENDIF IF(IFL.EQ.5) THEN AT=ATRIB ELSEIF(IFL.EQ.6) THEN AT=ATRIT ELSEIF(IFL.EQ.15) THEN AT=ATRIL ELSE AT=0D0 ENDIF C.........Need to complexify IF(IDU.EQ.2) THEN GHLR=XMF/2D0/XMW*(-XMU+AT/TANB) ELSE GHLR=XMF/2D0/XMW/(-XMU+AT*TANB) ENDIF BL=GHLL BR=GHRR BLR=GHLR ENDIF AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+ & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+ & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR XL=PYLAMF(XMI2,XMSF1**2,XMB**2) LKNT=LKNT+1 IF(IG.EQ.23) THEN XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2 ELSE XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2 ENDIF IDLAM(LKNT,3)=0 IDLAM(LKNT,1)=KFIN-KSUSY1 IDLAM(LKNT,2)=IG 160 CONTINUE C...SF -> SF' + W XMB=PMAS(24,1) IF(MOD(IFL,2).EQ.0) THEN KF1=KSUSY1+IFL-1 ELSE KF1=KSUSY1+IFL+1 ENDIF KF2=KF1+KSUSY1 XMSF1=PMAS(PYCOMP(KF1),1) XMSF2=PMAS(PYCOMP(KF2),1) IF(XMI.GT.XMB+XMSF1) THEN IF(MOD(IFL,2).EQ.0) THEN IF(ILR.EQ.1) THEN AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1) ELSE AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1) ENDIF ELSE IF(ILR.EQ.1) THEN AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1) ELSE AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1) ENDIF ENDIF XL=PYLAMF(XMI2,XMSF1**2,XMB**2) LKNT=LKNT+1 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2 IDLAM(LKNT,3)=0 IDLAM(LKNT,1)=KF1 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1)) ENDIF IF(XMI.GT.XMB+XMSF2) THEN IF(MOD(IFL,2).EQ.0) THEN IF(ILR.EQ.1) THEN AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3) ELSE AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3) ENDIF ELSE IF(ILR.EQ.1) THEN AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3) ELSE AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3) ENDIF ENDIF XL=PYLAMF(XMI2,XMSF2**2,XMB**2) LKNT=LKNT+1 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2 IDLAM(LKNT,3)=0 IDLAM(LKNT,1)=KF2 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1)) ENDIF C...SF -> SF' + HC XMB=PMAS(37,1) IF(MOD(IFL,2).EQ.0) THEN KF1=KSUSY1+IFL-1 ELSE KF1=KSUSY1+IFL+1 ENDIF KF2=KF1+KSUSY1 XMSF1=PMAS(PYCOMP(KF1),1) XMSF2=PMAS(PYCOMP(KF2),1) IF(XMI.GT.XMB+XMSF1) THEN XMF=0D0 XMFP=0D0 AT=0D0 AB=0D0 IF(MOD(IFL,2).EQ.0) THEN C...T1-> B1 HC IF(ILR.EQ.1) THEN CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1) CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2) CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2) CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1) C...T2-> B1 HC ELSE CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1) CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2) CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2) CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1) ENDIF IF(IFL.EQ.6) THEN XMF=XMTOP XMFP=XMBOT AT=ATRIT AB=ATRIB ENDIF ELSE C...B1 -> T1 HC IF(ILR.EQ.1) THEN CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1) CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2) CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2) CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1) C...B2-> T1 HC ELSE CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1) CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2) CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1) CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2) ENDIF IF(IFL.EQ.5) THEN XMF=XMTOP XMFP=XMBOT AT=ATRIT AB=ATRIB ENDIF ENDIF XL=PYLAMF(XMI2,XMSF1**2,XMB**2) LKNT=LKNT+1 C.......Need to complexify AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+ & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+ & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB) XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2 IDLAM(LKNT,3)=0 IDLAM(LKNT,1)=KF1 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1)) ENDIF IF(XMI.GT.XMB+XMSF2) THEN XMF=0D0 XMFP=0D0 AT=0D0 AB=0D0 IF(MOD(IFL,2).EQ.0) THEN C...T1-> B2 HC IF(ILR.EQ.1) THEN CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1) CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2) CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1) CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2) C...T2-> B2 HC ELSE CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3) CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4) CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4) CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3) ENDIF IF(IFL.EQ.6) THEN XMF=XMTOP XMFP=XMBOT AT=ATRIT AB=ATRIB ENDIF ELSE C...B1 -> T2 HC IF(ILR.EQ.1) THEN CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1) CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2) CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2) CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1) C...B2-> T2 HC ELSE CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3) CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4) CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4) CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3) ENDIF IF(IFL.EQ.5) THEN XMF=XMTOP XMFP=XMBOT AT=ATRIT AB=ATRIB ENDIF ENDIF XL=PYLAMF(XMI2,XMSF1**2,XMB**2) LKNT=LKNT+1 C.......Need to complexify AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+ & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+ & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB) XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2 IDLAM(LKNT,3)=0 IDLAM(LKNT,1)=KF2 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1)) ENDIF C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO IF(IFL.LE.6) THEN XMFP=0D0 XMF=0D0 IF(IFL.EQ.6) XMF=PMAS(6,1) IF(IFL.EQ.5) XMF=PMAS(5,1) XMJ=PMAS(PYCOMP(KSUSY1+21),1) AXMJ=ABS(XMJ) IF(XMI.GE.AXMJ+XMF) THEN AL=-SFMIX(IFL,3) BL=SFMIX(IFL,1) AR=-SFMIX(IFL,4) BR=SFMIX(IFL,2) C...F1 -> F CHI IF(ILR.EQ.1) THEN XCA=AL XCB=BL C...F2 -> F CHI ELSE XCA=AR XCB=BR ENDIF LKNT=LKNT+1 XMA2=XMJ**2 XMB2=XMF**2 XL=PYLAMF(XMI2,XMA2,XMB2) XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)* & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=IFL IDLAM(LKNT,3)=0 ENDIF ENDIF C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT. &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI) C...M*M = C1**2 * G**2/(16PI**2) C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3) LKNT=LKNT+1 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2) XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL) IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3 IDLAM(LKNT,1)=KSUSY1+22 IDLAM(LKNT,2)=4 IDLAM(LKNT,3)=0 ENDIF C...R-violating sfermion decays (SKANDS). CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT) IKNT=LKNT XLAM(0)=0D0 DO 170 I=1,IKNT IF(XLAM(I).LT.0D0) XLAM(I)=0D0 XLAM(0)=XLAM(0)+XLAM(I) 170 CONTINUE IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3 RETURN END C********************************************************************* C...PYGLUI C...Calculates gluino decay modes. SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) CC &SFMIX(16,4), C COMMON/PYINTS/XXM(20) COMPLEX*16 CXC COMMON/PYINTC/XXC(10),CXC(8) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/ C...Local variables COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP DOUBLE PRECISION PYLAMF,XL DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN DOUBLE PRECISION CA,CB,AL,AR,BL,BR DOUBLE PRECISION XLAM(0:300) INTEGER IDLAM(300,3) INTEGER LKNT,IX,ILR,I,IKNT,IFL DOUBLE PRECISION SR2 DOUBLE PRECISION GAM DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I EXTERNAL PYGAUS,PYXXZ6 DOUBLE PRECISION PYGAUS,PYXXZ6 DOUBLE PRECISION PREC INTEGER KFNCHI(4),KFCCHI(2) DATA PI/3.141592654D0/ DATA SR2/1.4142136D0/ DATA PREC/1D-2/ DATA KFNCHI/1000022,1000023,1000025,1000035/ DATA KFCCHI/1000024,1000037/ C...COUNT THE NUMBER OF DECAY MODES LKNT=0 IF(KFIN.NE.KSUSY1+21) RETURN KCIN=PYCOMP(KFIN) XW=PARU(102) TANW = SQRT(XW/(1D0-XW)) XMI=PMAS(KCIN,1) AXMI=ABS(XMI) XMI2=XMI**2 AEM=PYALEM(XMI2) AS =PYALPS(XMI2) C1=AEM/XW XMI3=XMI**3 C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON IF(IMSS(11).EQ.1) THEN XMP=RMSS(29) IDG=39+KSUSY1 XMGR=PMAS(PYCOMP(IDG),1) XFAC=(XMI2/(XMP*XMGR))**2*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) IF(XMI.GE.AXMJ+XMF) THEN C...Minus sign difference from gluino-quark-squark feynman rules AL=SFMIX(IFL,1) BL=-SFMIX(IFL,3) AR=SFMIX(IFL,2) BR=-SFMIX(IFL,4) C...F1 -> F CHI IF(ILR.EQ.1) THEN CA=AL CB=BL C...F2 -> F CHI ELSE CA=AR CB=BR ENDIF LKNT=LKNT+1 XMA2=XMJ**2 XMB2=XMF**2 XL=PYLAMF(XMI2,XMA2,XMB2) XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)* & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF) IDLAM(LKNT,1)=ILR*KSUSY1+IFL IDLAM(LKNT,2)=-IFL IDLAM(LKNT,3)=0 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=0 ENDIF 100 CONTINUE 110 CONTINUE C...3-BODY DECAYS TO GAUGINO FERMION-FERMION C...GLUINO -> NI Q QBAR DO 170 IX=1,4 XMJ=SMZ(IX) AXMJ=ABS(XMJ) IF(XMI.GE.AXMJ) THEN DO 120 I=1,4 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I)) 120 CONTINUE OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2 ORPP=DCONJG(OLPP) XXC(1)=0D0 XXC(2)=XMJ XXC(3)=0D0 XXC(4)=XMI IA=1 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1) XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1) XXC(7)=XXC(5) XXC(8)=XXC(6) XXC(9)=1D6 XXC(10)=0D0 EI=KCHG(IA,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP CXC(1)=0D0 CXC(2)=-GLIJ CXC(3)=0D0 CXC(4)=DCONJG(GLIJ) CXC(5)=0D0 CXC(6)=GRIJ CXC(7)=0D0 CXC(8)=-DCONJG(GRIJ) S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130 IF(XMI.GE.AXMJ+2D0*PMAS(1,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2) IDLAM(LKNT,1)=KFNCHI(IX) IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-1 ENDIF IF(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 130 CONTINUE 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 140 CONTINUE IA=2 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1) XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1) C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290 XXC(7)=XXC(5) XXC(8)=XXC(6) EI=KCHG(IA,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP CXC(2)=-GLIJ CXC(4)=DCONJG(GLIJ) CXC(6)=GRIJ CXC(8)=-DCONJG(GRIJ) IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150 IF(XMI.GE.AXMJ+2D0*PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2) IDLAM(LKNT,1)=KFNCHI(IX) IDLAM(LKNT,2)=2 IDLAM(LKNT,3)=-2 ENDIF IF(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 150 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 160 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 160 CONTINUE ENDIF 170 CONTINUE C...GLUINO -> CI Q QBAR' DO 210 IX=1,2 XMJ=SMW(IX) AXMJ=ABS(XMJ) IF(XMI.GE.AXMJ) THEN DO 180 I=1,2 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I)) UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I)) 180 CONTINUE S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 XXC(1)=0D0 XXC(2)=XMJ XXC(3)=0D0 XXC(4)=XMI XXC(5)=PMAS(PYCOMP(KSUSY1+1),1) XXC(6)=PMAS(PYCOMP(KSUSY1+2),1) XXC(9)=1D6 XXC(10)=0D0 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32))) ORPP=DCONJG(OLPP) CXC(1)=DCMPLX(0D0,0D0) CXC(3)=DCMPLX(0D0,0D0) CXC(5)=DCMPLX(0D0,0D0) CXC(7)=DCMPLX(0D0,0D0) CXC(2)=UMIXC(IX,1)*OLPP/SR2 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2 CXC(6)=DCMPLX(0D0,0D0) CXC(8)=DCMPLX(0D0,0D0) IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ELSEIF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(6) XXC(8)=XXC(5) IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190 IF(XMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(IX) IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-2 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ENDIF IF(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 190 CONTINUE IF(XMI.GE.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) GOTO 200 IF(XMI.GE.PMAS(PYCOMP(KSUSY1+6),1)+PMAS(6,1)) GOTO 200 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 200 CONTINUE ENDIF 210 CONTINUE IKNT=LKNT XLAM(0)=0D0 DO 220 I=1,IKNT IF(XLAM(I).LT.0D0) XLAM(I)=0D0 XLAM(0)=XLAM(0)+XLAM(I) 220 CONTINUE IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6 RETURN END C********************************************************************* C...PYTBBN C...Calculates the three-body decay of gluinos into C...neutralinos and third generation fermions. SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ C...Local variables. EXTERNAL PYSIMP,PYLAMF DOUBLE PRECISION PYSIMP,PYLAMF INTEGER LIN,NN DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100) DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24 DOUBLE PRECISION XLN1,XLN2,B1,B2 DOUBLE PRECISION E,XMGLU,GAM DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4) SAVE HRB,HLB,FLB,FRB DOUBLE PRECISION ALPHAW,ALPHAS DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4) SAVE HLT,HRT,FLT,FRT DOUBLE PRECISION AMN(4),AN(4,4),ZN(3) SAVE AMN,AN,ZN DOUBLE PRECISION AMBOT,SINC,COSC DOUBLE PRECISION AMTOP,SINA,COSA DOUBLE PRECISION SINW,COSW,TANW DOUBLE PRECISION ROT1(4,4) LOGICAL IFIRST SAVE IFIRST DATA IFIRST/.TRUE./ TANB=RMSS(5) SINB=TANB/SQRT(1D0+TANB**2) COSB=SINB/TANB XW=PARU(102) SINW=SQRT(XW) COSW=SQRT(1D0-XW) TANW=SINW/COSW AMW=PMAS(24,1) COSC=SFMIX(5,1) SINC=SFMIX(5,3) COSA=SFMIX(6,1) SINA=SFMIX(6,3) AMBOT=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 C FLU(J)=ZN(3) C FRU(J)=ZN(2) ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4)) ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1)) ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW HRB(J)=ZN(1)*COSC-ZN(3)*SINC HLB(J)=ZN(1)*COSC+ZN(2)*SINC FLB(J)=ZN(3)*COSC+ZN(1)*SINC FRB(J)=ZN(2)*COSC-ZN(1)*SINC C FLD(J)=ZN(3) C FRD(J)=ZN(2) 150 CONTINUE C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1) C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1) C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1) C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1) IFIRST=.FALSE. ENDIF IF(NINT(3D0*E).EQ.2) THEN HL=HLT(I) HR=HRT(I) FL=FLT(I) FR=FRT(I) COSD=SFMIX(6,1) SIND=SFMIX(6,3) XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2 XM=PMAS(6,1) ELSE HL=HLB(I) HR=HRB(I) FL=FLB(I) FR=FRB(I) COSD=SFMIX(5,1) SIND=SFMIX(5,3) XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2 XM=PMAS(5,1) ENDIF COSD2=COSD*COSD SIND2=SIND*SIND COS2D=COSD2-SIND2 SIN2D=SIND*COSD*2D0 HL2=HL*HL HR2=HR*HR FL2=FL*FL FR2=FR*FR FF=FL*FR HH=HL*HR HFL=HL*FL HFR=HR*FR HRFL=HR*FL HLFR=HL*FR XM2=XM*XM XMG=XMGLU XMG2=XMG*XMG ALPHAW=PYALEM(XMG2) ALPHAS=PYALPS(XMG2) XMR=AMN(I) XMR2=XMR*XMR XMQ4=XMG*XM2*XMR XM24=(XMG2+XM2)*(XM2+XMR2) SMIN=4D0*XM2 SMAX=(XMG-ABS(XMR))**2 XMQA=XMG2+2D0*XM2+XMR2 DO 170 LIN=1,NN-1 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN) GRS=SBAR-XMQA W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR) W=DSQRT(W) XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W))) XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W))) B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W) B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W) G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D & +2D0*(FF*SIND2-HH*COSD2))*W G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D) & +4D0*HFL*XM*XMR)*XLN1 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D) & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1)) & +8D0*HFL*XMQ4*SIN2D)*B1 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D) & +4D0*HFR*XMR*XM)*XLN2 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2)) & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2) & -8D0*HFR*XMQ4*SIN2D)*B2 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2) & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2) & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2) & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))* & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2) & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1)) G(5)=(2D0*(HH*COSD2-FF*SIND2) & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1) & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR) & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2) & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2) & +COS2D*XM*(SBAR+XMG2-XMR2)) & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2)) & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2)) G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2) & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2) & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2) & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2 SUMME(LIN)=0D0 DO 160 J=0,6 SUMME(LIN)=SUMME(LIN)+G(J) 160 CONTINUE 170 CONTINUE SUMME(0)=0D0 SUMME(NN)=0D0 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN) &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3) RETURN END C********************************************************************* C...PYTBBC C...Calculates the three-body decay of gluinos into C...charginos and third generation fermions. SUBROUTINE PYTBBC(I,NN,XMGLU,GAM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ C...Local variables. EXTERNAL PYSIMP,PYLAMF DOUBLE PRECISION PYSIMP,PYLAMF INTEGER I,NN,LIN DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4) DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX DOUBLE PRECISION SUMME(0:100),A(4,8) DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2 DOUBLE PRECISION XMGLU,GAM DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2), &DDD(2),EEE(2),FFF(2) SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF DOUBLE PRECISION ALPHAW,ALPHAS DOUBLE PRECISION AMC(2) SAVE AMC DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA SAVE AMSB,AMST LOGICAL IFIRST SAVE IFIRST DATA IFIRST/.TRUE./ TANB=RMSS(5) SINB=TANB/SQRT(1D0+TANB**2) COSB=SINB/TANB XW=PARU(102) AMW=PMAS(24,1) COSC=SFMIX(5,1) SINC=SFMIX(5,3) COSA=SFMIX(6,1) SINA=SFMIX(6,3) AMBOT=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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), c &SFMIX(16,4) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) C COMMON/PYINTS/XXM(20) COMPLEX*16 CXC COMMON/PYINTC/XXC(10),CXC(8) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/ C...Local variables. COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB INTEGER KFIN DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2, &XMZ,XMZ2,AXMJ,AXMI DOUBLE PRECISION S12MIN,S12MAX DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2 DOUBLE PRECISION PYLAMF,XL DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I DOUBLE PRECISION PYX2XH,PYX2XG DOUBLE PRECISION XLAM(0:300) INTEGER IDLAM(300,3) INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID INTEGER ITH(3),KF1,KF2 INTEGER ITHC DOUBLE PRECISION DH(3),EH(3) DOUBLE PRECISION SR2 DOUBLE PRECISION CBETA,SBETA DOUBLE PRECISION GAMCON,XMT1,XMT2 DOUBLE PRECISION PYALEM,PI,PYALPS DOUBLE PRECISION RAT1,RAT2 DOUBLE PRECISION T3T,FCOL DOUBLE PRECISION ALFA,BETA,TANB DOUBLE PRECISION PYXXGA EXTERNAL PYGAUS,PYXXZ6 DOUBLE PRECISION PYGAUS,PYXXZ6 DOUBLE PRECISION PREC INTEGER KFNCHI(4),KFCCHI(2) DATA ITH/25,35,36/ DATA ITHC/37/ DATA PREC/1D-2/ DATA PI/3.141592654D0/ DATA SR2/1.4142136D0/ DATA KFNCHI/1000022,1000023,1000025,1000035/ DATA KFCCHI/1000024,1000037/ C...COUNT THE NUMBER OF DECAY MODES LKNT=0 XMW=PMAS(24,1) XMW2=XMW**2 XMZ=PMAS(23,1) XMZ2=XMZ**2 XW=1D0-XMW2/XMZ2 XW1=1D0-XW TANW = SQRT(XW/XW1) C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER IX=1 IF(KFIN.EQ.KFNCHI(2)) IX=2 IF(KFIN.EQ.KFNCHI(3)) IX=3 IF(KFIN.EQ.KFNCHI(4)) IX=4 XMI=SMZ(IX) XMI2=XMI**2 AXMI=ABS(XMI) AEM=PYALEM(XMI2) AS =PYALPS(XMI2) C1=AEM/XW XMI3=ABS(XMI**3) TANB=RMSS(5) BETA=ATAN(TANB) ALFA=RMSS(18) CBETA=COS(BETA) SBETA=TANB*CBETA CALFA=COS(ALFA) SALFA=SIN(ALFA) DO 110 I=1,4 DO 100 J=1,4 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I)) 100 CONTINUE 110 CONTINUE DO 130 I=1,2 DO 120 J=1,2 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I)) UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I)) 120 CONTINUE 130 CONTINUE C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300 C...FORCE CHI0_2 -> CHI0_1 + GAMMA IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN XMJ=SMZ(1) AXMJ=ABS(XMJ) LKNT=LKNT+1 GAMCON=AEM**3/8D0/PI/XMW2/XW XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2) IDLAM(LKNT,1)=KSUSY1+22 IDLAM(LKNT,2)=22 IDLAM(LKNT,3)=0 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT) GOTO 340 ENDIF C...GRAVITINO DECAY MODES IF(IMSS(11).EQ.1) THEN XMP=RMSS(29) IDG=39+KSUSY1 XMGR=PMAS(PYCOMP(IDG),1) SINW=SQRT(XW) COSW=SQRT(1D0-XW) XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI IF(AXMI.GT.XMGR+PMAS(22,1)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=22 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2 ENDIF IF(AXMI.GT.XMGR+XMZ) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=23 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 + $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)* & (1D0-XMZ2/XMI2)**4 ENDIF IF(AXMI.GT.XMGR+PMAS(25,1)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=25 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)* $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4 ENDIF IF(AXMI.GT.XMGR+PMAS(35,1)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=35 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)* $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4 ENDIF IF(AXMI.GT.XMGR+PMAS(36,1)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=36 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)* $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4 ENDIF IF(IX.EQ.1) GOTO 300 ENDIF DO 220 IJ=1,IX-1 XMJ=SMZ(IJ) AXMJ=ABS(XMJ) XMJ2=XMJ**2 C...CHI0_I -> CHI0_J + GAMMA IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 ) RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 ) IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR. & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=22 IDLAM(LKNT,3)=0 GAMCON=AEM**3/8D0/PI/XMW2/XW XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2) ENDIF ENDIF C...CHI0_I -> CHI0_J + Z0 IF(AXMI.GE.AXMJ+XMZ) THEN LKNT=LKNT+1 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))- & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0 ORPP=-DCONJG(OLPP) GX2=ABS(OLPP)**2+ABS(ORPP)**2 GLR=DBLE(OLPP*DCONJG(ORPP)) XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=23 IDLAM(LKNT,3)=0 ELSEIF(AXMI.GE.AXMJ) THEN XXC(1)=0D0 XXC(2)=XMJ XXC(3)=0D0 XXC(4)=XMI XXC(9)=XMZ XXC(10)=PMAS(23,2) OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))- & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0 ORPP=DCONJG(OLPP) C...CHARGED LEPTONS FID=11 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) EI=KCHG(FID,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))* & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1)) GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP CXC(2)=-GLIJ CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP CXC(4)=DCONJG(GLIJ) CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP CXC(6)=GRIJ CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP CXC(8)=-DCONJG(GRIJ) S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF IF(XXC(6).LT.AXMI ) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=FID IDLAM(LKNT,3)=-FID IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=13 IDLAM(LKNT,3)=-13 ENDIF ENDIF 140 CONTINUE IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN XXC(5)=PMAS(PYCOMP(KSUSY1+15),1) XXC(6)=PMAS(PYCOMP(KSUSY2+15),1) ELSE XXC(6)=PMAS(PYCOMP(KSUSY1+15),1) XXC(5)=PMAS(PYCOMP(KSUSY2+15),1) ENDIF IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF IF(XXC(6).LT.AXMI ) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=15 IDLAM(LKNT,3)=-15 ENDIF C...NEUTRINOS 150 CONTINUE FID=12 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) EI=KCHG(FID,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))* & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1)) GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP CXC(2)=-GLIJ CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP CXC(4)=DCONJG(GLIJ) CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP CXC(6)=GRIJ CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP CXC(8)=-DCONJG(GRIJ) S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF IF( XXC(6).LT.AXMI ) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=12 IDLAM(LKNT,3)=-12 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=14 IDLAM(LKNT,3)=-14 160 CONTINUE IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1)) & THEN XXC(5)=PMAS(PYCOMP(KSUSY1+16),1) IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF XXC(7)=XXC(5) LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) ELSE LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) ENDIF IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=16 IDLAM(LKNT,3)=-16 C...D-TYPE QUARKS 170 CONTINUE FID=1 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) EI=KCHG(FID,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))* & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1)) GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP CXC(2)=-GLIJ CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP CXC(4)=DCONJG(GLIJ) CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP CXC(6)=GRIJ CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP CXC(8)=-DCONJG(GRIJ) S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF IF( XXC(6).LT.AXMI ) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0 IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-1 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=3 IDLAM(LKNT,3)=-3 ENDIF ENDIF 180 CONTINUE IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN XXC(5)=PMAS(PYCOMP(KSUSY1+5),1) XXC(6)=PMAS(PYCOMP(KSUSY2+5),1) ELSE XXC(6)=PMAS(PYCOMP(KSUSY1+5),1) XXC(5)=PMAS(PYCOMP(KSUSY2+5),1) ENDIF IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190 IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ELSEIF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0 IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=5 IDLAM(LKNT,3)=-5 ENDIF C...U-TYPE QUARKS 190 CONTINUE FID=2 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) EI=KCHG(FID,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))* & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1)) GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP CXC(2)=-GLIJ CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP CXC(4)=DCONJG(GLIJ) CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP CXC(6)=GRIJ CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP CXC(8)=-DCONJG(GRIJ) IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200 IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ELSEIF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0 IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=2 IDLAM(LKNT,3)=-2 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=4 IDLAM(LKNT,3)=-4 ENDIF ENDIF 200 CONTINUE ENDIF C...CHI0_I -> CHI0_J + H0_K EH(1)=SIN(ALFA) EH(2)=COS(ALFA) EH(3)=-SIN(BETA) DH(1)=COS(ALFA) DH(2)=-SIN(ALFA) DH(3)=COS(BETA) QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+ & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)- & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+ & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1)) RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+ & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))- & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+ & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1))) DO 210 IH=1,3 XMH=PMAS(ITH(IH),1) XMH2=XMH**2 IF(AXMI.GE.AXMJ+XMH) THEN LKNT=LKNT+1 XL=PYLAMF(XMI2,XMJ2,XMH2) F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH)) F12K=F21K C...SIGN OF MASSES I,J XMK=XMJ IF(IH.EQ.3) XMK=-XMK GX2=ABS(F21K)**2+ABS(F12K)**2 GLR=DBLE(F21K*DCONJG(F12K)) XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=ITH(IH) IDLAM(LKNT,3)=0 ENDIF 210 CONTINUE 220 CONTINUE C...CHI0_I -> CHI+_J + W- DO 260 IJ=1,2 XMJ=SMW(IJ) AXMJ=ABS(XMJ) XMJ2=XMJ**2 IF(AXMI.GE.AXMJ+XMW) THEN LKNT=LKNT+1 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)- & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2) CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+ & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2) GX2=ABS(CXC(1))**2+ABS(CXC(3))**2 GLR=DBLE(CXC(1)*DCONJG(CXC(3))) XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=-24 IDLAM(LKNT,3)=0 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-KFCCHI(IJ) IDLAM(LKNT,2)=24 IDLAM(LKNT,3)=0 ELSEIF(AXMI.GE.AXMJ) THEN S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 RT2I = 1D0/SQRT(2D0) CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)- & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+ & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I CXC(5)=DCMPLX(0D0,0D0) CXC(7)=DCMPLX(0D0,0D0) IA=11 JA=12 EI=KCHG(IA,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 EJ=KCHG(JA,1)/3D0 T3J=SIGN(1D0,EJ+1D-6)/2D0 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)* & TANW+ZMIXC(IX,2)*T3J)*RT2I CXC(4)=-DCONJG(UMIXC(IJ,1))*( & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I CXC(6)=DCMPLX(0D0,0D0) CXC(8)=DCMPLX(0D0,0D0) XXC(1)=0D0 XXC(2)=XMJ XXC(3)=0D0 XXC(4)=XMI XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1) XXC(9)=PMAS(24,1) XXC(10)=PMAS(24,2) IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230 IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ELSEIF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(6) XXC(8)=XXC(5) IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=11 IDLAM(LKNT,3)=-12 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=13 IDLAM(LKNT,3)=-14 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ENDIF ENDIF 230 CONTINUE IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN XXC(5)=PMAS(PYCOMP(KSUSY1+15),1) XXC(6)=PMAS(PYCOMP(KSUSY1+16),1) ELSE XXC(5)=PMAS(PYCOMP(KSUSY2+15),1) XXC(6)=PMAS(PYCOMP(KSUSY1+16),1) ENDIF IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ENDIF IF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(6) XXC(8)=XXC(5) IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=15 IDLAM(LKNT,3)=-16 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ENDIF C...NOW, DO THE QUARKS 240 CONTINUE IA=1 JA=2 EI=KCHG(IA,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 EJ=KCHG(JA,1)/3D0 T3J=SIGN(1D0,EJ+1D-6)/2D0 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)* & TANW+ZMIXC(IX,2)*T3J) CXC(4)=-DCONJG(UMIXC(IJ,1))*( & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I) XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1) XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1) IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ENDIF IF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(6) XXC(8)=XXC(5) IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-2 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=3 IDLAM(LKNT,3)=-4 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ENDIF ENDIF 250 CONTINUE ENDIF 260 CONTINUE 270 CONTINUE C...CHI0_I -> CHI+_I + H- DO 280 IJ=1,2 XMJ=SMW(IJ) AXMJ=ABS(XMJ) XMJ2=XMJ**2 XMHP=PMAS(ITHC,1) IF(AXMI.GE.AXMJ+XMHP) THEN LKNT=LKNT+1 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+ & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2) ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)- & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)* & UMIXC(IJ,2)/SR2) GX2=ABS(OLPP)**2+ABS(ORPP)**2 GLR=DBLE(OLPP*DCONJG(ORPP)) XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=-ITHC IDLAM(LKNT,3)=0 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) ELSE ENDIF 280 CONTINUE C...2-BODY DECAYS TO FERMION SFERMION DO 290 J=1,16 IF(J.GE.7.AND.J.LE.10) GOTO 290 KF1=KSUSY1+J KF2=KSUSY2+J XMSF1=PMAS(PYCOMP(KF1),1) XMSF2=PMAS(PYCOMP(KF2),1) XMF=PMAS(J,1) IF(J.LE.6) THEN FCOL=3D0 ELSE FCOL=1D0 ENDIF EI=KCHG(J,1)/3D0 T3T=SIGN(1D0,EI) IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0 IF(MOD(J,2).EQ.0) THEN CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T) CAL=XMF*ZMIXC(IX,4)/XMW/SBETA CAR=-2D0*EI*TANW*ZMIXC(IX,1) CBR=CAL ELSE CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T) CAL=XMF*ZMIXC(IX,3)/XMW/CBETA CAR=-2D0*EI*TANW*ZMIXC(IX,1) CBR=CAL ENDIF C...D~ D_L IF(AXMI.GE.XMF+XMSF1) THEN LKNT=LKNT+1 XMA2=XMSF1**2 XMB2=XMF**2 XL=PYLAMF(XMI2,XMA2,XMB2) CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2) CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2) XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI) IDLAM(LKNT,1)=KF1 IDLAM(LKNT,2)=-J IDLAM(LKNT,3)=0 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=0 ENDIF C...D~ D_R IF(AXMI.GE.XMF+XMSF2) THEN LKNT=LKNT+1 XMA2=XMSF2**2 XMB2=XMF**2 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4) CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4) XL=PYLAMF(XMI2,XMA2,XMB2) XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI) IDLAM(LKNT,1)=KF2 IDLAM(LKNT,2)=-J IDLAM(LKNT,3)=0 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=0 ENDIF 290 CONTINUE 300 CONTINUE C...3-BODY DECAY TO Q Q~ GLUINO XMJ=PMAS(PYCOMP(KSUSY1+21),1) IF(AXMI.GE.XMJ) THEN RT2I = 1D0/SQRT(2D0) OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I ORPP=DCONJG(OLPP) AXMJ=ABS(XMJ) XXC(1)=0D0 XXC(2)=XMJ XXC(3)=0D0 XXC(4)=XMI FID=1 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310 XXC(7)=XXC(5) XXC(8)=XXC(6) XXC(9)=1D6 XXC(10)=0D0 EI=KCHG(FID,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP CXC(1)=0D0 CXC(2)=-GLIJ CXC(3)=0D0 CXC(4)=DCONJG(GLIJ) CXC(5)=0D0 CXC(6)=GRIJ CXC(7)=0D0 CXC(8)=-DCONJG(GRIJ) S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 C...ALL QUARKS BUT T IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-1 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=3 IDLAM(LKNT,3)=-3 ENDIF ENDIF 310 CONTINUE IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN XXC(5)=PMAS(PYCOMP(KSUSY1+5),1) XXC(6)=PMAS(PYCOMP(KSUSY2+5),1) ELSE XXC(6)=PMAS(PYCOMP(KSUSY1+5),1) XXC(5)=PMAS(PYCOMP(KSUSY2+5),1) ENDIF IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320 XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=5 IDLAM(LKNT,3)=-5 ENDIF C...U-TYPE QUARKS 320 CONTINUE FID=2 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330 XXC(7)=XXC(5) XXC(8)=XXC(6) EI=KCHG(FID,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP CXC(2)=-GLIJ CXC(4)=DCONJG(GLIJ) CXC(6)=GRIJ CXC(8)=-DCONJG(GRIJ) IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=2 IDLAM(LKNT,3)=-2 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=4 IDLAM(LKNT,3)=-4 ENDIF ENDIF 330 CONTINUE ENDIF C...R-violating decay modes (SKANDS). CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT) 340 IKNT=LKNT XLAM(0)=0D0 DO 350 I=1,IKNT IF(XLAM(I).LT.0D0) XLAM(I)=0D0 XLAM(0)=XLAM(0)+XLAM(I) 350 CONTINUE IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6 RETURN END C********************************************************************* C...PYCJDC C...Calculate decay widths for the charginos (admixtures of C...charged Wino and charged Higgsino. C...Input: KCIN = KF code for particle C...Output: XLAM = widths C... IDLAM = KF codes for decay particles C... IKNT = number of decay channels defined C...AUTHOR: STEPHEN MRENNA C...Last change: C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e C...when CHIENU .NE. 0 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) CC &SFMIX(16,4), C COMMON/PYINTS/XXM(20) COMPLEX*16 CXC COMMON/PYINTC/XXC(10),CXC(8) SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/ C...Local variables COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB INTEGER KFIN,KCIN DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2, &XMZ,XMZ2,AXMJ,AXMI DOUBLE PRECISION S12MIN,S12MAX DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK DOUBLE PRECISION PYLAMF,XL DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA DOUBLE PRECISION PYX2XH,PYX2XG DOUBLE PRECISION XLAM(0:300) INTEGER IDLAM(300,3) INTEGER LKNT,IX,IH,J,IJ,I,IKNT INTEGER ITH(3) INTEGER ITHC DOUBLE PRECISION ETAH(3),DH(3),EH(3) DOUBLE PRECISION SR2 DOUBLE PRECISION CBETA,SBETA,TANB DOUBLE PRECISION PYALEM,PI,PYALPS DOUBLE PRECISION FCOL INTEGER KF1,KF2,ISF INTEGER KFNCHI(4),KFCCHI(2) DOUBLE PRECISION TEMP EXTERNAL PYGAUS,PYXXZ6 DOUBLE PRECISION PYGAUS,PYXXZ6 DOUBLE PRECISION PREC DATA ITH/25,35,36/ DATA ITHC/37/ DATA ETAH/1D0,1D0,-1D0/ DATA SR2/1.4142136D0/ DATA PI/3.141592654D0/ DATA PREC/1D-2/ DATA KFNCHI/1000022,1000023,1000025,1000035/ DATA KFCCHI/1000024,1000037/ C...COUNT THE NUMBER OF DECAY MODES LKNT=0 XMW=PMAS(24,1) XMW2=XMW**2 XMZ=PMAS(23,1) XMZ2=XMZ**2 XW=1D0-XMW2/XMZ2 XW1=1D0-XW TANW = SQRT(XW/XW1) C...1 OR 2 DEPENDING ON CHARGINO TYPE IX=1 IF(KFIN.EQ.KFCCHI(2)) IX=2 KCIN=PYCOMP(KFIN) XMI=SMW(IX) XMI2=XMI**2 AXMI=ABS(XMI) AEM=PYALEM(XMI2) AS =PYALPS(XMI2) C1=AEM/XW XMI3=ABS(XMI**3) TANB=RMSS(5) BETA=ATAN(TANB) CBETA=COS(BETA) SBETA=TANB*CBETA ALFA=RMSS(18) DO 110 I=1,2 DO 100 J=1,2 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I)) UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I)) 100 CONTINUE 110 CONTINUE C...GRAVITINO DECAY MODES IF(IMSS(11).EQ.1) THEN XMP=RMSS(29) IDG=39+KSUSY1 XMGR=PMAS(PYCOMP(IDG),1) C SINW=SQRT(XW) C COSW=SQRT(1D0-XW) XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI IF(AXMI.GT.XMGR+XMW) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=24 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*( & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+ & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))* & (1D0-XMW2/XMI2)**4 ENDIF IF(AXMI.GT.XMGR+PMAS(37,1)) THEN LKNT=LKNT+1 IDLAM(LKNT,1)=IDG IDLAM(LKNT,2)=37 IDLAM(LKNT,3)=0 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+ & (ABS(UMIXC(IX,2))*SBETA)**2)) & *(1D0-PMAS(37,1)**2/XMI2)**4 ENDIF ENDIF C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS IF(IX.EQ.1) GOTO 170 XMJ=SMW(1) AXMJ=ABS(XMJ) XMJ2=XMJ**2 C...CHI_2+ -> CHI_1+ + Z0 IF(AXMI.GE.AXMJ+XMZ) THEN LKNT=LKNT+1 IJ=1 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))- & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))- & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0 GX2=ABS(OLPP)**2+ABS(ORPP)**2 GLR=DBLE(OLPP*DCONJG(ORPP)) XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=23 IDLAM(LKNT,3)=0 C...CHARGED LEPTONS ELSEIF(AXMI.GE.AXMJ) THEN S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 IA=11 JA=12 EI=KCHG(IABS(IA),1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 XXC(1)=0D0 XXC(2)=XMJ XXC(3)=0D0 XXC(4)=XMI XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) XXC(6)=1D6 XXC(9)=PMAS(23,1) XXC(10)=PMAS(23,2) IJ=1 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))- & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))- & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP CXC(2)=DCMPLX(0D0,0D0) CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW) CXC(5)=-DCMPLX(EI/XW1)*ORPP CXC(6)=DCMPLX(0D0,0D0) CXC(7)=-DCMPLX(EI/XW1)*OLPP CXC(8)=DCMPLX(0D0,0D0) IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=11 IDLAM(LKNT,3)=-11 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=13 IDLAM(LKNT,3)=-13 ENDIF IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=15 IDLAM(LKNT,3)=-15 ENDIF ENDIF C...NEUTRINOS 120 CONTINUE IA=12 JA=11 EI=KCHG(IABS(IA),1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) XXC(6)=1D6 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW) CXC(5)=-DCMPLX(EI/XW1)*ORPP CXC(7)=-DCMPLX(EI/XW1)*OLPP IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=12 IDLAM(LKNT,3)=-12 LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=14 IDLAM(LKNT,3)=-14 ENDIF IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN XXC(5)=PMAS(PYCOMP(KSUSY1+15),1) ELSE XXC(5)=PMAS(PYCOMP(KSUSY2+15),1) ENDIF IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF XXC(7)=XXC(5) LKNT=LKNT+1 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=16 IDLAM(LKNT,3)=-16 ENDIF C...D-TYPE QUARKS 130 CONTINUE IA=1 JA=2 EI=KCHG(IABS(IA),1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) XXC(6)=1D6 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP CXC(2)=DCMPLX(0D0,0D0) CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW) CXC(5)=-DCMPLX(EI/XW1)*ORPP CXC(6)=DCMPLX(0D0,0D0) CXC(7)=-DCMPLX(EI/XW1)*OLPP CXC(8)=DCMPLX(0D0,0D0) IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=1 IDLAM(LKNT,3)=-1 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=3 IDLAM(LKNT,3)=-3 ENDIF ENDIF IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN XXC(5)=PMAS(PYCOMP(KSUSY1+5),1) ELSE XXC(5)=PMAS(PYCOMP(KSUSY2+5),1) ENDIF IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF XXC(7)=XXC(5) LKNT=LKNT+1 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=5 IDLAM(LKNT,3)=-5 ENDIF C...U-TYPE QUARKS 140 CONTINUE IA=2 JA=1 EI=KCHG(IABS(IA),1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) XXC(6)=1D6 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP CXC(2)=DCMPLX(0D0,0D0) CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW) CXC(5)=-DCMPLX(EI/XW1)*ORPP CXC(6)=DCMPLX(0D0,0D0) CXC(7)=-DCMPLX(EI/XW1)*OLPP CXC(8)=DCMPLX(0D0,0D0) IF( XXC(5).LT.AXMI ) THEN XXC(5)=1D6 ENDIF XXC(7)=XXC(5) XXC(8)=XXC(6) IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=2 IDLAM(LKNT,3)=-2 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=4 IDLAM(LKNT,3)=-4 ENDIF ENDIF 150 CONTINUE ENDIF C...CHI_2+ -> CHI_1+ + H0_K EH(2)=COS(ALFA) EH(1)=SIN(ALFA) EH(3)=-SBETA DH(2)=-SIN(ALFA) DH(1)=COS(ALFA) DH(3)=COS(BETA) DO 160 IH=1,3 XMH=PMAS(ITH(IH),1) XMH2=XMH**2 C...NO 3-BODY OPTION IF(AXMI.GE.AXMJ+XMH) THEN LKNT=LKNT+1 XL=PYLAMF(XMI2,XMJ2,XMH2) OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) - & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) - & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2 XMK=XMJ*ETAH(IH) GX2=ABS(OLPP)**2+ABS(ORPP)**2 GLR=DBLE(OLPP*DCONJG(ORPP)) XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR) IDLAM(LKNT,1)=KFCCHI(1) IDLAM(LKNT,2)=ITH(IH) IDLAM(LKNT,3)=0 ENDIF 160 CONTINUE C...CHI1 JUMPS TO HERE 170 CONTINUE C...CHI+_I -> CHI0_J + W+ DO 220 IJ=1,4 XMJ=SMZ(IJ) AXMJ=ABS(XMJ) XMJ2=XMJ**2 IF(AXMI.GE.AXMJ+XMW) THEN LKNT=LKNT+1 DO 180 I=1,4 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I)) 180 CONTINUE CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)- & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2) CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+ & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2) GX2=ABS(CXC(1))**2+ABS(CXC(3))**2 GLR=DBLE(CXC(1)*DCONJG(CXC(3))) XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=24 IDLAM(LKNT,3)=0 C...LEPTONS ELSEIF(AXMI.GE.AXMJ) THEN S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 DO 190 I=1,4 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I)) 190 CONTINUE CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)- & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+ & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2 CXC(5)=DCMPLX(0D0,0D0) CXC(7)=DCMPLX(0D0,0D0) IA=11 JA=12 EI=KCHG(IA,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 EJ=KCHG(JA,1)/3D0 T3J=SIGN(1D0,EJ+1D-6)/2D0 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)* & TANW+ZMIXC(IJ,2)*T3J)/SR2 CXC(4)=-DCONJG(UMIXC(IX,1))*( & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2 CXC(6)=DCMPLX(0D0,0D0) CXC(8)=DCMPLX(0D0,0D0) XXC(1)=0D0 XXC(2)=XMJ XXC(3)=0D0 XXC(4)=XMI XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1) XXC(9)=PMAS(24,1) XXC(10)=PMAS(24,2) CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190 IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ELSEIF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(6) XXC(8)=XXC(5) C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW, C...--> 1/(16PI)/M**3*(AEM/XW)**2 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN LKNT=LKNT+1 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=-11 IDLAM(LKNT,3)=12 C...ONLY DECAY CHI+1 -> E+ NU_E IF( IMSS(12).NE. 0 ) GOTO 260 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=-13 IDLAM(LKNT,3)=14 ENDIF ENDIF IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN LKNT=LKNT+1 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN XXC(6)=PMAS(PYCOMP(KSUSY1+15),1) ELSE XXC(6)=PMAS(PYCOMP(KSUSY2+15),1) ENDIF XXC(5)=PMAS(PYCOMP(KSUSY1+16),1) IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ELSEIF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(6) XXC(8)=XXC(5) TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=-15 IDLAM(LKNT,3)=16 ENDIF C...NOW, DO THE QUARKS 200 CONTINUE IA=1 JA=2 EI=KCHG(IA,1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 EJ=KCHG(JA,1)/3D0 T3J=SIGN(1D0,EJ+1D-6)/2D0 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)* & TANW+ZMIXC(IX,2)*T3J) CXC(4)=-DCONJG(UMIXC(IJ,1))*( & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I) XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1) IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210 IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ENDIF IF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(6) XXC(8)=XXC(5) IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=-1 IDLAM(LKNT,3)=2 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=-3 IDLAM(LKNT,3)=4 ENDIF ENDIF 210 CONTINUE ENDIF 220 CONTINUE C...CHI+_I -> CHI0_J + H+ DO 230 IJ=1,4 XMJ=SMZ(IJ) AXMJ=ABS(XMJ) XMJ2=XMJ**2 XMHP=PMAS(ITHC,1) IF(AXMI.GE.AXMJ+XMHP) THEN LKNT=LKNT+1 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+ & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2) ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)- & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)* & UMIXC(IX,2)/SR2) GX2=ABS(OLPP)**2+ABS(ORPP)**2 GLR=DBLE(OLPP*DCONJG(ORPP)) XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=ITHC IDLAM(LKNT,3)=0 ELSE ENDIF 230 CONTINUE C...2-BODY DECAYS TO FERMION SFERMION DO 240 J=1,16 IF(J.GE.7.AND.J.LE.10) GOTO 240 IF(MOD(J,2).EQ.0) THEN KF1=KSUSY1+J-1 ELSE KF1=KSUSY1+J+1 ENDIF KF2=KF1+KSUSY1 XMSF1=PMAS(PYCOMP(KF1),1) XMSF2=PMAS(PYCOMP(KF2),1) XMF=PMAS(J,1) IF(J.LE.6) THEN FCOL=3D0 ELSE FCOL=1D0 ENDIF C...U~ D_L IF(MOD(J,2).EQ.0) THEN XMFP=PMAS(J-1,1) CAL=UMIXC(IX,1) CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2 CBR=0D0 ISF=J-1 ELSE XMFP=PMAS(J+1,1) CAL=VMIXC(IX,1) CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2 CBR=0D0 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2 ISF=J+1 ENDIF C...~U_L D IF(AXMI.GE.XMF+XMSF1) THEN LKNT=LKNT+1 XMA2=XMSF1**2 XMB2=XMF**2 XL=PYLAMF(XMI2,XMA2,XMB2) CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2) CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2) XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI) IDLAM(LKNT,3)=0 IF(MOD(J,2).EQ.0) THEN IDLAM(LKNT,1)=-KF1 IDLAM(LKNT,2)=J ELSE IDLAM(LKNT,1)=KF1 IDLAM(LKNT,2)=-J ENDIF ENDIF C...U~ D_R IF(AXMI.GE.XMF+XMSF2) THEN LKNT=LKNT+1 XMA2=XMSF2**2 XMB2=XMF**2 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4) CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4) XL=PYLAMF(XMI2,XMA2,XMB2) XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI) IDLAM(LKNT,3)=0 IF(MOD(J,2).EQ.0) THEN IDLAM(LKNT,1)=-KF2 IDLAM(LKNT,2)=J ELSE IDLAM(LKNT,1)=KF2 IDLAM(LKNT,2)=-J ENDIF ENDIF 240 CONTINUE C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH C...A 2-BODY -- 2-BODY CHAIN XMJ=PMAS(PYCOMP(KSUSY1+21),1) IF(AXMI.GE.XMJ) THEN AXMJ=ABS(XMJ) S12MIN=0D0 S12MAX=(AXMI-AXMJ)**2 XXC(1)=0D0 XXC(2)=XMJ XXC(3)=0D0 XXC(4)=XMI XXC(5)=PMAS(PYCOMP(KSUSY1+1),1) XXC(6)=PMAS(PYCOMP(KSUSY1+2),1) XXC(9)=1D6 XXC(10)=0D0 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32))) ORPP=DCONJG(OLPP) CXC(1)=DCMPLX(0D0,0D0) CXC(3)=DCMPLX(0D0,0D0) CXC(5)=DCMPLX(0D0,0D0) CXC(7)=DCMPLX(0D0,0D0) CXC(2)=UMIXC(IX,1)*OLPP/SR2 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2 CXC(6)=DCMPLX(0D0,0D0) CXC(8)=DCMPLX(0D0,0D0) IF(XXC(5).LT.AXMI) THEN XXC(5)=1D6 ELSEIF(XXC(6).LT.AXMI) THEN XXC(6)=1D6 ENDIF XXC(7)=XXC(6) XXC(8)=XXC(5) IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)* & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=-1 IDLAM(LKNT,3)=2 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN LKNT=LKNT+1 XLAM(LKNT)=XLAM(LKNT-1) IDLAM(LKNT,1)=KSUSY1+21 IDLAM(LKNT,2)=-3 IDLAM(LKNT,3)=4 ENDIF ENDIF 250 CONTINUE ENDIF C...R-violating decay modes (SKANDS). CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT) 260 IKNT=LKNT XLAM(0)=0D0 DO 270 I=1,IKNT XLAM(0)=XLAM(0)+XLAM(I) IF(XLAM(I).LT.0D0) THEN WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN, & (IDLAM(I,J),J=1,3) XLAM(I)=0D0 ENDIF 270 CONTINUE IF(XLAM(0).EQ.0D0) THEN XLAM(0)=1D-6 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0) WRITE(MSTU(11),*) LKNT WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT) ENDIF RETURN END C********************************************************************* C...PYXXZ6 C...Used in the calculation of inoi -> inoj + f + ~f. FUNCTION PYXXZ6(X) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) C COMMON/PYINTS/XXM(20) COMPLEX*16 CXC COMMON/PYINTC/XXC(10),CXC(8) SAVE /PYDAT1/,/PYINTC/ C...Local variables. COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT DOUBLE PRECISION PYXXZ6,X DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2 DOUBLE PRECISION SIJ DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2 DOUBLE PRECISION OL2 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL INTEGER I C...Statement functions. C...Integral from x to y of (t-a)(b-t) dt. TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B) C...Integral from x to y of (t-a)(b-t)/(t-c) dt. TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))- &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A) C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt. TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+ &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C))) C...Integral from x to y of (t-a)/(b-t) dt. UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A) C...Integral from x to y of 1/(t-a) dt. TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A))) XM12=XXC(1)**2 XM22=XXC(2)**2 XM32=XXC(3)**2 S=XXC(4)**2 S13=X S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S) S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)* &( (X-XM22-S)**2 -4D0*XM22*S ) ) S23MIN=(S23AVE-S23DEL) S23MAX=(S23AVE+S23DEL) XMSD1=XXC(5)**2 XMSD2=XXC(7)**2 XMSU1=XXC(6)**2 XMSU2=XXC(8)**2 XMV=XXC(9) XMG=XXC(10) QLLS=CXC(1) QLLU=CXC(2) QLRS=CXC(3) QLRT=CXC(4) QRLS=CXC(5) QRLT=CXC(6) QRRS=CXC(7) QRRU=CXC(8) WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2 SIJ=2D0*XXC(2)*XXC(4)*S13 IF(XMV.LE.1000D0) THEN OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS)) WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S) & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2 IF(XXC(5).LE.10000D0) THEN WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))* & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)- & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+ & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)- & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1)) & *(S13-XMV**2)/WPROP2 ELSE WFL1=0D0 ENDIF IF(XXC(6).LE.10000D0) THEN WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))* & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)- & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+ & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)- & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1)) & *(S13-XMV**2)/WPROP2 ELSE WFL2=0D0 ENDIF ELSE WW=0D0 WFL1=0D0 WFL2=0D0 ENDIF IF(XXC(5).LE.10000D0) THEN WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1) & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2) & - 2D0*DBLE(QLRT*DCONJG(QLLU))* & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2) ELSE WF1=0D0 ENDIF IF(XXC(6).LE.10000D0) THEN WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1) & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2) & - 2D0*DBLE(QRLT*DCONJG(QRRU))* & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2) ELSE WF2=0D0 ENDIF PYXXZ6=(WW+WF1+WF2+WFL1+WFL2) IF(PYXXZ6.LT.0D0) THEN WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 ' WRITE(MSTU(11),*) XXc(1),XXc(2),XXc(3),XXc(4) WRITE(MSTU(11),*) (XXc(I),I=5,8) WRITE(MSTU(11),*) (XXc(I),I=9,12) WRITE(MSTU(11),*) (XXc(I),I=13,16) WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2 WRITE(MSTU(11),*) S23MIN,S23MAX PYXXZ6=0D0 ENDIF RETURN END C********************************************************************* C...PYXXGA C...Calculates chi0_i -> chi0_j + gamma. FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL DOUBLE PRECISION F1,F2 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR) F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL) PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2 RETURN END C********************************************************************* C...PYX2XG C...Calculates the decay rate for ino -> ino + gauge boson. FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR DOUBLE PRECISION XL,PYLAMF,C1 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3 XMI2=XM1**2 XMI3=ABS(XM1**3) XMJ2=XM2**2 XMV2=XM3**2 XL=PYLAMF(XMI2,XMJ2,XMV2) PYX2XG=C1/8D0/XMI3*SQRT(XL) &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))- &12D0*GLR*XM1*XM2*XMV2) RETURN END C********************************************************************* C...PYX2XH C...Calculates the decay rate for ino -> ino + H. FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DOUBLE PRECISION PYX2XH,XM1,XM2,XM3 DOUBLE PRECISION XL,PYLAMF,C1 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3 XMI2=XM1**2 XMI3=ABS(XM1**3) XMJ2=XM2**2 XMV2=XM3**2 XL=PYLAMF(XMI2,XMJ2,XMV2) PYX2XH=C1/8D0/XMI3*SQRT(XL) &*(GX2*(XMI2+XMJ2-XMV2)+ &4D0*GLR*XM1*XM2) RETURN END C********************************************************************* C...PYHEXT C...Calculates the non-standard decay modes of the Higgs boson. C... C...Author: Stephen Mrenna C...Last Update: April 2001 C......Allow complex values for Z,U, and V SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/ C...Local variables. COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP COMPLEX*16 QIJ,RIJ,F21K,F12K INTEGER KFIN DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI DOUBLE PRECISION XMI2,XMI3,XMJ2 DOUBLE PRECISION PYLAMF,XL,CF,EI INTEGER IDU,IFL DOUBLE PRECISION TANW,XW,AEM,C1,AS DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR DOUBLE PRECISION XLAM(0:300) INTEGER IDLAM(300,3) INTEGER LKNT,IH,J,IJ,I,IKNT,IK INTEGER ITH(4) INTEGER KFNCHI(4),KFCCHI(2) DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3) DOUBLE PRECISION SR2 DOUBLE PRECISION BETA,ALFA DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB DOUBLE PRECISION PYALEM DOUBLE PRECISION AL,AR,ALR DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL DOUBLE PRECISION XMJL,XMJR,XM1,XM2 DATA ITH/25,35,36,37/ DATA ETAH/1D0,1D0,-1D0/ DATA SR2/1.4142136D0/ DATA KFNCHI/1000022,1000023,1000025,1000035/ DATA KFCCHI/1000024,1000037/ C...COUNT THE NUMBER OF DECAY MODES LKNT=IKNT XMW=PMAS(24,1) XMW2=XMW**2 XMZ=PMAS(23,1) XW=PARU(102) TANW = SQRT(XW/(1D0-XW)) CW=SQRT(1D0-XW) C...1 - 4 DEPENDING ON Higgs species. IH=1 IF(KFIN.EQ.ITH(2)) IH=2 IF(KFIN.EQ.ITH(3)) IH=3 IF(KFIN.EQ.ITH(4)) IH=4 XMI=PMAS(KFIN,1) XMI2=XMI**2 AXMI=ABS(XMI) AEM=PYALEM(XMI2) C1=AEM/XW XMI3=ABS(XMI**3) TANB=RMSS(5) BETA=ATAN(TANB) CBETA=COS(BETA) SBETA=TANB*CBETA ALFA=RMSS(18) COSA=COS(ALFA) SINA=SIN(ALFA) ATRIT=RMSS(16) ATRIB=RMSS(15) ATRIL=RMSS(17) XMUZ=-RMSS(4) DO 110 I=1,4 DO 100 J=1,4 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I)) 100 CONTINUE 110 CONTINUE DO 130 I=1,2 DO 120 J=1,2 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I)) UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I)) 120 CONTINUE 130 CONTINUE IF(IH.EQ.4) GOTO 220 C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS C...H0_K -> CHI0_I + CHI0_J EH(2)=SINA EH(1)=COSA EH(3)=CBETA DH(2)=COSA DH(1)=-SINA DH(3)=SBETA DO 150 IJ=1,4 XMJ=SMZ(IJ) AXMJ=ABS(XMJ) DO 140 IK=1,IJ XMK=SMZ(IK) AXMK=ABS(XMK) IF(AXMI.GE.AXMJ+AXMK) THEN LKNT=LKNT+1 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+ & ZMIXC(IJ,3)*ZMIXC(IK,2)- & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+ & ZMIXC(IJ,3)*ZMIXC(IK,1)) RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+ & ZMIXC(IJ,4)*ZMIXC(IK,2)- & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+ & ZMIXC(IJ,4)*ZMIXC(IK,1)) F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH)) F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH)) C...SIGN OF MASSES I,J XML=XMK*ETAH(IH) GX2=ABS(F12K)**2+ABS(F21K)**2 GLR=DBLE(F12K*DCONJG(F21K)) XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR) IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0 IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=KFNCHI(IK) IDLAM(LKNT,3)=0 ENDIF 140 CONTINUE 150 CONTINUE C...H0_K -> CHI+_I CHI-_J DO 170 IJ=1,2 XMJ=SMW(IJ) AXMJ=ABS(XMJ) DO 160 IK=1,2 XMK=SMW(IK) AXMK=ABS(XMK) IF(AXMI.GE.AXMJ+AXMK) THEN LKNT=LKNT+1 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) + & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) + & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2 GX2=ABS(OLPP)**2+ABS(ORPP)**2 GLR=DBLE(OLPP*DCONJG(ORPP)) XML=XMK*ETAH(IH) XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR) IDLAM(LKNT,1)=KFCCHI(IJ) IDLAM(LKNT,2)=-KFCCHI(IK) IDLAM(LKNT,3)=0 ENDIF 160 CONTINUE 170 CONTINUE C...HIGGS TO SFERMION SFERMION DO 200 IFL=1,16 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200 IJ=KSUSY1+IFL XMJL=PMAS(PYCOMP(IJ),1) XMJR=PMAS(PYCOMP(IJ+KSUSY1),1) IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN XMJ=XMJL XMJ2=XMJ**2 XL=PYLAMF(XMI2,XMJ2,XMJ2) XMF=PMAS(IFL,1) EI=KCHG(IFL,1)/3D0 IDU=2-MOD(IFL,2) IF(IH.EQ.1) THEN IF(IDU.EQ.1) THEN GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+ & XMF**2/XMW*SINA/CBETA GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+ & XMF**2/XMW*SINA/CBETA IF(IFL.EQ.5) THEN GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA- & ATRIB*SINA) ELSEIF(IFL.EQ.15) THEN GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA- & ATRIL*SINA) ELSE GHLR=0D0 ENDIF ELSE GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)- & XMF**2/XMW*COSA/SBETA GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)- & XMF**2/XMW*COSA/SBETA IF(IFL.EQ.6) THEN GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA- & ATRIT*COSA) ELSE GHLR=0D0 ENDIF ENDIF ELSEIF(IH.EQ.2) THEN IF(IDU.EQ.1) THEN GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)- & XMF**2/XMW*COSA/CBETA GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)- & XMF**2/XMW*COSA/CBETA IF(IFL.EQ.5) THEN GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+ & ATRIB*COSA) ELSEIF(IFL.EQ.15) THEN GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+ & ATRIL*COSA) ELSE GHLR=0D0 ENDIF ELSE GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)- & XMF**2/XMW*SINA/SBETA GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)- & XMF**2/XMW*SINA/SBETA IF(IFL.EQ.6) THEN GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+ & ATRIT*SINA) ELSE GHLR=0D0 ENDIF ENDIF ELSEIF(IH.EQ.3) THEN GHLL=0D0 GHRR=0D0 GHLR=0D0 IF(IDU.EQ.1) THEN IF(IFL.EQ.5) THEN GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ) ELSEIF(IFL.EQ.15) THEN GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ) ENDIF ELSE IF(IFL.EQ.6) THEN GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ) ENDIF ENDIF ENDIF IF(IH.EQ.3) GOTO 180 AL=SFMIX(IFL,1)**2 AR=SFMIX(IFL,2)**2 ALR=SFMIX(IFL,1)*SFMIX(IFL,2) IF(IFL.LE.6) THEN CF=3D0 ELSE CF=1D0 ENDIF IF(AXMI.GE.2D0*XMJ) THEN LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* & (GHLL*AL+GHRR*AR & +2D0*GHLR*ALR)**2 IDLAM(LKNT,1)=IJ IDLAM(LKNT,2)=-IJ IDLAM(LKNT,3)=0 ENDIF IF(AXMI.GE.2D0*XMJR) THEN LKNT=LKNT+1 AL=SFMIX(IFL,3)**2 AR=SFMIX(IFL,4)**2 ALR=SFMIX(IFL,3)*SFMIX(IFL,4) XMJ=XMJR XMJ2=XMJ**2 XL=PYLAMF(XMI2,XMJ2,XMJ2) XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* & (GHLL*AL+GHRR*AR & +2D0*GHLR*ALR)**2 IDLAM(LKNT,1)=IJ+KSUSY1 IDLAM(LKNT,2)=-(IJ+KSUSY1) IDLAM(LKNT,3)=0 ENDIF 180 CONTINUE IF(AXMI.GE.XMJL+XMJR) THEN LKNT=LKNT+1 AL=SFMIX(IFL,1)*SFMIX(IFL,3) AR=SFMIX(IFL,2)*SFMIX(IFL,4) ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3) XMJ=XMJR XMJ2=XMJ**2 XL=PYLAMF(XMI2,XMJ2,XMJL**2) XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* & (GHLL*AL+GHRR*AR)**2 IDLAM(LKNT,1)=IJ IDLAM(LKNT,2)=-(IJ+KSUSY1) IDLAM(LKNT,3)=0 LKNT=LKNT+1 IDLAM(LKNT,1)=-IJ IDLAM(LKNT,2)=IJ+KSUSY1 IDLAM(LKNT,3)=0 XLAM(LKNT)=XLAM(LKNT-1) ENDIF ENDIF 190 CONTINUE 200 CONTINUE 210 CONTINUE GOTO 270 220 CONTINUE C...H+ -> CHI+_I + CHI0_J DO 240 IJ=1,4 XMJ=SMZ(IJ) AXMJ=ABS(XMJ) XMJ2=XMJ**2 DO 230 IK=1,2 XMK=SMW(IK) AXMK=ABS(XMK) IF(AXMI.GE.AXMJ+AXMK) THEN LKNT=LKNT+1 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+ & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2) ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)- & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2) GX2=ABS(OLPP)**2+ABS(ORPP)**2 GLR=DBLE(OLPP*DCONJG(ORPP)) XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR) IDLAM(LKNT,1)=KFNCHI(IJ) IDLAM(LKNT,2)=KFCCHI(IK) IDLAM(LKNT,3)=0 ENDIF 230 CONTINUE 240 CONTINUE GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2) GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB) AL=0D0 AR=0D0 CF=3D0 C...H+ -> T_1 B_1~ XM1=PMAS(PYCOMP(KSUSY1+6),1) XM2=PMAS(PYCOMP(KSUSY1+5),1) IF(XMI.GE.XM1+XM2) THEN XL=PYLAMF(XMI2,XM1**2,XM2**2) LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2 IDLAM(LKNT,1)=KSUSY1+6 IDLAM(LKNT,2)=-(KSUSY1+5) IDLAM(LKNT,3)=0 ENDIF C...H+ -> T_2 B_1~ XM1=PMAS(PYCOMP(KSUSY2+6),1) XM2=PMAS(PYCOMP(KSUSY1+5),1) IF(XMI.GE.XM1+XM2) THEN XL=PYLAMF(XMI2,XM1**2,XM2**2) LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2 IDLAM(LKNT,1)=KSUSY2+6 IDLAM(LKNT,2)=-(KSUSY1+5) IDLAM(LKNT,3)=0 ENDIF C...H+ -> T_1 B_2~ XM1=PMAS(PYCOMP(KSUSY1+6),1) XM2=PMAS(PYCOMP(KSUSY2+5),1) IF(XMI.GE.XM1+XM2) THEN XL=PYLAMF(XMI2,XM1**2,XM2**2) LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2 IDLAM(LKNT,1)=KSUSY1+6 IDLAM(LKNT,2)=-(KSUSY2+5) IDLAM(LKNT,3)=0 ENDIF C...H+ -> T_2 B_2~ XM1=PMAS(PYCOMP(KSUSY2+6),1) XM2=PMAS(PYCOMP(KSUSY2+5),1) IF(XMI.GE.XM1+XM2) THEN XL=PYLAMF(XMI2,XM1**2,XM2**2) LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2 IDLAM(LKNT,1)=KSUSY2+6 IDLAM(LKNT,2)=-(KSUSY2+5) IDLAM(LKNT,3)=0 ENDIF C...H+ -> UL DL~ GL=-XMW/SR2*SIN(2D0*BETA) DO 250 IJ=1,3,2 XM1=PMAS(PYCOMP(KSUSY1+IJ),1) XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1) IF(XMI.GE.XM1+XM2) THEN XL=PYLAMF(XMI2,XM1**2,XM2**2) LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2 IDLAM(LKNT,1)=-(KSUSY1+IJ) IDLAM(LKNT,2)=KSUSY1+IJ+1 IDLAM(LKNT,3)=0 ENDIF 250 CONTINUE C...H+ -> EL~ NUL CF=1D0 DO 260 IJ=11,13,2 XM1=PMAS(PYCOMP(KSUSY1+IJ),1) XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1) IF(XMI.GE.XM1+XM2) THEN XL=PYLAMF(XMI2,XM1**2,XM2**2) LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2 IDLAM(LKNT,1)=-(KSUSY1+IJ) IDLAM(LKNT,2)=KSUSY1+IJ+1 IDLAM(LKNT,3)=0 ENDIF 260 CONTINUE C...H+ -> TAU1 NUTAUL XM1=PMAS(PYCOMP(KSUSY1+15),1) XM2=PMAS(PYCOMP(KSUSY1+16),1) IF(XMI.GE.XM1+XM2) THEN XL=PYLAMF(XMI2,XM1**2,XM2**2) LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2 IDLAM(LKNT,1)=-(KSUSY1+15) IDLAM(LKNT,2)= KSUSY1+16 IDLAM(LKNT,3)=0 ENDIF C...H+ -> TAU2 NUTAUL XM1=PMAS(PYCOMP(KSUSY2+15),1) XM2=PMAS(PYCOMP(KSUSY1+16),1) IF(XMI.GE.XM1+XM2) THEN XL=PYLAMF(XMI2,XM1**2,XM2**2) LKNT=LKNT+1 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2 IDLAM(LKNT,1)=-(KSUSY2+15) IDLAM(LKNT,2)= KSUSY1+16 IDLAM(LKNT,3)=0 ENDIF 270 CONTINUE IKNT=LKNT XLAM(0)=0D0 DO 280 I=1,IKNT IF(XLAM(I).LE.0D0) XLAM(I)=0D0 XLAM(0)=XLAM(0)+XLAM(I) 280 CONTINUE IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6 RETURN END C********************************************************************* C...PYH2XX C...Calculates the decay rate for a Higgs to an ino pair. FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Local variables. DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR DOUBLE PRECISION XL,PYLAMF,C1 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3 XMI2=XM1**2 XMI3=ABS(XM1**3) XMJ2=XM2**2 XMK2=XM3**2 XL=PYLAMF(XMI2,XMJ2,XMK2) PYH2XX=C1/4D0/XMI3*SQRT(XL) &*(GX2*(XMI2-XMJ2-XMK2)- &4D0*GLR*XM3*XM2) IF(PYH2XX.LT.0D0) THEN WRITE(MSTU(11),*) ' NEGATIVE WIDTH IN PYH2XX ' WRITE(MSTU(11),*) XMI2,XMJ2,XMK2,GX2,GLR,XM1,XM2,XM3 STOP ENDIF RETURN END C********************************************************************* C...PYGAUS C...Integration by adaptive Gaussian quadrature. C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig. FUNCTION PYGAUS(F, A, B, EPS) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Local declarations. EXTERNAL F DOUBLE PRECISION F,W(12), X(12) DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/ DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/ DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/ DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/ DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/ DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/ DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/ DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/ DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/ DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/ DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/ DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/ C...The Gaussian quadrature algorithm. H = 0D0 IF(B .EQ. A) GOTO 140 CONST = 5D-3 / ABS(B-A) BB = A 100 CONTINUE AA = BB BB = B 110 CONTINUE C1 = 0.5D0*(BB+AA) C2 = 0.5D0*(BB-AA) S8 = 0D0 DO 120 I = 1, 4 U = C2*X(I) S8 = S8 + W(I) * (F(C1+U) + F(C1-U)) 120 CONTINUE S16 = 0D0 DO 130 I = 5, 12 U = C2*X(I) S16 = S16 + W(I) * (F(C1+U) + F(C1-U)) 130 CONTINUE S16 = C2*S16 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN H = H + S16 IF(BB .NE. B) GOTO 100 ELSE BB = C1 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110 H = 0D0 CALL PYERRM(18,'(PYGAUS:) too high accuracy required') GOTO 140 ENDIF 140 CONTINUE PYGAUS = H RETURN END C********************************************************************* C...PYSIMP C...Simpson formula for an integral. FUNCTION PYSIMP(Y,X0,X1,N) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DOUBLE PRECISION Y,X0,X1,H,S DIMENSION Y(0:N) S=0D0 H=(X1-X0)/N DO 100 I=0,N-2,2 S=S+Y(I)+4D0*Y(I+1)+Y(I+2) 100 CONTINUE PYSIMP=S*H/3D0 RETURN END C********************************************************************* C...PYLAMF C...The standard lambda function. FUNCTION PYLAMF(X,Y,Z) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Local variables. DOUBLE PRECISION PYLAMF,X,Y,Z PYLAMF=(X-(Y+Z))**2-4D0*Y*Z IF(PYLAMF.LT.0D0) PYLAMF=0D0 RETURN END C********************************************************************* C...PYTBDY C...Generates 3-body decays of gauginos. SUBROUTINE PYTBDY(IDIN) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/ C...Local variables. DOUBLE PRECISION XM(5) COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2) DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3 DOUBLE PRECISION CPHI1,SPHI1 DOUBLE PRECISION S23DEL,EPS DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3) DOUBLE PRECISION F1,F2,X0,X1,X2,X3 INTEGER INOID(4) DATA INOID/22,23,25,35/ DATA EPS/1D-6/ ID=IDIN ISKIP=1 XM(1)=P(N+1,5) XM(2)=P(N+2,5) XM(3)=P(N+3,5) XM(5)=P(ID,5) C...GENERATE S12 S12MIN=(XM(1)+XM(2))**2 S12MAX=(XM(5)-XM(3))**2 YJACO1=S12MAX-S12MIN C...Initialize some parameters XW=PARU(102) XW1=1D0-XW TANW=SQRT(XW/XW1) IZID1=0 IWID1=0 IZID2=0 IWID2=0 DO 100 I1=1,4 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1 100 CONTINUE IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2 IA=K(N+2,2) JA=K(N+3,2) ZM12=XM(5)**2 ZM22=XM(1)**2 EI=KCHG(IABS(IA),1)/3D0 T3I=SIGN(1D0,EI+1D-6)/2D0 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN ISKIP=0 ELSEIF(IZID1*IZID2.NE.0) THEN SQMZ=PMAS(23,1)**2 GMMZ=PMAS(23,1)*PMAS(23,2) DO 110 I=1,4 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I)) ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I)) 110 CONTINUE OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))- & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0 ORPP=DCONJG(OLPP) XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2 XLR2=XLL2 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2 XRL2=XRR2 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))* & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1)) GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2 XM1M2=SMZ(IZID1)*SMZ(IZID2) QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP QLLU=-GLIJ QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP QLRT=DCONJG(GLIJ) QRLS=-DCMPLX((EI*XW)/XW1)*OLPP QRLT=GRIJ QRRS=DCMPLX((EI*XW)/XW1)*ORPP QRRU=-DCONJG(GRIJ) ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN IF(IZID1.NE.0) THEN XM1M2=SMZ(IZID1)*SMW(IWID2) IZID1=IWID2 IZID2=IZID1 ELSE XM1M2=SMZ(IZID2)*SMW(IWID1) IZID1=IWID1 ENDIF RT2I = 1D0/SQRT(2D0) SQMZ=PMAS(24,1)**2 GMMZ=PMAS(24,1)*PMAS(24,2) DO 120 I=1,2 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I)) UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I)) 120 CONTINUE DO 130 I=1,4 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I)) 130 CONTINUE QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)- & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I) QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+ & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I) EJ=KCHG(JA,1)/3D0 T3J=SIGN(1D0,EJ+1D-6)/2D0 QRLS=DCMPLX(0D0,0D0) QRLT=QRLS QRRS=QRLS QRRU=QRLS XRR2=1D6**2 XRL2=XRR2 XLR2 = PMAS(PYCOMP(KSUSY1+JA),1)**2 XLL2 = PMAS(PYCOMP(KSUSY1+IA),1)**2 IF(MOD(IA,2).EQ.0) THEN QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)* & TANW+ZMIXC(IZID2,2)*T3I) QLRT=-DCONJG(UMIXC(IZID1,1))*( & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J) ELSE QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)* & TANW+ZMIXC(IZID2,2)*T3J) QLRT=-DCONJG(UMIXC(IZID1,1))*( & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I) ENDIF ELSEIF(IWID1*IWID2.NE.0) THEN IZID1=IWID1 IZID2=IWID2 XM1M2=SMW(IWID1)*SMW(IWID2) SQMZ=PMAS(23,1)**2 GMMZ=PMAS(23,1)*PMAS(23,2) DO 140 I=1,2 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I)) UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I)) VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I)) UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I)) 140 CONTINUE OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))- & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))- & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0 QRLS=-DCMPLX(EI/XW1)*ORPP QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP QRRS=-DCMPLX(EI/XW1)*OLPP QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP IF(MOD(IA,2).EQ.0) THEN XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW) ELSE XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW) ENDIF ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21) &THEN ISKIP=0 ELSE ISKIP=0 ENDIF IF(ISKIP.NE.0) THEN WTMAX=0D0 DO 160 KT=1,100 S12=S12MIN+YJACO1*(KT-1)/99 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2) & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12) S23DF1=(S12-XM(2)**2-XM(1)**2)**2 & -(2D0*XM(1)*XM(2))**2 S23DF2=(S12-XM(3)**2-XM(5)**2)**2 & -(2D0*XM(3)*XM(5))**2 S23DF1=S23DF1*EPS S23DF2=S23DF2*EPS S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12) S23DEL=S23DEL/EPS S23MIN=S23AVE-S23DEL S23MAX=S23AVE+S23DEL YJACO2=S23MAX-S23MIN TH=S12 DO 150 KS=1,100 S23=S23MIN+YJACO2*(KS-1)/99 SH=S23 UH=ZM12+ZM22-SH-TH WU2 = (UH-ZM12)*(UH-ZM22) WT2 = (TH-ZM12)*(TH-ZM22) WS2 = XM1M2*SH PROPZ2 = (SH-SQMZ)**2 + GMMZ**2 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2) QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2) QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2) QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2) QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2) WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+ & (ABS(QRL)**2+ABS(QLR)**2)*WT2+ & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2) IF(WT0.GT.WTMAX) WTMAX=WT0 150 CONTINUE 160 CONTINUE WTMAX=WTMAX*1.05D0 ENDIF C...FIND S12* AX=S12MIN CX=S12MAX BX=S12MIN+0.5D0*YJACO1 X0=AX X3=CX IF(ABS(CX-BX).GT.ABS(BX-AX))THEN X1=BX X2=BX+C*(CX-BX) ELSE X2=BX X1=BX-C*(BX-AX) ENDIF C...SOLVE FOR F1 AND F2 S23DF1=(X1-XM(2)**2-XM(1)**2)**2 &-(2D0*XM(1)*XM(2))**2 S23DF2=(X1-XM(3)**2-XM(5)**2)**2 &-(2D0*XM(3)*XM(5))**2 S23DF1=S23DF1*EPS S23DF2=S23DF2*EPS S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1) F1=-2D0*S23DEL/EPS S23DF1=(X2-XM(2)**2-XM(1)**2)**2 &-(2D0*XM(1)*XM(2))**2 S23DF2=(X2-XM(3)**2-XM(5)**2)**2 &-(2D0*XM(3)*XM(5))**2 S23DF1=S23DF1*EPS S23DF2=S23DF2*EPS S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2) F2=-2D0*S23DEL/EPS 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS) IF(F2.LE.F1)THEN X0=X1 X1=X2 X2=R*X1+C*X3 F1=F2 S23DF1=(X2-XM(2)**2-XM(1)**2)**2 & -(2D0*XM(1)*XM(2))**2 S23DF2=(X2-XM(3)**2-XM(5)**2)**2 & -(2D0*XM(3)*XM(5))**2 S23DF1=S23DF1*EPS S23DF2=S23DF2*EPS S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2) F2=-2D0*S23DEL/EPS ELSE X3=X2 X2=X1 X1=R*X2+C*X0 F2=F1 S23DF1=(X1-XM(2)**2-XM(1)**2)**2 & -(2D0*XM(1)*XM(2))**2 S23DF2=(X1-XM(3)**2-XM(5)**2)**2 & -(2D0*XM(3)*XM(5))**2 S23DF1=S23DF1*EPS S23DF2=S23DF2*EPS S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1) F1=-2D0*S23DEL/EPS ENDIF GOTO 170 ENDIF C...WE WANT THE MAXIMUM, NOT THE MINIMUM IF(F1.LT.F2)THEN GOLDEN=-F1 XMIN=X1 ELSE GOLDEN=-F2 XMIN=X2 ENDIF IKNT=0 180 S12=S12MIN+PYR(0)*YJACO1 IKNT=IKNT+1 C...GENERATE S23 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2) &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12) S23DF1=(S12-XM(2)**2-XM(1)**2)**2 &-(2D0*XM(1)*XM(2))**2 S23DF2=(S12-XM(3)**2-XM(5)**2)**2 &-(2D0*XM(3)*XM(5))**2 S23DF1=S23DF1*EPS S23DF2=S23DF2*EPS S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12) S23DEL=S23DEL/EPS S23MIN=S23AVE-S23DEL S23MAX=S23AVE+S23DEL YJACO2=S23MAX-S23MIN S23=S23MIN+PYR(0)*YJACO2 C...CHECK THE SAMPLING IF(IKNT.GT.100) THEN WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY ' GOTO 190 ENDIF IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180 IF(ISKIP.EQ.0) GOTO 190 SH=S23 TH=S12 UH=ZM12+ZM22-SH-TH WU2 = (UH-ZM12)*(UH-ZM22) WT2 = (TH-ZM12)*(TH-ZM22) WS2 = XM1M2*SH PROPZ2 = (SH-SQMZ)**2 + GMMZ**2 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2) QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2) QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2) QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2) QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2) c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2) c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ) c &/DCMPLX(TH-XML2) c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2) c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2) WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+ &(ABS(QRL)**2+ABS(QLR)**2)*WT2+ &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2) IF(WT.LT.PYR(0)*WTMAX) GOTO 180 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5)) D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5)) D2=XM(5)-D1-D3 P1=SQRT(D1*D1-XM(1)**2) P2=SQRT(D2*D2-XM(2)**2) P3=SQRT(D3*D3-XM(3)**2) CTHE1=2D0*PYR(0)-1D0 ANG1=2D0*PYR(0)*PARU(1) CPHI1=COS(ANG1) SPHI1=SIN(ANG1) ARG=1D0-CTHE1**2 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0 STHE1=SQRT(ARG) P(N+1,1)=P1*STHE1*CPHI1 P(N+1,2)=P1*STHE1*SPHI1 P(N+1,3)=P1*CTHE1 P(N+1,4)=D1 C...GET CPHI3 ANG3=2D0*PYR(0)*PARU(1) CPHI3=COS(ANG3) SPHI3=SIN(ANG3) CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3 ARG=1D0-CTHE3**2 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0 STHE3=SQRT(ARG) P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1 &+P3*STHE3*SPHI3*SPHI1 &+P3*CTHE3*STHE1*CPHI1 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1 &-P3*STHE3*SPHI3*CPHI1 &+P3*CTHE3*STHE1*SPHI1 P(N+3,3)=P3*STHE3*CPHI3*STHE1 &+P3*CTHE3*CTHE1 P(N+3,4)=D3 DO 200 I=1,3 P(N+2,I)=-P(N+1,I)-P(N+3,I) 200 CONTINUE P(N+2,4)=D2 RETURN END C********************************************************************* C...PYTECM C...Finds the s-hat dependent eigenvalues of the inverse propagator C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the C...phase space generation. SUBROUTINE PYTECM(S1,S2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/ C...Local variables. DOUBLE PRECISION AR(4,4),WR(4),ZR(4,4),ZI(4,4),WORK(12,12), &AT(4,4),WI(4),FV1(4),FV2(4),FV3(4),sh,aem,tanw,ct2w,qupd,alprht, &far,fao,fzr,fzo,shr,R1,R2,S1,S2,WDTP(0:300),WDTE(0:300,0:5) INTEGER i,j,ierr SH=PMAS(PYCOMP(KTECHN+113),1)**2 AEM=PYALEM(SH) TANW=SQRT(PARU(102)/(1D0-PARU(102))) CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW) QUPD=2D0*PARP(143)-1D0 ALPRHT=2.91D0*(3D0/PARP(144)) FAR=SQRT(AEM/ALPRHT) FAO=FAR*QUPD FZR=FAR*CT2W FZO=-FAO*TANW AR(1,1) = SH AR(2,2) = SH-PMAS(23,1)**2 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2 AR(1,2) = 0D0 AR(2,1) = 0D0 AR(1,3) = -SH*FAR AR(3,1) = AR(1,3) AR(1,4) = -SH*FAO AR(4,1) = AR(1,4) AR(2,3) = -SH*FZR AR(3,2) = AR(2,3) AR(2,4) = -SH*FZO AR(4,2) = AR(2,4) AR(3,4) = 0D0 AR(4,3) = 0D0 CCCCCCCC DO 110 I=1,4 DO 100 J=1,4 AT(I,J)=0D0 100 CONTINUE 110 CONTINUE SHR=SQRT(SH) CALL PYWIDT(23,SH,WDTP,WDTE) AT(2,2) = WDTP(0)*SHR CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE) AT(3,3) = WDTP(0)*SHR CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE) AT(4,4) = WDTP(0)*SHR CCCC CALL PYEICG(4,4,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR) DO 120 I=1,4 WI(I)=SQRT(ABS(SH-WR(I))) WR(I)=ABS(WR(I)) 120 CONTINUE R1=MIN(WR(1),WR(2),WR(3),WR(4)) R2=1D20 S1=0D0 S2=0D0 DO 130 I=1,4 IF(ABS(WR(I)-R1).LT.1D-6) THEN S1=WI(I) GOTO 130 ENDIF IF(WR(I).LE.R2) THEN R2=WR(I) S2=WI(I) ENDIF 130 CONTINUE S1=S1**2 S2=S2**2 RETURN END C********************************************************************* C...PYEIGC C...Finds eigenvalues of a general complex matrix C C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK) C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED) C OF A COMPLEX GENERAL MATRIX. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX A=(AR,AI). C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX. C C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS. C C ON OUTPUT C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO. C C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO. C C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR) INTEGER N,NM,IS1,IS2,IERR,MATZ DOUBLE PRECISION AR(4,4),AI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4), X FV1(4),FV2(4),FV3(4) IF (N .LE. NM) GOTO 100 IERR = 10 * N GOTO 120 C 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1) CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3) IF (MATZ .NE. 0) GOTO 110 C .......... FIND EIGENVALUES ONLY .......... CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR) GOTO 120 C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS .......... 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR) IF (IERR .NE. 0) GOTO 120 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI) 120 RETURN END C********************************************************************* C...PYCMQR C...Auxiliary to PYEICG. C C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN C AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. C C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX C UPPER HESSENBERG MATRIX BY THE QR METHOD. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, C SET LOW=1, IGH=N. C C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN C THE REDUCTION BY CORTH, IF PERFORMED. C C ON OUTPUT C C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE C CALLING COMQR IF SUBSEQUENT CALCULATION OF C EIGENVECTORS IS TO BE PERFORMED. C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. C C CALLS PYCDIV FOR COMPLEX DIVISION. C CALLS PYCSRT FOR COMPLEX SQUARE ROOT. C CALLS PYTHAG FOR DSQRT(A*A + B*B) . C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR) INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4) DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2, X PYTHAG IERR = 0 IF (LOW .EQ. IGH) GOTO 130 C .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... L = LOW + 1 C DO 120 I = L, IGH LL = MIN0(I+1,IGH) IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120 NORM = PYTHAG(HR(I,I-1),HI(I,I-1)) YR = HR(I,I-1) / NORM YI = HI(I,I-1) / NORM HR(I,I-1) = NORM HI(I,I-1) = 0.0D0 C DO 100 J = I, IGH SI = YR * HI(I,J) - YI * HR(I,J) HR(I,J) = YR * HR(I,J) + YI * HI(I,J) HI(I,J) = SI 100 CONTINUE C DO 110 J = LOW, LL SI = YR * HI(J,I) + YI * HR(J,I) HR(J,I) = YR * HR(J,I) - YI * HI(J,I) HI(J,I) = SI 110 CONTINUE C 120 CONTINUE C .......... STORE ROOTS ISOLATED BY CBAL .......... 130 DO 140 I = 1, N IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140 WR(I) = HR(I,I) WI(I) = HI(I,I) 140 CONTINUE C EN = IGH TR = 0.0D0 TI = 0.0D0 ITN = 30*N C .......... SEARCH FOR NEXT EIGENVALUE .......... 150 IF (EN .LT. LOW) GOTO 320 ITS = 0 ENM1 = EN - 1 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW D0 -- .......... 160 DO 170 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GOTO 180 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1)) X + DABS(HR(L,L)) + DABS(HI(L,L)) TST2 = TST1 + DABS(HR(L,L-1)) IF (TST2 .EQ. TST1) GOTO 180 170 CONTINUE C .......... FORM SHIFT .......... 180 IF (L .EQ. EN) GOTO 300 IF (ITN .EQ. 0) GOTO 310 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200 SR = HR(EN,EN) SI = HI(EN,EN) XR = HR(ENM1,EN) * HR(EN,ENM1) XI = HI(ENM1,EN) * HR(EN,ENM1) IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210 YR = (HR(ENM1,ENM1) - SR) / 2.0D0 YI = (HI(ENM1,ENM1) - SI) / 2.0D0 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI) IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190 ZZR = -ZZR ZZI = -ZZI 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) SR = SR - XR SI = SI - XI GOTO 210 C .......... FORM EXCEPTIONAL SHIFT .......... 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2)) SI = 0.0D0 C 210 DO 220 I = LOW, EN HR(I,I) = HR(I,I) - SR HI(I,I) = HI(I,I) - SI 220 CONTINUE C TR = TR + SR TI = TI + SI ITS = ITS + 1 ITN = ITN - 1 C .......... REDUCE TO TRIANGLE (ROWS) .......... LP1 = L + 1 C DO 240 I = LP1, EN SR = HR(I,I-1) HR(I,I-1) = 0.0D0 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR) XR = HR(I-1,I-1) / NORM WR(I-1) = XR XI = HI(I-1,I-1) / NORM WI(I-1) = XI HR(I-1,I-1) = NORM HI(I-1,I-1) = 0.0D0 HI(I,I-1) = SR / NORM C DO 230 J = I, EN YR = HR(I-1,J) YI = HI(I-1,J) ZZR = HR(I,J) ZZI = HI(I,J) HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI 230 CONTINUE C 240 CONTINUE C SI = HI(EN,EN) IF (SI .EQ. 0.0D0) GOTO 250 NORM = PYTHAG(HR(EN,EN),SI) SR = HR(EN,EN) / NORM SI = SI / NORM HR(EN,EN) = NORM HI(EN,EN) = 0.0D0 C .......... INVERSE OPERATION (COLUMNS) .......... 250 DO 280 J = LP1, EN XR = WR(J-1) XI = WI(J-1) C DO 270 I = L, J YR = HR(I,J-1) YI = 0.0D0 ZZR = HR(I,J) ZZI = HI(I,J) IF (I .EQ. J) GOTO 260 YI = HI(I,J-1) HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI 270 CONTINUE C 280 CONTINUE C IF (SI .EQ. 0.0D0) GOTO 160 C DO 290 I = L, EN YR = HR(I,EN) YI = HI(I,EN) HR(I,EN) = SR * YR - SI * YI HI(I,EN) = SR * YI + SI * YR 290 CONTINUE C GOTO 160 C .......... A ROOT FOUND .......... 300 WR(EN) = HR(EN,EN) + TR WI(EN) = HI(EN,EN) + TI EN = ENM1 GOTO 150 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT C CONVERGED AFTER 30*N ITERATIONS .......... 310 IERR = EN 320 RETURN END C********************************************************************* C...PYCMQ2 C...Auxiliary to PYEICG. C C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS C AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE C THIS GENERAL MATRIX TO HESSENBERG FORM. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, C SET LOW=1, IGH=N. C C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS. C C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE C ARBITRARY. C C ON OUTPUT C C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI C HAVE BEEN DESTROYED. C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N. C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF C THE EIGENVECTORS HAS BEEN FOUND. C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT. C C CALLS PYCDIV FOR COMPLEX DIVISION. C CALLS PYCSRT FOR COMPLEX SQUARE ROOT. C CALLS PYTHAG FOR DSQRT(A*A + B*B) . C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED OCTOBER 1989. C C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG) C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG) C SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR) INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1, X ITN,ITS,LOW,LP1,ENM1,IEND,IERR DOUBLE PRECISION HR(4,4),HI(4,4),WR(4),WI(4),ZR(4,4),ZI(4,4), X ORTR(4),ORTI(4) DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2, X PYTHAG IERR = 0 C .......... INITIALIZE EIGENVECTOR MATRIX .......... DO 110 J = 1, N C DO 100 I = 1, N ZR(I,J) = 0.0D0 ZI(I,J) = 0.0D0 100 CONTINUE ZR(J,J) = 1.0D0 110 CONTINUE C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS C FROM THE INFORMATION LEFT BY CORTH .......... IEND = IGH - LOW - 1 IF (IEND.LT.0) GOTO 220 IF (IEND.EQ.0) GOTO 170 C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- .......... DO 160 II = 1, IEND I = IGH - II IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160 C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH .......... NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I) IP1 = I + 1 C DO 120 K = IP1, IGH ORTR(K) = HR(K,I-1) ORTI(K) = HI(K,I-1) 120 CONTINUE C DO 150 J = I, IGH SR = 0.0D0 SI = 0.0D0 C DO 130 K = I, IGH SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J) SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J) 130 CONTINUE C SR = SR / NORM SI = SI / NORM C DO 140 K = I, IGH ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K) ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K) 140 CONTINUE C 150 CONTINUE C 160 CONTINUE C .......... CREATE REAL SUBDIAGONAL ELEMENTS .......... 170 L = LOW + 1 C DO 210 I = L, IGH LL = MIN0(I+1,IGH) IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210 NORM = PYTHAG(HR(I,I-1),HI(I,I-1)) YR = HR(I,I-1) / NORM YI = HI(I,I-1) / NORM HR(I,I-1) = NORM HI(I,I-1) = 0.0D0 C DO 180 J = I, N SI = YR * HI(I,J) - YI * HR(I,J) HR(I,J) = YR * HR(I,J) + YI * HI(I,J) HI(I,J) = SI 180 CONTINUE C DO 190 J = 1, LL SI = YR * HI(J,I) + YI * HR(J,I) HR(J,I) = YR * HR(J,I) - YI * HI(J,I) HI(J,I) = SI 190 CONTINUE C DO 200 J = LOW, IGH SI = YR * ZI(J,I) + YI * ZR(J,I) ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I) ZI(J,I) = SI 200 CONTINUE C 210 CONTINUE C .......... STORE ROOTS ISOLATED BY CBAL .......... 220 DO 230 I = 1, N IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230 WR(I) = HR(I,I) WI(I) = HI(I,I) 230 CONTINUE C EN = IGH TR = 0.0D0 TI = 0.0D0 ITN = 30*N C .......... SEARCH FOR NEXT EIGENVALUE .......... 240 IF (EN .LT. LOW) GOTO 430 ITS = 0 ENM1 = EN - 1 C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW DO -- .......... 250 DO 260 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GOTO 270 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1)) X + DABS(HR(L,L)) + DABS(HI(L,L)) TST2 = TST1 + DABS(HR(L,L-1)) IF (TST2 .EQ. TST1) GOTO 270 260 CONTINUE C .......... FORM SHIFT .......... 270 IF (L .EQ. EN) GOTO 420 IF (ITN .EQ. 0) GOTO 550 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290 SR = HR(EN,EN) SI = HI(EN,EN) XR = HR(ENM1,EN) * HR(EN,ENM1) XI = HI(ENM1,EN) * HR(EN,ENM1) IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300 YR = (HR(ENM1,ENM1) - SR) / 2.0D0 YI = (HI(ENM1,ENM1) - SI) / 2.0D0 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI) IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280 ZZR = -ZZR ZZI = -ZZI 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI) SR = SR - XR SI = SI - XI GOTO 300 C .......... FORM EXCEPTIONAL SHIFT .......... 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2)) SI = 0.0D0 C 300 DO 310 I = LOW, EN HR(I,I) = HR(I,I) - SR HI(I,I) = HI(I,I) - SI 310 CONTINUE C TR = TR + SR TI = TI + SI ITS = ITS + 1 ITN = ITN - 1 C .......... REDUCE TO TRIANGLE (ROWS) .......... LP1 = L + 1 C DO 330 I = LP1, EN SR = HR(I,I-1) HR(I,I-1) = 0.0D0 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR) XR = HR(I-1,I-1) / NORM WR(I-1) = XR XI = HI(I-1,I-1) / NORM WI(I-1) = XI HR(I-1,I-1) = NORM HI(I-1,I-1) = 0.0D0 HI(I,I-1) = SR / NORM C DO 320 J = I, N YR = HR(I-1,J) YI = HI(I-1,J) ZZR = HR(I,J) ZZI = HI(I,J) HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI 320 CONTINUE C 330 CONTINUE C SI = HI(EN,EN) IF (SI .EQ. 0.0D0) GOTO 350 NORM = PYTHAG(HR(EN,EN),SI) SR = HR(EN,EN) / NORM SI = SI / NORM HR(EN,EN) = NORM HI(EN,EN) = 0.0D0 IF (EN .EQ. N) GOTO 350 IP1 = EN + 1 C DO 340 J = IP1, N YR = HR(EN,J) YI = HI(EN,J) HR(EN,J) = SR * YR + SI * YI HI(EN,J) = SR * YI - SI * YR 340 CONTINUE C .......... INVERSE OPERATION (COLUMNS) .......... 350 DO 390 J = LP1, EN XR = WR(J-1) XI = WI(J-1) C DO 370 I = 1, J YR = HR(I,J-1) YI = 0.0D0 ZZR = HR(I,J) ZZI = HI(I,J) IF (I .EQ. J) GOTO 360 YI = HI(I,J-1) HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI 370 CONTINUE C DO 380 I = LOW, IGH YR = ZR(I,J-1) YI = ZI(I,J-1) ZZR = ZR(I,J) ZZI = ZI(I,J) ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI 380 CONTINUE C 390 CONTINUE C IF (SI .EQ. 0.0D0) GOTO 250 C DO 400 I = 1, EN YR = HR(I,EN) YI = HI(I,EN) HR(I,EN) = SR * YR - SI * YI HI(I,EN) = SR * YI + SI * YR 400 CONTINUE C DO 410 I = LOW, IGH YR = ZR(I,EN) YI = ZI(I,EN) ZR(I,EN) = SR * YR - SI * YI ZI(I,EN) = SR * YI + SI * YR 410 CONTINUE C GOTO 250 C .......... A ROOT FOUND .......... 420 HR(EN,EN) = HR(EN,EN) + TR WR(EN) = HR(EN,EN) HI(EN,EN) = HI(EN,EN) + TI WI(EN) = HI(EN,EN) EN = ENM1 GOTO 240 C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND C VECTORS OF UPPER TRIANGULAR FORM .......... 430 NORM = 0.0D0 C DO 440 I = 1, N C DO 440 J = I, N TR = DABS(HR(I,J)) + DABS(HI(I,J)) IF (TR .GT. NORM) NORM = TR 440 CONTINUE C IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560 C .......... FOR EN=N STEP -1 UNTIL 2 DO -- .......... DO 500 NN = 2, N EN = N + 2 - NN XR = WR(EN) XI = WI(EN) HR(EN,EN) = 1.0D0 HI(EN,EN) = 0.0D0 ENM1 = EN - 1 C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- .......... DO 490 II = 1, ENM1 I = EN - II ZZR = 0.0D0 ZZI = 0.0D0 IP1 = I + 1 C DO 450 J = IP1, EN ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN) ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN) 450 CONTINUE C YR = XR - WR(I) YI = XI - WI(I) IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470 TST1 = NORM YR = TST1 460 YR = 0.01D0 * YR TST2 = NORM + YR IF (TST2 .GT. TST1) GOTO 460 470 CONTINUE CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN)) C .......... OVERFLOW CONTROL .......... TR = DABS(HR(I,EN)) + DABS(HI(I,EN)) IF (TR .EQ. 0.0D0) GOTO 490 TST1 = TR TST2 = TST1 + 1.0D0/TST1 IF (TST2 .GT. TST1) GOTO 490 DO 480 J = I, EN HR(J,EN) = HR(J,EN)/TR HI(J,EN) = HI(J,EN)/TR 480 CONTINUE C 490 CONTINUE C 500 CONTINUE C .......... END BACKSUBSTITUTION .......... C .......... VECTORS OF ISOLATED ROOTS .......... DO 520 I = 1, N IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520 C DO 510 J = I, N ZR(I,J) = HR(I,J) ZI(I,J) = HI(I,J) 510 CONTINUE C 520 CONTINUE C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE C VECTORS OF ORIGINAL FULL MATRIX. C FOR J=N STEP -1 UNTIL LOW DO -- .......... DO 540 JJ = LOW, N J = N + LOW - JJ M = MIN0(J,IGH) C DO 540 I = LOW, IGH ZZR = 0.0D0 ZZI = 0.0D0 C DO 530 K = LOW, M ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J) ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J) 530 CONTINUE C ZR(I,J) = ZZR ZI(I,J) = ZZI 540 CONTINUE C GOTO 560 C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT C CONVERGED AFTER 30*N ITERATIONS .......... 550 IERR = EN 560 RETURN END C********************************************************************* C...PYCDIV C...Auxiliary to PYCMQR C C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI) C SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI) DOUBLE PRECISION AR,AI,BR,BI,CR,CI DOUBLE PRECISION S,ARS,AIS,BRS,BIS S = DABS(BR) + DABS(BI) ARS = AR/S AIS = AI/S BRS = BR/S BIS = BI/S S = BRS**2 + BIS**2 CR = (ARS*BRS + AIS*BIS)/S CI = (AIS*BRS - ARS*BIS)/S RETURN END C********************************************************************* C...PYCSRT C...Auxiliary to PYCMQR C C (YR,YI) = COMPLEX DSQRT(XR,XI) C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI) C SUBROUTINE PYCSRT(XR,XI,YR,YI) DOUBLE PRECISION XR,XI,YR,YI DOUBLE PRECISION S,TR,TI,PYTHAG TR = XR TI = XI S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR))) IF (TR .GE. 0.0D0) YR = S IF (TI .LT. 0.0D0) S = -S IF (TR .LE. 0.0D0) YI = S IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI) IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR) RETURN END DOUBLE PRECISION FUNCTION PYTHAG(A,B) DOUBLE PRECISION A,B C C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW C DOUBLE PRECISION P,R,S,T,U P = DMAX1(DABS(A),DABS(B)) IF (P .EQ. 0.0D0) GOTO 110 R = (DMIN1(DABS(A),DABS(B))/P)**2 100 CONTINUE T = 4.0D0 + R IF (T .EQ. 4.0D0) GOTO 110 S = R/T U = 1.0D0 + 2.0D0*S P = U*P R = (S/U)**2 * R GOTO 100 110 PYTHAG = P RETURN END C********************************************************************* C...PYCBAL C...Auxiliary to PYEICG C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE, C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). C C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES C EIGENVALUES WHENEVER POSSIBLE. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED. C C ON OUTPUT C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE BALANCED MATRIX. C C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J) C ARE EQUAL TO ZERO IF C (1) I IS GREATER THAN J AND C (2) J=1,...,LOW-1 OR I=IGH+1,...,N. C C SCALE CONTAINS INFORMATION DETERMINING THE C PERMUTATIONS AND SCALING FACTORS USED. C C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN C SCALE(J) = P(J), FOR J = 1,...,LOW-1 C = D(J,J) J = LOW,...,IGH C = P(J) J = IGH+1,...,N. C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, C THEN 1 TO LOW-1. C C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. C C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS C K,L HAVE BEEN REVERSED.) C C ARITHMETIC IS REAL THROUGHOUT. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE) INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC DOUBLE PRECISION AR(4,4),AI(4,4),SCALE(4) DOUBLE PRECISION C,F,G,R,S,B2,RADIX LOGICAL NOCONV RADIX = 16.0D0 C B2 = RADIX * RADIX K = 1 L = N GOTO 150 C .......... IN-LINE PROCEDURE FOR ROW AND C COLUMN EXCHANGE .......... 100 SCALE(M) = J IF (J .EQ. M) GOTO 130 C DO 110 I = 1, L F = AR(I,J) AR(I,J) = AR(I,M) AR(I,M) = F F = AI(I,J) AI(I,J) = AI(I,M) AI(I,M) = F 110 CONTINUE C DO 120 I = K, N F = AR(J,I) AR(J,I) = AR(M,I) AR(M,I) = F F = AI(J,I) AI(J,I) = AI(M,I) AI(M,I) = F 120 CONTINUE C 130 IF(IEXC.EQ.1) GOTO 140 IF(IEXC.EQ.2) GOTO 180 C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE C AND PUSH THEM DOWN .......... 140 IF (L .EQ. 1) GOTO 320 L = L - 1 C .......... FOR J=L STEP -1 UNTIL 1 DO -- .......... 150 DO 170 JJ = 1, L J = L + 1 - JJ C DO 160 I = 1, L IF (I .EQ. J) GOTO 160 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170 160 CONTINUE C M = L IEXC = 1 GOTO 100 170 CONTINUE C GOTO 190 C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE C AND PUSH THEM LEFT .......... 180 K = K + 1 C 190 DO 210 J = K, L C DO 200 I = K, L IF (I .EQ. J) GOTO 200 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210 200 CONTINUE C M = K IEXC = 2 GOTO 100 210 CONTINUE C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L .......... DO 220 I = K, L 220 SCALE(I) = 1.0D0 C .......... ITERATIVE LOOP FOR NORM REDUCTION .......... 230 NOCONV = .FALSE. C DO 310 I = K, L C = 0.0D0 R = 0.0D0 C DO 240 J = K, L IF (J .EQ. I) GOTO 240 C = C + DABS(AR(J,I)) + DABS(AI(J,I)) R = R + DABS(AR(I,J)) + DABS(AI(I,J)) 240 CONTINUE C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW .......... IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310 G = R / RADIX F = 1.0D0 S = C + R 250 IF (C .GE. G) GOTO 260 F = F * RADIX C = C * B2 GOTO 250 260 G = R * RADIX 270 IF (C .LT. G) GOTO 280 F = F / RADIX C = C / B2 GOTO 270 C .......... NOW BALANCE .......... 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310 G = 1.0D0 / F SCALE(I) = SCALE(I) * F NOCONV = .TRUE. C DO 290 J = K, N AR(I,J) = AR(I,J) * G AI(I,J) = AI(I,J) * G 290 CONTINUE C DO 300 J = 1, L AR(J,I) = AR(J,I) * F AI(J,I) = AI(J,I) * F 300 CONTINUE C 310 CONTINUE C IF (NOCONV) GOTO 230 C 320 LOW = K IGH = L RETURN END C********************************************************************* C...PYCBA2 C...Auxiliary to PYEICG. C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK, C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). C C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING C BALANCED MATRIX DETERMINED BY CBAL. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL. C C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS C AND SCALING FACTORS USED BY CBAL. C C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED. C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVECTORS TO BE C BACK TRANSFORMED IN THEIR FIRST M COLUMNS. C C ON OUTPUT C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS C IN THEIR FIRST M COLUMNS. C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI) INTEGER I,J,K,M,N,II,NM,IGH,LOW DOUBLE PRECISION SCALE(4),ZR(4,4),ZI(4,4) DOUBLE PRECISION S IF (M .EQ. 0) GOTO 150 IF (IGH .EQ. LOW) GOTO 120 C DO 110 I = LOW, IGH S = SCALE(I) C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED C IF THE FOREGOING STATEMENT IS REPLACED BY C S=1.0D0/SCALE(I). .......... DO 100 J = 1, M ZR(I,J) = ZR(I,J) * S ZI(I,J) = ZI(I,J) * S 100 CONTINUE C 110 CONTINUE C .......... FOR I=LOW-1 STEP -1 UNTIL 1, C IGH+1 STEP 1 UNTIL N DO -- .......... 120 DO 140 II = 1, N I = II IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140 IF (I .LT. LOW) I = LOW - II K = SCALE(I) IF (K .EQ. I) GOTO 140 C DO 130 J = 1, M S = ZR(I,J) ZR(I,J) = ZR(K,J) ZR(K,J) = S S = ZI(I,J) ZI(I,J) = ZI(K,J) ZI(K,J) = S 130 CONTINUE C 140 CONTINUE C 150 RETURN END C********************************************************************* C...PYCRTH C...Auxiliary to PYEICG. C C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968) C BY MARTIN AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). C C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY C UNITARY SIMILARITY TRANSFORMATIONS. C C ON INPUT C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT. C C N IS THE ORDER OF THE MATRIX. C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, C SET LOW=1, IGH=N. C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX. C C ON OUTPUT C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION C IS STORED IN THE REMAINING TRIANGLES UNDER THE C HESSENBERG MATRIX. C C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C CALLS PYTHAG FOR DSQRT(A*A + B*B) . C C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW, C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY C C THIS VERSION DATED AUGUST 1983. C SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI) INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW DOUBLE PRECISION AR(4,4),AI(4,4),ORTR(4),ORTI(4) DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG LA = IGH - 1 KP1 = LOW + 1 IF (LA .LT. KP1) GOTO 210 C DO 200 M = KP1, LA H = 0.0D0 ORTR(M) = 0.0D0 ORTI(M) = 0.0D0 SCALE = 0.0D0 C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) .......... DO 100 I = M, IGH 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1)) C IF (SCALE .EQ. 0.0D0) GOTO 200 MP = M + IGH C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... DO 110 II = M, IGH I = MP - II ORTR(I) = AR(I,M-1) / SCALE ORTI(I) = AI(I,M-1) / SCALE H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I) 110 CONTINUE C G = DSQRT(H) F = PYTHAG(ORTR(M),ORTI(M)) IF (F .EQ. 0.0D0) GOTO 120 H = H + F * G G = G / F ORTR(M) = (1.0D0 + G) * ORTR(M) ORTI(M) = (1.0D0 + G) * ORTI(M) GOTO 130 C 120 ORTR(M) = G AR(M,M-1) = SCALE C .......... FORM (I-(U*UT)/H) * A .......... 130 DO 160 J = M, N FR = 0.0D0 FI = 0.0D0 C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... DO 140 II = M, IGH I = MP - II FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J) FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J) 140 CONTINUE C FR = FR / H FI = FI / H C DO 150 I = M, IGH AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I) AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I) 150 CONTINUE C 160 CONTINUE C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) .......... DO 190 I = 1, IGH FR = 0.0D0 FI = 0.0D0 C .......... FOR J=IGH STEP -1 UNTIL M DO -- .......... DO 170 JJ = M, IGH J = MP - JJ FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J) FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J) 170 CONTINUE C FR = FR / H FI = FI / H C DO 180 J = M, IGH AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J) AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J) 180 CONTINUE C 190 CONTINUE C ORTR(M) = SCALE * ORTR(M) ORTI(M) = SCALE * ORTI(M) AR(M,M-1) = -G * AR(M,M-1) AI(M,M-1) = -G * AI(M,M-1) 200 CONTINUE C 210 RETURN END C********************************************************************* C...PYLDCM C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2 C...processes. SUBROUTINE PYLDCM(A,N,NP,INDX,D) IMPLICIT NONE INTEGER N,NP,INDX(N) REAL*8 D,TINY COMPLEX*16 A(NP,NP) PARAMETER (TINY=1.0D-20) INTEGER I,IMAX,J,K REAL*8 AAMAX,VV(6),DUM COMPLEX*16 SUM,DUMC D=1D0 DO 110 I=1,N AAMAX=0D0 DO 100 J=1,N IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J)) 100 CONTINUE IF (AAMAX.EQ.0D0) PAUSE 'SINGULAR MATRIX IN PYLDCM' VV(I)=1D0/AAMAX 110 CONTINUE DO 180 J=1,N DO 130 I=1,J-1 SUM=A(I,J) DO 120 K=1,I-1 SUM=SUM-A(I,K)*A(K,J) 120 CONTINUE A(I,J)=SUM 130 CONTINUE AAMAX=0D0 DO 150 I=J,N SUM=A(I,J) DO 140 K=1,J-1 SUM=SUM-A(I,K)*A(K,J) 140 CONTINUE A(I,J)=SUM DUM=VV(I)*ABS(SUM) IF (DUM.GE.AAMAX) THEN IMAX=I AAMAX=DUM ENDIF 150 CONTINUE IF (J.NE.IMAX)THEN DO 160 K=1,N DUMC=A(IMAX,K) A(IMAX,K)=A(J,K) A(J,K)=DUMC 160 CONTINUE D=-D VV(IMAX)=VV(J) ENDIF INDX(J)=IMAX IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0) IF(J.NE.N)THEN DO 170 I=J+1,N A(I,J)=A(I,J)/A(J,J) 170 CONTINUE ENDIF 180 CONTINUE RETURN END C********************************************************************* C...PYBKSB C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2 C...processes. SUBROUTINE PYBKSB(A,N,NP,INDX,B) IMPLICIT NONE INTEGER N,NP,INDX(N) COMPLEX*16 A(NP,NP),B(N) INTEGER I,II,J,LL COMPLEX*16 SUM II=0 DO 110 I=1,N LL=INDX(I) SUM=B(LL) B(LL)=B(I) IF (II.NE.0)THEN DO 100 J=II,I-1 SUM=SUM-A(I,J)*B(J) 100 CONTINUE ELSE IF (ABS(SUM).NE.0D0) THEN II=I ENDIF B(I)=SUM 110 CONTINUE DO 130 I=N,1,-1 SUM=B(I) DO 120 J=I+1,N SUM=SUM-A(I,J)*B(J) 120 CONTINUE B(I)=SUM/A(I,I) 130 CONTINUE RETURN END C*********************************************************************** C...PYWIDX C...Calculates full and partial widths of resonances. C....copy of PYWIDT, used for techniparticle widths SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, &/PYINT4/,/PYMSSM/ C...Local arrays and saved variables. DIMENSION WDTP(0:300),WDTE(0:300,0:5),MOFSV(3,2),WIDWSV(3,2), &WID2SV(3,2) SAVE MOFSV,WIDWSV,WID2SV DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/ C...Compressed code and sign; mass. KFLA=IABS(KFLR) KFLS=ISIGN(1,KFLR) KC=PYCOMP(KFLA) SHR=SQRT(SH) PMR=PMAS(KC,1) C...Reset width information. DO 110 I=0,200 WDTP(I)=0D0 DO 100 J=0,5 WDTE(I,J)=0D0 100 CONTINUE 110 CONTINUE C...Common electroweak and strong constants. XW=PARU(102) XWV=XW IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2 XW1=1D0-XW AEM=PYALEM(SH) IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1) AS=PYALPS(SH) RADC=1D0+AS/PARU(1) IF(KFLA.EQ.23) THEN C...Z0: ICASE=1 XWC=1D0/(16D0*XW*XW1) FAC=(AEM*XWC/3D0)*SHR 120 CONTINUE DO 130 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 130 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130 WID2=1D0 IF(I.LE.8) THEN C...Z0 -> q + qbar EF=KCHG(I,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV FCOF=3D0*RADC IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0) IF(I.EQ.6) WID2=WIDS(6,1) IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) ELSEIF(I.LE.16) THEN C...Z0 -> l+ + l-, nu + nubar EF=KCHG(I+2,1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*XWV FCOF=1D0 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1) ENDIF BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))* & BE34 WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+ & WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 130 CONTINUE ELSEIF(KFLA.EQ.24) THEN C...W+/-: FAC=(AEM/(24D0*XW))*SHR DO 140 I=1,MDCY(KC,3) IDC=I+MDCY(KC,2)-1 IF(MDME(IDC,1).LT.0) GOTO 140 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140 WID2=1D0 IF(I.LE.16) THEN C...W+/- -> q + qbar' FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1) IF(KFLR.GT.0) THEN IF(MOD(I,4).EQ.3) WID2=WIDS(6,2) IF(MOD(I,4).EQ.0) WID2=WIDS(8,2) IF(I.GE.13) WID2=WID2*WIDS(7,3) ELSE IF(MOD(I,4).EQ.3) WID2=WIDS(6,3) IF(MOD(I,4).EQ.0) WID2=WIDS(8,3) IF(I.GE.13) WID2=WID2*WIDS(7,2) ENDIF ELSEIF(I.LE.20) THEN C...W+/- -> l+/- + nu FCOF=1D0 IF(KFLR.GT.0) THEN IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2) ELSE IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3) ENDIF ENDIF WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) WDTP(0)=WDTP(0)+WDTP(I) IF(MDME(IDC,1).GT.0) THEN WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) WDTE(I,0)=WDTE(I,MDME(IDC,1)) WDTE(0,0)=WDTE(0,0)+WDTE(I,0) ENDIF 140 CONTINUE ENDIF RETURN END C********************************************************************* C...PYRVSF C...Calculates R-violating decays of sfermions. C... * Only L-violating decays included at this point. SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) C...Local variables. DOUBLE PRECISION XLAM(0:300), RM2, SM, SMT INTEGER IDLAM(300,3), KFIN, KFSM, I, J, K, LKNT, ICNT,PYCOMP SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/ C...IS L-VIOLATION ON ? IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN C...Mass eigenstate counter ICNT=INT(KFIN/KSUSY1) C...SM KF code of SUSY particle KFSM=KFIN-ICNT*KSUSY1 C...Squared Sparticle Mass SM=PMAS(PYCOMP(KFIN),1)**2 C... Squared mass of top quark SMT=PMAS(PYCOMP(6),1)**2 C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15)) THEN K=INT((KFSM-9)/2) DO 110 I=1,3 DO 100 J=1,3 IF(I.NE.J) THEN C...~e,~mu,~tau -> nu_I + lepton-_J LKNT = LKNT+1 IDLAM(LKNT,1)= 12 +2*(I-1) IDLAM(LKNT,2)= 11 +2*(J-1) IDLAM(LKNT,3)= 0 XLAM(LKNT)=0D0 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2+ICNT)**2 * SM IF (IMSS(51).NE.0) XLAM(LKNT) = & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-1 ENDIF ENDIF 100 CONTINUE 110 CONTINUE C...~e,~mu,~tau -> nu_Ibar + lepton-_K J=INT((KFSM-9)/2) DO 130 I=1,3 IF(I.NE.J) THEN DO 120 K=1,3 LKNT = LKNT+1 IDLAM(LKNT,1)=-12 -2*(I-1) IDLAM(LKNT,2)= 11 +2*(K-1) IDLAM(LKNT,3)= 0 XLAM(LKNT)=0D0 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,ICNT)**2 * SM IF (IMSS(51).NE.0) XLAM(LKNT) = & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-1 ENDIF 120 CONTINUE ENDIF 130 CONTINUE C...~e,~mu,~tau -> u_Jbar + d_K I=INT((KFSM-9)/2) DO 150 J=1,3 DO 140 K=1,3 LKNT = LKNT+1 IDLAM(LKNT,1)=-2 -2*(J-1) IDLAM(LKNT,2)= 1 +2*(K-1) IDLAM(LKNT,3)= 0 XLAM(LKNT)=0 IF (IMSS(52).NE.0) THEN C...Use massive top quark IF (IDLAM(LKNT,1).EQ.-6) THEN RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,ICNT)**2 & * (SM-SMT) XLAM(LKNT) = & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3) C...If no top quark, all decay products massless ELSE RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,ICNT)**2 * SM XLAM(LKNT) = & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) ENDIF C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-1 ENDIF ENDIF 140 CONTINUE 150 CONTINUE ENDIF C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D C...No right-handed neutrinos IF(ICNT.EQ.1) THEN IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN J=INT((KFSM-10)/2) DO 170 I=1,3 DO 160 K=1,3 IF (I.NE.J) THEN C...~nu_J -> lepton+_I + lepton-_K LKNT = LKNT+1 IDLAM(LKNT,1)=-11 -2*(I-1) IDLAM(LKNT,2)= 11 +2*(K-1) IDLAM(LKNT,3)= 0 XLAM(LKNT)=0D0 RM2=RVLAM(I,J,K)**2 * SM IF (IMSS(51).NE.0) XLAM(LKNT) = & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-1 ENDIF ENDIF 160 CONTINUE 170 CONTINUE C...~nu_I -> dbar_J + d_K I=INT((KFSM-10)/2) DO 190 J=1,3 DO 180 K=1,3 LKNT = LKNT+1 IDLAM(LKNT,1)=-1 -2*(J-1) IDLAM(LKNT,2)= 1 +2*(K-1) IDLAM(LKNT,3)= 0 XLAM(LKNT)=0D0 RM2=3*RVLAMP(I,J,K)**2 * SM IF (IMSS(52).NE.0) XLAM(LKNT) = & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-1 ENDIF 180 CONTINUE 190 CONTINUE ENDIF ENDIF C * SDOWN -> NU(BAR) + D and LEPTON- + U IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN J=INT((KFSM+1)/2) DO 210 I=1,3 DO 200 K=1,3 C...~d_J -> nu_Ibar + d_K LKNT = LKNT+1 IDLAM(LKNT,1)=-12 -2*(I-1) IDLAM(LKNT,2)= 1 +2*(K-1) IDLAM(LKNT,3)= 0 XLAM(LKNT)=0D0 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,ICNT)**2 * SM IF (IMSS(52).NE.0) XLAM(LKNT) = & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-1 ENDIF 200 CONTINUE 210 CONTINUE K=INT((KFSM+1)/2) DO 240 I=1,3 DO 230 J=1,3 C...~d_K -> nu_I + d_J LKNT = LKNT+1 IDLAM(LKNT,1)= 12 +2*(I-1) IDLAM(LKNT,2)= 1 +2*(J-1) IDLAM(LKNT,3)= 0 XLAM(LKNT)=0D0 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2+ICNT)**2 * SM IF (IMSS(52).NE.0) XLAM(LKNT) = & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-1 ENDIF C...~d_K -> lepton_I- + u_J 220 LKNT = LKNT+1 IDLAM(LKNT,1)= 11 +2*(I-1) IDLAM(LKNT,2)= 2 +2*(J-1) IDLAM(LKNT,3)= 0 XLAM(LKNT)=0D0 IF (IMSS(52).NE.0) THEN C...Use massive top quark IF (IDLAM(LKNT,2).EQ.6) THEN RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2+ICNT)**2*(SM-SMT) XLAM(LKNT) = & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2) C...If no top quark, all decay products massless ELSE RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2+ICNT)**2 * SM XLAM(LKNT) = & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) ENDIF C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-1 ENDIF ENDIF 230 CONTINUE 240 CONTINUE ENDIF C * SUP -> LEPTON+ + D IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN J=INT((KFSM+1)/2) DO 260 I=1,3 DO 250 K=1,3 C...~u_J -> lepton_I+ + d_K LKNT = LKNT+1 IDLAM(LKNT,1)=-11 -2*(I-1) IDLAM(LKNT,2)= 1 +2*(K-1) IDLAM(LKNT,3)= 0 XLAM(LKNT)=0D0 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,ICNT)**2 * SM IF (IMSS(52).NE.0) XLAM(LKNT) = & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-1 ENDIF 250 CONTINUE 260 CONTINUE ENDIF ENDIF RETURN END C********************************************************************* C...PYRVNE C...Calculates R-violating neutralino decay widths (pure 1->3 parts). C... * Only L-violating decays included at this point. SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) C...Local parameters PARAMETER (UNB=80) C...Local variables. COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3) DOUBLE PRECISION XLAM(0:300),AB,RES,RMS DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), LAMC, RMQ(6) INTEGER IDLAM(300,3),LKNT,KFIN,PYCOMP,ISM,IDR,IDR2 LOGICAL DCMASS CHARACTER*31 PRC CHARACTER*11 FNAME SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/ C...LEPTON NUMBER VIOLATING DECAYS IF (((IMSS(51).GE.1).OR.(IMSS(52).GE.1))) THEN KFSM=KFIN-KSUSY1 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN C...WHICH NEUTRALINO ? NCHI=1 IF (KFSM.EQ.23) NCHI=2 IF (KFSM.EQ.25) NCHI=3 IF (KFSM.EQ.35) NCHI=4 C...SIGN OF MASS ISM=1 IF (SMZ(NCHI).LT.0D0) ISM=-ISM C...Useful parameters for the calculation of the A and B constants. WMASS = PMAS(PYCOMP(24),1) ECHG = 2*SQRT(PARU(103)*PARU(1)) COSB=1/(SQRT(1+RMSS(5)**2)) SINB=RMSS(5)/SQRT(1+RMSS(5)**2) COSW=SQRT(1-PARU(102)) SINW=SQRT(PARU(102)) GW=2D0*SQRT(PARU(103)*PARU(1))/SINW C...Run quark masses to neutralino mass squared (for Higgs-type C...couplings) SQMCHI=PMAS(PYCOMP(KFIN),1)**2 DO 100 I=1,6 RMQ(I)=PYMRUN(I,SQMCHI) 100 CONTINUE C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS DO 110 I = 1,4 ZPMIX(I,1)= ZMIX(I,1)*COSW+ZMIX(I,2)*SINW ZPMIX(I,2)=-ZMIX(I,1)*SINW+ZMIX(I,2)*COSW ZPMIX(I,3)= ZMIX(I,3) ZPMIX(I,4)= ZMIX(I,4) 110 CONTINUE C1=GW*ZMIX(NCHI,3)/(2.*COSB*WMASS) C1U=GW*ZMIX(NCHI,4)/(2.*SINB*WMASS) C2=ECHG*ZPMIX(NCHI,1) C3=GW*ZPMIX(NCHI,2)/COSW EU=2D0/3D0 ED=-1D0/3D0 C... AB(x,y,z): C x=1-2 : Select A or B constant (1:A ; 2:B) C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ; C 11-16:e,nu_e,mu,...) C z=1-2 : Mass eigenstate number C...CALCULATE COUPLINGS DO 120 I = 11,15,2 CMS=PMAS(PYCOMP(I),1) AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) - SFMIX(I,3) & *(C2-C3*SINW**2)) AB(1,I,2)=ISM*(-CMS*C1*SFMIX(I,2) + SFMIX(I,4) & *(C2-C3*SINW**2)) AB(2,I,1)= -CMS*C1*SFMIX(I,3) - SFMIX(I,1)*(C2+C3*(5D-1-SINW & **2)) AB(2,I,2)=CMS*C1*SFMIX(I,4) + SFMIX(I,2)*(C2+C3*(5D-1 - SINW & **2)) AB(1,I+1,1)=0D0 AB(2,I+1,1)=5D-1*C3 AB(1,I+1,2)=0D0 AB(2,I+1,2)=0D0 J=I-10 CMS=RMQ(J) AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) + SFMIX(J,3) & *ED*(C2-ED*C3*SINW**2)) AB(1,J,2)=ISM*(-CMS*C1*SFMIX(J,2) - SFMIX(J,4) & *ED*(C2-ED*C3*SINW**2)) AB(2,J,1)=-CMS*C1*SFMIX(J,3) + SFMIX(J,1) & *(ED*C2-C3*(1D0/2D0+ED*SINW**2)) AB(2,J,2)=CMS*C1*SFMIX(J,4) - SFMIX(J,2) & *(ED*C2-C3*(1D0/2D0+ED*SINW**2)) J=J+1 CMS=RMQ(J) AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) + SFMIX(J,3) & *EU*(C2-C3*SINW**2)) AB(1,J,2)=ISM*(-CMS*C1U*SFMIX(J,2) - SFMIX(J,4) & *EU*(C2-C3*SINW**2)) AB(2,J,1)=-CMS*C1U*SFMIX(J,3) + SFMIX(J,1) & *(EU*C2+C3*(1D0/2D0-EU*SINW**2)) AB(2,J,2)=CMS*C1U*SFMIX(J,4) - SFMIX(J,2) & *(EU*C2+C3*(1D0/2D0-EU*SINW**2)) 120 CONTINUE C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION) C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K. C...STEP IN I,J,K USING SINGLE COUNTER DO 140 ISC=0,26 C...LAMBDA COUPLING ASYM IN I,J IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN LKNT = LKNT+1 IDLAM(LKNT,1)=-12 -2*MOD(ISC/9,3) IDLAM(LKNT,2)=-11 -2*MOD(ISC/3,3) IDLAM(LKNT,3)= 11 +2*MOD(ISC,3) XLAM(LKNT)=0D0 IF(IMSS(51).EQ.0) GOTO 130 C...Set coupling, and decay product masses on/off LAMC=RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 DCMASS=.FALSE. C...Resonance KF codes (1=I,2=J,3=K) KFR(1)=-IDLAM(LKNT,1) KFR(2)=-IDLAM(LKNT,2) KFR(3)=-IDLAM(LKNT,3) C...Calculate width. CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) & ,XLAM(LKNT)) XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*32) C...Charge conjugate mode. 130 LKNT=LKNT+1 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) XLAM(LKNT)=XLAM(LKNT-1) C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-2 ENDIF ENDIF 140 CONTINUE C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION) C * CHI0 -> NUBAR_I + DBAR_J + D_K DO 170 ISC=0,26 LKNT = LKNT+1 IDLAM(LKNT,1)=-12 -2*MOD(ISC/9,3) IDLAM(LKNT,2)= -1 -2*MOD(ISC/3,3) IDLAM(LKNT,3)= 1 +2*MOD(ISC,3) XLAM(LKNT)=0D0 IF(IMSS(52).EQ.0) GOTO 150 C...Set coupling, and decay product masses on/off LAMC=3*RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 DCMASS=.FALSE. C...Resonance KF codes (1=I,2=J,3=K) KFR(1)=-IDLAM(LKNT,1) KFR(2)=-IDLAM(LKNT,2) KFR(3)=-IDLAM(LKNT,3) C...Calculate width. CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) & ,XLAM(LKNT)) XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*32) C...Charge conjugate mode. 150 LKNT=LKNT+1 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) XLAM(LKNT)=XLAM(LKNT-1) C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-2 ENDIF C * CHI0 -> LEPTON_I+ + UBAR_J + D_K LKNT = LKNT+1 IDLAM(LKNT,1)=-11 -2*MOD(ISC/9,3) IDLAM(LKNT,2)= -2 -2*MOD(ISC/3,3) IDLAM(LKNT,3)= 1 +2*MOD(ISC,3) XLAM(LKNT)=0D0 IF(IMSS(52).EQ.0) GOTO 160 C...Set coupling, and decay product masses on/off LAMC=3*RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 DCMASS=.FALSE. IF (IDLAM(LKNT,2).EQ.-6) DCMASS=.TRUE. C...Resonance KF codes (1=I,2=J,3=K) KFR(1)=-IDLAM(LKNT,1) KFR(2)=-IDLAM(LKNT,2) KFR(3)=-IDLAM(LKNT,3) C...Calculate width. CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) & ,XLAM(LKNT)) XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*32) C...Charge conjugate mode. 160 LKNT=LKNT+1 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) XLAM(LKNT)=XLAM(LKNT-1) C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-2 ENDIF 170 CONTINUE ENDIF ENDIF RETURN END C********************************************************************* C...PYRVCH C...Calculates R-violating chargino decay widths. C... * Only L-violating decays included at this point. SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) C...Local variables. COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3) DOUBLE PRECISION XLAM(0:300),AB, RES, RMS, C1U, C1V, C2, C3 DOUBLE PRECISION LAMC, RMQ(6) INTEGER IDLAM(300,3),LKNT,KFIN,PYCOMP LOGICAL DCMASS CHARACTER*31 PRC CHARACTER*10 FNAME SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/ C...LEPTON NUMBER VIOLATING DECAYS IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN KFSM=KFIN-KSUSY1 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN ISM = 1 C...WHICH CHARGINO ? NCHI = 1 IF (KFSM.EQ.37) NCHI = 2 C...Useful parameters for calculating the A and B constants. IF (SMW(NCHI).LT.0D0) ISM=-1 WMASS = PMAS(PYCOMP(24),1) COSB = 1/(SQRT(1+RMSS(5)**2)) SINB = RMSS(5)/SQRT(1+RMSS(5)**2) GW2 = 4*PARU(103)*PARU(1)/PARU(102) SQMCHI = PMAS(PYCOMP(KFSM),1)**2 C...Running masses at Q^2=MCHI^2. DO 100 I=1,6 RMQ(I)=PYMRUN(I,SQMCHI) 100 CONTINUE C...Signs chosen to agree with U & V convention used in hep-ph/9912407. C1U = -UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS) C1V = -VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS) C2 = -UMIX(NCHI,1) C3 = -VMIX(NCHI,1) C... AB(x,y,z): C x=1-2 : A or B coefficient (1:A ; 2:B) C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ; C 11-16:e,nu_e,mu,...) C z=1-2 : Mass eigenstate number DO 110 I = 11,15,2 AB(1,I,1) = 0D0 AB(1,I,2) = 0D0 AB(2,I,1) = PMAS(PYCOMP(I),1)*C1U*SFMIX(I,3) + & SFMIX(I,1)*C2 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) - & SFMIX(I,2)*C2 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U AB(1,I+1,2) = 0D0 AB(2,I+1,1) = ISM*C3 AB(2,I+1,2) = 0D0 J=I-10 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1) AB(1,J,2) = RMQ(J+1)*C1V*SFMIX(J,2) AB(2,J,1) = ISM*(RMQ(J)*C1U*SFMIX(J,3) + SFMIX(J,1)*C2) AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) + SFMIX(J,2)*C2) J=J+1 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1) AB(1,J,2) = RMQ(J-1)*C1U*SFMIX(J,2) AB(2,J,1) = ISM*(RMQ(J)*C1V*SFMIX(J,3) - SFMIX(J,1)*C3) AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) + SFMIX(J,2)*C3) 110 CONTINUE C...LOOP OVER DECAY MODES DO 140 ISC=0,26 C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K. IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN LKNT = LKNT+1 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3) IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3) IDLAM(LKNT,3) = 12 +2*MOD(ISC,3) XLAM(LKNT)=0D0 IF(IMSS(51).EQ.0) GOTO 120 C...Set coupling, and decay product masses on/off LAMC = GW2 * & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 DCMASS=.FALSE. C...Resonance KF codes (1=I,2=J,3=K). KFR(1) = 0 KFR(2) = 0 KFR(3) = -IDLAM(LKNT,3)+1 C...Calculate width. CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) & ,XLAM(LKNT)) XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64) C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-1 ENDIF C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J) 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN LKNT = LKNT+1 IDLAM(LKNT,1)= 12 +2*MOD(ISC/9,3) IDLAM(LKNT,2)= 12 +2*MOD(ISC/3,3) IDLAM(LKNT,3)=-11 -2*MOD(ISC,3) XLAM(LKNT)=0D0 IF(IMSS(51).EQ.0) GOTO 130 C...Set coupling, and decay product masses on/off LAMC = GW2 * & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 C...I,J SYMMETRY => FACTOR 2 LAMC=2*LAMC DCMASS=.FALSE. C...Resonance KF codes (1=I,2=J,3=K) KFR(1)=IDLAM(LKNT,1)-1 KFR(2)=IDLAM(LKNT,2)-1 KFR(3)=0 C...Calculate width. CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), & IDLAM(LKNT,3),XLAM(LKNT)) XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64) C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-1 ENDIF 130 ENDIF C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K LKNT = LKNT+1 IDLAM(LKNT,1)=-11 -2*MOD(ISC/9,3) IDLAM(LKNT,2)=-11 -2*MOD(ISC/3,3) IDLAM(LKNT,3)= 11 +2*MOD(ISC,3) XLAM(LKNT)=0D0 IF(IMSS(51).EQ.0) GOTO 140 C...Set coupling, and decay product masses on/off LAMC = GW2 * & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 C...I,J SYMMETRY => FACTOR 2 LAMC=2*LAMC DCMASS=.FALSE. C...Resonance KF codes (1=I,2=J,3=K) KFR(1)=-IDLAM(LKNT,1)+1 KFR(2)=-IDLAM(LKNT,2)+1 KFR(3)=0 C...Calculate width. CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) & ,XLAM(LKNT)) XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64) C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-1 ENDIF ENDIF 140 CONTINUE C...LQD TYPE R-VIOLATION C...LOOP OVER DECAY MODES DO 180 ISC=0,26 C...CHI+ -> NUBAR_I + DBAR_J + U_K LKNT = LKNT+1 IDLAM(LKNT,1)=-12 -2*MOD(ISC/9,3) IDLAM(LKNT,2)= -1 -2*MOD(ISC/3,3) IDLAM(LKNT,3)= 2 +2*MOD(ISC,3) XLAM(LKNT)=0D0 IF(IMSS(52).EQ.0) GOTO 150 C...Set coupling, and decay product masses on/off LAMC = 3 * GW2 * & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 DCMASS=.FALSE. IF (IDLAM(LKNT,3).EQ.6) DCMASS=.TRUE. C...Resonance KF codes (1=I,2=J,3=K) KFR(1)=0 KFR(2)=0 KFR(3)=-IDLAM(LKNT,3)+1 C...Calculate width. CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) & ,XLAM(LKNT)) XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64) C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-1 ENDIF C * CHI+ -> LEPTON+_I + UBAR_J + U_K. 150 LKNT = LKNT+1 IDLAM(LKNT,1)=-11 -2*MOD(ISC/9,3) IDLAM(LKNT,2)= -2 -2*MOD(ISC/3,3) IDLAM(LKNT,3)= 2 +2*MOD(ISC,3) XLAM(LKNT)=0D0 IF(IMSS(52).EQ.0) GOTO 160 C...Set coupling, and decay product masses on/off LAMC = 3 * GW2 * & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 DCMASS=.FALSE. IF (-IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.6) DCMASS=.TRUE. C...Resonance KF codes (1=I,2=J,3=K) KFR(1)=0 KFR(2)=0 KFR(3)=-IDLAM(LKNT,3)+1 C...Calculate width. CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) & ,XLAM(LKNT)) XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64) C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-1 ENDIF C * CHI+ -> LEPTON+_I + DBAR_J + D_K. 160 LKNT = LKNT+1 IDLAM(LKNT,1)=-11 -2*MOD(ISC/9,3) IDLAM(LKNT,2)= -1 -2*MOD(ISC/3,3) IDLAM(LKNT,3)= 1 +2*MOD(ISC,3) XLAM(LKNT)=0D0 IF(IMSS(52).EQ.0) GOTO 170 C...Set coupling, and decay product masses on/off LAMC = 3 * GW2 * & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 DCMASS=.FALSE. C...Resonance KF codes (1=I,2=J,3=K) KFR(1)=-IDLAM(LKNT,1)+1 KFR(2)=-IDLAM(LKNT,2)+1 KFR(3)=0 C...Calculate width. CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) & ,XLAM(LKNT)) XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64) C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-1 ENDIF C * CHI+ -> NU_I + U_J + DBAR_K. 170 LKNT = LKNT+1 IDLAM(LKNT,1)= 12 +2*MOD(ISC/9,3) IDLAM(LKNT,2)= 2 +2*MOD(ISC/3,3) IDLAM(LKNT,3)= -1 -2*MOD(ISC,3) XLAM(LKNT)=0D0 IF(IMSS(52).EQ.0) GOTO 180 C...Set coupling, and decay product masses on/off DCMASS=.FALSE. LAMC = 3 * GW2 * & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 IF (IDLAM(LKNT,2).EQ.6) DCMASS=.TRUE. C...Resonance KF codes (1=I,2=J,3=K) KFR(1)=-IDLAM(LKNT,1)+1 KFR(2)=-IDLAM(LKNT,2)+1 KFR(3)=0 C...Calculate width. CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) & ,XLAM(LKNT)) XLAM(LKNT)=XLAM(LKNT)*LAMC/((2*PARU(1)*RMS(0))**3*64) C...KINEMATICS CHECK IF (XLAM(LKNT).EQ.0D0) THEN LKNT=LKNT-1 ENDIF 180 CONTINUE ENDIF ENDIF RETURN END C********************************************************************* C...PYRVSB C...Auxiliary function to PYRVSF for calculating R-Violating C...sfermion widths. Though the decay products are most often treated C...as massless in the calculation, the kinematical boundary of phase C...space is tested using the true masses. C...MODE = 1: All decay products massive C...MODE = 2: Decay product 1 massless C...MODE = 3: Decay product 2 massless C...MODE = 4: All decay products massless FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE) IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ DOUBLE PRECISION SM(3), PYRVSB, RM2 CHARACTER*24 PRC INTEGER KFIN, ID1,ID2, PYCOMP, KC(3), MODE KC(1)=PYCOMP(KFIN) KC(2)=PYCOMP(ID1) KC(3)=PYCOMP(ID2) SM(1)=PMAS(KC(1),1)**2 SM(2)=PMAS(KC(2),1)**2 SM(3)=PMAS(KC(3),1)**2 C...Kinematics check IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN PYRVSB=0D0 RETURN ENDIF C...CM momenta squared IF (MODE.EQ.1) THEN P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2) & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2) ELSE IF (MODE.EQ.2) THEN P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2 ELSE IF (MODE.EQ.3) THEN P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2 ELSE P2CM=SM(1)/4. ENDIF C...Calculate Width PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1)) RETURN END C********************************************************************* C...PYRVGW C...Main routine for R-Violating neutralino/chargino 3-body widths. SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM) IMPLICIT DOUBLE PRECISION (A-H,O-Z) IMPLICIT INTEGER (I-N) PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) PARAMETER (EPS=1D-2) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3) COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) DOUBLE PRECISION RMS, XLIM(3,3), RES, XLAM, XLAM0, PREF INTEGER INTC, KC(0:3), KFIN,ID1,ID2,ID3,KFR,PYCOMP CHARACTER*31 PRC LOGICAL DCMASS, DCHECK(6) SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/ KC(0)=PYCOMP(KFIN) KC(1)=PYCOMP(ID1) KC(2)=PYCOMP(ID2) KC(3)=PYCOMP(ID3) DO 100 INTC=0,3 RMS(INTC)=PMAS(KC(INTC),1) 100 CONTINUE C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK XLIM(1,1)=(RMS(1)+RMS(2))**2 XLIM(1,2)=(RMS(0)-RMS(3))**2 XLIM(1,3)=XLIM(1,2)-XLIM(1,1) XLIM(2,1)=(RMS(2)+RMS(3))**2 XLIM(2,2)=(RMS(0)-RMS(1))**2 XLIM(2,3)=XLIM(2,2)-XLIM(2,1) XLIM(3,1)=(RMS(1)+RMS(3))**2 XLIM(3,2)=(RMS(0)-RMS(2))**2 XLIM(3,3)=XLIM(3,2)-XLIM(3,1) IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN RETURN ENDIF C...INITIALIZE RESONANCE INFORMATION DO 120 JRES=1,3 DO 110 IMASS=1,2 IRES=2*(JRES-1)+IMASS RES(IRES,1)=0D0 DCHECK(IRES)=.FALSE. C...NO RIGHT-HANDED NEUTRINOS IF((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR.(IABS(KFR(JRES & )).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))) GOTO 110 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1) RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2) RES(IRES,3) = IABS(KFR(JRES)) RES(IRES,4) = IMASS IF (KFR(JRES).LT.0) RES(IRES,5) = 1D0 IF (KFR(JRES).GT.0) RES(IRES,5) = 0D0 110 CONTINUE 120 CONTINUE C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE C...RESONANCE CONTRIBUTIONS C...(Only sum contributions where the resonance is off shell). C...LOOP OVER MASS STATES DO 130 J=1,2 IDR=J IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2) & +RMS(3)))).AND.ABS(SFMIX(NINT(RES(IDR,3)),J)).GT.EPS & .AND.RES(IDR,1).NE.0D0) THEN DCHECK(IDR) =.TRUE. XLAM = XLAM + SFMIX(NINT(RES(IDR,3)),J)**2 * PYRVI1(2,3,1) ENDIF IDR=J+2 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1) & +RMS(3)))).AND.ABS(SFMIX(NINT(RES(IDR,3)),J)).GT.EPS & .AND.RES(IDR,1).NE.0D0) THEN DCHECK(IDR) =.TRUE. XLAM = XLAM + SFMIX(NINT(RES(IDR,3)),J)**2 * PYRVI1(1,3,2) ENDIF IDR=J+4 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1) & +RMS(2)))).AND.ABS(SFMIX(NINT(RES(IDR,3)),2+J)).GT.EPS & .AND.RES(IDR,1).NE.0D0) THEN DCHECK(IDR) =.TRUE. XLAM = XLAM + SFMIX(NINT(RES(IDR,3)),2+J)**2 * PYRVI1(1,2,3) ENDIF 130 CONTINUE C... L-R INTERFERENCES C... (Only add contributions where both contributing diagrams C... are non-resonant). IDR=1 IF (DCHECK(1).AND.DCHECK(2)) THEN XLAM = XLAM + PYRVI2(2,1,3) & * SFMIX(NINT(RES(1,3)),1+2*NINT(RES(1,5))) & * SFMIX(NINT(RES(2,3)),2+2*NINT(RES(2,5))) ENDIF IDR=3 IF (DCHECK(3).AND.DCHECK(4)) THEN XLAM = XLAM + PYRVI2(1,3,2) & * SFMIX(NINT(RES(3,3)),1+2*NINT(RES(3,5))) & * SFMIX(NINT(RES(4,3)),2+2*NINT(RES(4,5))) ENDIF IDR=5 IF (DCHECK(5).AND.DCHECK(6)) THEN XLAM = XLAM + PYRVI2(1,2,3) & * SFMIX(NINT(RES(5,3)),1+2*NINT(RES(5,5))) & * SFMIX(NINT(RES(6,3)),2+2*NINT(RES(6,5))) ENDIF C... TRUE INTERFERENCES C... (Only add contributions where both contributing diagrams C... are non-resonant). PREF=-2. IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2. DO 150 IKR1 = 1,2 DO 140 IKR2 = 1,2 IDR = IKR1+2 IDR2 = IKR2 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN XLAM = XLAM + PREF*PYRVI3(1,3,2) * & SFMIX(NINT(RES(IDR,3)),IKR1)*SFMIX(NINT(RES(IDR2,3)),IKR2) ENDIF IDR = IKR1+4 IDR2 = IKR2 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN XLAM = XLAM + PREF*PYRVI3(1,2,3) * & SFMIX(NINT(RES(IDR,3)),2+IKR1)*SFMIX(NINT(RES(IDR2,3)),IKR2) ENDIF IDR = IKR1+4 IDR2 = IKR2+2 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN XLAM = XLAM + PREF*PYRVI3(2,1,3) * & SFMIX(NINT(RES(IDR,3)),2+IKR1)*SFMIX(NINT(RES(IDR2,3)),IKR2) ENDIF 140 CONTINUE 150 CONTINUE RETURN END C********************************************************************* C...PYRVI1 C...Function to integrate resonance contributions FUNCTION PYRVI1(ID1,ID2,ID3) IMPLICIT NONE DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS INTEGER ID1,ID2,ID3, IANTI, IDR, IDR2, KFR LOGICAL MFLAG,DCMASS EXTERNAL PYRVG1,PYGAUS COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3) COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG SAVE/PYRVNV/,/PYRVPM/ C...Initialize mass and width information PYRVI1=0D0 RM(0)=RMS(0) RM(1)=RMS(ID1) RM(2)=RMS(ID2) RM(3)=RMS(ID3) RESM(1)=RES(IDR,1) RESW(1)=RES(IDR,2) C...A->B and B->A for antisparticles IANTI=NINT(RES(IDR,5)) A(1)=AB(1+IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4))) B(1)=AB(2-IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4))) C...Integration boundaries and mass flag LO=(RM(1)+RM(2))**2 HI=(RM(0)-RM(3))**2 MFLAG=DCMASS PYRVI1=PYGAUS(PYRVG1,LO,HI,1D-2) RETURN END C********************************************************************* C...PYRVI2 C...Function to integrate L-R interference contributions FUNCTION PYRVI2(ID1,ID2,ID3) IMPLICIT NONE DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS INTEGER ID1,ID2,ID3, IANTI, IDR, IDR2, KFR LOGICAL MFLAG,DCMASS EXTERNAL PYRVG2,PYGAUS COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3) COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG SAVE/PYRVNV/,/PYRVPM/ C...Initialize mass and width information PYRVI2=0D0 RM(0)=RMS(0) RM(1)=RMS(ID1) RM(2)=RMS(ID2) RM(3)=RMS(ID3) RESM(1)=RES(IDR,1) RESW(1)=RES(IDR,2) RESM(2)=RES(IDR+1,1) RESW(2)=RES(IDR+1,2) C...A->B and B->A for antisparticles IANTI=NINT(RES(IDR,5)) A(1)=AB(1+IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4))) B(1)=AB(2-IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4))) A(2)=AB(1+IANTI,NINT(RES(IDR+1,3)),NINT(RES(IDR+1,4))) B(2)=AB(2-IANTI,NINT(RES(IDR+1,3)),NINT(RES(IDR+1,4))) C...Boundaries and mass flag LO=(RM(1)+RM(2))**2 HI=(RM(0)-RM(3))**2 MFLAG=DCMASS PYRVI2=PYGAUS(PYRVG2,LO,HI,1D-2) RETURN END C********************************************************************* C...PYRVI3 C...Function to integrate true interference contributions FUNCTION PYRVI3(ID1,ID2,ID3) IMPLICIT NONE DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS INTEGER ID1,ID2,ID3, IANTI, IDR, IDR2, KFR LOGICAL MFLAG,DCMASS EXTERNAL PYRVG3,PYGAUS COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,5),IDR,IDR2,DCMASS,KFR(3) COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG SAVE/PYRVNV/,/PYRVPM/ C...Initialize mass and width information PYRVI3=0D0 RM(0)=RMS(0) RM(1)=RMS(ID1) RM(2)=RMS(ID2) RM(3)=RMS(ID3) RESM(1)=RES(IDR,1) RESW(1)=RES(IDR,2) RESM(2)=RES(IDR2,1) RESW(2)=RES(IDR2,2) C...A -> B and B -> A for antisparticles IANTI=NINT(RES(IDR,5)) A(1)=AB(1+IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4))) B(1)=AB(2-IANTI,NINT(RES(IDR,3)),NINT(RES(IDR,4))) IANTI=NINT(RES(IDR2,5)) A(2)=AB(1+IANTI,NINT(RES(IDR2,3)),NINT(RES(IDR2,4))) B(2)=AB(2-IANTI,NINT(RES(IDR2,3)),NINT(RES(IDR2,4))) C...Boundaries and mass flag LO=(RM(1)+RM(2))**2 HI=(RM(0)-RM(3))**2 MFLAG=DCMASS PYRVI3=PYGAUS(PYRVG3,LO,HI,1D-2) RETURN END C********************************************************************* C...PYRVG1 C...Integrand for resonance contributions FUNCTION PYRVG1(X) IMPLICIT NONE COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG DOUBLE PRECISION X, RM, A, B, RESM, RESW, YMIN, YMAX, DELTAY,PYRVR DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SQ1,SR1,SR2,A1,A2 LOGICAL MFLAG SAVE/PYRVPM/ RVR=PYRVR(X,RESM(1),RESW(1)) C1=2D0*SQRT(MAX(0D0,X)) IF (.NOT.MFLAG) THEN E2=X/C1 E3=(RM(0)**2-X)/C1 DELTAY=4D0*E2*E3 PYRVG1=DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X) ELSE E2=(X-RM(1)**2+RM(2)**2)/C1 E3=(RM(0)**2-X-RM(3)**2)/C1 SQ1=(E2+E3)**2 SR1=SQRT(MAX(0D0,E2**2-RM(2)**2)) SR2=SQRT(MAX(0D0,E3**2-RM(3)**2)) YMIN=SQ1-(SR1+SR2)**2 YMAX=SQ1-(SR1-SR2)**2 DELTAY=YMAX-YMIN A1=4*A(1)*B(1)*RM(3)*RM(0) A2=(A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X) PYRVG1=DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2) ENDIF RETURN END C********************************************************************* C...PYRVG2 C...Integrand for L-R interference contributions FUNCTION PYRVG2(X) IMPLICIT NONE COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG DOUBLE PRECISION X, RM, A, B, RESM, RESW, YMIN, YMAX, DELTAY,PYRVS DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SQ1,SR1,SR2 LOGICAL MFLAG SAVE/PYRVPM/ C1=2D0*SQRT(MAX(0D0,X)) RVS=PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2)) IF (.NOT.MFLAG) THEN E2=X/C1 E3=(RM(0)**2-X)/C1 DELTAY=4D0*E2*E3 PYRVG2=DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X) ELSE E2=(X-RM(1)**2+RM(2)**2)/C1 E3=(RM(0)**2-X-RM(3)**2)/C1 SQ1=(E2+E3)**2 SR1=SQRT(MAX(0D0,E2**2-RM(2)**2)) SR2=SQRT(MAX(0D0,E3**2-RM(3)**2)) YMIN=SQ1-(SR1+SR2)**2 YMAX=SQ1-(SR1-SR2)**2 DELTAY=YMAX-YMIN PYRVG2=DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2) & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X) & + 2*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0)) ENDIF RETURN END C********************************************************************* C...PYRVG3 C...Function to do Y integration over true interference contributions FUNCTION PYRVG3(X) IMPLICIT NONE COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG C...Second Dalitz variable for PYRVG4 COMMON/PYG2DX/X1 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX DOUBLE PRECISION PYRVG3, PYRVG4, PYGAUS LOGICAL MFLAG EXTERNAL PYGAUS,PYRVG4 SAVE/PYRVPM/,/PYG2DX/ C1=2D0*SQRT(MAX(0D0,X)) X1=X IF (.NOT.MFLAG) THEN E2=X/C1 E3=(RM(0)**2-X)/C1 YMIN=0D0 YMAX=4D0*E2*E3 ELSE E2=(X-RM(1)**2+RM(2)**2)/C1 E3=(RM(0)**2-X-RM(3)**2)/C1 SQ1=(E2+E3)**2 SR1=SQRT(MAX(0D0,E2**2-RM(2)**2)) SR2=SQRT(MAX(0D0,E3**2-RM(3)**2)) YMIN=SQ1-(SR1+SR2)**2 YMAX=SQ1-(SR1-SR2)**2 ENDIF PYRVG3=PYGAUS(PYRVG4,YMIN,YMAX,1D-2) RETURN END C********************************************************************* C...PYRVG4 C...Integrand for true intereference contributions FUNCTION PYRVG4(Y) IMPLICIT NONE COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG COMMON/PYG2DX/X DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS LOGICAL MFLAG SAVE /PYRVPM/,/PYG2DX/ PYRVG4=0D0 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2)) IF (.NOT.MFLAG) THEN PYRVG4=RVS*B(1)*B(2)*X*Y ELSE PYRVG4=RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2) & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2) & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2) & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2)) ENDIF RETURN END C********************************************************************* C...PYRVR C...Breit-Wigner for resonance contributions FUNCTION PYRVR(Mab2,RM,RW) IMPLICIT NONE DOUBLE PRECISION Mab2,RM,RW,PYRVR PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2) RETURN END C********************************************************************* C...PYRVS C...Interference function FUNCTION PYRVS(X,Y,M1,W1,M2,W2) IMPLICIT NONE DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2) & +W1*W2*M1*M2) RETURN END C********************************************************************* C...PY1ENT C...Stores one parton/particle in commonblock PYJETS. SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Standard checks. MSTU(28)=0 IF(MSTU(12).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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Standard checks. MSTU(28)=0 IF(MSTU(12).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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Standard checks. MSTU(28)=0 IF(MSTU(12).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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Standard checks. MSTU(28)=0 IF(MSTU(12).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...PY2FRM C...An interface from a two-fermion generator to include C...parton showers and hadronization. SUBROUTINE PY2FRM(IRAD,ITAU,ICOM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYJETS/,/PYDAT1/ C...Local arrays. DIMENSION IJOIN(2),INTAU(2) C...Call PYHEPC to convert input from HEPEVT to PYJETS common. IF(ICOM.EQ.0) THEN MSTU(28)=0 CALL PYHEPC(2) ENDIF C...Loop through entries and pick up all final fermions/antifermions. I1=0 I2=0 DO 100 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100 KFA=IABS(K(I,2)) IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN IF(K(I,2).GT.0) THEN IF(I1.EQ.0) THEN I1=I ELSE CALL PYERRM(16,'(PY2FRM:) more than one fermion') ENDIF ELSE IF(I2.EQ.0) THEN I2=I ELSE CALL PYERRM(16,'(PY2FRM:) more than one antifermion') ENDIF ENDIF ENDIF 100 CONTINUE C...Check that event is arranged according to conventions. IF(I1.EQ.0.OR.I2.EQ.0) THEN CALL PYERRM(16,'(PY2FRM:) event contains too few fermions') ENDIF IF(I2.LT.I1) THEN CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order') ENDIF C...Check whether fermion pair is quarks or leptons. IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN IQL12=1 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN IQL12=2 ELSE CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent') ENDIF C...Decide whether to allow or not photon radiation in showers. MSTJ(41)=2 IF(IRAD.EQ.0) MSTJ(41)=1 C...Do colour joining and parton showers. IP1=I1 IP2=I2 IF(IQL12.EQ.1) THEN IJOIN(1)=IP1 IJOIN(2)=IP2 CALL PYJOIN(2,IJOIN) ENDIF IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2- & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S))) ENDIF C...Do fragmentation and decays. Possibly except tau decay. IF(ITAU.EQ.0) THEN NTAU=0 DO 110 I=1,N IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN NTAU=NTAU+1 INTAU(NTAU)=I K(I,1)=11 ENDIF 110 CONTINUE ENDIF CALL PYEXEC IF(ITAU.EQ.0) THEN DO 120 I=1,NTAU K(INTAU(I),1)=1 120 CONTINUE ENDIF C...Call PYHEPC to convert output from PYJETS to HEPEVT common. IF(ICOM.EQ.0) THEN MSTU(28)=0 CALL PYHEPC(1) ENDIF END C********************************************************************* C...PY4FRM C...An interface from a four-fermion generator to include C...parton showers and hadronization. SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/ C...Local arrays. DIMENSION IJOIN(2),INTAU(4) C...Call PYHEPC to convert input from HEPEVT to PYJETS common. IF(ICOM.EQ.0) THEN MSTU(28)=0 CALL PYHEPC(2) ENDIF C...Loop through entries and pick up all final fermions/antifermions. I1=0 I2=0 I3=0 I4=0 DO 100 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100 KFA=IABS(K(I,2)) IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN IF(K(I,2).GT.0) THEN IF(I1.EQ.0) THEN I1=I ELSEIF(I3.EQ.0) THEN I3=I ELSE CALL PYERRM(16,'(PY4FRM:) more than two fermions') ENDIF ELSE IF(I2.EQ.0) THEN I2=I ELSEIF(I4.EQ.0) THEN I4=I ELSE CALL PYERRM(16,'(PY4FRM:) more than two antifermions') ENDIF ENDIF ENDIF 100 CONTINUE C...Check that event is arranged according to conventions. IF(I3.EQ.0.OR.I4.EQ.0) THEN CALL PYERRM(16,'(PY4FRM:) event contains too few fermions') ENDIF IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order') ENDIF C...Check which fermion pairs are quarks and which leptons. IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN IQL12=1 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN IQL12=2 ELSE CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent') ENDIF IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN IQL34=1 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN IQL34=2 ELSE CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent') ENDIF C...Decide whether to allow or not photon radiation in showers. MSTJ(41)=2 IF(IRAD.EQ.0) MSTJ(41)=1 C...Decide on dipole pairing. IP1=I1 IP2=I2 IP3=I3 IP4=I4 IF(IQL12.EQ.IQL34) THEN R1SQ=A1SQ R2SQ=A2SQ DELTA=ATOTSQ-A1SQ-A2SQ IF(ISTRAT.EQ.1) THEN IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA) ELSEIF(ISTRAT.EQ.2) THEN IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA) ENDIF IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN IP2=I4 IP4=I2 ENDIF ENDIF C...If colour reconnection then bookkeep W+W- or Z0Z0 C...and copy q qbar q qbar consecutively. IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN K(N+1,1)=11 K(N+1,3)=IP1 K(N+1,4)=N+3 K(N+1,5)=N+4 K(N+2,1)=11 K(N+2,3)=IP3 K(N+2,4)=N+5 K(N+2,5)=N+6 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN K(N+1,2)=23 K(N+2,2)=23 MINT(1)=22 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN K(N+1,2)=24 K(N+2,2)=-24 MINT(1)=25 ELSE K(N+1,2)=-24 K(N+2,2)=24 MINT(1)=25 ENDIF DO 110 J=1,5 K(N+3,J)=K(IP1,J) K(N+4,J)=K(IP2,J) K(N+5,J)=K(IP3,J) K(N+6,J)=K(IP4,J) P(N+1,J)=P(IP1,J)+P(IP2,J) P(N+2,J)=P(IP3,J)+P(IP4,J) P(N+3,J)=P(IP1,J) P(N+4,J)=P(IP2,J) P(N+5,J)=P(IP3,J) P(N+6,J)=P(IP4,J) V(N+1,J)=V(IP1,J) V(N+2,J)=V(IP3,J) V(N+3,J)=V(IP1,J) V(N+4,J)=V(IP2,J) V(N+5,J)=V(IP3,J) V(N+6,J)=V(IP4,J) 110 CONTINUE P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- & P(N+1,3)**2)) P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2- & P(N+2,3)**2)) K(N+3,3)=N+1 K(N+4,3)=N+1 K(N+5,3)=N+2 K(N+6,3)=N+2 C...Remove original q qbar q qbar and update counters. K(IP1,1)=K(IP1,1)+10 K(IP2,1)=K(IP2,1)+10 K(IP3,1)=K(IP3,1)+10 K(IP4,1)=K(IP4,1)+10 IW1=N+1 IW2=N+2 NSD1=N+2 IP1=N+3 IP2=N+4 IP3=N+5 IP4=N+6 N=N+6 ENDIF C...Do colour joinings and parton showers. IF(IQL12.EQ.1) THEN IJOIN(1)=IP1 IJOIN(2)=IP2 CALL PYJOIN(2,IJOIN) ENDIF IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2- & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S))) ENDIF NAFT1=N IF(IQL34.EQ.1) THEN IJOIN(1)=IP3 IJOIN(2)=IP4 CALL PYJOIN(2,IJOIN) ENDIF IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2- & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S))) ENDIF C...Optionally do colour reconnection. MINT(32)=0 MSTI(32)=0 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN CALL PYRECO(IW1,IW2,NSD1,NAFT1) MSTI(32)=MINT(32) ENDIF C...Do fragmentation and decays. Possibly except tau decay. IF(ITAU.EQ.0) THEN NTAU=0 DO 120 I=1,N IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN NTAU=NTAU+1 INTAU(NTAU)=I K(I,1)=11 ENDIF 120 CONTINUE ENDIF CALL PYEXEC IF(ITAU.EQ.0) THEN DO 130 I=1,NTAU K(INTAU(I),1)=1 130 CONTINUE ENDIF C...Call PYHEPC to convert output from PYJETS to HEPEVT common. IF(ICOM.EQ.0) THEN MSTU(28)=0 CALL PYHEPC(1) ENDIF END C********************************************************************* C...PY6FRM C...An interface from a six-fermion generator to include C...parton showers and hadronization. SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYJETS/,/PYDAT1/ C...Local arrays. DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3) C...Call PYHEPC to convert input from HEPEVT to PYJETS common. IF(ICOM.EQ.0) THEN MSTU(28)=0 CALL PYHEPC(2) ENDIF C...Loop through entries and pick up all final fermions/antifermions. I1=0 I2=0 I3=0 I4=0 I5=0 I6=0 DO 100 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100 KFA=IABS(K(I,2)) IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN IF(K(I,2).GT.0) THEN IF(I1.EQ.0) THEN I1=I ELSEIF(I3.EQ.0) THEN I3=I ELSEIF(I5.EQ.0) THEN I5=I ELSE CALL PYERRM(16,'(PY6FRM:) more than three fermions') ENDIF ELSE IF(I2.EQ.0) THEN I2=I ELSEIF(I4.EQ.0) THEN I4=I ELSEIF(I6.EQ.0) THEN I6=I ELSE CALL PYERRM(16,'(PY6FRM:) more than three antifermions') ENDIF ENDIF ENDIF 100 CONTINUE C...Check that event is arranged according to conventions. IF(I5.EQ.0.OR.I6.EQ.0) THEN CALL PYERRM(16,'(PY6FRM:) event contains too few fermions') ENDIF IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order') ENDIF C...Check which fermion pairs are quarks and which leptons. IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN IQL12=1 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN IQL12=2 ELSE CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent') ENDIF IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN IQL34=1 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN IQL34=2 ELSE CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent') ENDIF IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN IQL56=1 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN IQL56=2 ELSE CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent') ENDIF C...Decide whether to allow or not photon radiation in showers. MSTJ(41)=2 IF(IRAD.EQ.0) MSTJ(41)=1 C...Allow dipole pairings only among leptons and quarks separately. P12D=P12 P13D=0D0 IF(IQL34.EQ.IQL56) P13D=P13 P21D=0D0 IF(IQL12.EQ.IQL34) P21D=P21 P23D=0D0 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23 P31D=0D0 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31 P32D=0D0 IF(IQL12.EQ.IQL56) P32D=P32 C...Decide whether t+tbar. ITOP=0 IF(PYR(0).LT.PTOP) THEN ITOP=1 C...If t+tbar: reconstruct t's. IT=N+1 ITB=N+2 DO 110 J=1,5 K(IT,J)=0 K(ITB,J)=0 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J) P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J) V(IT,J)=0D0 V(ITB,J)=0D0 110 CONTINUE K(IT,1)=1 K(ITB,1)=1 K(IT,2)=6 K(ITB,2)=-6 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2- & P(IT,3)**2)) P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2- & P(ITB,3)**2)) N=N+2 C...If t+tbar: colour join t's and let them shower. IJOIN(1)=IT IJOIN(2)=ITB CALL PYJOIN(2,IJOIN) PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2- & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS))) C...If t+tbar: pick up the t's after shower. ITNEW=IT ITBNEW=ITB DO 120 I=ITB+1,N IF(K(I,2).EQ.6) ITNEW=I IF(K(I,2).EQ.-6) ITBNEW=I 120 CONTINUE C...If t+tbar: loop over two top systems. DO 200 IT1=1,2 IF(IT1.EQ.1) THEN ITO=IT ITN=ITNEW IBO=I1 IW1=I3 IW2=I4 ELSE ITO=ITB ITN=ITBNEW IBO=I2 IW1=I5 IW2=I6 ENDIF IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6, & '(PY6FRM:) not b in t decay') C...If t+tbar: find boost from original to new top frame. DO 130 J=1,3 BETAO(J)=P(ITO,J)/P(ITO,4) BETAN(J)=P(ITN,J)/P(ITN,4) 130 CONTINUE C...If t+tbar: boost copy of b by t shower and connect it in colour. N=N+1 IB=N K(IB,1)=3 K(IB,2)=K(IBO,2) K(IB,3)=ITN DO 140 J=1,5 P(IB,J)=P(IBO,J) V(IB,J)=0D0 140 CONTINUE CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3)) CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3)) K(IB,4)=MSTU(5)*ITN K(IB,5)=MSTU(5)*ITN K(ITN,4)=K(ITN,4)+IB K(ITN,5)=K(ITN,5)+IB K(ITN,1)=K(ITN,1)+10 K(IBO,1)=K(IBO,1)+10 C...If t+tbar: construct W recoiling against b. N=N+1 IW=N DO 150 J=1,5 K(IW,J)=0 V(IW,J)=0D0 150 CONTINUE K(IW,1)=1 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2)) IF(IABS(KCHW).EQ.3) THEN K(IW,2)=ISIGN(24,KCHW) ELSE CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W') ENDIF K(IW,3)=IW1 C...If t+tbar: construct W momentum, including boost by t shower. DO 160 J=1,4 P(IW,J)=P(IW1,J)+P(IW2,J) 160 CONTINUE P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2- & P(IW,3)**2)) CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3)) CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3)) C...If t+tbar: boost b and W to top rest frame. DO 170 J=1,3 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4)) 170 CONTINUE CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) C...If t+tbar: let b shower and pick up modified W. PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2- & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS))) DO 180 I=IW,N IF(IABS(K(I,2)).EQ.24) IWM=I 180 CONTINUE C...If t+tbar: take copy of W decay products. DO 190 J=1,5 K(N+1,J)=K(IW1,J) P(N+1,J)=P(IW1,J) V(N+1,J)=V(IW1,J) K(N+2,J)=K(IW2,J) P(N+2,J)=P(IW2,J) V(N+2,J)=V(IW2,J) 190 CONTINUE K(IW1,1)=K(IW1,1)+10 K(IW2,1)=K(IW2,1)+10 K(IWM,1)=K(IWM,1)+10 K(IWM,4)=N+1 K(IWM,5)=N+2 K(N+1,3)=IWM K(N+2,3)=IWM IF(IT1.EQ.1) THEN I3=N+1 I4=N+2 ELSE I5=N+1 I6=N+2 ENDIF N=N+2 C...If t+tbar: boost W decay products, first by effects of t shower, C...then by those of b shower. b and its shower simple boost back. CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3)) CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3)) CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4), & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4)) CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4), & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4)) CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3)) CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3)) 200 CONTINUE ENDIF C...Decide on dipole pairing. IP1=I1 IP3=I3 IP5=I5 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D) IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN IP2=I2 IP4=I4 IP6=I6 ELSEIF(PRN.LT.P12D+P13D) THEN IP2=I2 IP4=I6 IP6=I4 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN IP2=I4 IP4=I2 IP6=I6 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN IP2=I4 IP4=I6 IP6=I2 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN IP2=I6 IP4=I2 IP6=I4 ELSE IP2=I6 IP4=I4 IP6=I2 ENDIF C...Do colour joinings and parton showers C...(except ones already made for t+tbar). IF(ITOP.EQ.0) THEN IF(IQL12.EQ.1) THEN IJOIN(1)=IP1 IJOIN(2)=IP2 CALL PYJOIN(2,IJOIN) ENDIF IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2- & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S))) ENDIF ENDIF IF(IQL34.EQ.1) THEN IJOIN(1)=IP3 IJOIN(2)=IP4 CALL PYJOIN(2,IJOIN) ENDIF IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2- & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S))) ENDIF IF(IQL56.EQ.1) THEN IJOIN(1)=IP5 IJOIN(2)=IP6 CALL PYJOIN(2,IJOIN) ENDIF IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2- & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S))) ENDIF C...Do fragmentation and decays. Possibly except tau decay. IF(ITAU.EQ.0) THEN NTAU=0 DO 210 I=1,N IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN NTAU=NTAU+1 INTAU(NTAU)=I K(I,1)=11 ENDIF 210 CONTINUE ENDIF CALL PYEXEC IF(ITAU.EQ.0) THEN DO 220 I=1,NTAU K(INTAU(I),1)=1 220 CONTINUE ENDIF C...Call PYHEPC to convert output from PYJETS to HEPEVT common. IF(ICOM.EQ.0) THEN MSTU(28)=0 CALL PYHEPC(1) ENDIF END C********************************************************************* C...PY4JET C...An interface from a four-parton generator to include C...parton showers and hadronization. SUBROUTINE PY4JET(PMAX,IRAD,ICOM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYJETS/,/PYDAT1/ C...Local arrays. DIMENSION IJOIN(2),PTOT(4),BETA(3) C...Call PYHEPC to convert input from HEPEVT to PYJETS common. IF(ICOM.EQ.0) THEN MSTU(28)=0 CALL PYHEPC(2) ENDIF C...Loop through entries and pick up all final partons. I1=0 I2=0 I3=0 I4=0 DO 100 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100 KFA=IABS(K(I,2)) IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN IF(I1.EQ.0) THEN I1=I ELSEIF(I3.EQ.0) THEN I3=I ELSE CALL PYERRM(16,'(PY4JET:) more than two quarks') ENDIF ELSEIF(K(I,2).LT.0) THEN IF(I2.EQ.0) THEN I2=I ELSEIF(I4.EQ.0) THEN I4=I ELSE CALL PYERRM(16,'(PY4JET:) more than two antiquarks') ENDIF ELSE IF(I3.EQ.0) THEN I3=I ELSEIF(I4.EQ.0) THEN I4=I ELSE CALL PYERRM(16,'(PY4JET:) more than two gluons') ENDIF ENDIF ENDIF 100 CONTINUE C...Check that event is arranged according to conventions. IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN CALL PYERRM(16,'(PY4JET:) event contains too few partons') ENDIF IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order') ENDIF C...Check whether second pair are quarks or gluons. IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN IQG34=1 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN IQG34=2 ELSE CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent') ENDIF C...Boost partons to their cm frame. DO 110 J=1,4 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J) 110 CONTINUE ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2)) DO 120 J=1,3 BETA(J)=PTOT(J)/PTOT(4) 120 CONTINUE CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) NSAV=N C...Decide and set up shower history for q qbar q' qbar' events. IF(IQG34.EQ.1) THEN W1=PY4JTW(0,I1,I3,I4) W2=PY4JTW(0,I2,I3,I4) IF(W1.GT.PYR(0)*(W1+W2)) THEN CALL PY4JTS(0,I1,I3,I4,I2,QMAX) ELSE CALL PY4JTS(0,I2,I3,I4,I1,QMAX) ENDIF C...Decide and set up shower history for q qbar g g events. ELSE W1=PY4JTW(I1,I3,I2,I4) W2=PY4JTW(I1,I4,I2,I3) W3=PY4JTW(0,I3,I1,I4) W4=PY4JTW(0,I4,I1,I3) W5=PY4JTW(0,I3,I2,I4) W6=PY4JTW(0,I4,I2,I3) W7=PY4JTW(0,I1,I3,I4) W8=PY4JTW(0,I2,I3,I4) WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0) IF(W1.GT.WR) THEN CALL PY4JTS(I1,I3,I2,I4,0,QMAX) ELSEIF(W1+W2.GT.WR) THEN CALL PY4JTS(I1,I4,I2,I3,0,QMAX) ELSEIF(W1+W2+W3.GT.WR) THEN CALL PY4JTS(0,I3,I1,I4,I2,QMAX) ELSEIF(W1+W2+W3+W4.GT.WR) THEN CALL PY4JTS(0,I4,I1,I3,I2,QMAX) ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN CALL PY4JTS(0,I3,I2,I4,I1,QMAX) ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN CALL PY4JTS(0,I4,I2,I3,I1,QMAX) ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN CALL PY4JTS(0,I1,I3,I4,I2,QMAX) ELSE CALL PY4JTS(0,I2,I3,I4,I1,QMAX) ENDIF ENDIF C...Boost back original partons and mark them as deleted. CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3)) CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3)) CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3)) CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3)) K(I1,1)=K(I1,1)+10 K(I2,1)=K(I2,1)+10 K(I3,1)=K(I3,1)+10 K(I4,1)=K(I4,1)+10 C...Rotate shower initiating partons to be along z axis. PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2)) CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0) THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1)) CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0) C...Set up copy of shower initiating partons as on mass shell. DO 140 I=N+1,N+2 DO 130 J=1,5 K(I,J)=0 P(I,J)=0D0 V(I,J)=V(I1,J) 130 CONTINUE K(I,1)=1 K(I,2)=K(I-6,2) 140 CONTINUE IF(K(NSAV+1,2).EQ.K(I1,2)) THEN K(N+1,3)=I1 P(N+1,5)=P(I1,5) K(N+2,3)=I2 P(N+2,5)=P(I2,5) ELSE K(N+1,3)=I2 P(N+1,5)=P(I2,5) K(N+2,3)=I1 P(N+2,5)=P(I1,5) ENDIF PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2- &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM) P(N+1,3)=PABS P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2) P(N+2,3)=-PABS P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2) N=N+2 C...Decide whether to allow or not photon radiation in showers. C...Connect up colours. MSTJ(41)=2 IF(IRAD.EQ.0) MSTJ(41)=1 IJOIN(1)=N-1 IJOIN(2)=N CALL PYJOIN(2,IJOIN) C...Decide on maximum virtuality and do parton shower. IF(PMAX.LT.PARJ(82)) THEN PQMAX=QMAX ELSE PQMAX=PMAX ENDIF CALL PYSHOW(NSAV+1,-8,PQMAX) C...Rotate and boost back system. CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3)) C...Do fragmentation and decays. CALL PYEXEC C...Call PYHEPC to convert output from PYJETS to HEPEVT common. IF(ICOM.EQ.0) THEN MSTU(28)=0 CALL PYHEPC(1) ENDIF RETURN END C********************************************************************* C...PY4JTW C...Auxiliary to PY4JET, to evaluate weight of configuration. FUNCTION PY4JTW(IA1,IA2,IA3,IA4) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) SAVE /PYJETS/ C...First case: when both original partons radiate. C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4. IF(IA1.NE.0) THEN DO 100 J=1,4 P(N+1,J)=P(IA1,J)+P(IA2,J) P(N+2,J)=P(IA3,J)+P(IA4,J) 100 CONTINUE P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- & P(N+1,3)**2)) P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2- & P(N+2,3)**2)) Z1=P(IA1,4)/P(N+1,4) WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2) Z2=P(IA3,4)/P(N+2,4) WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2) C...Second case: when one original parton radiates to three. C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4. ELSE DO 110 J=1,4 P(N+2,J)=P(IA3,J)+P(IA4,J) P(N+1,J)=P(N+2,J)+P(IA2,J) 110 CONTINUE P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- & P(N+1,3)**2)) P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2- & P(N+2,3)**2)) IF(K(IA2,2).EQ.21) THEN Z1=P(N+2,4)/P(N+1,4) WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2- & P(IA3,5)**2) ELSE Z1=P(IA2,4)/P(N+1,4) WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2- & P(IA2,5)**2) ENDIF Z2=P(IA3,4)/P(N+2,4) IF(K(IA2,2).EQ.21) THEN WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2- & P(IA3,5)**2) ELSEIF(K(IA3,2).EQ.21) THEN WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2 ELSE WT2=0.5D0*(Z2**2+(1D0-Z2)**2) ENDIF ENDIF C...Total weight. PY4JTW=WT1*WT2 RETURN END C********************************************************************* C...PY4JTS C...Auxiliary to PY4JET, to set up chosen configuration. SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) SAVE /PYJETS/ C...Reset info. DO 110 I=N+1,N+6 DO 100 J=1,5 K(I,J)=0 V(I,J)=V(IA2,J) 100 CONTINUE K(I,1)=16 110 CONTINUE C...First case: when both original partons radiate. C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6). IF(IA1.NE.0) THEN C...Set up flavour and history pointers for new partons. K(N+1,2)=K(IA1,2) K(N+2,2)=K(IA3,2) K(N+3,2)=K(IA1,2) K(N+4,2)=K(IA2,2) K(N+5,2)=K(IA3,2) K(N+6,2)=K(IA4,2) K(N+1,3)=IA1 K(N+1,4)=N+3 K(N+1,5)=N+4 K(N+2,3)=IA3 K(N+2,4)=N+5 K(N+2,5)=N+6 K(N+3,3)=N+1 K(N+4,3)=N+1 K(N+5,3)=N+2 K(N+6,3)=N+2 C...Set up momenta for new partons. DO 120 J=1,5 P(N+1,J)=P(IA1,J)+P(IA2,J) P(N+2,J)=P(IA3,J)+P(IA4,J) P(N+3,J)=P(IA1,J) P(N+4,J)=P(IA2,J) P(N+5,J)=P(IA3,J) P(N+6,J)=P(IA4,J) 120 CONTINUE P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- & P(N+1,3)**2)) P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2- & P(N+2,3)**2)) QMAX=MIN(P(N+1,5),P(N+2,5)) C...Second case: q radiates twice. C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6), C...IA5=N+2 does not radiate. ELSEIF(K(IA2,2).EQ.21) THEN C...Set up flavour and history pointers for new partons. K(N+1,2)=K(IA3,2) K(N+2,2)=K(IA5,2) K(N+3,2)=K(IA3,2) K(N+4,2)=K(IA2,2) K(N+5,2)=K(IA3,2) K(N+6,2)=K(IA4,2) K(N+1,3)=IA3 K(N+1,4)=N+3 K(N+1,5)=N+4 K(N+2,3)=IA5 K(N+3,3)=N+1 K(N+3,4)=N+5 K(N+3,5)=N+6 K(N+4,3)=N+1 K(N+5,3)=N+3 K(N+6,3)=N+3 C...Set up momenta for new partons. DO 130 J=1,5 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J) P(N+2,J)=P(IA5,J) P(N+3,J)=P(IA3,J)+P(IA4,J) P(N+4,J)=P(IA2,J) P(N+5,J)=P(IA3,J) P(N+6,J)=P(IA4,J) 130 CONTINUE P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- & P(N+1,3)**2)) P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2- & P(N+3,3)**2)) QMAX=P(N+3,5) C...Third case: q radiates g, g branches. C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6), C...IA5=N+2 does not radiate. ELSE C...Set up flavour and history pointers for new partons. K(N+1,2)=K(IA2,2) K(N+2,2)=K(IA5,2) K(N+3,2)=K(IA2,2) K(N+4,2)=21 K(N+5,2)=K(IA3,2) K(N+6,2)=K(IA4,2) K(N+1,3)=IA2 K(N+1,4)=N+3 K(N+1,5)=N+4 K(N+2,3)=IA5 K(N+3,3)=N+1 K(N+4,3)=N+1 K(N+4,4)=N+5 K(N+4,5)=N+6 K(N+5,3)=N+4 K(N+6,3)=N+4 C...Set up momenta for new partons. DO 140 J=1,5 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J) P(N+2,J)=P(IA5,J) P(N+3,J)=P(IA2,J) P(N+4,J)=P(IA3,J)+P(IA4,J) P(N+5,J)=P(IA3,J) P(N+6,J)=P(IA4,J) 140 CONTINUE P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- & P(N+1,3)**2)) P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2- & P(N+4,3)**2)) QMAX=P(N+4,5) ENDIF N=N+6 RETURN END C********************************************************************* C...PYJOIN C...Connects a sequence of partons with colour flow indices, C...as required for subsequent shower evolution (or other operations). SUBROUTINE PYJOIN(NJOIN,IJOIN) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local array. DIMENSION IJOIN(*) C...Check that partons are of right types to be connected. IF(NJOIN.LT.2) GOTO 120 KQSUM=0 DO 100 IJN=1,NJOIN I=IJOIN(IJN) IF(I.LE.0.OR.I.GT.N) GOTO 120 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120 KC=PYCOMP(K(I,2)) IF(KC.EQ.0) GOTO 120 KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) IF(KQ.EQ.0) GOTO 120 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120 IF(KQ.NE.2) KQSUM=KQSUM+KQ IF(IJN.EQ.1) KQS=KQ 100 CONTINUE IF(KQSUM.NE.0) GOTO 120 C...Connect the partons sequentially (closing for gluon loop). KCS=(9-KQS)/2 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0)) DO 110 IJN=1,NJOIN I=IJOIN(IJN) K(I,1)=3 IF(IJN.NE.1) IP=IJOIN(IJN-1) IF(IJN.EQ.1) IP=IJOIN(NJOIN) IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1) IF(IJN.EQ.NJOIN) IN=IJOIN(1) K(I,KCS)=MSTU(5)*IN K(I,9-KCS)=MSTU(5)*IP IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0 110 CONTINUE C...Error exit: no action taken. RETURN 120 CALL PYERRM(12, &'(PYJOIN:) given entries can not be joined by one string') RETURN END C********************************************************************* C...PYGIVE C...Sets values of commonblock variables. SUBROUTINE PYGIVE(CHIN) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYDAT4/CHAF(500,2) CHARACTER CHAF*16 COMMON/PYDATR/MRPY(6),RRPY(100) COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) COMMON/PYINT4/MWID(500),WIDS(500,5) COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) COMMON/PYINT6/PROC(0:500) CHARACTER PROC*28 COMMON/PYINT7/SIGT(0:6,0:6,0:5) COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6), &XPDIR(-6:6) COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/, &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/, &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/ C...Local arrays and character variables. CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28, &CHNEW2*28,CHNAM*6,CHVAR(52)*6,CHALP(2)*26,CHIND*8,CHINI*10, &CHINR*16 DIMENSION MSVAR(52,8) C...For each variable to be translated give: name, C...integer/real/character, no. of indices, lower&upper index bounds. DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG', &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY', &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI', &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH', &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL', &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB'/ DATA ((MSVAR(I,J),J=1,8),I=1,52)/ 1,7*0, 1,2,1,4000,1,5,2*0, &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0, &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0, &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0, &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0, &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0, &1,1,1,6,4*0, 2,1,1,100,4*0, &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0, &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0, &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0, &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2, &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0, &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0, &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5, &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0, &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0, &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3/ 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...Peel off any text following exclamation mark. LHIG2=LBIT DO 140 LLOW2=LHIG2,1,-1 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1 140 CONTINUE IF(LBIT.EQ.0) RETURN C...Identify commonblock variable. LNAM=1 150 LNAM=LNAM+1 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND. &LNAM.LE.6) GOTO 150 CHNAM=CHBIT(1:LNAM-1)//' ' DO 170 LCOM=1,LNAM-1 DO 160 LALP=1,26 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)= & CHALP(2)(LALP:LALP) 160 CONTINUE 170 CONTINUE IVAR=0 DO 180 IV=1,52 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV 180 CONTINUE IF(IVAR.EQ.0) THEN CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM) LLOW=LHIG IF(LLOW.LT.LTOT) GOTO 120 RETURN ENDIF C...Identify any indices. I1=0 I2=0 I3=0 NINDX=0 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN LIND=LNAM 190 LIND=LIND+1 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190 CHIND=' ' IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c') & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR. & IVAR.EQ.37)) THEN CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1) READ(CHIND,'(I8)') KF I1=PYCOMP(KF) ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ. & 'c') THEN CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '// & CHNAM) LLOW=LHIG IF(LLOW.LT.LTOT) GOTO 120 RETURN ELSE CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1) READ(CHIND,'(I8)') I1 ENDIF LNAM=LIND IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1 NINDX=1 ENDIF IF(CHBIT(LNAM:LNAM).EQ.',') THEN LIND=LNAM 200 LIND=LIND+1 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200 CHIND=' ' CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1) READ(CHIND,'(I8)') I2 LNAM=LIND IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1 NINDX=2 ENDIF IF(CHBIT(LNAM:LNAM).EQ.',') THEN LIND=LNAM 210 LIND=LIND+1 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210 CHIND=' ' CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1) READ(CHIND,'(I8)') I3 LNAM=LIND+1 NINDX=3 ENDIF C...Check that indices allowed. IERR=0 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4))) &IERR=2 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6))) &IERR=3 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8))) &IERR=4 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5 IF(IERR.GE.1) THEN CALL PYERRM(18,'(PYGIVE:) unallowed indices for '// & CHBIT(1:LNAM-1)) LLOW=LHIG IF(LLOW.LT.LTOT) GOTO 120 RETURN ENDIF C...Save old value of variable. IF(IVAR.EQ.1) THEN IOLD=N ELSEIF(IVAR.EQ.2) THEN IOLD=K(I1,I2) ELSEIF(IVAR.EQ.3) THEN ROLD=P(I1,I2) ELSEIF(IVAR.EQ.4) THEN ROLD=V(I1,I2) ELSEIF(IVAR.EQ.5) THEN IOLD=MSTU(I1) ELSEIF(IVAR.EQ.6) THEN ROLD=PARU(I1) ELSEIF(IVAR.EQ.7) THEN IOLD=MSTJ(I1) ELSEIF(IVAR.EQ.8) THEN ROLD=PARJ(I1) ELSEIF(IVAR.EQ.9) THEN IOLD=KCHG(I1,I2) ELSEIF(IVAR.EQ.10) THEN ROLD=PMAS(I1,I2) ELSEIF(IVAR.EQ.11) THEN ROLD=PARF(I1) ELSEIF(IVAR.EQ.12) THEN ROLD=VCKM(I1,I2) ELSEIF(IVAR.EQ.13) THEN IOLD=MDCY(I1,I2) ELSEIF(IVAR.EQ.14) THEN IOLD=MDME(I1,I2) ELSEIF(IVAR.EQ.15) THEN ROLD=BRAT(I1) ELSEIF(IVAR.EQ.16) THEN IOLD=KFDP(I1,I2) ELSEIF(IVAR.EQ.17) THEN CHOLD=CHAF(I1,I2) ELSEIF(IVAR.EQ.18) THEN IOLD=MRPY(I1) ELSEIF(IVAR.EQ.19) THEN ROLD=RRPY(I1) ELSEIF(IVAR.EQ.20) THEN IOLD=MSEL ELSEIF(IVAR.EQ.21) THEN IOLD=MSUB(I1) ELSEIF(IVAR.EQ.22) THEN IOLD=KFIN(I1,I2) ELSEIF(IVAR.EQ.23) THEN ROLD=CKIN(I1) ELSEIF(IVAR.EQ.24) THEN IOLD=MSTP(I1) ELSEIF(IVAR.EQ.25) THEN ROLD=PARP(I1) ELSEIF(IVAR.EQ.26) THEN IOLD=MSTI(I1) ELSEIF(IVAR.EQ.27) THEN ROLD=PARI(I1) ELSEIF(IVAR.EQ.28) THEN IOLD=MINT(I1) ELSEIF(IVAR.EQ.29) THEN ROLD=VINT(I1) ELSEIF(IVAR.EQ.30) THEN IOLD=ISET(I1) ELSEIF(IVAR.EQ.31) THEN IOLD=KFPR(I1,I2) ELSEIF(IVAR.EQ.32) THEN ROLD=COEF(I1,I2) ELSEIF(IVAR.EQ.33) THEN IOLD=ICOL(I1,I2,I3) ELSEIF(IVAR.EQ.34) THEN ROLD=XSFX(I1,I2) ELSEIF(IVAR.EQ.35) THEN IOLD=ISIG(I1,I2) ELSEIF(IVAR.EQ.36) THEN ROLD=SIGH(I1) ELSEIF(IVAR.EQ.37) THEN IOLD=MWID(I1) ELSEIF(IVAR.EQ.38) THEN ROLD=WIDS(I1,I2) ELSEIF(IVAR.EQ.39) THEN IOLD=NGEN(I1,I2) ELSEIF(IVAR.EQ.40) THEN ROLD=XSEC(I1,I2) ELSEIF(IVAR.EQ.41) THEN CHOLD2=PROC(I1) ELSEIF(IVAR.EQ.42) THEN ROLD=SIGT(I1,I2,I3) ELSEIF(IVAR.EQ.43) THEN ROLD=XPVMD(I1) ELSEIF(IVAR.EQ.44) THEN ROLD=XPANL(I1) ELSEIF(IVAR.EQ.45) THEN ROLD=XPANH(I1) ELSEIF(IVAR.EQ.46) THEN ROLD=XPBEH(I1) ELSEIF(IVAR.EQ.47) THEN ROLD=XPDIR(I1) ELSEIF(IVAR.EQ.48) THEN IOLD=IMSS(I1) ELSEIF(IVAR.EQ.49) THEN ROLD=RMSS(I1) ELSEIF(IVAR.EQ.50) THEN ROLD=RVLAM(I1,I2,I3) ELSEIF(IVAR.EQ.51) THEN ROLD=RVLAMP(I1,I2,I3) ELSEIF(IVAR.EQ.52) THEN ROLD=RVLAMB(I1,I2,I3) ENDIF C...Print current value of variable. Loop back. IF(LNAM.GE.LBIT) THEN CHBIT(LNAM:14)=' ' CHBIT(15:60)=' has the value ' IF(MSVAR(IVAR,1).EQ.1) THEN WRITE(CHBIT(51:60),'(I10)') IOLD ELSEIF(MSVAR(IVAR,1).EQ.2) THEN WRITE(CHBIT(47:60),'(F14.5)') ROLD ELSEIF(MSVAR(IVAR,1).EQ.3) THEN CHBIT(53:60)=CHOLD ELSE CHBIT(33:60)=CHOLD ENDIF IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60) LLOW=LHIG IF(LLOW.LT.LTOT) GOTO 120 RETURN ENDIF C...Read in new variable value. IF(MSVAR(IVAR,1).EQ.1) THEN CHINI=' ' CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT) READ(CHINI,'(I10)') INEW ELSEIF(MSVAR(IVAR,1).EQ.2) THEN CHINR=' ' CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT) READ(CHINR,*) RNEW ELSEIF(MSVAR(IVAR,1).EQ.3) THEN CHNEW=CHBIT(LNAM+1:LBIT)//' ' ELSE CHNEW2=CHBIT(LNAM+1:LBIT)//' ' ENDIF C...Store new variable value. IF(IVAR.EQ.1) THEN N=INEW ELSEIF(IVAR.EQ.2) THEN K(I1,I2)=INEW ELSEIF(IVAR.EQ.3) THEN P(I1,I2)=RNEW ELSEIF(IVAR.EQ.4) THEN V(I1,I2)=RNEW ELSEIF(IVAR.EQ.5) THEN MSTU(I1)=INEW ELSEIF(IVAR.EQ.6) THEN PARU(I1)=RNEW ELSEIF(IVAR.EQ.7) THEN MSTJ(I1)=INEW ELSEIF(IVAR.EQ.8) THEN PARJ(I1)=RNEW ELSEIF(IVAR.EQ.9) THEN KCHG(I1,I2)=INEW ELSEIF(IVAR.EQ.10) THEN PMAS(I1,I2)=RNEW ELSEIF(IVAR.EQ.11) THEN PARF(I1)=RNEW ELSEIF(IVAR.EQ.12) THEN VCKM(I1,I2)=RNEW ELSEIF(IVAR.EQ.13) THEN MDCY(I1,I2)=INEW ELSEIF(IVAR.EQ.14) THEN MDME(I1,I2)=INEW ELSEIF(IVAR.EQ.15) THEN BRAT(I1)=RNEW ELSEIF(IVAR.EQ.16) THEN KFDP(I1,I2)=INEW ELSEIF(IVAR.EQ.17) THEN CHAF(I1,I2)=CHNEW ELSEIF(IVAR.EQ.18) THEN MRPY(I1)=INEW ELSEIF(IVAR.EQ.19) THEN RRPY(I1)=RNEW ELSEIF(IVAR.EQ.20) THEN MSEL=INEW ELSEIF(IVAR.EQ.21) THEN MSUB(I1)=INEW ELSEIF(IVAR.EQ.22) THEN KFIN(I1,I2)=INEW ELSEIF(IVAR.EQ.23) THEN CKIN(I1)=RNEW ELSEIF(IVAR.EQ.24) THEN MSTP(I1)=INEW ELSEIF(IVAR.EQ.25) THEN PARP(I1)=RNEW ELSEIF(IVAR.EQ.26) THEN MSTI(I1)=INEW ELSEIF(IVAR.EQ.27) THEN PARI(I1)=RNEW ELSEIF(IVAR.EQ.28) THEN MINT(I1)=INEW ELSEIF(IVAR.EQ.29) THEN VINT(I1)=RNEW ELSEIF(IVAR.EQ.30) THEN ISET(I1)=INEW ELSEIF(IVAR.EQ.31) THEN KFPR(I1,I2)=INEW ELSEIF(IVAR.EQ.32) THEN COEF(I1,I2)=RNEW ELSEIF(IVAR.EQ.33) THEN ICOL(I1,I2,I3)=INEW ELSEIF(IVAR.EQ.34) THEN XSFX(I1,I2)=RNEW ELSEIF(IVAR.EQ.35) THEN ISIG(I1,I2)=INEW ELSEIF(IVAR.EQ.36) THEN SIGH(I1)=RNEW ELSEIF(IVAR.EQ.37) THEN MWID(I1)=INEW ELSEIF(IVAR.EQ.38) THEN WIDS(I1,I2)=RNEW ELSEIF(IVAR.EQ.39) THEN NGEN(I1,I2)=INEW ELSEIF(IVAR.EQ.40) THEN XSEC(I1,I2)=RNEW ELSEIF(IVAR.EQ.41) THEN PROC(I1)=CHNEW2 ELSEIF(IVAR.EQ.42) THEN SIGT(I1,I2,I3)=RNEW ELSEIF(IVAR.EQ.43) THEN XPVMD(I1)=RNEW ELSEIF(IVAR.EQ.44) THEN XPANL(I1)=RNEW ELSEIF(IVAR.EQ.45) THEN XPANH(I1)=RNEW ELSEIF(IVAR.EQ.46) THEN XPBEH(I1)=RNEW ELSEIF(IVAR.EQ.47) THEN XPDIR(I1)=RNEW ELSEIF(IVAR.EQ.48) THEN IMSS(I1)=INEW ELSEIF(IVAR.EQ.49) THEN RMSS(I1)=RNEW ELSEIF(IVAR.EQ.50) THEN RVLAM(I1,I2,I3)=RNEW ELSEIF(IVAR.EQ.51) THEN RVLAMP(I1,I2,I3)=RNEW ELSEIF(IVAR.EQ.52) THEN RVLAMB(I1,I2,I3)=RNEW 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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/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. C...Allows small systems to collapse into one or two particles. C...Checks flavours and colour singlet invarient masses. SUBROUTINE PYPREP(IP) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/ C...Local arrays. DIMENSION DPS(5),DPC(5),UE(3),PG(5), &E1(3),E2(3),E3(3),E4(3),ECL(3) C...Function to give four-product. FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) C...Rearrange parton shower product listing along strings: begin loop. 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...GOTO 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 C...Done if no checks on small-mass systems. IF(MSTJ(14).LT.0) RETURN IF(MSTJ(14).EQ.0) GOTO 540 C...Find lowest-mass colour singlet jet system. NS=N 140 NSIN=N-NS PDMIN=1D0+PARJ(32) IC=0 DO 190 I=MAX(1,IP),N IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN NSIN=NSIN+1 IC=I DO 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.PDMIN) THEN PDMIN=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 C...Done if lowest-mass system above threshold for string frag. IF(PDMIN.GE.PARJ(32)) GOTO 540 C...Fill small-mass system as cluster. NSAV=N PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2)) K(N+1,1)=11 K(N+1,2)=91 K(N+1,3)=IC1 P(N+1,1)=DPC(1) P(N+1,2)=DPC(2) P(N+1,3)=DPC(3) P(N+1,4)=DPC(4) P(N+1,5)=PECM C...Set up history, assuming cluster -> 2 hadrons. NBODY=2 K(N+1,4)=N+2 K(N+1,5)=N+3 K(N+2,1)=1 K(N+3,1)=1 IF(MSTU(16).NE.2) THEN K(N+2,3)=N+1 K(N+3,3)=N+1 ELSE K(N+2,3)=IC1 K(N+3,3)=IC2 ENDIF K(N+2,4)=0 K(N+3,4)=0 K(N+2,5)=0 K(N+3,5)=0 V(N+1,5)=0D0 V(N+2,5)=0D0 V(N+3,5)=0D0 C...Form two particles from flavours of lowest-mass system, if feasible. NTRY = 0 200 NTRY = NTRY + 1 C...Open string. 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 540 KQ1=KCHG(KC1,2)*ISIGN(1,K(IC1,2)) KQ2=KCHG(KC2,2)*ISIGN(1,K(IC2,2)) IF(KQ1+KQ2.NE.0) GOTO 540 C...Start with qq, if there is one. Only allow for rank 1 popcorn meson 210 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 210 C...Closed string. ELSE IF(IABS(K(IC2,2)).NE.21) GOTO 540 C...No room for popcorn mesons in closed string -> 2 hadrons. MSTU(125)=0 220 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 220 ENDIF P(N+2,5)=PYMASS(K(N+2,2)) P(N+3,5)=PYMASS(K(N+3,2)) C...If it does not work: try again (a number of times), give up C...(if no place to shuffle momentum), or form one hadron. IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN IF(NTRY.LT.MSTJ(17)) THEN GOTO 200 ELSEIF(NSIN.EQ.1) THEN GOTO 540 ELSE GOTO 290 END IF END IF C...Perform two-particle decay of jet system. C...First step: find reference axis in decaying system rest frame. C...(Borrow slot N+2 for temporary direction.) DO 230 J=1,4 P(N+2,J)=P(IC1,J) 230 CONTINUE DO 250 I=IC1+1,IC2-1 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND. & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I)) DO 240 J=1,4 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J) 240 CONTINUE ENDIF 250 CONTINUE CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4), &-DPC(3)/DPC(4)) THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2)) PHI1=PYANGL(P(N+2,1),P(N+2,2)) C...Second step: generate isotropic/anisotropic decay. PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2- &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM) 260 UE(3)=PYR(0) PT2=(1D0-UE(3)**2)*PA**2 IF(MSTJ(16).LE.0) THEN PREV=0.5D0 ELSE IF(EXP(-PT2/(2D0*PARJ(21)**2)).LT.PYR(0)) GOTO 260 PR1=P(N+2,5)**2+PT2 PR2=P(N+3,5)**2+PT2 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2)) PREVCF=PARJ(42) IF(MSTJ(11).EQ.2) PREVCF=PARJ(39) PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD))) ENDIF IF(PYR(0).LT.PREV) UE(3)=-UE(3) PHI=PARU(2)*PYR(0) UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI) UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI) DO 270 J=1,3 P(N+2,J)=PA*UE(J) P(N+3,J)=-PA*UE(J) 270 CONTINUE P(N+2,4)=SQRT(PA**2+P(N+2,5)**2) P(N+3,4)=SQRT(PA**2+P(N+3,5)**2) C...Third step: move back to event frame and set production vertex. CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4), &DPC(3)/DPC(4)) DO 280 J=1,4 V(N+1,J)=V(IC1,J) V(N+2,J)=V(IC1,J) V(N+3,J)=V(IC2,J) 280 CONTINUE N=N+3 GOTO 520 C...Else form one particle, if possible. 290 NBODY=1 K(N+1,5)=N+2 DO 300 J=1,4 V(N+1,J)=V(IC1,J) V(N+2,J)=V(IC1,J) 300 CONTINUE C...Select hadron flavour from available quark flavours. 310 IF(IABS(K(IC1,2)).GT.100.AND.IABS(K(IC2,2)).GT.100) THEN GOTO 540 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 310 P(N+2,5)=PYMASS(K(N+2,2)) C...Use old algorithm for E/p conservation? (EN) IF (MSTJ(16).LE.0) GOTO 480 C...Find the string piece closest to the cluster by a loop C...over the undecayed partons not in present cluster. (EN) DGLOMI=1D30 IBEG=0 I0=0 DO 340 I1=MAX(1,IP),N-1 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN I0=0 ELSEIF(K(I1,1).EQ.2) THEN IF(I0.EQ.0) I0=I1 I2=I1 320 I2=I2+1 IF(K(I2,1).GT.10) GOTO 320 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 320 C...Define velocity vectors e1, e2, ecl and differences e3, e4. DO 330 J=1,3 E1(J)=P(I1,J)/P(I1,4) E2(J)=P(I2,J)/P(I2,4) ECL(J)=P(N+1,J)/P(N+1,4) E3(J)=E2(J)-E1(J) E4(J)=ECL(J)-E1(J) 330 CONTINUE C...Calculate minimal D=(e4-alpha*e3)**2 for 0 0: emit a 'gluon' (EN) IF (P(N+1,5).GE.P(N+2,5)) THEN C...Construct 'gluon' that is needed to put hadron on the mass shell. FRAC=P(N+2,5)/P(N+1,5) DO 350 J=1,5 P(N+2,J)=FRAC*P(N+1,J) PG(J)=(1D0-FRAC)*P(N+1,J) 350 CONTINUE C... Copy string with new gluon put in. N=N+2 I=IBEG-1 360 I=I+1 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 360 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0) GOTO 360 N=N+1 DO 370 J=1,5 K(N,J)=K(I,J) P(N,J)=P(I,J) V(N,J)=V(I,J) 370 CONTINUE K(I,1)=K(I,1)+10 K(I,4)=N K(I,5)=N K(N,3)=I IF(I.EQ.IPCS) THEN N=N+1 DO 380 J=1,5 K(N,J)=K(N-1,J) P(N,J)=PG(J) V(N,J)=V(N-1,J) 380 CONTINUE K(N,2)=21 K(N,3)=NSAV+1 ENDIF IF(K(I,1).EQ.12) GOTO 360 GOTO 520 C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead, C...from string piece endpoints. ELSE C...Begin by copying string that should give energy to cluster. N=N+2 I=IBEG-1 390 I=I+1 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 390 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0) GOTO 390 N=N+1 DO 400 J=1,5 K(N,J)=K(I,J) P(N,J)=P(I,J) V(N,J)=V(I,J) 400 CONTINUE K(I,1)=K(I,1)+10 K(I,4)=N K(I,5)=N K(N,3)=I IF(I.EQ.IPCS) I1=N IF(K(I,1).EQ.12) GOTO 390 I2=I1+1 C...Set initial Phad. DO 410 J=1,4 P(NSAV+2,J)=P(NSAV+1,J) 410 CONTINUE C...Calculate Pg, a part of which will be added to Phad later. (EN) 420 IF(MSTJ(16).EQ.1) THEN ALPHA=1D0 BETA=1D0 ELSE ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2) BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2) ENDIF DO 430 J=1,4 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J) 430 CONTINUE PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2)) C..Solve 2nd order equation, use the best (smallest) solution. (EN) PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2- & P(NSAV+2,3)**2 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)- & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG C...If all gluon energy eaten, zero it and take a step back. ITER=0 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3) THEN ITER=1 DO 440 J=1,4 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J) P(I1,J)=0D0 440 CONTINUE P(I1,5)=0D0 K(I1,1)=K(I1,1)+10 I1=I1-1 ENDIF IF(DELTA*BETA.GT.1D0.AND.I2.LT.N) THEN ITER=1 DO 450 J=1,4 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J) P(I2,J)=0D0 450 CONTINUE P(I2,5)=0D0 K(I2,1)=K(I2,1)+10 I2=I2+1 ENDIF IF(ITER.EQ.1) GOTO 420 C...If also all endpoint energy eaten, revert to old procedure. IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR. & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5)) THEN DO 460 I=NSAV+3,N IM=K(I,3) K(IM,1)=K(IM,1)-10 K(IM,4)=0 K(IM,5)=0 460 CONTINUE N=NSAV GOTO 480 ENDIF C... Construct the collapsed hadron and modified string partons. DO 470 J=1,4 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J) P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J) P(I2,J)=(1D0-DELTA*BETA)*P(I2,J) 470 CONTINUE P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5) P(I2,5)=(1D0-DELTA*BETA)*P(I2,5) C...Finished with string collapse in new scheme. GOTO 520 ENDIF C... Use old algorithm; by choice or when in trouble. 480 CONTINUE C...Find parton/particle which combines to largest extra mass. IR=0 HA=0D0 HSM=0D0 DO 500 MCOMB=1,3 IF(IR.NE.0) GOTO 500 DO 490 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 490 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2)) IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 490 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 490 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100) & GOTO 490 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 490 CONTINUE 500 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 510 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) 510 CONTINUE N=N+2 ELSE CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster') RETURN ENDIF C...Mark collapsed system and store daughter pointers. Iterate. 520 DO 530 I=IC1,IC2 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND. & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN K(I,1)=K(I,1)+10 IF(MSTU(16).NE.2) THEN K(I,4)=NSAV+1 K(I,5)=NSAV+1 ELSE K(I,4)=NSAV+2 K(I,5)=NSAV+1+NBODY ENDIF ENDIF 530 CONTINUE IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 140 C...Check flavours and invariant masses in parton systems. 540 NP=0 KFN=0 KQS=0 DO 550 J=1,5 DPS(J)=0D0 550 CONTINUE DO 580 I=MAX(1,IP),N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 580 KC=PYCOMP(K(I,2)) IF(KC.EQ.0) GOTO 580 KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) IF(KQ.EQ.0) GOTO 580 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 560 J=1,4 DPS(J)=DPS(J)+P(I,J) 560 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) THEN CALL PYERRM(3,'(PYPREP:) too small mass in jet system') END IF NP=0 KFN=0 KQS=0 DO 570 J=1,5 DPS(J)=0D0 570 CONTINUE ENDIF 580 CONTINUE RETURN END C********************************************************************* C...PYSTRF C...Handles the fragmentation of an arbitrary colour singlet C...jet system according to the Lund string fragmentation model. SUBROUTINE PYSTRF(IP) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local arrays. All MOPS variables ends with MO DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2), &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(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=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ) P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ) P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ) ELSE HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ) P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ) P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ) ENDIF 130 CONTINUE ENDIF C...Search for very nearby partons that may be recombined. NTRYR=0 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)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2)) DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ) PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ) PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS* & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2 ENDIF C...Solve kinematics for final two hadrons, if possible. WREM2=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) FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT))) PREVCF=PARJ(42) IF(MSTJ(11).EQ.2) PREVCF=PARJ(39) PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB))) FB=SIGN(FB,JS*(PYR(0)-PREV)) KFL1A=IABS(KFL(1)) KFL2A=IABS(KFL(2)) IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10), &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2- &4D0*WREM2*PR(JT))),DBLE(JS)) DO 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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local arrays. DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3), &KFLO(2),PXO(2),PYO(2),WO(2) C.. MOPS error message IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'// &' are not treated as expected in independent fragmentation') C...Reset counters. Identify parton system and take copy. Check flavour. NSAV=N MSTU90=MSTU(90) NJET=0 KQSUM=0 DO 100 J=1,5 DPS(J)=0D0 100 CONTINUE I=IP-1 110 I=I+1 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system') IF(MSTU(21).GE.1) RETURN ENDIF IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110 KC=PYCOMP(K(I,2)) IF(KC.EQ.0) GOTO 110 KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) IF(KQ.EQ.0) GOTO 110 NJET=NJET+1 IF(KQ.NE.2) KQSUM=KQSUM+KQ DO 120 J=1,5 K(NSAV+NJET,J)=K(I,J) P(NSAV+NJET,J)=P(I,J) DPS(J)=DPS(J)+P(I,J) 120 CONTINUE K(NSAV+NJET,3)=I IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND. &K(I+1,1).EQ.2)) GOTO 110 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN CALL PYERRM(12,'(PYINDF:) unphysical flavour combination') IF(MSTU(21).GE.1) RETURN ENDIF C...Boost copied system to CM frame. Find CM energy and sum flavours. IF(NJET.NE.1) THEN MSTU(33)=1 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4), & -DPS(2)/DPS(4),-DPS(3)/DPS(4)) ENDIF PECM=0D0 DO 130 J=1,3 NFI(J)=0 130 CONTINUE DO 140 I=NSAV+1,NSAV+NJET PECM=PECM+P(I,4) KFA=IABS(K(I,2)) IF(KFA.LE.3) THEN NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2)) ELSEIF(KFA.GT.1000) THEN KFLA=MOD(KFA/1000,10) KFLB=MOD(KFA/100,10) IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2)) IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2)) ENDIF 140 CONTINUE C...Loop over attempts made. Reset counters. NTRY=0 150 NTRY=NTRY+1 IF(NTRY.GT.200) THEN CALL PYERRM(14,'(PYINDF:) caught in infinite loop') IF(MSTU(21).GE.1) RETURN ENDIF N=NSAV+NJET MSTU(90)=MSTU90 DO 160 J=1,3 NFL(J)=NFI(J) IFET(J)=0 KFLF(J)=0 160 CONTINUE C...Loop over jets to be fragmented. DO 230 IP1=NSAV+1,NSAV+NJET MSTJ(91)=0 NSAV1=N MSTU91=MSTU(90) C...Initial flavour and momentum values. Jet along +z axis. KFLH=IABS(K(IP1,2)) IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10) KFLO(2)=0 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2) C...Initial values for quark or diquark jet. 170 IF(IABS(K(IP1,2)).NE.21) THEN NSTR=1 KFLO(1)=K(IP1,2) CALL PYPTDI(0,PXO(1),PYO(1)) WO(1)=WF C...Initial values for gluon treated like random quark jet. ELSEIF(MSTJ(2).LE.2) THEN NSTR=1 IF(MSTJ(2).EQ.2) MSTJ(91)=1 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0) CALL PYPTDI(0,PXO(1),PYO(1)) WO(1)=WF C...Initial values for gluon treated like quark-antiquark jet pair, C...sharing energy according to Altarelli-Parisi splitting function. ELSE NSTR=2 IF(MSTJ(2).EQ.4) MSTJ(91)=1 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0) KFLO(2)=-KFLO(1) CALL PYPTDI(0,PXO(1),PYO(1)) PXO(2)=-PXO(1) PYO(2)=-PYO(1) WO(1)=WF*PYR(0)**(1D0/3D0) WO(2)=WF-WO(1) ENDIF C...Initial values for rank, flavour, pT and W+. DO 220 ISTR=1,NSTR 180 I=N MSTU(90)=MSTU91 IRANK=0 KFL1=KFLO(ISTR) PX1=PXO(ISTR) PY1=PYO(ISTR) W=WO(ISTR) C...New hadron. Generate flavour and hadron species. 190 I=I+1 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS') IF(MSTU(21).GE.1) RETURN ENDIF IRANK=IRANK+1 K(I,1)=1 K(I,3)=IP1 K(I,4)=0 K(I,5)=0 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2)) IF(K(I,2).EQ.0) GOTO 180 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN IF(PYR(0).GT.PARJ(19)) GOTO 200 ENDIF C...Find hadron mass. Generate four-momentum. P(I,5)=PYMASS(K(I,2)) CALL PYPTDI(KFL1,PX2,PY2) P(I,1)=PX1+PX2 P(I,2)=PY1+PY2 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2 CALL PYZDIS(KFL1,KFL2,PR,Z) MZSAV=0 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN MZSAV=1 MSTU(90)=MSTU(90)+1 MSTU(90+MSTU(90))=I PARU(90+MSTU(90))=Z ENDIF P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W)) P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W)) IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND. & P(I,3).LE.0.001D0) THEN IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180 P(I,3)=0.0001D0 P(I,4)=SQRT(PR) Z=P(I,4)/W ENDIF C...Remaining flavour and momentum. KFL1=-KFL2 PX1=-PX2 PY1=-PY2 W=(1D0-Z)*W DO 210 J=1,5 V(I,J)=0D0 210 CONTINUE C...Check if pL acceptable. Go back for new hadron if enough energy. IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN I=I-1 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1 ENDIF IF(W.GT.PARJ(31)) GOTO 190 N=I 220 CONTINUE IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32) IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170 C...Rotate jet to new direction. THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2)) PHI=PYANGL(P(IP1,1),P(IP1,2)) MSTU(33)=1 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0) K(K(IP1,3),4)=NSAV1+1 K(K(IP1,3),5)=N C...End of jet generation loop. Skip conservation in some cases. 230 CONTINUE IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150 C...Subtract off produced hadron flavours, finished if zero. DO 240 I=NSAV+NJET+1,N KFA=IABS(K(I,2)) KFLA=MOD(KFA/1000,10) KFLB=MOD(KFA/100,10) KFLC=MOD(KFA/10,10) IF(KFLA.EQ.0) THEN IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB ELSE IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2)) IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2)) IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2)) ENDIF 240 CONTINUE NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3 IF(NREQ.EQ.0) GOTO 320 C...Take away flavour of low-momentum particles until enough freedom. NREM=0 250 IREM=0 P2MIN=PECM**2 DO 260 I=NSAV+NJET+1,N P2=P(I,1)**2+P(I,2)**2+P(I,3)**2 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2 260 CONTINUE IF(IREM.EQ.0) GOTO 150 K(IREM,1)=7 KFA=IABS(K(IREM,2)) KFLA=MOD(KFA/1000,10) KFLB=MOD(KFA/100,10) KFLC=MOD(KFA/10,10) IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8 IF(K(IREM,1).EQ.8) GOTO 250 IF(KFLA.EQ.0) THEN ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN ELSE IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2)) IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2)) IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2)) ENDIF NREM=NREM+1 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3 IF(NREQ.GT.NREM) GOTO 250 DO 270 I=NSAV+NJET+1,N IF(K(I,1).EQ.8) K(I,1)=1 270 CONTINUE C...Find combination of existing and new flavours for hadron. 280 NFET=2 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3 IF(NREQ.LT.NREM) NFET=1 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0 DO 290 J=1,NFET IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0) KFLF(J)=ISIGN(1,NFL(1)) IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2)) IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3)) 290 CONTINUE IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0)) &GOTO 280 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR. &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3) &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0)) IF(NFET.EQ.0) KFLF(2)=-KFLF(1) IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1)) IF(NFET.LE.2) KFLF(3)=0 IF(KFLF(3).NE.0) THEN KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+ & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1)) IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0) & KFLFC=KFLFC+ISIGN(2,KFLFC) ELSE KFLFC=KFLF(1) ENDIF CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF) IF(KF.EQ.0) GOTO 280 DO 300 J=1,MAX(2,NFET) NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J)) 300 CONTINUE C...Store hadron at random among free positions. NPOS=MIN(1+INT(PYR(0)*NREM),NREM) DO 310 I=NSAV+NJET+1,N IF(K(I,1).EQ.7) NPOS=NPOS-1 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310 K(I,1)=1 K(I,2)=KF P(I,5)=PYMASS(K(I,2)) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) 310 CONTINUE NREM=NREM-1 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+ &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3 IF(NREM.GT.0) GOTO 280 C...Compensate for missing momentum in global scheme (3 options). 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN DO 340 J=1,3 PSI(J)=0D0 DO 330 I=NSAV+NJET+1,N PSI(J)=PSI(J)+P(I,J) 330 CONTINUE 340 CONTINUE PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2 PWS=0D0 DO 350 I=NSAV+NJET+1,N IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4) IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+ & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4)) IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0 350 CONTINUE DO 370 I=NSAV+NJET+1,N IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4) IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+ & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4)) IF(MOD(MSTJ(3),5).EQ.3) PW=1D0 DO 360 J=1,3 P(I,J)=P(I,J)-PSI(J)*PW/PWS 360 CONTINUE P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) 370 CONTINUE C...Compensate for missing momentum withing each jet separately. ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN DO 390 I=N+1,N+NJET K(I,1)=0 DO 380 J=1,5 P(I,J)=0D0 380 CONTINUE 390 CONTINUE DO 410 I=NSAV+NJET+1,N IR1=K(I,3) IR2=N+IR1-NSAV K(IR2,1)=K(IR2,1)+1 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/ & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2) DO 400 J=1,3 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J) 400 CONTINUE P(IR2,4)=P(IR2,4)+P(I,4) P(IR2,5)=P(IR2,5)+PLS 410 CONTINUE PSS=0D0 DO 420 I=N+1,N+NJET IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0)) 420 CONTINUE DO 440 I=NSAV+NJET+1,N IR1=K(I,3) IR2=N+IR1-NSAV PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/ & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2) DO 430 J=1,3 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)* & PLS*P(IR1,J) 430 CONTINUE P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) 440 CONTINUE ENDIF C...Scale momenta for energy conservation. IF(MOD(MSTJ(3),5).NE.0) THEN PMS=0D0 PES=0D0 PQS=0D0 DO 450 I=NSAV+NJET+1,N PMS=PMS+P(I,5) PES=PES+P(I,4) PQS=PQS+P(I,5)**2/P(I,4) 450 CONTINUE IF(PMS.GE.PECM) GOTO 150 NECO=0 460 NECO=NECO+1 PFAC=(PECM-PQS)/(PES-PQS) PES=0D0 PQS=0D0 DO 480 I=NSAV+NJET+1,N DO 470 J=1,3 P(I,J)=PFAC*P(I,J) 470 CONTINUE P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) PES=PES+P(I,4) PQS=PQS+P(I,5)**2/P(I,4) 480 CONTINUE IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460 ENDIF C...Origin of produced particles and parton daughter pointers. 490 DO 500 I=NSAV+NJET+1,N IF(MSTU(16).NE.2) K(I,3)=NSAV+1 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3) 500 CONTINUE DO 510 I=NSAV+1,NSAV+NJET I1=K(I,3) K(I1,1)=K(I1,1)+10 IF(MSTU(16).NE.2) THEN K(I1,4)=NSAV+1 K(I1,5)=NSAV+1 ELSE K(I1,4)=K(I1,4)-NJET+1 K(I1,5)=K(I1,5)-NJET+1 IF(K(I1,5).LT.K(I1,4)) THEN K(I1,4)=0 K(I1,5)=0 ENDIF ENDIF 510 CONTINUE C...Document independent fragmentation system. Remove copy of jets. NSAV=NSAV+1 K(NSAV,1)=11 K(NSAV,2)=93 K(NSAV,3)=IP K(NSAV,4)=NSAV+1 K(NSAV,5)=N-NJET+1 DO 520 J=1,4 P(NSAV,J)=DPS(J) V(NSAV,J)=V(IP,J) 520 CONTINUE P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2)) V(NSAV,5)=0D0 DO 540 I=NSAV+NJET,N DO 530 J=1,5 K(I-NJET+1,J)=K(I,J) P(I-NJET+1,J)=P(I,J) V(I-NJET+1,J)=V(I,J) 530 CONTINUE 540 CONTINUE N=N-NJET+1 DO 550 IZ=MSTU90+1,MSTU(90) MSTU(90+IZ)=MSTU(90+IZ)-NJET+1 550 CONTINUE C...Boost back particle system. Set production vertices. IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4), &DPS(2)/DPS(4),DPS(3)/DPS(4)) DO 570 I=NSAV+1,N DO 560 J=1,4 V(I,J)=V(IP,J) 560 CONTINUE 570 CONTINUE RETURN END C********************************************************************* C...PYDECY C...Handles the decay of unstable particles. SUBROUTINE PYDECY(IP) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/ C...Local arrays. DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3), &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3) CHARACTER CIDC*4 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/ C...Functions: momentum in two-particle decays and four-product. PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A) FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) C...Initial values. NTRY=0 NSAV=N KFA=IABS(K(IP,2)) KFS=ISIGN(1,K(IP,2)) KC=PYCOMP(KFA) MSTJ(92)=0 C...Choose lifetime and determine decay vertex. IF(K(IP,1).EQ.5) THEN V(IP,5)=0D0 ELSEIF(K(IP,1).NE.4) THEN V(IP,5)=-PMAS(KC,4)*LOG(PYR(0)) ENDIF DO 100 J=1,4 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5) 100 CONTINUE C...Determine whether decay allowed or not. MOUT=0 IF(MSTJ(22).EQ.2) THEN IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1 ELSEIF(MSTJ(22).EQ.3) THEN IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1 ELSEIF(MSTJ(22).EQ.4) THEN IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1 ENDIF IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN K(IP,1)=4 RETURN ENDIF C...Interface to external tau decay library (for tau polarization). IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN C...Starting values for pointers and momenta. ITAU=IP DO 110 J=1,4 PTAU(J)=P(ITAU,J) PCMTAU(J)=P(ITAU,J) 110 CONTINUE C...Iterate to find position and code of mother of tau. IMTAU=ITAU 120 IMTAU=K(IMTAU,3) IF(IMTAU.EQ.0) THEN C...If no known origin then impossible to do anything further. KFORIG=0 IORIG=0 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN C...If tau -> tau + gamma then add gamma energy and loop. IF(K(K(IMTAU,4),2).EQ.22) THEN DO 130 J=1,4 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J) 130 CONTINUE ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN DO 140 J=1,4 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J) 140 CONTINUE ENDIF GOTO 120 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN C...If coming from weak decay of hadron then W is not stored in record, C...but can be reconstructed by adding neutrino momentum. KFORIG=-ISIGN(24,K(ITAU,2)) IORIG=0 DO 160 II=K(IMTAU,4),K(IMTAU,5) IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN DO 150 J=1,4 PCMTAU(J)=PCMTAU(J)+P(II,J) 150 CONTINUE ENDIF 160 CONTINUE ELSE C...If coming from resonance decay then find latest copy of this C...resonance (may not completely agree). KFORIG=K(IMTAU,2) IORIG=IMTAU DO 170 II=IMTAU+1,IP-1 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND. & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II 170 CONTINUE DO 180 J=1,4 PCMTAU(J)=P(IORIG,J) 180 CONTINUE ENDIF C...Boost tau to rest frame of production process (where known) C...and rotate it to sit along +z axis. DO 190 J=1,3 DBETAU(J)=PCMTAU(J)/PCMTAU(4) 190 CONTINUE IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1), & -DBETAU(2),-DBETAU(3)) PHITAU=PYANGL(P(ITAU,1),P(ITAU,2)) CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0) THETAU=PYANGL(P(ITAU,3),P(ITAU,1)) CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0) C...Call tau decay routine (if meaningful) and fill extra info. IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY) DO 200 II=NSAV+1,NSAV+NDECAY K(II,1)=1 K(II,3)=IP K(II,4)=0 K(II,5)=0 200 CONTINUE N=NSAV+NDECAY ENDIF C...Boost back decay tau and decay products. DO 210 J=1,4 P(ITAU,J)=PTAU(J) 210 CONTINUE IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0) IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1), & DBETAU(2),DBETAU(3)) C...Skip past ordinary tau decay treatment. MMAT=0 MBST=0 ND=0 GOTO 630 ENDIF ENDIF C...B-Bbar mixing: flip sign of meson appropriately. MMIX=0 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN XBBMIX=PARJ(76) IF(KFA.EQ.531) XBBMIX=PARJ(77) IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1 IF(MMIX.EQ.1) KFS=-KFS ENDIF C...Check existence of decay channels. Particle/antiparticle rules. KCA=KC IF(MDCY(KC,2).GT.0) THEN MDMDCY=MDME(MDCY(KC,2),2) IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY ENDIF IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN CALL PYERRM(9,'(PYDECY:) no decay channel defined') RETURN ENDIF IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS IF(KCHG(KC,3).EQ.0) THEN KFSP=1 KFSN=0 IF(PYR(0).GT.0.5D0) KFS=-KFS ELSEIF(KFS.GT.0) THEN KFSP=1 KFSN=0 ELSE KFSP=0 KFSN=1 ENDIF C...Sum branching ratios of allowed decay channels. 220 NOPE=0 BRSU=0D0 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND. & KFSN*MDME(IDL,1).NE.3) GOTO 230 IF(MDME(IDL,2).GT.100) GOTO 230 NOPE=NOPE+1 BRSU=BRSU+BRAT(IDL) 230 CONTINUE IF(NOPE.EQ.0) THEN CALL PYERRM(2,'(PYDECY:) all decay channels closed by user') RETURN ENDIF C...Select decay channel among allowed ones. 240 RBR=BRSU*PYR(0) IDL=MDCY(KCA,2)-1 250 IDL=IDL+1 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND. &KFSN*MDME(IDL,1).NE.3) THEN IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250 ELSEIF(MDME(IDL,2).GT.100) THEN IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250 ELSE IDC=IDL RBR=RBR-BRAT(IDL) IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250 ENDIF C...Start readout of decay channel: matrix element, reset counters. MMAT=MDME(IDC,2) 260 NTRY=NTRY+1 IF(MOD(NTRY,200).EQ.0) THEN WRITE(CIDC,'(I4)') IDC C...Do not print warning for some well-known special cases. IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215) & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'// & CIDC) GOTO 240 ENDIF IF(NTRY.GT.1000) THEN CALL PYERRM(14,'(PYDECY:) caught in infinite loop') IF(MSTU(21).GE.1) RETURN ENDIF I=N NP=0 NQ=0 MBST=0 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1 DO 270 J=1,4 PV(1,J)=0D0 IF(MBST.EQ.0) PV(1,J)=P(IP,J) 270 CONTINUE IF(MBST.EQ.1) PV(1,4)=P(IP,5) PV(1,5)=P(IP,5) PS=0D0 PSQ=0D0 MREM=0 MHADDY=0 IF(KFA.GT.80) MHADDY=1 C.. Random flavour and popcorn system memory. IRNDMO=0 JTMO=0 MSTU(121)=0 MSTU(125)=10 C...Read out decay products. Convert to standard flavour code. JTMAX=5 IF(MDME(IDC+1,2).EQ.101) JTMAX=10 DO 280 JT=1,JTMAX IF(JT.LE.5) KP=KFDP(IDC,JT) IF(JT.GE.6) KP=KFDP(IDC+1,JT-5) IF(KP.EQ.0) GOTO 280 KPA=IABS(KP) KCP=PYCOMP(KPA) IF(KPA.GT.80) MHADDY=1 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN KFP=KP ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN KFP=KFS*KP ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN KFP=-KFS*MOD(KFA/10,10) ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN KFP=KFS*(100*MOD(KFA/10,100)+3) ELSEIF(KPA.EQ.81) THEN KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1) ELSEIF(KP.EQ.82) THEN CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP) IF(KFP.EQ.0) GOTO 260 KFP=-KFP IRNDMO=1 MSTJ(93)=1 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260 ELSEIF(KP.EQ.-82) THEN KFP=MSTU(124) ENDIF IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP) C...Add decay product to event record or to quark flavour list. KFPA=IABS(KFP) KQP=KCHG(KCP,2) IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN NQ=NQ+1 KFLO(NQ)=KFP C...set rndmflav popcorn system pointer IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ MSTJ(93)=2 PSQ=PSQ+PYMASS(KFLO(NQ)) ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND. & MOD(NQ,2).EQ.1) THEN NQ=NQ-1 PS=PS-P(I,5) K(I,1)=1 KFI=K(I,2) CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2)) IF(K(I,2).EQ.0) GOTO 260 MSTJ(93)=1 P(I,5)=PYMASS(K(I,2)) PS=PS+P(I,5) ELSE I=I+1 NP=NP+1 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1 K(I,1)=1+MOD(NQ,2) IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1 K(I,2)=KFP K(I,3)=IP K(I,4)=0 K(I,5)=0 P(I,5)=PYMASS(KFP) PS=PS+P(I,5) ENDIF 280 CONTINUE C...Check masses for resonance decays. IF(MHADDY.EQ.0) THEN IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240 ENDIF C...Choose decay multiplicity in phase space model. 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN PSP=PS CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0)) IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63) 300 NTRY=NTRY+1 C...Reset popcorn flags if new attempt. Re-select rndmflav if failed. IF(IRNDMO.EQ.0) THEN MSTU(121)=0 JTMO=0 ELSEIF(IRNDMO.EQ.1) THEN IRNDMO=2 ELSE GOTO 260 ENDIF IF(NTRY.GT.1000) THEN CALL PYERRM(14,'(PYDECY:) caught in infinite loop') IF(MSTU(21).GE.1) RETURN ENDIF IF(MMAT.LE.20) THEN GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))* & SIN(PARU(2)*PYR(0)) ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300 ELSE ND=MMAT-20 ENDIF C.. Set maximum popcorn meson number. Test rndmflav popcorn size. MSTU(125)=ND-NQ/2 IF(MSTU(121).GT.MSTU(125)) GOTO 300 C...Form hadrons from flavour content. DO 310 JT=1,NQ KFL1(JT)=KFLO(JT) 310 CONTINUE IF(ND.EQ.NP+NQ/2) GOTO 330 DO 320 I=N+NP+1,N+ND-NQ/2 C.. Stick to started popcorn system, else pick side at random JT=JTMO IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0)) CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2)) IF(K(I,2).EQ.0) GOTO 300 MSTU(125)=MSTU(125)-1 JTMO=0 IF(MSTU(121).GT.0) JTMO=JT KFL1(JT)=-KFL2 320 CONTINUE 330 JT=2 JT2=3 JT3=4 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))* & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3 IF(JT.EQ.3) JT2=2 IF(JT.EQ.4) JT3=2 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2)) IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2)) IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300 C...Check that sum of decay product masses not too large. PS=PSP DO 340 I=N+NP+1,N+ND K(I,1)=1 K(I,3)=IP K(I,4)=0 K(I,5)=0 P(I,5)=PYMASS(K(I,2)) PS=PS+P(I,5) 340 CONTINUE IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300 C...Rescale energy to subtract off spectator quark mass. ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44) & .AND.NP.GE.3) THEN PS=PS-P(N+NP,5) PQT=(P(N+NP,5)+PARJ(65))/PV(1,5) DO 350 J=1,5 P(N+NP,J)=PQT*PV(1,J) PV(1,J)=(1D0-PQT)*PV(1,J) 350 CONTINUE IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260 ND=NP-1 MREM=1 C...Fully specified final state: check mass broadening effects. ELSE IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260 ND=NP ENDIF C...Determine position of grandmother, number of sisters. NM=0 KFAS=0 MSGN=0 IF(MMAT.EQ.3) THEN IM=K(IP,3) IF(IM.LT.0.OR.IM.GE.IP) IM=0 IF(IM.NE.0) KFAM=IABS(K(IM,2)) IF(IM.NE.0) THEN DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N) IF(K(IL,3).EQ.IM) NM=NM+1 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL 360 CONTINUE IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR. & MOD(KFAM/1000,10).NE.0) NM=0 IF(NM.EQ.2) THEN KFAS=IABS(K(ISIS,2)) IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR. & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0 ENDIF ENDIF ENDIF C...Kinematics of one-particle decays. IF(ND.EQ.1) THEN DO 370 J=1,4 P(N+1,J)=P(IP,J) 370 CONTINUE GOTO 630 ENDIF C...Calculate maximum weight ND-particle decay. PV(ND,5)=P(N+ND,5) IF(ND.GE.3) THEN WTMAX=1D0/WTCOR(ND-2) PMAX=PV(1,5)-PS+P(N+ND,5) PMIN=0D0 DO 380 IL=ND-1,1,-1 PMAX=PMAX+P(N+IL,5) PMIN=PMIN+P(N+IL+1,5) WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5)) 380 CONTINUE ENDIF C...Find virtual gamma mass in Dalitz decay. 390 IF(ND.EQ.2) THEN ELSEIF(MMAT.EQ.2) THEN PMES=4D0*PMAS(11,1)**2 PMRHO2=PMAS(131,1)**2 PGRHO2=PMAS(131,2)**2 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0) WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))* & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/ & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2) IF(WT.LT.PYR(0)) GOTO 400 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST)) C...M-generator gives weight. If rejected, try again. ELSE 410 RORD(1)=1D0 DO 440 IL1=2,ND-1 RSAV=PYR(0) DO 420 IL2=IL1-1,1,-1 IF(RSAV.LE.RORD(IL2)) GOTO 430 RORD(IL2+1)=RORD(IL2) 420 CONTINUE 430 RORD(IL2+1)=RSAV 440 CONTINUE RORD(ND)=0D0 WT=1D0 DO 450 IL=ND-1,1,-1 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))* & (PV(1,5)-PS) WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5)) 450 CONTINUE IF(WT.LT.PYR(0)*WTMAX) GOTO 410 ENDIF C...Perform two-particle decays in respective CM frame. 460 DO 480 IL=1,ND-1 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5)) UE(3)=2D0*PYR(0)-1D0 PHI=PARU(2)*PYR(0) UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI) UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI) DO 470 J=1,3 P(N+IL,J)=PA*UE(J) PV(IL+1,J)=-PA*UE(J) 470 CONTINUE P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2) PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2) 480 CONTINUE C...Lorentz transform decay products to lab frame. DO 490 J=1,4 P(N+ND,J)=PV(ND,J) 490 CONTINUE DO 530 IL=ND-1,1,-1 DO 500 J=1,3 BE(J)=PV(IL,J)/PV(IL,4) 500 CONTINUE GA=PV(IL,4)/PV(IL,5) DO 520 I=N+IL,N+ND BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3) DO 510 J=1,3 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J) 510 CONTINUE P(I,4)=GA*(P(I,4)+BEP) 520 CONTINUE 530 CONTINUE C...Check that no infinite loop in matrix element weight. NTRY=NTRY+1 IF(NTRY.GT.800) GOTO 560 C...Matrix elements for omega and phi decays. IF(MMAT.EQ.1) THEN WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3) IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390 C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-. ELSEIF(MMAT.EQ.2) THEN FOUR12=FOUR(N+1,N+2) FOUR13=FOUR(N+1,N+3) WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+ & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2) IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460 C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar, C...V vector), of form cos**2(theta02) in V1 rest frame, and for C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02). ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN FOUR10=FOUR(IP,IM) FOUR12=FOUR(IP,N+1) FOUR02=FOUR(IM,N+1) PMS1=P(IP,5)**2 PMS0=P(IM,5)**2 PMS2=P(N+1,5)**2 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02- & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2) HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM) HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2) IF(HNUM.LT.PYR(0)*HDEN) GOTO 460 C...Matrix element for "onium" -> g + g + g or gamma + g + g. ELSEIF(MMAT.EQ.4) THEN HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+ & ((1D0-HX3)/(HX1*HX2))**2 IF(WT.LT.2D0*PYR(0)) GOTO 390 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2) & GOTO 390 C...Effective matrix element for nu spectrum in tau -> nu + hadrons. ELSEIF(MMAT.EQ.41) THEN 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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C.. Call PYKFDI directly if no popcorn option is on IF(MSTJ(12).LT.2) THEN CALL PYKFDI(KFL1,KFL2,KFL3,KF) MSTU(124)=KFL3 RETURN ENDIF KFL3=0 KF=0 IF(KFL1.EQ.0) RETURN KF1A=IABS(KFL1) KF2A=IABS(KFL2) NSTO=130 NMAX=MIN(MSTU(125),10) C.. Identify rank 0 cluster qq IRANK=1 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0 IF(KF2A.GT.0)THEN C.. Join jets: Fails if store not empty IF(MSTU(121).GT.0) THEN MSTU(121)=0 RETURN ENDIF CALL PYKFDI(KFL1,KFL2,KFL3,KF) ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN C.. Pick popcorn meson from store, return same qq, decrease store KF=MSTU(NSTO+MSTU(121)) KFL3=-KFL1 MSTU(121)=MSTU(121)-1 ELSE C.. Generate new flavour. Then done if no diquark is generated 100 CALL PYKFDI(KFL1,0,KFL3,KF) IF(MSTU(121).EQ.-1) GOTO 100 MSTU(124)=KFL3 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN C.. Simple case if no dynamical popcorn suppressions are considered IF(MSTJ(12).LT.4) THEN IF(MSTU(121).EQ.0) RETURN NMES=1 KFPREV=-KFL3 CALL PYKFDI(KFPREV,0,KFL3,KFM) C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q IF(IABS(KFL3).LE.10)THEN KFL3=-KFPREV RETURN ENDIF GOTO 120 ENDIF C test output qq against fake Gamma, then return if no popcorn. GB=2D0 IF(IRANK.NE.0)THEN CALL PYZDIS(1,2103,5D0,Z) GB=5D0*(1D0-Z)/Z IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN MSTU(121)=0 GOTO 100 ENDIF ENDIF IF(MSTU(121).EQ.0) RETURN C..Set store size memory. Pick fake dynamical variables of qq. NMES=MSTU(121) CALL PYPTDI(1,PX3,PY3) X=1D0 POPM=0D0 G=GB POPG=GB C.. Pick next popcorn meson, test with fake dynamical variables 110 KFPREV=-KFL3 PX1=-PX3 PY1=-PY3 CALL PYKFDI(KFPREV,0,KFL3,KFM) IF(MSTU(121).EQ.-1) GOTO 100 CALL PYPTDI(KFL3,PX3,PY3) PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2 CALL PYZDIS(KFPREV,KFL3,PM,Z) G=(1D0-Z)*(G+PM/Z) X=(1D0-Z)*X PTST=1D0 GTST=1D0 RTST=PYR(0) IF(MSTJ(12).GT.4)THEN POPMN=SQRT((1D0-X)*(G/X-GB)) POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3) PTST=EXP((POPM-POPMN)*PARF(193)) POPM=POPMN ENDIF IF(IRANK.NE.0)THEN POPGN=X*GB GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG) POPG=POPGN ENDIF IF(RTST.GT.PTST*GTST)THEN MSTU(121)=0 IF(RTST.GT.PTST) MSTU(121)=-1 GOTO 100 ENDIF C.. Store meson 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM IF(MSTU(121).GT.0) GOTO 110 C.. Test accepted system size. If OK set global popcorn size variable. IF(NMES.GT.NMAX)THEN KF=0 KFL3=0 RETURN ENDIF MSTU(121)=NMES ENDIF RETURN END C******************************************************************** C...PYKFDI C...Generates a new flavour pair and combines off a hadron SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C...Local arrays. DIMENSION PD(7) IF(MSTU(123).EQ.0.AND.MSTJ(12).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) THEN MSTU(121)=0 RETURN ENDIF MBARY=2 ENDIF KFQOLD=KF1A KFQVER=KF2A GOTO 130 ENDIF C.. Separate incoming flavours, curtain flavour consistency check KFIN=KFL1 KFQOLD=KF1A KFQPOP=KF1A/10000 IF(KF1A.GT.10)THEN KFIN=-KFL1 KFL1A=MOD(KF1A/1000,10) KFL1B=MOD(KF1A/100,10) IF(IRANK.EQ.0)THEN QAWT=1D0 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4) IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4) KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0)) ENDIF IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN MSTU(121)=0 RETURN ENDIF KFQOLD=KFL1A+KFL1B-KFQPOP ENDIF C...Meson/baryon choice. Set number of mesons if starting a popcorn C...system. 110 MBARY=0 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN MBARY=1 CALL PYNMES(0) ENDIF ELSEIF(KF1A.GT.10)THEN MBARY=2 IF(IRANK.EQ.0) CALL PYNMES(KF1A) IF(MSTU(121).GT.0) MBARY=-1 ENDIF C..x->H+q: Choose single vertex quark. Jump to form hadron. IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN KFQVER=1+INT((2D0+PARJ(2))*PYR(0)) KFL3=ISIGN(KFQVER,-KFIN) GOTO 130 ENDIF C..x->H+qq: (IDW=proper PARF position for diquark weights) IDW=160 IF(MBARY.EQ.1)THEN IF(MSTU(121).EQ.0) IDW=150 SQWT=PARF(IDW+1) IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121) KFQPOP=1+INT((2D0+SQWT)*PYR(0)) C.. Shift to s-curtain parameters if needed IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN PARF(194)=PARF(138)*PARF(139) PARF(193)=PARJ(8)+PARJ(9) ENDIF ENDIF C.. x->H+qq: Get vertex quark IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN IDW=MSTU(122) MSTU(121)=MSTU(121)-1 IF(IDW.EQ.170) THEN IF(MSTU(121).EQ.0)THEN IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2) ELSE IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2) ENDIF ELSE IF(MSTU(121).EQ.0)THEN IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4) ELSE IPOS=3*5+5*4+MIN(KFQOLD-1,4) ENDIF ENDIF IPOS=200+30*IPOS+1 IMES=-1 RMES=PYR(0)*PARF(194) 120 IMES=IMES+1 RMES=RMES-PARF(IPOS+IMES) IF(IMES.EQ.30) THEN MSTU(121)=-1 KF=-111 RETURN ENDIF IF(RMES.GT.0D0) GOTO 120 KMUL=IMES/5 KFJ=2*KMUL+1 IF(KMUL.EQ.2) KFJ=10003 IF(KMUL.EQ.3) KFJ=10001 IF(KMUL.EQ.4) KFJ=20003 IF(KMUL.EQ.5) KFJ=5 IDIAG=0 KFQVER=MOD(IMES,5)+1 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1 IF(KFQVER.GT.3)THEN IDIAG=KFQVER-3 KFQVER=KFQOLD ENDIF ELSE IF(MBARY.EQ.-1) IDW=170 SQWT=PARF(IDW+2) IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3) IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0))) IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN KFQVER=KFQPOP IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP ENDIF ENDIF C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos KFLDS=3 IF(KFQPOP.NE.KFQVER)THEN SWT=PARF(IDW+7) IF(KFQVER.EQ.3) SWT=PARF(IDW+6) IF(KFQPOP.GE.3) SWT=PARF(IDW+5) IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1 ENDIF KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS & +10000*KFQPOP KFL3=ISIGN(KFDIQ,KFIN) C..x->M+y: flavour for meson. 130 IF(MBARY.LE.0)THEN KFLA=MAX(KFQOLD,KFQVER) KFLB=MIN(KFQOLD,KFQVER) KFS=ISIGN(1,KFL1) IF(KFLA.NE.KFQOLD) KFS=-KFS C... Form meson, with spin and flavour mixing for diagonal states. IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN IF(IDIAG.GT.0) KF=110*IDIAG+KFJ IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA RETURN ENDIF IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0)) IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0)) IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0)) IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN IF(PYR(0).LT.PARJ(14)) KMUL=2 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN RMUL=PYR(0) IF(RMUL.LT.PARJ(15)) KMUL=3 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5 ENDIF KFLS=3 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1 IF(KMUL.EQ.5) KFLS=5 IF(KFLA.NE.KFLB)THEN KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA ELSE RMIX=PYR(0) IMIX=2*KFLA+10*KMUL IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+ & INT(RMIX+PARF(IMIX)))+KFLS IF(KFLA.GE.4) KF=110*KFLA+KFLS ENDIF IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF) IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF) C..Optional extra suppression of eta and eta'. C..Allow shift to qq->B+q in old version (set IRANK to 0) IF(KF.EQ.221.OR.KF.EQ.331)THEN IF(PYR(0).GT.PARJ(25+KF/300))THEN IF(KF2A.GT.0) GOTO 130 IF(MSTJ(12).LT.4) IRANK=0 GOTO 110 ENDIF ENDIF MSTU(121)=0 C.. x->B+y: Flavour for baryon ELSE KFLA=KFQVER IF(KF1A.LE.10) KFLA=KFQOLD KFLB=MOD(KFDIQ/1000,10) KFLC=MOD(KFDIQ/100,10) KFLDS=MOD(KFDIQ,10) KFLD=MAX(KFLA,KFLB,KFLC) KFLF=MIN(KFLA,KFLB,KFLC) KFLE=KFLA+KFLB+KFLC-KFLD-KFLF C... SU(6) factors for formation of baryon. KBARY=3 KDMAX=5 KFLG=KFLB IF(KFLB.NE.KFLC)THEN KBARY=2*KFLDS-1 KDMAX=1+KFLDS/2 IF(KFLB.GT.2) KDMAX=KDMAX+2 ENDIF IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN KBARY=KBARY+1 KFLG=KFLA ENDIF SU6MAX=PARF(140+KDMAX) SU6DEC=PARJ(18) SU6S =PARF(146) IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN SU6MAX=1D0 SU6DEC=1D0 SU6S =1D0 ENDIF SU6OCT=PARF(60+KBARY) IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1) IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1) ELSE IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1) ENDIF SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY) C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected. IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN MSTU(121)=0 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1 GOTO 110 ENDIF C.. Form baryon. Distinguish Lambda- and Sigmalike baryons. KSIG=1 KFLS=2 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN KSIG=KFLDS/3 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0)) ENDIF KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1) IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1) ENDIF RETURN C...Use tabulated probabilities to select new flavour and hadron. 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN KT3L=1 KT3U=6 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN KT3L=1 KT3U=6 ELSEIF(KTAB2.EQ.0) THEN KT3L=1 KT3U=22 ELSE KT3L=KTAB2 KT3U=KTAB2 ENDIF RFL=0D0 DO 160 KTS=0,2 DO 150 KT3=KT3L,KT3U RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3) 150 CONTINUE 160 CONTINUE RFL=PYR(0)*RFL DO 180 KTS=0,2 KTABS=KTS DO 170 KT3=KT3L,KT3U KTAB3=KT3 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3) IF(RFL.LE.0D0) GOTO 190 170 CONTINUE 180 CONTINUE 190 CONTINUE C...Reconstruct flavour of produced quark/diquark. IF(KTAB3.LE.6) THEN KFL3A=KTAB3 KFL3B=0 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13)) ELSE KFL3A=1 IF(KTAB3.GE.8) KFL3A=2 IF(KTAB3.GE.11) KFL3A=3 IF(KTAB3.GE.16) KFL3A=4 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2 KFL3=1000*KFL3A+100*KFL3B+1 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3= & KFL3+2 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1)) ENDIF C...Reconstruct meson code. IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR. &KFL3B.NE.0)) THEN RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+ & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS)) KF=110+2*KTABS+1 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+ & 25*KTABS)) KF=330+2*KTABS+1 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN KFLA=MAX(KTAB1,KTAB3) KFLB=MIN(KTAB1,KTAB3) KFS=ISIGN(1,KFL1) IF(KFLA.NE.KF1A) KFS=-KFS KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN KFS=ISIGN(1,KFL1) IF(KFL1A.EQ.KFL3A) THEN KFLA=MAX(KFL1B,KFL3B) KFLB=MIN(KFL1B,KFL3B) IF(KFLA.NE.KFL1B) KFS=-KFS ELSEIF(KFL1A.EQ.KFL3B) THEN KFLA=KFL3A KFLB=KFL1B KFS=-KFS ELSEIF(KFL1B.EQ.KFL3A) THEN KFLA=KFL1A KFLB=KFL3B ELSEIF(KFL1B.EQ.KFL3B) THEN KFLA=MAX(KFL1A,KFL3A) KFLB=MIN(KFL1A,KFL3A) IF(KFLA.NE.KFL1A) KFS=-KFS ELSE CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq') GOTO 100 ENDIF KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA C...Reconstruct baryon code. ELSE IF(KTAB1.GE.7) THEN KFLA=KFL3A KFLB=KFL1A KFLC=KFL1B ELSE KFLA=KFL1A KFLB=KFL3A KFLC=KFL3B ENDIF KFLD=MAX(KFLA,KFLB,KFLC) KFLF=MIN(KFLA,KFLB,KFLC) KFLE=KFLA+KFLB+KFLC-KFLD-KFLF IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1) IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1) ENDIF C...Check that constructed flavour code is an allowed one. IF(KFL2.NE.0) KFL3=0 KC=PYCOMP(KF) IF(KC.EQ.0) THEN CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '// & 'failed') GOTO 100 ENDIF RETURN END C********************************************************************* C...PYNMES C...Generates number of popcorn mesons and stores some relevant C...parameters. SUBROUTINE PYNMES(KFDIQ) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ MSTU(121)=0 IF(MSTJ(12).LT.2) RETURN C..Old version: Get 1 or 0 popcorn mesons IF(MSTJ(12).LT.5)THEN POPWT=PARF(131) IF(KFDIQ.NE.0) THEN KFDIQA=IABS(KFDIQ) KFA=MOD(KFDIQA/1000,10) KFB=MOD(KFDIQA/100,10) KFS=MOD(KFDIQA,10) POPWT=PARF(132) IF(KFA.EQ.3) POPWT=PARF(133) IF(KFB.EQ.3) POPWT=PARF(134) IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4)) ENDIF MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0)) RETURN ENDIF C..New version: Store popcorn- or rank 0 diquark parameters MSTU(122)=170 PARF(193)=PARJ(8) PARF(194)=PARF(139) IF(KFDIQ.NE.0) THEN MSTU(122)=180 PARF(193)=PARJ(10) PARF(194)=PARF(140) ENDIF IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9, & '(PYNMES:) Neglecting too large popcorn possibility') RETURN ENDIF C..New version: Get number of popcorn mesons 100 RTST=PYR(0) MSTU(121)=-1 110 MSTU(121)=MSTU(121)+1 RTST=RTST/PARF(194) IF(RTST.LT.1D0) GOTO 110 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT. & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100 RETURN END C*************************************************************** C...PYKFIN C...Precalculates a set of diquark and popcorn weights. SUBROUTINE PYKFIN C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14) MSTU(123)=1 C..Diquark indices for dimensional variables IUD1=1 IUU1=2 IUS0=3 ISU0=4 IUS1=5 ISU1=6 ISS1=7 C.. *** SU(6) factors ** C..Modify with decuplet- (and Sigma/Lambda-) suppression. PARF(146)=1D0 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0) IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9, & '(PYKFIN:) PARJ(18)<1 combined with 0 B+B+.. DO 120 I=1,7 QBB(I)=QBB(I)*QBM(I) 120 CONTINUE IF(MSTJ(12).GE.5)THEN C..New version: tau for rank 0 diquark. DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0) DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0) DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0) DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1) DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0) DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1) DMB(7+IUD1)=DMB(7+IUU1)/2D0 C..New version: curtain flavour ratios. C.. s/u for q->B+M+... C.. s/u for rank 0 diquark: su -> ...M+B+... C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+... WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1) PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1) PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))* & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU ELSE C..Old version: reset unused rank 0 diquark weights and C.. unused diquark SU(6) survival weights DO 130 I=1,7 IF(MSTJ(12).LT.3) DMB(I)=1D0 DMB(7+I)=1D0 130 CONTINUE C..Old version: Shuffle PARJ(7) into tau QBM(IUS0)=QBM(IUS0)*PARJ(7) QBM(ISS1)=QBM(ISS1)*PARJ(7) QBM(IUS1)=QBM(IUS1)*PARJ(7) C..Old version: curtain flavour ratios. C.. s/u for q->B+M+... C.. s/u for rank 0 diquark: su -> ...M+B+... C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+... WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1) PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0) PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU ENDIF C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for: C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B.. DO 140 I=1,7 DMB(7+I)=DMB(7+I)*DMB(I) DMB(I)=DMB(I)*QBM(I) QBM(I)=QBM(I)*SU6M(I)/SU6MUD QBB(I)=QBB(I)*SU6M(I)/SU6MUD 140 CONTINUE C.. *** Popcorn factors *** IF(MSTJ(12).LT.5)THEN C.. Old version: Resulting popcorn weights. PARF(138)=PARJ(6) WS=PARF(135)*PARF(138) WQ=WU*PARJ(5)/3D0 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1) PARF(133)=WQ* & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1) PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+ & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/ & (1D0+QBB(IUD1)+QBB(IUU1)+ & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0) ELSE C..New version: Store weights for popcorn mesons, C..get prel. popcorn weights. DO 150 IPOS=201,1400 PARF(IPOS)=0D0 150 CONTINUE DO 160 I=138,140 PARF(I)=0D0 160 CONTINUE IPOS=200 PARF(193)=PARJ(8) DO 240 MR=0,7,7 IF(MR.EQ.7) PARF(193)=PARJ(10) SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/ & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1)) QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1)) DO 230 NMES=0,1 IF(NMES.EQ.1) SQWT=PARJ(2) DO 220 KFQPOP=1,4 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1)) QQWT=0.5D0 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9) IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0 ENDIF DO 210 KFQOLD =1,5 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210 IF(NMES.EQ.1) THEN IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210 ENDIF WTTOT=0D0 WTFAIL=0D0 DO 190 KMUL=0,5 PJWT=PARJ(12+KMUL) IF(KMUL.EQ.0) PJWT=1D0-PARJ(14) IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17) IF(PJWT.LE.0D0) GOTO 190 IF(PJWT.GT.1D0) PJWT=1D0 IMES=5*KMUL IMIX=2*KFQOLD+10*KMUL KFJ=2*KMUL+1 IF(KMUL.EQ.2) KFJ=10003 IF(KMUL.EQ.3) KFJ=10001 IF(KMUL.EQ.4) KFJ=20003 IF(KMUL.EQ.5) KFJ=5 DO 180 KFQVER =1,3 KFLA=MAX(KFQOLD,KFQVER) KFLB=MIN(KFQOLD,KFQVER) SWT=PARJ(11+KFLA/3+KFLA/4) IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT SWT=SWT*PJWT QWT=SQWT/(2D0+SQWT) IF(KFQVER.LT.3)THEN IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT) ENDIF IF(KFQVER.NE.KFQOLD)THEN IMES=IMES+1 KFM=100*KFLA+10*KFLB+KFJ PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3) PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM) WTTOT=WTTOT+PARF(IPOS+IMES) ELSE DO 170 ID=3,5 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1) IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX) IF(ID.EQ.5) DWT=PARF(IMIX) KFM=110*(ID-2)+KFJ PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3) PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM) IF(KMUL.EQ.0.AND.ID.GT.3) THEN WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID)) PARF(IPOS+5*KMUL+ID)= & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID) ENDIF WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID) 170 CONTINUE ENDIF 180 CONTINUE 190 CONTINUE DO 200 IMES=1,30 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL) 200 CONTINUE IF(MR.EQ.7) PARF(140)= & MAX(PARF(140),WTTOT/(1D0-WTFAIL)) IF(MR.EQ.0) PARF(139-KFQPOP/3)= & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL)) IPOS=IPOS+30 210 CONTINUE 220 CONTINUE 230 CONTINUE 240 CONTINUE IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139) MSTU(121)=0 ENDIF C..Recombine diquark weights to flavour and spin ratios PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/ & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1)) PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1)) PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1)) PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1)) PARF(155)=QBB(ISU1)/QBB(ISU0) PARF(156)=QBB(IUS1)/QBB(IUS0) PARF(157)=QBB(IUD1) PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/ & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)) PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1)) PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1)) PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1)) PARF(165)=QBM(ISU1)/QBM(ISU0) PARF(166)=QBM(IUS1)/QBM(IUS0) PARF(167)=QBM(IUD1) PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/ & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1)) PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1)) PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1)) PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1)) PARF(175)=DMB(ISU1)/DMB(ISU0) PARF(176)=DMB(IUS1)/DMB(IUS0) PARF(177)=DMB(IUD1) PARF(185)=DMB(7+ISU1)/DMB(7+ISU0) PARF(186)=DMB(7+IUS1)/DMB(7+IUS0) PARF(187)=DMB(7+IUD1) RETURN END C********************************************************************* C...PYPTDI C...Generates transverse momentum according to a Gaussian. SUBROUTINE PYPTDI(KFL,PX,PY) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Generate p_T and azimuthal angle, gives p_x and p_y. KFLA=IABS(KFL) PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0)))) IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0 PHI=PARU(2)*PYR(0) PX=PT*COS(PHI) PY=PT*SIN(PHI) RETURN END C********************************************************************* C...PYZDIS C...Generates the longitudinal splitting variable z. SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C...Check if heavy flavour fragmentation. KFLA=IABS(KFL1) KFLB=IABS(KFL2) KFLH=KFLA IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10) C...Lund symmetric scaling function: determine parameters of shape. IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR. &MSTJ(11).GE.4) THEN FA=PARJ(41) IF(MSTJ(91).EQ.1) FA=PARJ(43) IF(KFLB.GE.10) FA=FA+PARJ(45) FBB=PARJ(42) IF(MSTJ(91).EQ.1) FBB=PARJ(44) FB=FBB*PR FC=1D0 IF(KFLA.GE.10) FC=FC-PARJ(45) IF(KFLB.GE.10) FC=FC+PARJ(45) IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN FRED=PARJ(46) IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47) FC=FC+FRED*FBB*PARF(100+KFLH)**2 ENDIF MC=1 IF(ABS(FC-1D0).GT.0.01D0) MC=2 C...Determine position of maximum. Special cases for a = 0 or a = c. IF(FA.LT.0.02D0) THEN MA=1 ZMAX=1D0 IF(FC.GT.FB) ZMAX=FB/FC ELSEIF(ABS(FC-FA).LT.0.01D0) THEN MA=2 ZMAX=FB/(FB+FC) ELSE MA=3 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA) IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB) ENDIF C...Subdivide z range if distribution very peaked near endpoint. MMAX=2 IF(ZMAX.LT.0.1D0) THEN MMAX=1 ZDIV=2.75D0*ZMAX IF(MC.EQ.1) THEN FINT=1D0-LOG(ZDIV) ELSE ZDIVC=ZDIV**(1D0-FC) FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0) ENDIF ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN MMAX=3 FSCB=SQRT(4D0+(FC/FB)**2) ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB)) IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX) ZDIV=MIN(ZMAX,MAX(0D0,ZDIV)) FINT=1D0+FB*(1D0-ZDIV) ENDIF C...Choice of z, preweighted for peaks at low or high z. 100 Z=PYR(0) FPRE=1D0 IF(MMAX.EQ.1) THEN IF(FINT*PYR(0).LE.1D0) THEN Z=ZDIV*Z ELSEIF(MC.EQ.1) THEN Z=ZDIV**Z FPRE=ZDIV/Z ELSE Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC)) FPRE=(ZDIV/Z)**FC ENDIF ELSEIF(MMAX.EQ.3) THEN IF(FINT*PYR(0).LE.1D0) THEN Z=ZDIV+LOG(Z)/FB FPRE=EXP(FB*(Z-ZDIV)) ELSE Z=ZDIV+Z*(1D0-ZDIV) ENDIF ENDIF C...Weighting according to correct formula. IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z) IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX)) FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP))) IF(FVAL.LT.PYR(0)*FPRE) GOTO 100 C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c. ELSE FC=PARJ(50+MAX(1,KFLH)) IF(MSTJ(91).EQ.1) FC=PARJ(59) 110 Z=PYR(0) IF(FC.GE.0D0.AND.FC.LE.1D0) THEN IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0) ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2) & GOTO 110 ELSE IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC) IF(FC.LT.0D0) Z=Z**(-1D0/FC) ENDIF ENDIF RETURN END C********************************************************************* C...PYSHOW C...Generates timelike parton showers from given partons. SUBROUTINE PYSHOW(IP1,IP2,QMAX) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) 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 PMTH(5,50),PS(5),PMA(19),PMSD(10),IEP(10),IPA(10), &KFLA(10),KFLD(10),KFL(10),ITRY(10),ISI(10),ISL(10),DP(10), &DPT(5,4),KSH(0:40),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2), &PHIIIS(2,2),ISII(2),ISSET(3),ISCOL(0:40),ISCHG(0:40), &IREF(1000) C...Check that QMAX not too low. IF(MSTJ(41).LE.0) THEN RETURN ELSEIF(MSTJ(41).EQ.1) THEN IF(QMAX.LE.PARJ(82).AND.IP2.GT.-8) RETURN ELSE IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GT.-8) & RETURN ENDIF C...Initialization of cutoff masses etc. DO 100 IFL=0,40 ISCOL(IFL)=0 ISCHG(IFL)=0 KSH(IFL)=0 100 CONTINUE ISCOL(21)=1 KSH(21)=1 PMTH(1,21)=PYMASS(21) PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2) PMTH(3,21)=2D0*PMTH(2,21) PMTH(4,21)=PMTH(3,21) PMTH(5,21)=PMTH(3,21) PMTH(1,22)=PYMASS(22) PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2) PMTH(3,22)=2D0*PMTH(2,22) PMTH(4,22)=PMTH(3,22) PMTH(5,22)=PMTH(3,22) PMQTH1=PARJ(82) IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83)) PMQT1E=MIN(PMQTH1,PARJ(90)) PMQTH2=PMTH(2,21) IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22)) PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90)) DO 110 IFL=1,5 ISCOL(IFL)=1 IF(MSTJ(41).GE.2) ISCHG(IFL)=1 KSH(IFL)=1 PMTH(1,IFL)=PYMASS(IFL) PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2) PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21) PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22) 110 CONTINUE DO 120 IFL=11,15,2 IF(MSTJ(41).GE.2) ISCHG(IFL)=1 IF(MSTJ(41).GE.2) KSH(IFL)=1 PMTH(1,IFL)=PYMASS(IFL) PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2) PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90) PMTH(4,IFL)=PMTH(3,IFL) PMTH(5,IFL)=PMTH(3,IFL) 120 CONTINUE PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2 ALAMS=PARJ(81)**2 ALFM=LOG(PT2MIN/ALAMS) C...Store positions of shower initiating partons. MPSPD=0 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN NPA=1 IPA(1)=IP1 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)- & MSTU(32))) THEN NPA=2 IPA(1)=IP1 IPA(2)=IP2 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0 & .AND.IP2.GE.-7) THEN NPA=IABS(IP2) DO 130 I=1,NPA IPA(I)=IP1+I-1 130 CONTINUE ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND. &IP2.EQ.-8) THEN MPSPD=1 NPA=2 IPA(1)=IP1+6 IPA(2)=IP1+7 ELSE CALL PYERRM(12, & '(PYSHOW:) failed to reconstruct showering system') IF(MSTU(21).GE.1) RETURN ENDIF C...Check on phase space available for emission. IREJ=0 DO 140 J=1,5 PS(J)=0D0 140 CONTINUE PM=0D0 DO 160 I=1,NPA KFLA(I)=IABS(K(IPA(I),2)) PMA(I)=P(IPA(I),5) C...Special cutoff masses for initial partons (may be a heavy quark, C...squark, ..., and need not be on the mass shell). IR=30+I IF(NPA.LE.1) IREF(I)=IR IF(NPA.GE.2) IREF(I+1)=IR IF(KFLA(I).LE.8) THEN ISCOL(IR)=1 IF(MSTJ(41).GE.2) ISCHG(IR)=1 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR. & KFLA(I).EQ.17) THEN IF(MSTJ(41).GE.2) ISCHG(IR)=1 ELSEIF(KFLA(I).EQ.21) THEN ISCOL(IR)=1 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR. & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN ISCOL(IR)=1 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN ISCOL(IR)=1 ENDIF IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1 PMTH(1,IR)=PMA(I) IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2) PMTH(3,IR)=PMTH(2,IR)+PMQTH2 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21) PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22) ELSEIF(ISCOL(IR).EQ.1) THEN PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2) PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82) PMTH(4,IR)=PMTH(3,IR) PMTH(5,IR)=PMTH(3,IR) ELSEIF(ISCHG(IR).EQ.1) THEN PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2) PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90) PMTH(4,IR)=PMTH(3,IR) PMTH(5,IR)=PMTH(3,IR) ENDIF IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR) PM=PM+PMA(I) IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1 DO 150 J=1,4 PS(J)=PS(J)+P(IPA(I),J) 150 CONTINUE 160 CONTINUE IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2)) IF(NPA.EQ.1) PS(5)=PS(4) IF(PS(5).LE.PM+PMQT1E) RETURN C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0). KFSRCE=0 IF(IP2.LE.0) THEN ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN KFSRCE=IABS(K(K(IP1,3),2)) ELSE IPAR1=MAX(1,K(IP1,3)) IPAR2=MAX(1,K(IP2,3)) IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0) & KFSRCE=IABS(K(K(IPAR1,3),2)) ENDIF ITYPES=0 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6 C...Identify two primary showerers. ITYPE1=0 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6 ITYPE2=0 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6 C...Order of showerers. Presence of gluino. ITYPMN=MIN(ITYPE1,ITYPE2) ITYPMX=MAX(ITYPE1,ITYPE2) IORD=1 IF(ITYPE1.GT.ITYPE2) IORD=2 IGLUI=0 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1 C...Check if 3-jet matrix elements to be used. M3JC=0 ALPHA=0.5D0 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN IF(MSTJ(38).NE.0) THEN M3JC=MSTJ(38) ALPHA=PARJ(80) MSTJ(38)=0 ELSEIF(MSTJ(47).GE.6) THEN M3JC=MSTJ(47) ELSE ICLASS=1 ICOMBI=4 C...Vector/axial vector -> q + qbar; q -> q + V. IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.3)) THEN ICLASS=2 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN ICOMBI=1 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND. & K(IP1,2)+K(IP2,2).EQ.0)) THEN C...gamma*/Z0: assume e+e- initial state if unknown. EI=-1D0 IF(KFSRCE.EQ.23) THEN IANNFL=K(K(IP1,3),3) IF(IANNFL.NE.0) THEN KANNFL=IABS(K(IANNFL,2)) IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0 ENDIF ENDIF AI=SIGN(1D0,EI+0.1D0) VI=AI-4D0*EI*PARU(102) EF=KCHG(KFLA(1),1)/3D0 AF=SIGN(1D0,EF+0.1D0) VF=AF-4D0*EF*PARU(102) XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102))) SH=PS(5)**2 SQMZ=PMAS(23,1)**2 SQWZ=PS(5)*PMAS(23,2) SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2) VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+ & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ ICOMBI=3 ALPHA=VECT/(VECT+AXIV) ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN ICOMBI=4 ENDIF C...For chi -> chi q qbar, use V/A -> q qbar as first approximation. ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN ICLASS=2 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.1)) THEN ICLASS=3 C...Scalar/pseudoscalar -> q + qbar; q -> q + S. ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN ICLASS=4 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN ICOMBI=1 ELSEIF(KFSRCE.EQ.36) THEN ICOMBI=2 ENDIF ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.1)) THEN ICLASS=5 C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S. ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.3)) THEN ICLASS=6 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.2)) THEN ICLASS=7 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN ICLASS=8 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.2)) THEN ICLASS=9 C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi. ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.5)) THEN ICLASS=10 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.2)) THEN ICLASS=11 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.1)) THEN ICLASS=12 C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g. ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN ICLASS=13 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.2)) THEN ICLASS=14 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR. & ITYPES.EQ.1)) THEN ICLASS=15 C...g -> ~g + ~g (eikonal approximation). ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN ICLASS=16 ENDIF M3JC=5*ICLASS+ICOMBI ENDIF ENDIF C...Find if interference with initial state partons. MIIS=0 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.MPSPD.EQ.0) &MIIS=MSTJ(50) IF(MIIS.NE.0) THEN DO 180 I=1,2 KCII(I)=0 KCA=PYCOMP(KFLA(I)) IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2)) NIIS(I)=0 IF(KCII(I).NE.0) THEN DO 170 J=1,2 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5)) IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND. & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN NIIS(I)=NIIS(I)+1 IIIS(I,NIIS(I))=ICSI ENDIF 170 CONTINUE ENDIF 180 CONTINUE IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0 ENDIF C...Boost interfering initial partons to rest frame C...and reconstruct their polar and azimuthal angles. IF(MIIS.NE.0) THEN DO 200 I=1,2 DO 190 J=1,5 K(N+I,J)=K(IPA(I),J) P(N+I,J)=P(IPA(I),J) V(N+I,J)=0D0 190 CONTINUE 200 CONTINUE DO 220 I=3,2+NIIS(1) DO 210 J=1,5 K(N+I,J)=K(IIIS(1,I-2),J) P(N+I,J)=P(IIIS(1,I-2),J) V(N+I,J)=0D0 210 CONTINUE 220 CONTINUE DO 240 I=3+NIIS(1),2+NIIS(1)+NIIS(2) DO 230 J=1,5 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J) P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J) V(N+I,J)=0D0 230 CONTINUE 240 CONTINUE CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4), & -PS(2)/PS(4),-PS(3)/PS(4)) PHI=PYANGL(P(N+1,1),P(N+1,2)) CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0) THE=PYANGL(P(N+1,3),P(N+1,1)) CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0) DO 250 I=3,2+NIIS(1) THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2)) PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2)) 250 CONTINUE DO 260 I=3+NIIS(1),2+NIIS(1)+NIIS(2) THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3), & SQRT(P(N+I,1)**2+P(N+I,2)**2)) PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2)) 260 CONTINUE ENDIF C...Boost 3 or more partons to their rest frame. IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4), &-PS(2)/PS(4),-PS(3)/PS(4)) C...Define imagined single initiator of shower for parton system. NS=N IF(N.GT.MSTU(4)-MSTU(32)-10) THEN CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS') IF(MSTU(21).GE.1) RETURN ENDIF 270 N=NS IF(NPA.GE.2) THEN K(N+1,1)=11 K(N+1,2)=21 K(N+1,3)=0 K(N+1,4)=0 K(N+1,5)=0 P(N+1,1)=0D0 P(N+1,2)=0D0 P(N+1,3)=0D0 P(N+1,4)=PS(5) P(N+1,5)=PS(5) V(N+1,5)=PS(5)**2 N=N+1 IREF(1)=21 ENDIF C...Loop over partons that may branch. NEP=NPA IM=NS IF(NPA.EQ.1) IM=NS-1 280 IM=IM+1 IF(N.GT.NS) THEN IF(IM.GT.N) GOTO 590 KFLM=IABS(K(IM,2)) IR=IREF(IM-NS) IF(KSH(IR).EQ.0) GOTO 280 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 280 IGM=K(IM,3) ELSE IGM=-1 ENDIF IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS') IF(MSTU(21).GE.1) RETURN ENDIF C...Position of aunt (sister to branching parton). C...Origin and flavour of daughters. IAU=0 IF(IGM.GT.0) THEN IF(K(IM-1,3).EQ.IGM) IAU=IM-1 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1 ENDIF IF(IGM.GE.0) THEN K(IM,4)=N+1 DO 290 I=1,NEP K(N+I,3)=IM 290 CONTINUE ELSE K(N+1,3)=IPA(1) ENDIF IF(IGM.LE.0) THEN DO 300 I=1,NEP K(N+I,2)=K(IPA(I),2) 300 CONTINUE ELSEIF(KFLM.NE.21) THEN K(N+1,2)=K(IM,2) K(N+2,2)=K(IM,5) IREF(N+1-NS)=IREF(IM-NS) IREF(N+2-NS)=IABS(K(N+2,2)) ELSEIF(K(IM,5).EQ.21) THEN K(N+1,2)=21 K(N+2,2)=21 IREF(N+1-NS)=21 IREF(N+2-NS)=21 ELSE K(N+1,2)=K(IM,5) K(N+2,2)=-K(IM,5) IREF(N+1-NS)=IABS(K(N+1,2)) IREF(N+2-NS)=IABS(K(N+2,2)) ENDIF C...Reset flags on daughters and tries made. DO 310 IP=1,NEP K(N+IP,1)=3 K(N+IP,4)=0 K(N+IP,5)=0 KFLD(IP)=IABS(K(N+IP,2)) IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1 ITRY(IP)=0 ISL(IP)=0 ISI(IP)=0 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1 310 CONTINUE ISLM=0 C...Maximum virtuality of daughters. IF(IGM.LE.0) THEN DO 320 I=1,NPA IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4) P(N+I,5)=MIN(QMAX,PS(5)) IR=IREF(N+I-NS) IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR)) IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5) 320 CONTINUE ELSE IF(MSTJ(43).LE.2) PEM=V(IM,2) IF(MSTJ(43).GE.3) PEM=P(IM,4) P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM) P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM) IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22) ENDIF DO 330 I=1,NEP PMSD(I)=P(N+I,5) IF(ISI(I).EQ.1) THEN IR=IREF(N+I-NS) IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR) ENDIF V(N+I,5)=P(N+I,5)**2 330 CONTINUE C...Choose one of the daughters for evolution. 340 INUM=0 IF(NEP.EQ.1) INUM=1 DO 350 I=1,NEP IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I 350 CONTINUE DO 360 I=1,NEP IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN IR=IREF(N+I-NS) IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I ENDIF 360 CONTINUE IF(INUM.EQ.0) THEN RMAX=0D0 DO 370 I=1,NEP IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN RPM=P(N+I,5)/PMSD(I) IR=IREF(N+I-NS) IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN RMAX=RPM INUM=I ENDIF ENDIF 370 CONTINUE ENDIF C...Cancel choice of predetermined daughter already treated. INUM=MAX(1,INUM) INUMT=INUM IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM ENDIF C...Store information on choice of evolving daughter. IEP(1)=N+INUM DO 380 I=2,NEP IEP(I)=IEP(I-1)+1 IF(IEP(I).GT.N+NEP) IEP(I)=N+1 380 CONTINUE DO 390 I=1,NEP KFL(I)=IABS(K(IEP(I),2)) 390 CONTINUE ITRY(INUM)=ITRY(INUM)+1 IF(ITRY(INUM).GT.200) THEN CALL PYERRM(14,'(PYSHOW:) caught in infinite loop') IF(MSTU(21).GE.1) RETURN ENDIF Z=0.5D0 IR=IREF(IEP(1)-NS) IF(KSH(IR).EQ.0) GOTO 440 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 440 C...Check if evolution already predetermined for daughter. IPSPD=0 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3 ENDIF ISSET(INUM)=0 IF(IPSPD.NE.0) ISSET(INUM)=1 C...Select side for interference with initial state partons. IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN III=IEP(1)-NS-1 ISII(III)=0 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN ISII(III)=1 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN IF(PYR(0).GT.0.5D0) ISII(III)=1 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN ISII(III)=1 IF(PYR(0).GT.0.5D0) ISII(III)=2 ENDIF ENDIF C...Calculate allowed z range. IF(NEP.EQ.1) THEN PMED=PS(4) ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN PMED=P(IM,5) ELSE IF(INUM.EQ.1) PMED=V(IM,1)*PEM IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM ENDIF IF(MOD(MSTJ(43),2).EQ.1) THEN ZC=PMTH(2,21)/PMED ZCE=PMTH(2,22)/PMED IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED ELSE ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2))) IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2 PMTMPE=PMTH(2,22) IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90) ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2))) IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2 ENDIF ZC=MIN(ZC,0.491D0) ZCE=MIN(ZCE,0.49991D0) IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND. &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN P(IEP(1),5)=PMTH(1,IR) V(IEP(1),5)=P(IEP(1),5)**2 GOTO 440 ENDIF C...Integral of Altarelli-Parisi z kernel for QCD. C...(Includes squark and gluino; with factor N_C/C_F extra for latter). IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0 ELSEIF(MSTJ(49).EQ.0) THEN FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC) IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0) C...Integral of Altarelli-Parisi z kernel for scalar gluon. ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC) ELSEIF(MSTJ(49).EQ.1) THEN FBR=(1D0-2D0*ZC)/3D0 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon. ELSEIF(KFL(1).EQ.21) THEN FBR=6D0*MSTJ(45)*(0.5D0-ZC) ELSE FBR=2D0*LOG((1D0-ZC)/ZC) ENDIF C...Reset QCD probability for colourless. IF(ISCOL(IR).EQ.0) FBR=0D0 C...Integral of Altarelli-Parisi kernel for photon emission. FBRE=0D0 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN IF(KFL(1).LE.18) THEN FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE) ENDIF IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE ENDIF C...Inner veto algorithm starts. Find maximum mass for evolution. 400 PMS=V(IEP(1),5) IF(IGM.GE.0) THEN PM2=0D0 DO 410 I=2,NEP PM=P(IEP(I),5) IRI=IREF(IEP(I)-NS) IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI) PM2=PM2+PM 410 CONTINUE PMS=MIN(PMS,(P(IM,5)-PM2)**2) ENDIF C...Select mass for daughter in QCD evolution. B0=27D0/6D0 DO 420 IFF=4,MSTJ(45) IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0 420 CONTINUE C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2. PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2) C...Already predetermined choice. IF(IPSPD.NE.0) THEN PMSQCD=P(IPSPD,5)**2 ELSEIF(FBR.LT.1D-3) THEN PMSQCD=0D0 ELSEIF(MSTJ(44).LE.0) THEN PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR))) ELSEIF(MSTJ(44).EQ.1) THEN PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR)) ELSE PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR)) ENDIF C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2. IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2 V(IEP(1),5)=PMSQCD MCE=1 C...Select mass for daughter in QED evolution. IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2. PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2) IF(FBRE.LT.1D-3) THEN PMSQED=0D0 ELSE PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/ & (PARU(101)*FBRE))) ENDIF C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2. PMSQED=PMSQED+PMTH(1,IR)**2 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED= & PMTH(2,IR)**2 IF(PMSQED.GT.PMSQCD) THEN V(IEP(1),5)=PMSQED MCE=2 ENDIF ENDIF C...Check whether daughter mass below cutoff. P(IEP(1),5)=SQRT(V(IEP(1),5)) IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN P(IEP(1),5)=PMTH(1,IR) V(IEP(1),5)=P(IEP(1),5)**2 GOTO 440 ENDIF C...Already predetermined choice of z, and flavour in g -> qqbar. IF(IPSPD.NE.0) THEN IPSGD1=K(IPSPD,4) IPSGD2=K(IPSPD,5) PMSGD1=P(IPSGD1,5)**2 PMSGD2=P(IPSGD2,5)**2 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2- & 4D0*PMSGD1*PMSGD2)) Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS- & PMSGD1+PMSGD2)/ALAMPS Z=MAX(0.00001D0,MIN(0.99999D0,Z)) IF(KFL(1).NE.21) THEN K(IEP(1),5)=21 ELSE K(IEP(1),5)=IABS(K(IPSGD1,2)) ENDIF C...Select z value of branching: q -> qgamma. ELSEIF(MCE.EQ.2) THEN Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0) IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 400 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) C...Only do z weighting when no ME correction afterwards. IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 400 K(IEP(1),5)=21 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0) IF(PYR(0).GT.0.5D0) Z=1D0-Z IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 400 K(IEP(1),5)=21 ELSEIF(MSTJ(49).NE.1) THEN Z=PYR(0) IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 400 KFLB=1+INT(MSTJ(45)*PYR(0)) PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5) IF(PMQ.GE.1D0) GOTO 400 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 400 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 400 ELSE IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 400 ENDIF K(IEP(1),5)=KFLB C...Ditto for scalar gluon model. ELSEIF(KFL(1).NE.21) THEN Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC)) K(IEP(1),5)=21 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN Z=ZC+(1D0-2D0*ZC)*PYR(0) K(IEP(1),5)=21 ELSE Z=ZC+(1D0-2D0*ZC)*PYR(0) KFLB=1+INT(MSTJ(45)*PYR(0)) PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5) IF(PMQ.GE.1D0) GOTO 400 K(IEP(1),5)=KFLB ENDIF C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar). IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND. & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 400 ELSE PT2APP=Z*(1D0-Z)*V(IEP(1),5) IF(MSTJ(44).GE.4) PT2APP=PT2APP* & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2 IF(PT2APP.LT.PT2MIN) GOTO 400 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 400 ENDIF ENDIF C...Check if z consistent with chosen m. IF(KFL(1).EQ.21) THEN IRGD1=IABS(K(IEP(1),5)) IRGD2=IRGD1 ELSE IRGD1=IR IRGD2=IABS(K(IEP(1),5)) ENDIF IF(NEP.EQ.1) THEN PED=PS(4) ELSEIF(NEP.GE.3) THEN PED=P(IEP(1),4) ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5) ELSE IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM ENDIF IF(MOD(MSTJ(43),2).EQ.1) THEN PMQTH3=0.5D0*PARJ(82) IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83) IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90) PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5) PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5) ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2- & 4D0*PMQ1*PMQ2))) ZH=1D0+PMQ1-PMQ2 ELSE ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2)) ZH=1D0 ENDIF IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND. &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN ELSEIF(IPSPD.NE.0) THEN ELSE ZL=0.5D0*(ZH-ZD) ZU=0.5D0*(ZH+ZD) IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 400 ENDIF IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL* &(1D0-ZU))) IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU)) C...Width suppression for q -> q + g. IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN IF(IGM.EQ.0) THEN EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5)) ELSE EGLU=PMED*(1D0-Z) ENDIF CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2) IF(MSTJ(40).EQ.1) THEN IF(CHI.LT.PYR(0)) GOTO 400 ELSEIF(MSTJ(40).EQ.2) THEN IF(1D0-CHI.LT.PYR(0)) GOTO 400 ENDIF ENDIF C...Three-jet matrix element correction. IF(M3JC.GE.1) THEN WME=1D0 WSHOW=1D0 C...QED matrix elements: only for massless case so far. IF(MCE.EQ.2.AND.IGM.EQ.0) THEN X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5)) X2=1D0-V(IEP(1),5)/V(NS+1,5) X3=(1D0-X1)+(1D0-X2) KI1=K(IPA(INUM),2) KI2=K(IPA(3-INUM),2) QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+ & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2) WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2) ELSEIF(MCE.EQ.2) THEN C...QCD matrix elements, including mass effects. ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN PS1ME=V(IEP(1),5) PM1ME=PMTH(1,IR) M3JCC=M3JC IF(IR.GE.31.AND.IGM.EQ.0) THEN C...QCD ME: original parton, first branching. PM2ME=PMTH(1,63-IR) ECMME=PS(5) ELSEIF(IR.GE.31) THEN C...QCD ME: original parton, subsequent branchings. PM2ME=PMTH(1,63-IR) PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5)) ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2)) ELSEIF(K(IM,2).EQ.21) THEN C...QCD ME: secondary partons, first branching. PM2ME=PM1ME ZMME=V(IM,1) IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2- & 4D0*PS1ME*PM2ME**2)) PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/ & V(IM,5) ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2)) M3JCC=66 ELSE C...QCD ME: secondary partons, subsequent branchings. PM2ME=PM1ME PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5)) ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2)) M3JCC=66 ENDIF C...Construct ME variables. R1ME=PM1ME/ECMME R2ME=PM2ME/ECMME X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME) X2=1D0+R2ME**2-PS1ME/ECMME**2 C...Call ME, with right order important for two inequivalent showerers. IF(IR.EQ.IORD+30) THEN WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA) ELSE WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA) ENDIF C...Split up total ME when two radiating partons. ISPRAD=1 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR. & (M3JCC.GE.26.AND.M3JCC.LE.29).OR. & (M3JCC.GE.36.AND.M3JCC.LE.39).OR. & (M3JCC.GE.46.AND.M3JCC.LE.49).OR. & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/ & MAX(1D-10,2D0-X1-X2) C...Evaluate shower rate to be compared with. WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)* & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2)) IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW ELSEIF(MSTJ(49).NE.1) THEN C...Toy model scalar theory matrix elements; no mass effects. ELSE X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5)) X2=1D0-V(IEP(1),5)/V(NS+1,5) X3=(1D0-X1)+(1D0-X2) WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2) WME=X3**2 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)* & PARJ(171) ENDIF IF(WME.LT.PYR(0)*WSHOW) GOTO 400 ENDIF C...Impose angular ordering by rejection of nonordered emission. IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN PEMAO=V(IM,1)*P(IM,4) IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4) IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN MAOD=0 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4 & .OR.MSTJ(42).EQ.7)) THEN MAOD=0 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3 & .OR.MSTJ(42).EQ.6)) THEN MAOD=1 PMDAO=PMTH(2,K(IEP(1),5)) THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2) ELSE MAOD=1 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5) IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID* & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2 ENDIF MAOM=1 IAOM=IM 430 IF(K(IAOM,5).EQ.22) THEN IAOM=K(IAOM,3) IF(K(IAOM,3).LE.NS) MAOM=0 IF(MAOM.EQ.1) GOTO 430 ENDIF IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5) IF(THE2ID.LT.THE2IM) GOTO 400 ENDIF ENDIF C...Impose user-defined maximum angle at first branching. IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN IF(NEP.EQ.1.AND.IM.EQ.NS) THEN THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5) IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 400 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5) IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 400 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5) IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 400 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 400 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 400 ENDIF ENDIF C...End of inner veto algorithm. Check if only one leg evolved so far. 440 V(IEP(1),1)=Z ISL(1)=0 ISL(2)=0 IF(NEP.EQ.1) GOTO 480 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 340 DO 450 I=1,NEP IR=IREF(N+I-NS) IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 340 ENDIF 450 CONTINUE C...Check if chosen multiplet m1,m2,z1,z2 is physical. IF(NEP.GE.3) THEN PMSUM=0D0 DO 460 I=1,NEP PMSUM=PMSUM+P(N+I,5) 460 CONTINUE IF(PMSUM.GE.PS(5)) GOTO 340 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN DO 470 I1=N+1,N+2 IRDA=IREF(I1-NS) IF(KSH(IRDA).EQ.0) GOTO 470 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 470 IF(IRDA.EQ.21) THEN IRGD1=IABS(K(I1,5)) IRGD2=IRGD1 ELSE IRGD1=IRDA IRGD2=IABS(K(I1,5)) ENDIF I2=2*N+3-I1 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5) ELSE IF(I1.EQ.N+1) ZM=V(IM,1) IF(I1.EQ.N+2) ZM=1D0-V(IM,1) PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2- & 4D0*V(N+1,5)*V(N+2,5)) PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/ & V(IM,5) ENDIF IF(MOD(MSTJ(43),2).EQ.1) THEN PMQTH3=0.5D0*PARJ(82) IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83) IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90) PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5) PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5) ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2- & 4D0*PMQ1*PMQ2))) ZH=1D0+PMQ1-PMQ2 ELSE ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2)) ZH=1D0 ENDIF IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND. & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN ELSE ZL=0.5D0*(ZH-ZD) ZU=0.5D0*(ZH+ZD) IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND. & ISSET(1).EQ.0) THEN ISL(1)=1 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND. & ISSET(2).EQ.0) THEN ISL(2)=1 ENDIF ENDIF IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20, & ZL*(1D0-ZU))) IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU)) 470 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 340 ENDIF IRD1=IREF(N+1-NS) IRD2=IREF(N+2-NS) IF(IGM.GT.0) THEN IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE. & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN PMQ1=V(N+1,5)/V(IM,5) PMQ2=V(N+2,5)/V(IM,5) ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2- & 4D0*PMQ1*PMQ2))) ZH=1D0+PMQ1-PMQ2 ZL=0.5D0*(ZH-ZD) ZU=0.5D0*(ZH+ZD) IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 340 ENDIF ENDIF C...Accepted branch. Construct four-momentum for initial partons. 480 MAZIP=0 MAZIC=0 IF(NEP.EQ.1) THEN P(N+1,1)=0D0 P(N+1,2)=0D0 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)- & P(N+1,5)))) P(N+1,4)=P(IPA(1),4) V(N+1,2)=P(N+1,4) ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5) P(N+1,1)=0D0 P(N+1,2)=0D0 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5)))) P(N+1,4)=PED1 P(N+2,1)=0D0 P(N+2,2)=0D0 P(N+2,3)=-P(N+1,3) P(N+2,4)=P(IM,5)-PED1 V(N+1,2)=P(N+1,4) V(N+2,2)=P(N+2,4) ELSEIF(NEP.GE.3) THEN C...Rescale all momenta for energy conservation. LOOP=0 PES=0D0 PQS=0D0 DO 500 I=1,NEP DO 490 J=1,4 P(N+I,J)=P(IPA(I),J) 490 CONTINUE PES=PES+P(N+I,4) PQS=PQS+P(N+I,5)**2/P(N+I,4) 500 CONTINUE 510 LOOP=LOOP+1 FAC=(PS(5)-PQS)/(PES-PQS) PES=0D0 PQS=0D0 DO 530 I=1,NEP DO 520 J=1,3 P(N+I,J)=FAC*P(N+I,J) 520 CONTINUE P(N+I,4)=SQRT(P(N+I,5)**2+P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2) V(N+I,2)=P(N+I,4) PES=PES+P(N+I,4) PQS=PQS+P(N+I,5)**2/P(N+I,4) 530 CONTINUE IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 510 C...Construct transverse momentum for ordinary branching in shower. ELSE ZM=V(IM,1) LOOPPT=0 540 LOOPPT=LOOPPT+1 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5)))) PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5) IF(PZM.LE.0D0) THEN PTS=0D0 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND. & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN PTS=PMLS*ZM*(1D0-ZM)/V(IM,5) ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)- & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2 ELSE PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2 ENDIF IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN ZM=0.05D0+0.9D0*ZM GOTO 540 ELSEIF(PTS.LT.0D0) THEN GOTO 270 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 energies for ordinary branching in shower. 550 IF(NEP.EQ.2.AND.IGM.GT.0) THEN IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND. & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+ & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5) ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN P(N+1,4)=PEM*V(IM,1) ELSE P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+ & SQRT(PMLS)*ZM)/V(IM,5) ENDIF C...Already predetermined choice of phi angle or not PHI=PARU(2)*PYR(0) IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN IPSPD=IP1+IM-NS-2 IF(K(IPSPD,4).GT.0) THEN IPSGD1=K(IPSPD,4) IF(IM.EQ.NS+2) THEN PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2)) ELSE PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2)) ENDIF ENDIF ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN IPSPD=IP1+IM-NS-2 IF(K(IPSPD,4).GT.0) THEN IPSGD1=K(IPSPD,4) PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2)) THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2)) CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0) CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0) PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2)) CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0) ENDIF ENDIF C...Construct momenta for ordinary branching in shower. P(N+1,1)=PT*COS(PHI) P(N+1,2)=PT*SIN(PHI) IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND. & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+ & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5) ELSEIF(PZM.GT.0D0) THEN P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+ & 2D0*PEM*P(N+1,4))/PZM ELSE P(N+1,3)=0D0 ENDIF P(N+2,1)=-P(N+1,1) P(N+2,2)=-P(N+1,2) P(N+2,3)=PZM-P(N+1,3) P(N+2,4)=PEM-P(N+1,4) IF(MSTJ(43).LE.2) THEN V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5) V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5) ENDIF ENDIF C...Rotate and boost daughters. IF(IGM.GT.0) THEN IF(MSTJ(43).LE.2) THEN BEX=P(IGM,1)/P(IGM,4) BEY=P(IGM,2)/P(IGM,4) BEZ=P(IGM,3)/P(IGM,4) GA=P(IGM,4)/P(IGM,5) GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)- & P(IM,4)) ELSE BEX=0D0 BEY=0D0 BEZ=0D0 GA=1D0 GABEP=0D0 ENDIF PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2) THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB) IF(PTIMB.GT.1D-4) THEN PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY) ELSE PHI=0D0 ENDIF DO 560 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) 560 CONTINUE ENDIF C...Weight with azimuthal distribution, if required. IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN DO 570 J=1,3 DPT(1,J)=P(IM,J) DPT(2,J)=P(IAU,J) DPT(3,J)=P(N+1,J) 570 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 580 J=1,3 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM) DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM) 580 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 550 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 550 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 550 ENDIF ENDIF C...Continue loop over partons that may branch, until none left. IF(IGM.GE.0) K(IM,1)=14 N=N+NEP NEP=2 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS') IF(MSTU(21).GE.1) N=NS IF(MSTU(21).GE.1) RETURN ENDIF GOTO 280 C...Set information on imagined shower initiator. 590 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 600 I=NS+1+IIM,N KQ=KCHG(PYCOMP(K(I,2)),2) IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN K(I,1)=1 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND. & IABS(K(I,2)).LE.18) THEN K(I,1)=1 ELSEIF(K(I,1).LE.10) THEN K(I,4)=MSTU(5)*(K(I,4)/MSTU(5)) K(I,5)=MSTU(5)*(K(I,5)/MSTU(5)) ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN ID1=MOD(K(I,4),MSTU(5)) IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND. & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2 K(ID1,4)=K(ID1,4)+MSTU(5)*I K(ID1,5)=K(ID1,5)+MSTU(5)*ID2 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1 K(ID2,5)=K(ID2,5)+MSTU(5)*I ELSE ID1=MOD(K(I,4),MSTU(5)) ID2=ID1+1 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN K(ID1,4)=K(ID1,4)+MSTU(5)*I K(ID1,5)=K(ID1,5)+MSTU(5)*I ELSE K(ID1,4)=0 K(ID1,5)=0 ENDIF K(ID2,4)=0 K(ID2,5)=0 ENDIF 600 CONTINUE C...Transformation from CM frame. IF(NPA.EQ.1) THEN THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2)) PHI=PYANGL(P(IPA(1),1),P(IPA(1),2)) MSTU(33)=1 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0) ELSEIF(NPA.EQ.2) THEN BEX=PS(1)/PS(4) BEY=PS(2)/PS(4) BEZ=PS(3)/PS(4) GA=PS(4)/PS(5) GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3)) & /(1D0+GA)-P(IPA(1),4)) THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1) & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2)) PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY) MSTU(33)=1 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ) ELSE CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4), & PS(3)/PS(4)) MSTU(33)=1 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4)) ENDIF C...Decay vertex of shower. DO 620 I=NS+1,N DO 610 J=1,5 V(I,J)=V(IP1,J) 610 CONTINUE 620 CONTINUE C...Delete trivial shower, else connect initiators. IF(N.LE.NS+NPA+IIM) THEN N=NS ELSE DO 630 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 630 CONTINUE ENDIF RETURN END C********************************************************************* C...PYMAEL C...Auxiliary to PYSHOW. C...Matrix elements for gluon (or photon) emission from C...a two-body state; to be used by the parton shower routine. C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and C...1/sigma_0 d(sigma)/d(x_1)d(x_2) = C... = (alpha-strong/2 pi) * CF * PYMAEL, C...i.e. normalization is such that one recovers the familiar C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case. C...Coupling structure: C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent) C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet) C... = 16-19 : q -> q V C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet) C... = 26-29 : q -> q S C... = 31-34 : V -> ~q ~qbar (~q = squark) C... = 36-39 : ~q -> ~q V C... = 41-44 : S -> ~q ~qbar C... = 46-49 : ~q -> ~q S C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino) C... = 56-59 : ~q -> q chi C... = 61-64 : q -> ~q chi C... = 66-69 : ~g -> q ~qbar C... = 71-74 : ~q -> q ~g C... = 76-79 : q -> ~q ~g C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g C...Note that the order of the decay products is important. C...In each set of four, the variants are ordered as: C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/... C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/.... C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2) C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2) FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...Check input values. Return zero outside allowed phase space. PYMAEL=0D0 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE. &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN ALPCOR=MAX(0D0,MIN(1D0,ALPHA)) C...Initial values and flags. ICLASS=NI/5 ICOMBI=NI-5*ICLASS ISSET1=0 ISSET2=0 ISSET4=0 C... Phase space. PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2)) C...Eikonal expression; also acts as default. IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN RLO=PS IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN ANUM=0D0 ELSEIF(ICOMBI.EQ.2) THEN ANUM=(2D0-X1-X2)**2 ELSEIF(ICOMBI.EQ.3) THEN ANUM=ALPCOR*(2D0-X1-X2)**2 ELSE ANUM=0.5D0*(2D0-X1-X2)**2 ENDIF RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/ & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))- & R1**2/(1D0+R2**2-R1**2-X2)**2- & R2**2/(1D0+R1**2-R2**2-X1)**2) ICOMBI=0 C...V -> q qbar (V = gamma*/Z0/W+-/...). ELSEIF(ICLASS.EQ.2) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2) & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2) & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2) & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/ & (-1+R1**2-R2**2+X2)**2 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2) & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2 & -X1-X2)**2+X1*(2-X1-X2)**2)/ & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2* & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2 RFO1=RFO1/2.D0 ISSET1=1 ENDIF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2) & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2) & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2) & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2 & -X1-X2)**2+X1*(2-X1-X2)**2)/ & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2) & +X2)/(-1-R1**2+R2**2+X1)**2 RFO2=RFO2/2.D0 ISSET2=1 ENDIF IF(ICOMBI.EQ.4) THEN RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/ & (-1-R1**2+R2**2+X1)**2 RFO4=RFO4 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2 & -R1**2*X2**2+X1*X2**2)/ & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/ & (-1+R1**2-R2**2+X2)**2 RFO4=RFO4/2.D0 ISSET4=1 ENDIF C...q -> q V. ELSEIF(ICLASS.EQ.3) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2 & +R1**2*R2**2-2D0*R2**4) RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2) RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2 ISSET1=1 ENDIF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2 & +R1**2*R2**2-2D0*R2**4) RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2 & +X1*X2**2)/(-2+X1+X2)**2 ISSET2=1 ENDIF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4) RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2 & +X1*X2**2)/(2-X1-X2)**2 ISSET4=1 ENDIF C...S -> q qbar (S = h0/H0/A0/H+-/...). ELSEIF(ICLASS.EQ.4) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2) RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 ISSET1=1 ENDIF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2) RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/ & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) ISSET2=1 ENDIF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1D0-R1**2-R2**2) RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/ & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 ISSET4=1 ENDIF C...q -> q S. ELSEIF(ICLASS.EQ.5) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1D0+R1**2-R2**2+2D0*R1) RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (1-R1**2+R2**2-X2)/(-2+X1+X2) & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (-1+R1**2-R2**2+X2)**2 ISSET1=1 ENDIF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1D0+R1**2-R2**2-2D0*R1) RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (1-R1**2+R2**2-X2)/(-2+X1+X2) & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (-1+R1**2-R2**2+X2)**2 ISSET2=1 ENDIF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1D0+R1**2-R2**2) RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2) & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2 ISSET4=1 ENDIF C...V -> ~q ~qbar (~q = squark). ELSEIF(ICLASS.EQ.6) THEN RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4) RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/ & (-1-R1**2+R2**2+X1)**2 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/ & (-1-R1**2+R2**2+X1) & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2) & /(-1+R1**2-R2**2+X2)**2 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/ & (-1+R1**2-R2**2+X2) & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) ISSET1=1 C...~q -> ~q V. ELSEIF(ICLASS.EQ.7) THEN RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4) RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)* & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)* & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)* & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/ & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/ & (3*(-2+X1+X2)) RFO1=3D0*RFO1/8D0 ISSET1=1 C...S -> ~q ~qbar. ELSEIF(ICLASS.EQ.8) THEN RLO1=PS RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2 & -R1**2*X2**2+X1*X2**2)/ & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2 RFO1=2D0*RFO1 ISSET1=1 C...~q -> ~q S. ELSEIF(ICLASS.EQ.9) THEN RLO1=PS RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) & -(X1+X2)/(-2+X1+X2)**2 ISSET1=1 C...chi -> q ~qbar (chi = neutralino/chargino). ELSEIF(ICLASS.EQ.10) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1D0+R1**2-R2**2+2D0*R1) RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/ & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (-1+R1**2-R2**2+X2)**2 ISSET1=1 ENDIF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1D0-2D0*R1+R1**2-R2**2) RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/ & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (-1+R1**2-R2**2+X2)**2 ISSET2=1 ENDIF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1+R1**2-R2**2) RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2 & +X2+R1**2*X2-X1*X2/2)/ & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2 ISSET4=1 ENDIF C...~q -> q chi. ELSEIF(ICLASS.EQ.11) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1D0-(R1+R2)**2) RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) ISSET1=1 ENDIF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1D0-(R1-R2)**2) RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/ & (-2+X1+X2)**2 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) ISSET2=1 ENDIF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1D0-R1**2-R2**2) RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2 & +3*R1**2*X2-R2**2*X2-X1*X2)/ & (-1+R1**2-R2**2+X2)**2 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/ & (2-X1-X2)/(-1+R1**2-R2**2+X2) ISSET4=1 ENDIF C...q -> ~q chi. ELSEIF(ICLASS.EQ.12) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1D0-R1**2+R2**2+2D0*R2) RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/ & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/ & (2-X1-X2)/(-1+R1**2-R2**2+X2) ISSET1=1 END IF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1D0-R1**2+R2**2-2D0*R2) RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/ & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/ & (2-X1-X2)/(-1+R1**2-R2**2+X2) ISSET2=1 END IF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1D0-R1**2+R2**2) RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/ & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2 & +R1**2*X2-X1*X2/2-X2**2/2)/ & (2-X1-X2)/(-1+R1**2-R2**2+X2) ISSET4=1 END IF C...~g -> q ~qbar. ELSEIF(ICLASS.EQ.13) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1D0+R1**2-R2**2+2D0*R1) RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2) & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/ & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (3*(-1+R1**2-R2**2+X2)**2) RFO1=3D0*RFO1/4D0 ISSET1=1 ENDIF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1D0+R1**2-R2**2-2D0*R1) RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2) & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2)) & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/ & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (3*(-1+R1**2-R2**2+X2)**2) RFO2=3D0*RFO2/4D0 ISSET2=1 ENDIF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1D0+R1**2-R2**2) RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/ & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ & (3*(-1+R1**2-R2**2+X2)**2) RFO4=3D0*RFO4/8D0 ISSET4=1 ENDIF C...~q -> q ~g. ELSEIF(ICLASS.EQ.14) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2) RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2) & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2)) & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2) & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2)) RFO1=RFO1 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) RFO1=9D0*RFO1/64D0 ISSET1=1 ENDIF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2) RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2) & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/ & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2)) RFO2=RFO2 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2)) & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) RFO2=9D0*RFO2/64D0 ISSET2=1 ENDIF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1-R1**2-R2**2) RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/ & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2) & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/ & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2)) RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/ & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2)) RFO4=9D0*RFO4/128D0 ISSET4=1 ENDIF C...q -> ~q ~g. ELSEIF(ICLASS.EQ.15) THEN IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN RLO1=PS*(1D0-R1**2+R2**2+2D0*R2) RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2) & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/ & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/ & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2) RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/ & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) RFO1=9D0*RFO1/32D0 ISSET1=1 END IF IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN RLO2=PS*(1D0-R1**2+R2**2-2D0*R2) RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2) & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/ & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/ & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2)) RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/ & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/ & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) RFO2=9D0*RFO2/32D0 ISSET2=1 END IF IF(ICOMBI.EQ.4) THEN RLO4=PS*(1D0-R1**2+R2**2) RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2) & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2 & -R2**2*X2/2-X1*X2/2)/ & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2)) & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2) RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) RFO4=9D0*RFO4/64D0 ISSET4=1 END IF C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future. ELSEIF(ICLASS.EQ.16) THEN RLO=PS IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN ANUM=0D0 ELSEIF(ICOMBI.EQ.2) THEN ANUM=(2D0-X1-X2)**2 ELSEIF(ICOMBI.EQ.3) THEN ANUM=ALPCOR*(2D0-X1-X2)**2 ELSE ANUM=0.5D0*(2D0-X1-X2)**2 ENDIF RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/ & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))- & R1**2/(1D0+R2**2-R1**2-X2)**2- & R2**2/(1D0+R1**2-R2**2-X1)**2) RFO=9D0*RFO/4D0 ICOMBI=0 ENDIF C...Find relevant LO and FO expression. IF(ICOMBI.EQ.0) THEN ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN RLO=RLO1 RFO=RFO1 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN RLO=RLO2 RFO=RFO2 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2 ELSEIF(ISSET4.EQ.1) THEN RLO=RLO4 RFO=RFO4 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN RLO=0.5D0*(RLO1+RLO2) RFO=0.5D0*(RFO1+RFO2) ELSEIF(ISSET1.EQ.1) THEN RLO=RLO1 RFO=RFO1 ELSE CALL PYERRM(16,'(PYMAEL:) not implemented ME code') RLO=1D0 RFO=0D0 ENDIF C...Output. PYMAEL=RFO/RLO RETURN END C********************************************************************* C...PYBOEI C...Modifies an event so as to approximately take into account C...Bose-Einstein effects according to a simple phenomenological C...parametrization. SUBROUTINE PYBOEI(NSAV) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYINT1/MINT(400),VINT(400) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/ C...Local arrays and data. DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100), &BEIW(100),BEI3W(100) DATA KFBE/211,-211,111,321,-321,130,310,221,331/ C...Statement function: squared invariant mass. SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2- &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2) C...Boost event to overall CM frame. Calculate CM energy. IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN DO 100 J=1,4 DPS(J)=0D0 100 CONTINUE DO 120 I=1,N KFA=IABS(K(I,2)) IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22) & .AND.K(I,3).GT.0) THEN KFMA=IABS(K(K(I,3),2)) IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1) ENDIF IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120 DO 110 J=1,4 DPS(J)=DPS(J)+P(I,J) 110 CONTINUE 120 CONTINUE CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4), &-DPS(3)/DPS(4)) PECM=0D0 DO 130 I=1,N IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4) 130 CONTINUE C...Check if we have separated strings C...Reserve copy of particles by species at end of record. IWP=0 IWN=0 NBE(0)=N+MSTU(3) NMAX=NBE(0) SMMIN=PECM DO 190 IBE=1,MIN(10,MSTJ(52)+1) NBE(IBE)=NBE(IBE-1) DO 180 I=NSAV+1,N IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN DO 140 IIBE=1,IBE-1 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180 140 CONTINUE ELSE IF(K(I,2).NE.KFBE(IBE)) GOTO 180 ENDIF IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS') RETURN ENDIF NBE(IBE)=NBE(IBE)+1 NMAX=NBE(IBE) K(NBE(IBE),1)=I K(NBE(IBE),2)=0 K(NBE(IBE),3)=0 K(NBE(IBE),4)=0 K(NBE(IBE),5)=0 P(NBE(IBE),1)=0.0D0 P(NBE(IBE),2)=0.0D0 P(NBE(IBE),3)=0.0D0 P(NBE(IBE),4)=0.0D0 P(NBE(IBE),5)=0.0D0 SMMIN=MIN(SMMIN,P(I,5)) C...Check if particles comes from different W's or Z's IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN IM=I 150 IF(K(IM,3).GT.0) THEN IM=K(IM,3) IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150 K(NBE(IBE),5)=IM IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM ENDIF ENDIF C...Check if particles comes from different strings. IF(PARJ(94).GT.0.0D0) THEN IM=I 160 IF(K(IM,3).GT.0) THEN IM=K(IM,3) IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160 K(NBE(IBE),5)=IM ENDIF ENDIF DO 170 J=1,3 P(NBE(IBE),J)=0D0 V(NBE(IBE),J)=0D0 170 CONTINUE P(NBE(IBE),5)=-1.0D0 180 CONTINUE 190 CONTINUE IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510 C...Calculate separation between W+ and W- or between two Z0's. C...No separation if there has been re-connections. SIGW=PARJ(93) IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN IF(K(IWP,2).EQ.23) THEN DMW=PMAS(23,1) DGW=PMAS(23,2) ELSE DMW=PMAS(24,1) DGW=PMAS(24,2) ENDIF DMP=P(IWP,5) DMN=P(IWN,5) TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2) TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2) TAUP=-TAUPD*LOG(PYR(IDUM)) TAUN=-TAUND*LOG(PYR(IDUM)) DXP=TAUP*PYP(IWP,8)/DMP DXN=TAUN*PYP(IWN,8)/DMN DX=DXP+DXN SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX) IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94)) ENDIF C...Add separation between strings. IF(PARJ(94).GT.0.0D0) THEN SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94)) IWP=-1 IWN=-1 ENDIF IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN DO 220 IBE=1,MIN(9,MSTJ(52)) DO 210 I1M=NBE(IBE-1)+1,NBE(IBE) Q2MIN=PECM**2 I1=K(I1M,1) DO 200 I2M=NBE(IBE-1)+1,NBE(IBE) IF(I2M.EQ.I1M) GOTO 200 I2=K(I2M,1) Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2- & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2- & (P(I1,5)+P(I2,5))**2 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN Q2MIN=Q2 ENDIF 200 CONTINUE P(I1M,5)=Q2MIN 210 CONTINUE 220 CONTINUE ENDIF C...Tabulate integral for subsequent momentum shift. DO 400 IBE=1,MIN(9,MSTJ(52)) IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2)) & .LE.1) GOTO 270 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5), & NBE(7)-NBE(6)).LE.1) GOTO 270 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211) IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321) IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221) IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331) QDEL=0.1D0*MIN(PMHQ,PARJ(93)) QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0) QDELW=0.1D0*MIN(PMHQ,SIGW) QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0) IF(MSTJ(51).EQ.1) THEN NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL)) NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3)) NBINW=MIN(100,NINT(9D0*SIGW/QDELW)) NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W)) BEEX=EXP(0.5D0*QDEL/PARJ(93)) BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93))) BEEXW=EXP(0.5D0*QDELW/SIGW) BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW)) BERT=EXP(-QDEL/PARJ(93)) BERT3=EXP(-QDEL3/(3.0D0*PARJ(93))) BERTW=EXP(-QDELW/SIGW) BERT3W=EXP(-QDEL3W/(3.0D0*SIGW)) ELSE NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL)) NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3)) NBINW=MIN(100,NINT(3D0*SIGW/QDELW)) NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W)) ENDIF DO 230 IBIN=1,NBIN QBIN=QDEL*(IBIN-0.5D0) BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2) IF(MSTJ(51).EQ.1) THEN BEEX=BEEX*BERT BEI(IBIN)=BEI(IBIN)*BEEX ELSE BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2) ENDIF IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1) 230 CONTINUE DO 240 IBIN=1,NBIN3 QBIN=QDEL3*(IBIN-0.5D0) BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2) IF(MSTJ(51).EQ.1) THEN BEEX3=BEEX3*BERT3 BEI3(IBIN)=BEI3(IBIN)*BEEX3 ELSE BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2) ENDIF IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1) 240 CONTINUE DO 250 IBIN=1,NBINW QBIN=QDELW*(IBIN-0.5D0) BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2) IF(MSTJ(51).EQ.1) THEN BEEXW=BEEXW*BERTW BEIW(IBIN)=BEIW(IBIN)*BEEXW ELSE BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2) ENDIF IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1) 250 CONTINUE DO 260 IBIN=1,NBIN3W QBIN=QDEL3W*(IBIN-0.5D0) BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/ & SQRT(QBIN**2+PMHQ**2) IF(MSTJ(51).EQ.1) THEN BEEX3W=BEEX3W*BERT3W BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W ELSE BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2) ENDIF IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1) 260 CONTINUE C...Loop through particle pairs and find old relative momentum. 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1 I1=K(I1M,1) DO 380 I2M=I1M+1,NBE(IBE) IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380 I2=K(I2M,1) Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+ & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2 IF(Q2OLD.LE.0.0D0) GOTO 380 QOLD=SQRT(Q2OLD) C...Calculate new relative momentum. QMOV=0.0D0 QMOV3=0.0D0 QMOVW=0.0D0 QMOV3W=0.0D0 IF(QOLD.LT.1D-3*QDEL) THEN GOTO 280 ELSEIF(QOLD.LE.QDEL) THEN QMOV=QOLD/3D0 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN RBIN=QOLD/QDEL IBIN=RBIN RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1) QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))* & SQRT(Q2OLD+PMHQ**2)/Q2OLD ELSE QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD ENDIF 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0) IF(QOLD.LT.1D-3*QDEL3) THEN GOTO 290 ELSEIF(QOLD.LE.QDEL3) THEN QMOV3=QOLD/3D0 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN RBIN3=QOLD/QDEL3 IBIN3=RBIN3 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1) QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))* & SQRT(Q2OLD+PMHQ**2)/Q2OLD ELSE QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD ENDIF 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0) RSCALE=1.0D0 IF(MSTJ(54).EQ.2) & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2) IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR. & K(I1M,5).EQ.K(I2M,5)) GOTO 320 IF(QOLD.LT.1D-3*QDELW) THEN GOTO 300 ELSEIF(QOLD.LE.QDELW) THEN QMOVW=QOLD/3D0 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN RBINW=QOLD/QDELW IBINW=RBINW RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1) QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))* & SQRT(Q2OLD+PMHQ**2)/Q2OLD ELSE QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD ENDIF 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0) IF(QOLD.LT.1D-3*QDEL3W) THEN GOTO 310 ELSEIF(QOLD.LE.QDEL3W) THEN QMOV3W=QOLD/3D0 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN RBIN3W=QOLD/QDEL3W IBIN3W=RBIN3W RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1) QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)- & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD ELSE QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD ENDIF 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0) IF(MSTJ(54).EQ.2) & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2) 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW) DO 330 J=1,3 P(I1M,J)=P(I1M,J)+P(NMAX+1,J) P(I2M,J)=P(I2M,J)+P(NMAX+2,J) 330 CONTINUE IF(MSTJ(54).GE.1) THEN CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3) DO 340 J=1,3 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE 340 CONTINUE ELSEIF(MSTJ(54).LE.-1) THEN EDEL=P(I1,4)+P(I2,4)- & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0)) A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+ & (P(I1,3)-P(I2,3))**2 WMAX=-1.0D20 MI3=0 MI4=0 S12=SDIP(I1,I2) SM1=(P(I1,5)+SMMIN)**2 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1)) IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND. & K(I3M,5).NE.K(I1M,5)) GOTO 360 I3=K(I3M,1) IF(K(I3,2).EQ.K(I1,2)) GOTO 360 S13=SDIP(I1,I3) S23=SDIP(I2,I3) SM3=(P(I3,5)+SMMIN)**2 IF(MSTJ(54).EQ.-2) THEN WI=(MIN(S12*SM3,S13*MIN(SM1,SM3), & S23*MIN(SM1,SM3))*SM1) ELSE WI=((P(I1,4)+P(I2,4)+P(I3,4))**2- & (P(I1,3)+P(I2,3)+P(I3,3))**2- & (P(I1,2)+P(I2,2)+P(I3,2))**2- & (P(I1,1)+P(I2,1)+P(I3,1))**2) ENDIF IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))) & GOTO 360 ELSE IF(WMAX*WI.GE.1.0) GOTO 360 ENDIF DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1)) IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND. & K(I4M,5).NE.K(I1M,5)) GOTO 350 I4=K(I4M,1) IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2)) & GOTO 350 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT. & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+ & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2) & GOTO 350 IF(MSTJ(54).EQ.-2) THEN S14=SDIP(I1,I4) S24=SDIP(I2,I4) S34=SDIP(I3,I4) W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24) W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23) W=MIN(W,MIN(S23,S24)*S13*S14) W=1.0D0/W ELSE C...weight=1-cos(theta)/mtot2 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2- & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2- & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2- & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2 W=1.0D0/S1234 IF(W.LE.WMAX) GOTO 350 ENDIF IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))) IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0) & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2))) IF(W.LE.WMAX) GOTO 350 MI3=I3M MI4=I4M WMAX=W 350 CONTINUE 360 CONTINUE IF(MI4.EQ.0) GOTO 380 I3=K(MI3,1) I4=K(MI4,1) EOLD=P(I3,4)+P(I4,4) ENEW=EOLD+EDEL P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+ & (P(I3,3)+P(I4,3))**2 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2) Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2) CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP) DO 370 J=1,3 V(MI3,J)=V(MI3,J)+P(NMAX+1,J) V(MI4,J)=V(MI4,J)+P(NMAX+2,J) 370 CONTINUE ENDIF 380 CONTINUE 390 CONTINUE 400 CONTINUE C...Shift momenta and recalculate energies. ESUMP=0.0D0 ESUM=0.0D0 PROD=0.0D0 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1)) I=K(IM,1) ESUMP=ESUMP+P(I,4) DO 410 J=1,3 P(I,J)=P(I,J)+P(IM,J) 410 CONTINUE P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) ESUM=ESUM+P(I,4) DO 420 J=1,3 PROD=PROD+V(IM,J)*P(I,J)/P(I,4) 420 CONTINUE 430 CONTINUE PARJ(96)=0.0D0 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN 440 ALPHA=(ESUMP-ESUM)/PROD PARJ(96)=PARJ(96)+ALPHA PROD=0.0D0 ESUM=0.0D0 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1)) I=K(IM,1) DO 450 J=1,3 P(I,J)=P(I,J)+ALPHA*V(IM,J) 450 CONTINUE P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) ESUM=ESUM+P(I,4) DO 460 J=1,3 PROD=PROD+V(IM,J)*P(I,J)/P(I,4) 460 CONTINUE 470 CONTINUE IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0) & GOTO 440 ENDIF C...Rescale all momenta for energy conservation. PES=0D0 PQS=0D0 DO 480 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480 PES=PES+P(I,4) PQS=PQS+P(I,5)**2/P(I,4) 480 CONTINUE PARJ(95)=PES-PECM FAC=(PECM-PQS)/(PES-PQS) DO 500 I=1,N IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500 DO 490 J=1,3 P(I,J)=FAC*P(I,J) 490 CONTINUE P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) 500 CONTINUE C...Boost back to correct reference frame. 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4)) DO 520 I=1,N IF(K(I,1).LT.0) K(I,1)=-K(I,1) 520 CONTINUE RETURN END C********************************************************************* C...PYBESQ C...Calculates the momentum shift in a system of two particles assuming C...the relative momentum squared should be shifted to Q2NEW. NI is the C...last position occupied in /PYJETS/. SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYJETS/,/PYDAT1/ C...Local arrays and data. DIMENSION DP(5) SAVE HC1 IF(MSTJ(55).EQ.0) THEN DQ2=Q2NEW-Q2OLD DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+ & (P(I1,3)-P(I2,3))**2 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2 SE=P(I1,4)+P(I2,4) DE=P(I1,4)-P(I2,4) DQ2SE=DQ2+SE**2 DA=SE*DE*DP12-DP2*DQ2SE DB=DP2*DQ2SE-DP12**2 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB) DO 100 J=1,3 PD=HA*(P(I1,J)-P(I2,J)) P(NI+1,J)=PD P(NI+2,J)=-PD 100 CONTINUE RETURN ENDIF K(NI+1,1)=1 K(NI+2,1)=1 DO 110 J=1,5 P(NI+1,J)=P(I1,J) P(NI+2,J)=P(I2,J) DP(J)=P(I1,J)+P(I2,J) 110 CONTINUE C...Boost to cms and rotate first particle to z-axis CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0, &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4)) PHI=PYANGL(P(NI+1,1),P(NI+1,2)) THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2)) S=Q2NEW+(P(I1,5)+P(I2,5))**2 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S) P(NI+1,1)=0.0D0 P(NI+1,2)=0.0D0 P(NI+1,3)=PZ P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2) P(NI+2,1)=0.0D0 P(NI+2,2)=0.0D0 P(NI+2,3)=-PZ P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2) DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S) CALL PYROBO(NI+1,NI+2,THE,PHI, &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4)) DO 120 J=1,3 P(NI+1,J)=P(NI+1,J)-P(I1,J) P(NI+2,J)=P(NI+2,J)-P(I2,J) 120 CONTINUE RETURN END C********************************************************************* C...PYMASS C...Gives the mass of a particle/parton. FUNCTION PYMASS(KF) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C...Reset variables. Compressed code. Special case for popcorn diquarks. PYMASS=0D0 KFA=IABS(KF) KC=PYCOMP(KF) IF(KC.EQ.0) THEN MSTJ(93)=0 RETURN ENDIF C...Guarantee use of constituent masses for internal checks. IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND. &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN IF(KFA.LE.5) THEN PYMASS=PARF(100+KFA) IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121)) ELSEIF(KFA.LE.10) THEN PYMASS=PMAS(KFA,1) ELSEIF(MSTJ(93).EQ.1) THEN PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10)) ELSE PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0) ENDIF C...Other masses can be read directly off table. ELSE PYMASS=PMAS(KC,1) ENDIF C...Optional mass broadening according to truncated Breit-Wigner C...(either in m or in m^2). IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)* & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2))) ELSE PM0=PYMASS PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/ & (PM0*PMAS(KC,2))) PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2))) PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+ & (PMUPP-PMLOW)*PYR(0)))) ENDIF ENDIF MSTJ(93)=0 RETURN END C********************************************************************* C...PYMRUN C...Gives the running, current-algebra mass of a d, u, s, c or b quark, C...for Higgs couplings. Everything else sent on to PYMASS. FUNCTION PYMRUN(KF,Q2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) SAVE /PYDAT1/,/PYDAT2/,/PYPARS/ C...Most masses not handled here. KFA=IABS(KF) IF(KFA.EQ.0.OR.KFA.GT.6) THEN PYMRUN=PYMASS(KF) C...Current-algebra masses, but no Q2 dependence. ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN PYMRUN=PARF(90+KFA) C...Running current-algebra masses. ELSE AS=PYALPS(Q2) PYMRUN=PARF(90+KFA)* & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/ & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118))) ENDIF RETURN END C********************************************************************* C...PYNAME C...Gives the particle/parton name as a character string. SUBROUTINE PYNAME(KF,CHAU) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT4/CHAF(500,2) CHARACTER CHAF*16 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/ C...Local character variable. CHARACTER CHAU*16 C...Read out code with distinction particle/antiparticle. CHAU=' ' KC=PYCOMP(KF) IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2) RETURN END C********************************************************************* C...PYCHGE C...Gives three times the charge for a particle/parton. FUNCTION PYCHGE(KF) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT2/ C...Read out charge and change sign for antiparticle. PYCHGE=0 KC=PYCOMP(KF) IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF) RETURN END C********************************************************************* C...PYCOMP C...Compress the standard KF codes for use in mass and decay arrays; C...also checks whether a given code actually is defined. FUNCTION PYCOMP(KF) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C...Local arrays and saved data. DIMENSION KFORD(100:500),KCORD(101:500) SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST C...Whenever necessary reorder codes for faster search. IF(MSTU(20).EQ.0) THEN NFORD=100 KFORD(100)=0 DO 120 I=101,500 KFA=KCHG(I,4) IF(KFA.LE.100) GOTO 120 NFORD=NFORD+1 DO 100 I1=NFORD-1,0,-1 IF(KFA.GE.KFORD(I1)) GOTO 110 KFORD(I1+1)=KFORD(I1) KCORD(I1+1)=KCORD(I1) 100 CONTINUE 110 KFORD(I1+1)=KFA KCORD(I1+1)=I 120 CONTINUE MSTU(20)=1 KFLAST=0 KCLAST=0 ENDIF C...Fast action if same code as in latest call. IF(KF.EQ.KFLAST) THEN PYCOMP=KCLAST RETURN ENDIF C...Starting values. Remove internal diquark flags. PYCOMP=0 KFA=IABS(KF) IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000) C...Simple cases: direct translation. IF(KFA.GT.KFORD(NFORD)) THEN ELSEIF(KFA.LE.100) THEN PYCOMP=KFA C...Else binary search. ELSE IMIN=100 IMAX=NFORD+1 130 IAVG=(IMIN+IMAX)/2 IF(KFORD(IAVG).GT.KFA) THEN IMAX=IAVG IF(IMAX.GT.IMIN+1) GOTO 130 ELSEIF(KFORD(IAVG).LT.KFA) THEN IMIN=IAVG IF(IMAX.GT.IMIN+1) GOTO 130 ELSE PYCOMP=KCORD(IAVG) ENDIF ENDIF C...Check if antiparticle allowed. IF(PYCOMP.NE.0.AND.KF.LT.0) THEN IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0 ENDIF C...Save codes for possible future fast action. KFLAST=KF KCLAST=PYCOMP RETURN END C********************************************************************* C...PYERRM C...Informs user of errors in program execution. SUBROUTINE PYERRM(MERR,CHMESS) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYJETS/,/PYDAT1/ C...Local character variable. CHARACTER CHMESS*(*) C...Write first few warnings, then be silent. IF(MERR.LE.10) THEN MSTU(27)=MSTU(27)+1 MSTU(28)=MERR IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000) & MERR,MSTU(31),CHMESS C...Write first few errors, then be silent or stop program. ELSEIF(MERR.LE.20) THEN 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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Calculate real part of photon vacuum polarization. C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions. C...For hadrons use parametrization of H. Burkhardt et al. C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131. AEMPI=PARU(101)/(3D0*PARU(1)) IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN RPIGG=0D0 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN RPIGG=0D0 ELSEIF(MSTU(101).EQ.2) THEN RPIGG=1D0-PARU(101)/PARU(103) ELSEIF(Q2.LT.0.09D0) THEN RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2) ELSEIF(Q2.LT.9D0) THEN RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+ & 0.00238D0*LOG(1D0+3.927D0*Q2) ELSEIF(Q2.LT.1D4) THEN RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+ & 0.00299D0*LOG(1D0+Q2) ELSE RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+ & 0.00293D0*LOG(1D0+Q2) ENDIF C...Calculate running alpha_em. PYALEM=PARU(101)/(1D0-RPIGG) PARU(108)=PYALEM RETURN END C********************************************************************* C...PYALPS C...Gives the value of alpha_strong. FUNCTION PYALPS(Q2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C...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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ PYANGL=0D0 R=SQRT(X**2+Y**2) IF(R.LT.1D-20) RETURN IF(ABS(X)/R.LT.0.8D0) THEN PYANGL=SIGN(ACOS(X/R),Y) ELSE PYANGL=ASIN(Y/R) IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN PYANGL=PARU(1)-PYANGL ELSEIF(X.LT.0D0) THEN PYANGL=-PARU(1)-PYANGL ENDIF ENDIF RETURN END C********************************************************************* C...PYR C...Generates random numbers uniformly distributed between C...0 and 1, excluding the endpoints. * FUNCTION PYR(IDUMMY) * *C...Double precision and integer declarations. * IMPLICIT DOUBLE PRECISION(A-H, O-Z) * IMPLICIT INTEGER(I-N) * INTEGER PYK,PYCHGE,PYCOMP *C...Commonblocks. * COMMON/PYDATR/MRPY(6),RRPY(100) * SAVE /PYDATR/ *C...Equivalence between commonblock and local variables. * EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)), * &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)), * &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100)) * *C...Initialize generation from given seed. * IF(MRPY2.EQ.0) THEN * IJ=MOD(MRPY1/30082,31329) * KL=MOD(MRPY1,30082) * I=MOD(IJ/177,177)+2 * J=MOD(IJ,177)+2 * K=MOD(KL/169,178)+1 * L=MOD(KL,169) * DO 110 II=1,97 * S=0D0 * T=0.5D0 * DO 100 JJ=1,48 * M=MOD(MOD(I*J,179)*K,179) * I=J * J=K * K=M * L=MOD(53*L+1,169) * IF(MOD(L*M,64).GE.32) S=S+T * T=0.5D0*T * 100 CONTINUE * RRPY(II)=S * 110 CONTINUE * TWOM24=1D0 * DO 120 I24=1,24 * TWOM24=0.5D0*TWOM24 * 120 CONTINUE * RRPY98=362436D0*TWOM24 * RRPY99=7654321D0*TWOM24 * RRPY00=16777213D0*TWOM24 * MRPY2=1 * MRPY3=0 * MRPY4=97 * MRPY5=33 * ENDIF * *C...Generate next random number. * 130 RUNI=RRPY(MRPY4)-RRPY(MRPY5) * IF(RUNI.LT.0D0) RUNI=RUNI+1D0 * RRPY(MRPY4)=RUNI * MRPY4=MRPY4-1 * IF(MRPY4.EQ.0) MRPY4=97 * MRPY5=MRPY5-1 * IF(MRPY5.EQ.0) MRPY5=97 * RRPY98=RRPY98-RRPY99 * IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00 * RUNI=RUNI-RRPY98 * IF(RUNI.LT.0D0) RUNI=RUNI+1D0 * IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130 * *C...Update counters. Random number to output. * MRPY3=MRPY3+1 * IF(MRPY3.EQ.1000000000) THEN * MRPY2=MRPY2+1 * MRPY3=0 * ENDIF * PYR=RUNI * * RETURN * END * C********************************************************************* * C...PYRGET C...Dumps the state of the random number generator on a file C...for subsequent startup from this state onwards. * * SUBROUTINE PYRGET(LFN,MOVE) * C...Double precision and integer declarations. * IMPLICIT DOUBLE PRECISION(A-H, O-Z) * IMPLICIT INTEGER(I-N) * INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. * COMMON/PYDATR/MRPY(6),RRPY(100) * SAVE /PYDATR/ C...Local character variable. * CHARACTER CHERR*8 * C...Backspace required number of records (or as many as there are). * IF(MOVE.LT.0) THEN * NBCK=MIN(MRPY(6),-MOVE) * DO 100 IBCK=1,NBCK * BACKSPACE(LFN,ERR=110,IOSTAT=IERR) * 100 CONTINUE * MRPY(6)=MRPY(6)-NBCK * ENDIF * C...Unformatted write on unit LFN. * WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5), * &(RRPY(I2),I2=1,100) * MRPY(6)=MRPY(6)+1 * RETURN * C...Write error. * 110 WRITE(CHERR,'(I8)') IERR * CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='// * &CHERR) * * RETURN * END * C********************************************************************* C...PYRSET C...Reads a state of the random number generator from a file C...for subsequent generation from this state onwards. * * SUBROUTINE PYRSET(LFN,MOVE) * C...Double precision and integer declarations. * IMPLICIT DOUBLE PRECISION(A-H, O-Z) * IMPLICIT INTEGER(I-N) * INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. * COMMON/PYDATR/MRPY(6),RRPY(100) * SAVE /PYDATR/ C...Local character variable. * CHARACTER CHERR*8 * C...Backspace required number of records (or as many as there are). * IF(MOVE.LT.0) THEN * NBCK=MIN(MRPY(6),-MOVE) * DO 100 IBCK=1,NBCK * BACKSPACE(LFN,ERR=120,IOSTAT=IERR) * 100 CONTINUE * MRPY(6)=MRPY(6)-NBCK * ENDIF * C...Unformatted read from unit LFN. * NFOR=1+MAX(0,MOVE) * DO 110 IFOR=1,NFOR * READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5), * & (RRPY(I2),I2=1,100) * 110 CONTINUE * MRPY(6)=MRPY(6)+NFOR * RETURN * C...Write error. * 120 WRITE(CHERR,'(I8)') IERR * CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='// * &CHERR) * * RETURN * END * C********************************************************************* C...PYROBO C...Performs rotations and boosts. SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYJETS/,/PYDAT1/ C...Local arrays. DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4) C...Find and check range of rotation/boost. IMIN=IMI IF(IMIN.LE.0) IMIN=1 IF(MSTU(1).GT.0) IMIN=MSTU(1) IMAX=IMA IF(IMAX.LE.0) IMAX=N IF(MSTU(2).GT.0) IMAX=MSTU(2) IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory') RETURN ENDIF C...Optional resetting of V (when not set before.) IF(MSTU(33).NE.0) THEN DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4)) DO 100 J=1,5 V(I,J)=0D0 100 CONTINUE 110 CONTINUE MSTU(33)=0 ENDIF C...Rotate, typically from z axis to direction (theta,phi). IF(THE**2+PHI**2.GT.1D-20) THEN ROT(1,1)=COS(THE)*COS(PHI) ROT(1,2)=-SIN(PHI) ROT(1,3)=SIN(THE)*COS(PHI) ROT(2,1)=COS(THE)*SIN(PHI) ROT(2,2)=COS(PHI) ROT(2,3)=SIN(THE)*SIN(PHI) ROT(3,1)=-SIN(THE) ROT(3,2)=0D0 ROT(3,3)=COS(THE) DO 140 I=IMIN,IMAX IF(K(I,1).LE.0) GOTO 140 DO 120 J=1,3 PR(J)=P(I,J) VR(J)=V(I,J) 120 CONTINUE DO 130 J=1,3 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3) V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3) 130 CONTINUE 140 CONTINUE ENDIF C...Boost, typically from rest to momentum/energy=beta. IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN DBX=BEX DBY=BEY DBZ=BEZ DB=SQRT(DBX**2+DBY**2+DBZ**2) EPS1=1D0-1D-12 IF(DB.GT.EPS1) THEN C...Rescale boost vector if too close to unity. CALL PYERRM(3,'(PYROBO:) boost vector too large') DBX=DBX*(EPS1/DB) DBY=DBY*(EPS1/DB) DBZ=DBZ*(EPS1/DB) DB=EPS1 ENDIF DGA=1D0/SQRT(1D0-DB**2) DO 160 I=IMIN,IMAX IF(K(I,1).LE.0) GOTO 160 DO 150 J=1,4 DP(J)=P(I,J) DV(J)=V(I,J) 150 CONTINUE DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3) DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4)) P(I,1)=DP(1)+DGABP*DBX P(I,2)=DP(2)+DGABP*DBY P(I,3)=DP(3)+DGABP*DBZ P(I,4)=DGA*(DP(4)+DBP) DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3) DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4)) V(I,1)=DV(1)+DGABV*DBX V(I,2)=DV(2)+DGABV*DBY V(I,3)=DV(3)+DGABV*DBZ V(I,4)=DGA*(DV(4)+DBV) 160 CONTINUE ENDIF RETURN END C********************************************************************* C...PYEDIT C...Performs global manipulations on the event record, in particular C...to exclude unstable or undetectable partons/particles. SUBROUTINE PYEDIT(MEDIT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter statement to help give large particle numbers. PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, &KEXCIT=4000000,KDIMEN=5000000) C...HEPEVT commonblock. PARAMETER (NMXHEP=4000) COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) DOUBLE PRECISION PHEP,VHEP SAVE /HEPEVT/ C...User process event common block. INTEGER MAXNUP PARAMETER (MAXNUP=500) INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), &VTIMUP(MAXNUP),SPINUP(MAXNUP) SAVE /HEPEUP/ C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) 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) GOTO 120 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120 C...Get particle name, pad it and check it is not too long. CALL PYNAME(K(I,2),CHAP) LEN=0 DO 100 LEM=1,16 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM 100 CONTINUE MDL=(K(I,1)+19)/10 LDL=0 IF(MDL.EQ.2.OR.MDL.GE.8) THEN CHAC=CHAP IF(LEN.GT.LMX) CHAC(LMX:LMX)='?' ELSE LDL=1 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2 IF(LEN.EQ.0) THEN CHAC=CHDL(MDL)(1:2*LDL)//' ' ELSE CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))// & CHDL(MDL)(LDL+1:2*LDL)//' ' IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?' ENDIF ENDIF C...Add information on string connection. IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12) & THEN KC=PYCOMP(K(I,2)) KCC=0 IF(KC.NE.0) KCC=KCHG(KC,2) IF(IABS(K(I,2)).EQ.39) THEN IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X' ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN ISTR=1 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A' ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I' ELSEIF(KCC.NE.0) THEN ISTR=0 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V' ENDIF ENDIF 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...Simple listing of HEPEVT entries (mainly for test purposes). ELSEIF(MLIST.EQ.5) THEN WRITE(MSTU(11),7500) DO 140 I=1,NHEP IF(ISTHEP(I).EQ.0) GOTO 140 WRITE(MSTU(11),7600) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I), & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5) 140 CONTINUE C...Simple listing of user-process entries (mainly for test purposes). ELSEIF(MLIST.EQ.7) THEN WRITE(MSTU(11),7300) DO 150 I=1,NUP WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I), & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5) 150 CONTINUE C...Give simple list of KF codes defined in program. ELSEIF(MLIST.EQ.11) THEN WRITE(MSTU(11),6600) DO 160 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 160 CONTINUE DO 190 KFLS=1,3,2 DO 180 KFLA=1,5 DO 170 KFLB=1,KFLA-(3-KFLS)/2 KF=1000*KFLA+100*KFLB+KFLS CALL PYNAME(KF,CHAP) CALL PYNAME(-KF,CHAN) WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN 170 CONTINUE 180 CONTINUE 190 CONTINUE DO 220 KMUL=0,5 KFLS=3 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1 IF(KMUL.EQ.5) KFLS=5 KFLR=0 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1 IF(KMUL.EQ.4) KFLR=2 DO 210 KFLB=1,5 DO 200 KFLC=1,KFLB-1 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS CALL PYNAME(KF,CHAP) CALL PYNAME(-KF,CHAN) WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN IF(KF.EQ.311) THEN KFK=130 CALL PYNAME(KFK,CHAP) WRITE(MSTU(11),6700) KFK,CHAP KFK=310 CALL PYNAME(KFK,CHAP) WRITE(MSTU(11),6700) KFK,CHAP ENDIF 200 CONTINUE KF=10000*KFLR+110*KFLB+KFLS CALL PYNAME(KF,CHAP) WRITE(MSTU(11),6700) KF,CHAP 210 CONTINUE 220 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 260 KFLSP=1,3 KFLS=2+2*(KFLSP/3) DO 250 KFLA=1,5 DO 240 KFLB=1,KFLA DO 230 KFLC=1,KFLB IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC)) & GOTO 230 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS CALL PYNAME(KF,CHAP) CALL PYNAME(-KF,CHAN) WRITE(MSTU(11),6700) KF,CHAP,-KF,CHAN 230 CONTINUE 240 CONTINUE 250 CONTINUE 260 CONTINUE DO 270 KC=1,500 KF=KCHG(KC,4) IF(KF.LT.1000000) GOTO 270 CALL PYNAME(KF,CHAP) CALL PYNAME(-KF,CHAN) IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),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) 7300 FORMAT(/10X,'Event listing of user process at input (simplified)' &//' I IST ID Mothers Colours p_x p_y p_z', &' E m') 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3) 7500 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)' &//' I IST ID Mothers Daughters p_x p_y p_z', &' E m') 7600 FORMAT(1X,I4,I2,I8,4I5,5F9.3) RETURN END C********************************************************************* C...PYLOGO C...Writes a logo for the program. SUBROUTINE PYLOGO C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Parameter for length of information block. PARAMETER (IREFER=18) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) SAVE /PYDAT1/,/PYPARS/ C...Local arrays and character variables. INTEGER IDATI(6) CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79, &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2 C...Data on months, logo, titles, and references. DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep', &'Oct','Nov','Dec'/ DATA (LOGO(J),J=1,19)/ &' *......* ', &' *:::!!:::::::::::* ', &' *::::::!!::::::::::::::* ', &' *::::::::!!::::::::::::::::* ', &' *:::::::::!!:::::::::::::::::* ', &' *:::::::::!!:::::::::::::::::* ', &' *::::::::!!::::::::::::::::*! ', &' *::::::!!::::::::::::::* !! ', &' !! *:::!!:::::::::::* !! ', &' !! !* -><- * !! ', &' !! !! !! ', &' !! !! !! ', &' !! !! ', &' !! lh !! ', &' !! !! ', &' !! hh !! ', &' !! ll !! ', &' !! !! ', &' !! '/ DATA (LOGO(J),J=20,38)/ &'Welcome to the Lund Monte Carlo!', &' ', &'PPP Y Y TTTTT H H III A ', &'P P Y Y T H H I A A ', &'PPP Y T HHHHH I AAAAA', &'P Y T H H I A A', &'P Y T H H III A A', &' ', &'This is PYTHIA version x.xxx ', &'Last date of change: xx xxx 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 (2001) '/ DATA (REFER(J),J=1,18)/ &'An archive of program versions and d', &'ocumentation is found on the web: ', &'http://www.thep.lu.se/~torbjorn/Pyth', &'ia.html ', &' ', &' ', &'When you cite this program, currentl', &'y the official reference is ', &'T. Sjostrand, P. Eden, C. Friberg, L', &'. Lonnblad, G. Miu, S. Mrenna and ', &'E. Norrbin, Computer Physics Commun.', &' 135 (2001) 238. ', &'The large manual is ', &' ', &'T. Sjostrand, L. Lonnblad and S. Mre', &'nna, LU TP 01-21 [hep-ph/0108264]. ', &'Also remember that the program, to a', &' large extent, represents original '/ DATA (REFER(J),J=19,2*IREFER)/ &'physics research. Other publications', &' of special relevance to your ', &'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, Physics', &' Department, UC Davis, ', &' One Shields Avenue, Davis, CA 9561', &'6, USA; ', &' phone: + 1 - 530 - 752 - 2661; e-m', &'ail: mrenna@physics.ucdavis.edu '/ C...Check that PYDATA linked. IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN WRITE(*,'(1X,A)') & 'Error: PYDATA has not been linked.' WRITE(*,'(1X,A)') 'Execution stopped!' STOP C...Write current version number and current date+time. ELSE WRITE(VERS,'(I1)') MSTP(181) LOGO(28)(24:24)=VERS WRITE(SUBV,'(I3)') MSTP(182) LOGO(28)(26:28)=SUBV IF(MSTP(182).LT.100) LOGO(28)(26:26)='0' WRITE(DATE,'(I2)') MSTP(185) LOGO(29)(22:23)=DATE LOGO(29)(25:27)=MONTH(MSTP(184)) WRITE(YEAR,'(I4)') MSTP(183) LOGO(29)(29:32)=YEAR CALL PYTIME(IDATI) IF(IDATI(1).LE.0) THEN LOGO(31)=' ' ELSE WRITE(DATE,'(I2)') IDATI(3) LOGO(31)(8:9)=DATE LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2)))) WRITE(YEAR,'(I4)') IDATI(1) LOGO(31)(15:18)=YEAR WRITE(HOUR,'(I2)') IDATI(4) LOGO(31)(23:24)=HOUR WRITE(MINU,'(I2)') IDATI(5) LOGO(31)(26:27)=MINU IF(IDATI(5).LT.10) LOGO(31)(26:26)='0' WRITE(SECO,'(I2)') IDATI(6) LOGO(31)(29:30)=SECO IF(IDATI(6).LT.10) LOGO(31)(29:29)='0' ENDIF ENDIF C...Loop over lines in header. Define page feed and side borders. DO 100 ILIN=1,29+IREFER LINE=' ' IF(ILIN.EQ.1) THEN LINE(1:1)='1' ELSE LINE(2:3)='**' LINE(78:79)='**' ENDIF C...Separator lines and logos. IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN LINE(4:77)='***********************************************'// & '***************************' ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN LINE(6:37)=LOGO(ILIN-5) LINE(44:75)=LOGO(ILIN+14) ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN LINE(5:40)=REFER(2*ILIN-51) LINE(41:76)=REFER(2*ILIN-50) ENDIF C...Write lines to appropriate unit. WRITE(MSTU(11),'(A79)') LINE 100 CONTINUE RETURN END C********************************************************************* C...PYUPDA C...Facilitates the updating of particle and decay data C...by allowing it to be done in an external file. SUBROUTINE PYUPDA(MUPDA,LFN) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) COMMON/PYDAT4/CHAF(500,2) CHARACTER CHAF*16 COMMON/PYINT4/MWID(500),WIDS(500,5) SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/ C...Local arrays, character variables and data. CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72, &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)', &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)', &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ', &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)', &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/ C...Write header if not yet done. IF(MSTU(12).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.AND.MDCY(KCREP,3).GT.0) THEN IDCREP=MDCY(KCREP,2) NDCREP=MDCY(KCREP,3) DO 160 I=1,KCC IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP 160 CONTINUE DO 180 I=IDCREP,NDC-NDCREP MDME(I,1)=MDME(I+NDCREP,1) MDME(I,2)=MDME(I+NDCREP,2) BRAT(I)=BRAT(I+NDCREP) DO 170 J=1,5 KFDP(I,J)=KFDP(I+NDCREP,J) 170 CONTINUE 180 CONTINUE NDC=NDC-NDCREP KC=KCREP ELSEIF(KCREP.NE.0) THEN KC=KCREP ELSE KCC=KCC+1 KC=KCC ENDIF ENDIF C...Study line with particle data. IF(KC.GT.MSTU(6)) CALL PYERRM(27, & '(PYUPDA:) Particle arrays full by KF ='//CHKF) READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2), & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4), & MWID(KC),MDCY(KC,1) MDCY(KC,2)=0 MDCY(KC,3)=0 C...Study line with decay data. ELSE NDC=NDC+1 IF(NDC.GT.MSTU(7)) CALL PYERRM(27, & '(PYUPDA:) Decay data arrays full by KF ='//CHKF) IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC MDCY(KC,3)=MDCY(KC,3)+1 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC), & (KFDP(NDC,J),J=1,5) ENDIF C...End of loop; ensure that PYCOMP tables are updated. GOTO 140 190 CONTINUE MSTU(20)=0 C...Perform possible tests that new information is consistent. DO 220 KC=1,MSTU(6) KF=KCHG(KC,4) IF(KF.EQ.0) GOTO 220 WRITE(CHKF,5300) KF IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3), & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17, & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF) BRSUM=0D0 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 IF(MDME(IDC,2).GT.80) GOTO 210 KQ=KCHG(KC,1) PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64) MERR=0 DO 200 J=1,5 KP=KFDP(IDC,J) IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN IF(KP.EQ.81) KQ=0 ELSEIF(PYCOMP(KP).EQ.0) THEN MERR=3 ELSE KQ=KQ-PYCHGE(KP) KPC=PYCOMP(KP) PMS=PMS-PMAS(KPC,1) IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2), & PMAS(KPC,3)) ENDIF 200 CONTINUE IF(KQ.NE.0) MERR=MAX(2,MERR) IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0) & MERR=MAX(1,MERR) IF(MERR.EQ.3) CALL PYERRM(17, & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF) IF(MERR.EQ.2) CALL PYERRM(17, & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF) IF(MERR.EQ.1) CALL PYERRM(7, & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF) BRSUM=BRSUM+BRAT(IDC) 210 CONTINUE WRITE(CHTMP,5500) BRSUM IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0) & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '// & CHTMP(9:16)//' for KF ='//CHKF) 220 CONTINUE C...Write DATA statements for inclusion in program. ELSEIF(MUPDA.EQ.4) THEN C...Find out how many codes and decay channels are actually used. KCC=0 NDC=0 DO 230 I=1,MSTU(6) IF(KCHG(I,4).NE.0) THEN KCC=I NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1) ENDIF 230 CONTINUE C...Initialize writing of DATA statements for inclusion in program. DO 300 IVAR=1,22 NDIM=MSTU(6) IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7) NLIN=1 CHLIN=' ' CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/' LLIN=35 CHOLD='START' C...Loop through variables for conversion to characters. DO 280 IDIM=1,NDIM IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1) IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2) IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3) IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4) IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1) IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2) IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3) IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4) IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1) IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2) IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3) IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1) IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2) IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM) IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1) IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2) IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3) IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4) IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5) IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1) IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2) IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM) C...Replace variables beyond what is properly defined. IF(IVAR.LE.4) THEN IF(IDIM.GT.KCC) CHTMP=' 0' ELSEIF(IVAR.LE.8) THEN IF(IDIM.GT.KCC) CHTMP=' 0.0' ELSEIF(IVAR.LE.11) THEN IF(IDIM.GT.KCC) CHTMP=' 0' ELSEIF(IVAR.LE.13) THEN IF(IDIM.GT.NDC) CHTMP=' 0' ELSEIF(IVAR.LE.14) THEN IF(IDIM.GT.NDC) CHTMP=' 0.0' ELSEIF(IVAR.LE.19) THEN IF(IDIM.GT.NDC) CHTMP=' 0' ELSEIF(IVAR.LE.21) THEN IF(IDIM.GT.KCC) CHTMP=' ' ELSE IF(IDIM.GT.KCC) CHTMP=' 0' ENDIF C...Length of variable, trailing decimal zeros, quotation marks. LLOW=1 LHIG=1 DO 240 LL=1,16 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL IF(CHTMP(LL:LL).NE.' ') LHIG=LL 240 CONTINUE CHNEW=CHTMP(LLOW:LHIG)//' ' LNEW=1+LHIG-LLOW IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN LNEW=LNEW+1 250 LNEW=LNEW-1 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1 IF(LNEW.EQ.0) THEN CHNEW(1:3)='0D0' LNEW=3 ELSE CHNEW(LNEW+1:LNEW+2)='D0' LNEW=LNEW+2 ENDIF ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN DO 260 LL=LNEW,1,-1 IF(CHNEW(LL:LL).EQ.'''') THEN CHTMP=CHNEW CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11) LNEW=LNEW+1 ENDIF 260 CONTINUE LNEW=MIN(14,LNEW) CHTMP=CHNEW CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//'''' LNEW=LNEW+2 ENDIF C...Form composite character string, often including repetition counter. IF(CHNEW.NE.CHOLD) THEN NRPT=1 CHOLD=CHNEW CHCOM=CHNEW LCOM=LNEW ELSE LRPT=LNEW+1 IF(NRPT.GE.2) LRPT=LNEW+3 IF(NRPT.GE.10) LRPT=LNEW+4 IF(NRPT.GE.100) LRPT=LNEW+5 IF(NRPT.GE.1000) LRPT=LNEW+6 LLIN=LLIN-LRPT NRPT=NRPT+1 WRITE(CHTMP,5400) NRPT LRPT=1 IF(NRPT.GE.10) LRPT=2 IF(NRPT.GE.100) LRPT=3 IF(NRPT.GE.1000) LRPT=4 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW) LCOM=LRPT+1+LNEW ENDIF C...Add characters to end of line, to new line (after storing old line), C...or to new block of lines (after writing old block). IF(LLIN+LCOM.LE.70) THEN CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//',' LLIN=LLIN+LCOM+1 ELSEIF(NLIN.LE.19) THEN CHLIN(LLIN+1:72)=' ' CHBLK(NLIN)=CHLIN NLIN=NLIN+1 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//',' LLIN=6+LCOM+1 ELSE CHLIN(LLIN:72)='/'//' ' CHBLK(NLIN)=CHLIN WRITE(CHTMP,5400) IDIM-NRPT CHBLK(1)(30:33)=CHTMP(13:16) DO 270 ILIN=1,NLIN WRITE(LFN,5700) CHBLK(ILIN) 270 CONTINUE NLIN=1 CHLIN=' ' CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)// & ',I= , )/'//CHCOM(1:LCOM)//',' WRITE(CHTMP,5400) IDIM-NRPT+1 CHLIN(25:28)=CHTMP(13:16) LLIN=35+LCOM+1 ENDIF 280 CONTINUE C...Write final block of lines. CHLIN(LLIN:72)='/'//' ' CHBLK(NLIN)=CHLIN WRITE(CHTMP,5400) NDIM CHBLK(1)(30:33)=CHTMP(13:16) DO 290 ILIN=1,NLIN WRITE(LFN,5700) CHBLK(ILIN) 290 CONTINUE 300 CONTINUE ENDIF C...Formats for reading and writing particle data. 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3) 5100 FORMAT(10X,2I5,F12.6,5I10) 5200 FORMAT(A120) 5300 FORMAT(I9) 5400 FORMAT(I16) 5500 FORMAT(F16.5) 5600 FORMAT(F16.6) 5700 FORMAT(A72) RETURN END C********************************************************************* C...PYK C...Provides various integer-valued event related data. FUNCTION PYK(I,J) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Default value. For I=0 number of entries, number of stable entries C...or 3 times total charge. PYK=0 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN ELSEIF(I.EQ.0.AND.J.EQ.1) THEN PYK=N ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN DO 100 I1=1,N IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+ & PYCHGE(K(I1,2)) 100 CONTINUE ELSEIF(I.EQ.0) THEN C...For I > 0 direct readout of K matrix or charge. ELSEIF(J.LE.5) THEN PYK=K(I,J) ELSEIF(J.EQ.6) THEN PYK=PYCHGE(K(I,2)) C...Status (existing/fragmented/decayed), parton/hadron separation. ELSEIF(J.LE.8) THEN IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1 IF(J.EQ.8) PYK=PYK*K(I,2) ELSEIF(J.LE.12) THEN KFA=IABS(K(I,2)) KC=PYCOMP(KFA) KQ=0 IF(KC.NE.0) KQ=KCHG(KC,2) IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2) IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2) IF(J.EQ.11) PYK=KC IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2)) C...Heaviest flavour in hadron/diquark. ELSEIF(J.EQ.13) THEN KFA=IABS(K(I,2)) PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10) IF(KFA.LT.10) PYK=KFA IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10) PYK=PYK*ISIGN(1,K(I,2)) C...Particle history: generation, ancestor, rank. ELSEIF(J.LE.15) THEN I2=I I1=I 110 PYK=PYK+1 I2=I1 I1=K(I1,3) IF(I1.GT.0) THEN IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110 ENDIF IF(J.EQ.15) PYK=I2 ELSEIF(J.EQ.16) THEN KFA=IABS(K(I,2)) IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR. & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN I1=I 120 I2=I1 I1=K(I1,3) IF(I1.GT.0) THEN KFAM=IABS(K(I1,2)) ILP=1 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93) & ILP=0 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0 IF(ILP.EQ.1) GOTO 120 ENDIF IF(K(I1,1).EQ.12) THEN DO 130 I3=I1+1,I2 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92 & .AND.K(I3,2).NE.93) PYK=PYK+1 130 CONTINUE ELSE I3=I2 140 PYK=PYK+1 I3=I3+1 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140 ENDIF ENDIF C...Particle coming from collapsing jet system or not. ELSEIF(J.EQ.17) THEN I1=I 150 PYK=PYK+1 I3=I1 I1=K(I1,3) I0=MAX(1,I1) KC=PYCOMP(K(I0,2)) IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN IF(PYK.EQ.1) PYK=-1 IF(PYK.GT.1) PYK=0 RETURN ENDIF IF(KCHG(KC,2).EQ.0) GOTO 150 IF(K(I1,1).NE.12) PYK=0 IF(K(I1,1).NE.12) RETURN I2=I1 160 I2=I2+1 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160 K3M=K(I3-1,3) IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0 K3P=K(I3+1,3) IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0 C...Number of decay products. Colour flow. ELSEIF(J.EQ.18) THEN IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1) IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0 ELSEIF(J.LE.22) THEN IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5)) IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5)) IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5)) IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5)) ELSE ENDIF RETURN END C********************************************************************* C...PYP C...Provides various real-valued event related data. FUNCTION PYP(I,J) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local array. DIMENSION PSUM(4) C...Set default value. For I = 0 sum of momenta or charges, C...or invariant mass of system. PYP=0D0 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN ELSEIF(I.EQ.0.AND.J.LE.4) THEN DO 100 I1=1,N IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J) 100 CONTINUE ELSEIF(I.EQ.0.AND.J.EQ.5) THEN DO 120 J1=1,4 PSUM(J1)=0D0 DO 110 I1=1,N IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+ & P(I1,J1) 110 CONTINUE 120 CONTINUE PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2)) ELSEIF(I.EQ.0.AND.J.EQ.6) THEN DO 130 I1=1,N IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0 130 CONTINUE ELSEIF(I.EQ.0) THEN C...Direct readout of P matrix. ELSEIF(J.LE.5) THEN PYP=P(I,J) C...Charge, total momentum, transverse momentum, transverse mass. ELSEIF(J.LE.12) THEN IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP) C...Theta and phi angle in radians or degrees. ELSEIF(J.LE.16) THEN IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2)) IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2)) IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1) C...True rapidity, rapidity with pion mass, pseudorapidity. ELSEIF(J.LE.19) THEN PMR=0D0 IF(J.EQ.17) PMR=P(I,5) IF(J.EQ.18) PMR=PYMASS(211) PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2) PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR), & 1D20)),P(I,3)) C...Energy and momentum fractions (only to be used in CM frame). ELSEIF(J.LE.25) THEN IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21) IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21) IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21) IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21) IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21) IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21) ENDIF RETURN END C********************************************************************* C...PYSPHE C...Performs sphericity tensor analysis to give sphericity, C...aplanarity and the related event axes. SUBROUTINE PYSPHE(SPH,APL) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local arrays. DIMENSION 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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Local arrays 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 RETURN ENDIF IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET) IF(MSTU(43).GE.2) N=N+MAX(0,NJET) NSAV=NJET RETURN END C********************************************************************* C...PYCELL C...Provides a simple way of jet finding in eta-phi-ET coordinates, C...as used for calorimeters at hadron colliders. SUBROUTINE PYCELL(NJET) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...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)=MAX(0,NJET) IF(MSTU(43).GE.2) N=N+MAX(0,NJET) RETURN END C********************************************************************* C...PYJMAS C...Determines, approximately, the two jet masses that minimize C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler. SUBROUTINE PYJMAS(PMH,PML) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/ C...Local arrays, 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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Check input parameters. IF(MSTU(12).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) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C...Status, (optimized) Q^2 scale, alpha_strong. PARJ(151)=ECM MSTJ(119)=10*MSTJ(102)+KFL IF(MSTJ(111).EQ.0) THEN Q2R=ECM**2 ELSEIF(MSTU(111).EQ.0) THEN PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/ & ((33D0-2D0*MSTU(112))*PARU(111))))) Q2R=PARJ(168)*ECM**2 ELSE PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM, & (2D0*PARU(112)/ECM)**2)) Q2R=PARJ(168)*ECM**2 ENDIF ALSPI=PYALPS(Q2R)/PARU(1) C...QCD corrections factor in R. IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN RQCD=1D0 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN RQCD=1D0+ALSPI ELSEIF(MSTJ(109).EQ.0) THEN RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0* & LOG(PARJ(168))*ALSPI**2) ELSEIF(IABS(MSTJ(101)).EQ.1) THEN RQCD=1D0+(3D0/4D0)*ALSPI ELSE RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2 ENDIF C...Calculate Z0 width if default value not acceptable. IF(MSTJ(102).GE.3) THEN RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+ & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2) DO 100 KFLC=5,6 VQ=1D0 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0- & (2D0*PYMASS(KFLC)/ ECM)**2)) IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3) 100 CONTINUE PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)* & (1D0-PARU(102))) ENDIF C...Calculate propagator and related constants for QFD case. POLL=1D0-PARJ(131)*PARJ(132) IF(MSTJ(102).GE.2) THEN SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102))) SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2) SFI=SFW*(1D0-(PARJ(123)/ECM)**2) VE=4D0*PARU(102)-1D0 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131)) SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131))) HF1I=SFI*SF1I HF1W=SFW*SF1W ENDIF C...Loop over different flavours: charge, velocity. RTOT=0D0 RQQ=0D0 RQV=0D0 RVA=0D0 DO 110 KFLC=1,MAX(MSTJ(104),KFL) IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110 MSTJ(93)=1 PMQ=PYMASS(KFLC) IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110 QF=KCHG(KFLC,1)/3D0 VQ=1D0 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2) C...Calculate R and sum of charges for QED or QFD case. RQQ=RQQ+3D0*QF**2*POLL IF(MSTJ(102).LE.1) THEN RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL ELSE VF=SIGN(1D0,QF)-4D0*QF*PARU(102) RQV=RQV-6D0*QF*VF*SF1I RVA=RVA+3D0*(VF**2+1D0)*SF1W RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL- & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W) ENDIF 110 CONTINUE RSUM=RQQ IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA C...Calculate cross-section, including QCD corrections. PARJ(141)=RQQ PARJ(142)=RTOT PARJ(143)=RTOT*RQCD PARJ(144)=PARJ(143) PARJ(145)=PARJ(141)*86.8D0/ECM**2 PARJ(146)=PARJ(142)*86.8D0/ECM**2 PARJ(147)=PARJ(143)*86.8D0/ECM**2 PARJ(148)=PARJ(147) PARJ(157)=RSUM*RQCD PARJ(158)=0D0 PARJ(159)=0D0 XTOT=PARJ(147) IF(MSTJ(107).LE.0) RETURN C...Virtual cross-section. XKL=PARJ(135) XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2) ALE=2D0*LOG(ECM/PYMASS(11))-1D0 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+ &1.526D0*LOG(ECM**2/0.932D0) C...Soft and hard radiative cross-section in QED case. IF(MSTJ(102).LE.1) THEN SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL) SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL)) C...Soft and hard radiative cross-section in QFD case. ELSE SZM=1D0-(PARJ(123)/ECM)**2 SZW=PARJ(123)*PARJ(124)/ECM**2 PARJ(161)=-RQQ/RSUM PARJ(162)=-(RQQ+RQV+RVA)/RSUM PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2- & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM) SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/ & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+ & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+ & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW))) SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/ & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)* & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+ & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW))) ENDIF C...Total cross-section and fraction of hard photon events. PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH) PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD PARJ(144)=PARJ(157) PARJ(148)=PARJ(144)*86.8D0/ECM**2 XTOT=PARJ(148) RETURN END C********************************************************************* C...PYRADK C...Generates initial state photon radiation. SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Function: cumulative hard photon spectrum in QFD case. FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+ &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW) C...Determine whether radiative photon or not. MK=0 PAK=0D0 IF(PARJ(160).LT.PYR(0)) RETURN MK=1 C...Photon energy range. Find photon momentum in QED case. XKL=PARJ(135) XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2) IF(MSTJ(102).LE.1) THEN 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0)) IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100 C...Ditto in QFD case, by numerical inversion of integrated spectrum. ELSE SZM=1D0-(PARJ(123)/ECM)**2 SZW=PARJ(123)*PARJ(124)/ECM**2 FXKL=FXK(XKL) FXKU=FXK(XKU) FXKD=1D-4*(FXKU-FXKL) FXKR=FXKL+PYR(0)*(FXKU-FXKL) NXK=0 110 NXK=NXK+1 XK=0.5D0*(XKL+XKU) FXKV=FXK(XK) IF(FXKV.GT.FXKR) THEN XKU=XK FXKU=FXKV ELSE XKL=XK FXKL=FXKV ENDIF IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL) ENDIF PAK=0.5D0*ECM*XK C...Photon polar and azimuthal angle. PME=2D0*(PYMASS(11)/ECM)**2 120 CTHM=PME*(2D0/PME)**PYR(0) IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME, &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120 CTHE=1D0-CTHM IF(PYR(0).GT.0.5D0) CTHE=-CTHE STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM))) THEK=PYANGL(CTHE,STHE) PHIK=PARU(2)*PYR(0) C...Rotation angle for hadronic system. SGN=1D0 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT. &PYR(0)) SGN=-1D0 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/ &(2D0-XK*(1D0-SGN*CTHE))) RETURN END C********************************************************************* C...PYXKFL C...Selects flavour for produced qqbar pair. SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYDAT1/,/PYDAT2/ C...Calculate maximum weight in QED or QFD case. IF(MSTJ(102).LE.1) THEN RFMAX=4D0/9D0 ELSE POLL=1D0-PARJ(131)*PARJ(132) SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102))) SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2) SFI=SFW*(1D0-(PARJ(123)/ECMC)**2) VE=4D0*PARU(102)-1D0 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131)) HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131))) RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+ & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0* & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+ & 1D0)*HF1W) ENDIF C...Choose flavour. Gives charge and velocity. NTRY=0 100 NTRY=NTRY+1 IF(NTRY.GT.100) THEN CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop') KFLC=0 RETURN ENDIF KFLC=KFL IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0)) MSTJ(93)=1 PMQ=PYMASS(KFLC) IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100 QF=KCHG(KFLC,1)/3D0 VQ=1D0 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2)) C...Calculate weight in QED or QFD case. IF(MSTJ(102).LE.1) THEN RF=QF**2 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2 ELSE VF=SIGN(1D0,QF)-4D0*QF*PARU(102) RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+ & VQ**3*HF1W IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV) ENDIF C...Weighting or new event (radiative photon). Cross-section update. IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100 PARJ(158)=PARJ(158)+1D0 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158) PARJ(148)=PARJ(144)*86.8D0/ECM**2 RETURN END C********************************************************************* C...PYXJET C...Selects number of jets in matrix element approach. SUBROUTINE PYXJET(ECM,NJET,CUT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Local array and data. DIMENSION ZHUT(5) DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/ C...Trivial result for two-jets only, including parton shower. IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN CUT=0D0 C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R. ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN CF=4D0/3D0 IF(MSTJ(109).EQ.2) CF=1D0 IF(MSTJ(111).EQ.0) THEN Q2=ECM**2 Q2R=ECM**2 ELSEIF(MSTU(111).EQ.0) THEN PARJ(169)=MIN(1D0,PARJ(129)) Q2=PARJ(169)*ECM**2 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/ & ((33D0-2D0*MSTU(112))*PARU(111))))) Q2R=PARJ(168)*ECM**2 ELSE PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2)) Q2=PARJ(169)*ECM**2 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM, & (2D0*PARU(112)/ECM)**2)) Q2R=PARJ(168)*ECM**2 ENDIF C...alpha_strong for R and R itself. ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1) IF(IABS(MSTJ(101)).EQ.1) THEN RQCD=1D0+ALSPI ELSEIF(MSTJ(109).EQ.0) THEN RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+ & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2) ELSE RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2 ENDIF C...alpha_strong for jet rate. Initial value for y cut. ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1) CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2) IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0)) & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0) IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT)) C...Parametrization of first order three-jet cross-section. 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN PARJ(152)=0D0 ELSE PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))* & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)* & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0* & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2)) & PARJ(152)=0D0 ENDIF C...Parametrization of second order three-jet cross-section. IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR. & CUT.GE.0.25D0) THEN PARJ(153)=0D0 ELSEIF(MSTJ(110).LE.1) THEN CT=LOG(1D0/CUT-2D0) PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2- & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD C...Interpolation in second/first order ratio for Zhu parametrization. ELSEIF(MSTJ(110).EQ.2) THEN IZA=0 DO 110 IY=1,5 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY 110 CONTINUE IF(IZA.NE.0) THEN ZHURAT=ZHUT(IZA) ELSE IZ=100D0*CUT ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ)) ENDIF PARJ(153)=ALSPI*PARJ(152)*ZHURAT ENDIF C...Shift in second order three-jet cross-section with optimized Q^2. IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+ & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152) C...Parametrization of second order four-jet cross-section. IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN PARJ(154)=0D0 ELSE CT=LOG(1D0/CUT-5D0) IF(CUT.LE.0.018D0) THEN XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+ & 0.4059D0*CT**2) XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2) IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ ELSE XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+ & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3) XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+ & 0.002093D0*CT**3) IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ ENDIF PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD PARJ(155)=XQQQQ/(XQQGG+XQQQQ) ENDIF C...If negative three-jet rate, change y' optimization parameter. IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND. & PARJ(169).LT.0.99D0) THEN PARJ(169)=MIN(1D0,1.2D0*PARJ(169)) Q2=PARJ(169)*ECM**2 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1) GOTO 100 ENDIF C...If too high cross-section, use harder cuts, or fail. IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND. & PARJ(169).LT.0.99D0) THEN PARJ(169)=MIN(1D0,1.2D0*PARJ(169)) Q2=PARJ(169)*ECM**2 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1) GOTO 100 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN CALL PYERRM(26, & '(PYXJET:) no allowed y cut value for Zhu parametrization') ENDIF CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+ & PARJ(154))**(-1D0/3D0) IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT)) GOTO 100 ENDIF C...Scalar gluon (first order only). ELSE ALSPI=PYALPS(ECM**2)/PARU(1) CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI)) PARJ(152)=0D0 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)* & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0)) PARJ(153)=0D0 PARJ(154)=0D0 ENDIF C...Select number of jets. PARJ(150)=CUT IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN NJET=2 ELSEIF(MSTJ(101).LE.0) THEN NJET=MIN(4,2-MSTJ(101)) ELSE RNJ=PYR(0) NJET=2 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3 IF(PARJ(154).GT.RNJ) NJET=4 ENDIF RETURN END C********************************************************************* C...PYX3JT C...Selects the kinematical variables of three-jet events. SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Local array. DIMENSION ZHUP(5,12) C...Coefficients of Zhu second order parametrization. DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/ &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0, &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0, &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0, &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0, &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0, &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0, &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0, &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0, &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0, &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/ C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick). DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+ &X**7/49D0 C...Event type. Mass effect factors and other common constants. MSTJ(120)=2 MSTJ(121)=0 PMQ=PYMASS(KFL) QME=(2D0*PMQ/ECM)**2 IF(MSTJ(109).NE.1) THEN CUTL=LOG(CUT) CUTD=LOG(1D0/CUT-2D0) IF(MSTJ(109).EQ.0) THEN CF=4D0/3D0 CN=3D0 TR=2D0 WTMX=MIN(20D0,37D0-6D0*CUTD) IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT) ELSE CF=1D0 CN=0D0 TR=12D0 WTMX=0D0 ENDIF C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight. ALS2PI=PARU(118)/PARU(2) WTOPT=0D0 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0* & LOG(PARJ(169))*ALS2PI WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX) C...Choose three-jet events in allowed region. 100 NJET=3 110 Y13L=CUTL+CUTD*PYR(0) Y23L=CUTL+CUTD*PYR(0) Y13=EXP(Y13L) Y23=EXP(Y23L) Y12=1D0-Y13-Y23 IF(Y12.LE.CUT) GOTO 110 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110 C...Second order corrections. IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN Y12L=LOG(Y12) Y13M=LOG(1D0-Y13) Y23M=LOG(1D0-Y23) Y12M=LOG(1D0-Y12) IF(Y13.LE.0.5D0) Y13I=DILOG(Y13) IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13) IF(Y23.LE.0.5D0) Y23I=DILOG(Y23) IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23) IF(Y12.LE.0.5D0) Y12I=DILOG(Y12) IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12) WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23) WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+ & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+ & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2- & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+ & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+ & TR*(2D0*CUTL/3D0-10D0/9D0)+ & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+ & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/ & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+ & Y13*Y23)/(Y12+Y13)**2)/WT1+ & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)* & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L* & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)* & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/ & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))- & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1- & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I) IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2) ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN C...Second order corrections; Zhu parametrization of ERT. ZX=(Y23-Y13)**2 ZY=1D0-Y12 IZA=0 DO 120 IY=1,5 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY 120 CONTINUE IF(IZA.NE.0) THEN IZ=IZA WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+ & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+ & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY ELSE IZ=100D0*CUT WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+ & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+ & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY IZ=IZ+1 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+ & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+ & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ) ENDIF IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2) ENDIF C...Impose mass cuts (gives two jets). For fixed jet number new try. X1=1D0-Y23 X2=1D0-Y13 X3=1D0-Y12 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+ & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+ & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100 C...Scalar gluon model (first order only, no mass effects). ELSE 130 NJET=3 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2)) IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0) X1=1D0-0.5D0*(X3+YD) X2=1D0-0.5D0*(X3-YD) IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2 IF(MSTJ(102).GE.2) THEN IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT. & X3**2*PYR(0)) NJET=2 ENDIF IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130 ENDIF RETURN END C********************************************************************* C...PYX4JT C...Selects the kinematical variables of four-jet events. SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYDAT1/ C...Local arrays. DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4) C...Common constants. Colour factors for QCD and Abelian gluon theory. PMQ=PYMASS(KFL) QME=(2D0*PMQ/ECM)**2 CT=LOG(1D0/CUT-5D0) IF(MSTJ(109).EQ.0) THEN CF=4D0/3D0 CN=3D0 TR=2.5D0 ELSE CF=1D0 CN=0D0 TR=15D0 ENDIF C...Choice of process (qqbargg or qqbarqqbar). 100 NJET=4 IT=1 IF(PARJ(155).GT.PYR(0)) IT=2 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2 IF(IT.EQ.1) WTMX=0.7D0/CUT**2 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2 ID=1 C...Sample the five kinematical variables (for qqgg preweighted in y34). 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0) Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0) IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0)) IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0) IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110 VT=PYR(0) CP=COS(PARU(1)*PYR(0)) Y14=(Y134-Y34)*VT Y13=Y134-Y14-Y34 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34)) Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)* &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB)) Y23=Y234-Y34-Y24 Y12=1D0-Y134-Y23-Y24 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110 Y123=Y12+Y13+Y23 Y124=Y12+Y14+Y24 C...Calculate matrix elements for qqgg or qqqq process. IC=0 WTTOT=0D0 120 IC=IC+1 IF(IT.EQ.1) THEN WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+ & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24- & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12* & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+ & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/ & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24- & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/ & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24) WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12* & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14* & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+ & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24) WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+ & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+ & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24- & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23- & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+ & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+ & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+ & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24- & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+ & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+ & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2- & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34) WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+ & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34- & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+ & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+ & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+ & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/ & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34- & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+ & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24- & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14- & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2- & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34- & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34- & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23- & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14- & Y12*Y13**2)/(4D0*Y34**2*Y134**2) WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+ & CN*WTC(IC))/8D0 ELSE WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12* & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2* & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12* & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14* & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+ & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+ & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24* & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24- & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123) WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13* & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23* & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13* & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+ & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+ & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134* & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14* & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124) WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0 ENDIF C...Permutations of momenta in matrix element. Weighting. 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN YSAV=Y13 Y13=Y14 Y14=YSAV YSAV=Y23 Y23=Y24 Y24=YSAV YSAV=Y123 Y123=Y124 Y124=YSAV ENDIF IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN YSAV=Y13 Y13=Y23 Y23=YSAV YSAV=Y14 Y14=Y24 Y24=YSAV YSAV=Y134 Y134=Y234 Y234=YSAV ENDIF IF(IC.LE.3) GOTO 120 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110 IC=5 C...qqgg events: string configuration and event type. IF(IT.EQ.1) THEN IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+ & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT) IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+ & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2 IF(ID.EQ.2) GOTO 130 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT) IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2 IF(ID.EQ.2) GOTO 130 ENDIF MSTJ(120)=3 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+ & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4 KFLN=21 C...Mass cuts. Kinematical variables out. IF(Y12.LE.CUT+QME) NJET=2 IF(NJET.EQ.2) GOTO 150 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12)) X1=1D0-(1D0-Q12)*Y234-Q12*Y134 X4=1D0-(1D0-Q12)*Y134-Q12*Y234 X2=1D0-Y124 X12=(1D0-Q12)*Y13+Q12*Y23 X14=Y12-0.5D0*QME IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2 C...qqbarqqbar events: string configuration, choose new flavour. ELSE IF(ID.EQ.1) THEN WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4)) IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2 IF(WTR.LT.WTD(3)+WTD(4)) ID=3 IF(WTR.LT.WTD(4)) ID=4 IF(ID.GE.2) GOTO 130 ENDIF MSTJ(120)=5 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT) 140 KFLN=1+INT(5D0*PYR(0)) IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140 IF(KFLN.GT.MSTJ(104)) NJET=2 PMQN=PYMASS(KFLN) QMEN=(2D0*PMQN/ECM)**2 C...Mass cuts. Kinematical variables out. IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2 IF(NJET.EQ.2) GOTO 150 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24)) Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13)) X1=1D0-(1D0-Q24)*Y123-Q24*Y134 X4=1D0-(1D0-Q24)*Y134-Q24*Y123 X2=1D0-(1D0-Q13)*Y234-Q13*Y124 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+ & Q13*Y23) X14=Y24-0.5D0*QME X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+ & Q13*Y14) IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE. & (PARJ(127)+PMQ+PMQN)**2) NJET=2 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2 ENDIF 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100 RETURN END C********************************************************************* C...PYXDIF C...Gives the angular orientation of events. SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Charge. Factors depending on polarization for QED case. QF=KCHG(KFL,1)/3D0 POLL=1D0-PARJ(131)*PARJ(132) POLD=PARJ(132)-PARJ(131) IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN HF1=POLL HF2=0D0 HF3=PARJ(133)**2 HF4=0D0 C...Factors depending on flavour, energy and polarization for QFD case. ELSE SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102))) SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2) SFI=SFW*(1D0-(PARJ(123)/ECM)**2) AE=-1D0 VE=4D0*PARU(102)-1D0 AF=SIGN(1D0,QF) VF=AF-4D0*QF*PARU(102) HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+ & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD) HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2* & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD) HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)* & SFW*SFF**2*(VE**2-AE**2)) HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)* & SFF*AE ENDIF C...Mass factor. Differential cross-sections for two-jet events. SQ2=SQRT(2D0) QME=0D0 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND. &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2 IF(NJET.EQ.2) THEN SIGU=4D0*SQRT(1D0-QME) SIGL=2D0*QME*SQRT(1D0-QME) SIGT=0D0 SIGI=0D0 SIGA=0D0 SIGP=4D0 C...Kinematical variables. Reduce four-jet event to three-jet one. ELSE IF(NJET.EQ.3) THEN X1=2D0*P(NC+1,4)/ECM X2=2D0*P(NC+3,4)/ECM ELSE ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+ & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2) X1=2D0*P(NC+1,4)/ECMR X2=2D0*P(NC+4,4)/ECMR ENDIF C...Differential cross-sections for three-jet (or reduced four-jet). XQ=(1D0-X1)/(1D0-X2) CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME)) ST12=SQRT(1D0-CT12**2) IF(MSTJ(109).NE.1) THEN SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)- & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+ & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2- & X2)*XQ SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+ & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2 SIGA=X2**2*ST12/SQ2 SIGP=2D0*(X1**2-X2**2*CT12) C...Differential cross-sect for scalar gluons (no mass effects). ELSE X3=2D0-X1-X2 XT=X2*ST12 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2)) SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+ & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1) SIGL=(1D0-PARJ(171))*0.5D0*XT**2+ & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+ & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1) SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+ & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2))) SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3) SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1 ENDIF ENDIF C...Upper bounds for differential cross-section. HF1A=ABS(HF1) HF2A=ABS(HF2) HF3A=ABS(HF3) HF4A=ABS(HF4) SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)* &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2* &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+ &2D0*HF2A*ABS(SIGP) C...Generate angular orientation according to differential cross-sect. 100 CHI=PARU(2)*PYR(0) CTHE=2D0*PYR(0)-1D0 PHI=PARU(2)*PYR(0) CCHI=COS(CHI) SCHI=SIN(CHI) C2CHI=COS(2D0*CHI) S2CHI=SIN(2D0*CHI) THE=ACOS(CTHE) STHE=SIN(THE) C2PHI=COS(2D0*(PHI-PARJ(134))) S2PHI=SIN(2D0*(PHI-PARJ(134))) SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+ &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+ &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI* &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)* &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI- &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+ &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100 RETURN END C********************************************************************* C...PYONIA C...Generates Upsilon and toponium decays into three gluons C...or two gluons and a photon. SUBROUTINE PYONIA(KFL,ECM) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ C...Printout. Check input parameters. IF(MSTU(12).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) IMPLICIT INTEGER(I-N) C...Commonblock. COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYBINS/ C...Local character variables. CHARACTER TITLE*(*), TITFX*60 C...Check that input is sensible. Find initial address in memory. IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28, &'(PYBOOK:) not allowed histogram number') IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28, &'(PYBOOK:) not allowed number of bins') IF(XL.GE.XU) CALL PYERRM(28, &'(PYBOOK:) x limits in wrong order') INDX(ID)=IHIST(4) IHIST(4)=IHIST(4)+28+NX IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28, &'(PYBOOK:) out of histogram space') IS=INDX(ID) C...Store histogram size and reset contents. BIN(IS+1)=NX BIN(IS+2)=XL BIN(IS+3)=XU BIN(IS+4)=(XU-XL)/NX CALL PYNULL(ID) C...Store title by conversion to integer to double precision. TITFX=TITLE//' ' DO 100 IT=1,20 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+ & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT)) 100 CONTINUE RETURN END C********************************************************************* C...PYFILL C...Fills entry in histogram. SUBROUTINE PYFILL(ID,X,W) C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...Commonblock. COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYBINS/ C...Find initial address in memory. Increase number of entries. IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28, &'(PYFILL:) not allowed histogram number') IS=INDX(ID) IF(IS.EQ.0) CALL PYERRM(28, &'(PYFILL:) filling unbooked histogram') BIN(IS+5)=BIN(IS+5)+1D0 C...Find bin in x, including under/overflow, and fill. IF(X.LT.BIN(IS+2)) THEN BIN(IS+6)=BIN(IS+6)+W ELSEIF(X.GE.BIN(IS+3)) THEN BIN(IS+8)=BIN(IS+8)+W ELSE BIN(IS+7)=BIN(IS+7)+W IX=(X-BIN(IS+2))/BIN(IS+4) IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX)) BIN(IS+9+IX)=BIN(IS+9+IX)+W ENDIF RETURN END C********************************************************************* C...PYFACT C...Multiplies histogram contents by factor. SUBROUTINE PYFACT(ID,F) C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...Commonblock. COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYBINS/ C...Find initial address in memory. Multiply all contents bins. IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28, &'(PYFACT:) not allowed histogram number') IS=INDX(ID) IF(IS.EQ.0) CALL PYERRM(28, &'(PYFACT:) scaling unbooked histogram') DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1)) BIN(IX)=F*BIN(IX) 100 CONTINUE RETURN END C********************************************************************* C...PYOPER C...Performs operations between histograms. SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2) C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...Commonblock. COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYBINS/ C...Character variable. CHARACTER OPER*(*) C...Find initial addresses in memory, and histogram size. IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28, &'(PYFACT:) not allowed histogram number') IS1=INDX(ID1) IS2=INDX(MIN(IHIST(1),MAX(1,ID2))) IS3=INDX(MIN(IHIST(1),MAX(1,ID3))) NX=NINT(BIN(IS3+1)) IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1)) C...Update info on number of histogram entries. IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5) ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN BIN(IS3+5)=BIN(IS1+5) ENDIF C...Operations on pair of histograms: addition, subtraction, C...multiplication, division. IF(OPER.EQ.'+') THEN DO 100 IX=6,8+NX BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX) 100 CONTINUE ELSEIF(OPER.EQ.'-') THEN DO 110 IX=6,8+NX BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX) 110 CONTINUE ELSEIF(OPER.EQ.'*') THEN DO 120 IX=6,8+NX BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX) 120 CONTINUE ELSEIF(OPER.EQ.'/') THEN DO 130 IX=6,8+NX FA2=F2*BIN(IS2+IX) IF(ABS(FA2).LE.1D-20) THEN BIN(IS3+IX)=0D0 ELSE BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2 ENDIF 130 CONTINUE C...Operations on single histogram: multiplication+addition, C...square root+addition, logarithm+addition. ELSEIF(OPER.EQ.'A') THEN DO 140 IX=6,8+NX BIN(IS3+IX)=F1*BIN(IS1+IX)+F2 140 CONTINUE ELSEIF(OPER.EQ.'S') THEN DO 150 IX=6,8+NX BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2 150 CONTINUE ELSEIF(OPER.EQ.'L') THEN ZMIN=1D20 DO 160 IX=9,8+NX IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20) & ZMIN=0.8D0*BIN(IS1+IX) 160 CONTINUE DO 170 IX=6,8+NX BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2 170 CONTINUE C...Operation on two or three histograms: average and C...standard deviation. ELSEIF(OPER.EQ.'M') THEN DO 180 IX=6,8+NX IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN BIN(IS2+IX)=0D0 ELSE BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX) ENDIF IF(ID3.NE.0) THEN IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN BIN(IS3+IX)=0D0 ELSE BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)- & BIN(IS2+IX)**2)) ENDIF ENDIF BIN(IS1+IX)=F1*BIN(IS1+IX) 180 CONTINUE ENDIF RETURN END C********************************************************************* C...PYHIST C...Prints and resets all histograms. SUBROUTINE PYHIST C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...Commonblock. COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYBINS/ C...Loop over histograms, print and reset used ones. DO 100 ID=1,IHIST(1) IS=INDX(ID) IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN CALL PYPLOT(ID) CALL PYNULL(ID) ENDIF 100 CONTINUE RETURN END C********************************************************************* C...PYPLOT C...Prints a histogram (but does not reset it). SUBROUTINE PYPLOT(ID) C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYDAT1/,/PYBINS/ C...Local arrays and character variables. DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10) CHARACTER TITLE*60, OUT*100, CHA(0:11)*1 C...Steps in histogram scale. Character sequence. DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/ DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/ C...Find initial address in memory; skip if empty histogram. IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN IS=INDX(ID) IF(IS.EQ.0) RETURN IF(NINT(BIN(IS+5)).LE.0) THEN WRITE(MSTU(11),5000) ID RETURN ENDIF C...Number of histogram lines and x bins. LIN=IHIST(3)-18 NX=NINT(BIN(IS+1)) C...Extract title by conversion from double precision via integer. DO 100 IT=1,20 IEQ=NINT(BIN(IS+8+NX+IT)) TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256) & //CHAR(MOD(IEQ,256)) 100 CONTINUE C...Find time; print title. CALL PYTIME(IDATI) IF(IDATI(1).GT.0) THEN WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5) ELSE WRITE(MSTU(11),5200) ID, TITLE ENDIF C...Find minimum and maximum bin content. YMIN=BIN(IS+9) YMAX=BIN(IS+9) DO 110 IX=IS+10,IS+8+NX IF(BIN(IX).LT.YMIN) YMIN=BIN(IX) IF(BIN(IX).GT.YMAX) YMAX=BIN(IX) 110 CONTINUE C...Determine scale and step size for y axis. IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1 DELY=DYAC(1) DO 120 IDEL=1,9 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1) 120 CONTINUE DY=DELY*10D0**IPOT C...Convert bin contents to integer form; fractional fill in top row. DO 130 IX=1,NX CTA=ABS(BIN(IS+8+IX))/DY IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX)) IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0))) 130 CONTINUE IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN) IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX) C...Print histogram row by row. DO 150 IR=IRMA,IRMI,-1 IF(IR.EQ.0) GOTO 150 OUT=' ' DO 140 IX=1,NX IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX)) IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10) 140 CONTINUE WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT 150 CONTINUE C...Print sign and value of bin contents. IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10 OUT=' ' DO 160 IX=1,NX IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11) IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX))) 160 CONTINUE WRITE(MSTU(11),5400) OUT DO 180 IR=4,1,-1 DO 170 IX=1,NX OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1)) 170 CONTINUE WRITE(MSTU(11),5500) IPOT+IR-4, OUT 180 CONTINUE C...Print sign and value of lower bin edge. IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+ & 10.0001D0)-10 OUT=' ' DO 190 IX=1,NX IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3)) & OUT(IX:IX)=CHA(11) IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4))) 190 CONTINUE WRITE(MSTU(11),5600) OUT DO 210 IR=3,1,-1 DO 200 IX=1,NX OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1)) 200 CONTINUE WRITE(MSTU(11),5500) IPOT+IR-3, OUT 210 CONTINUE ENDIF C...Calculate and print statistics. CSUM=0D0 CXSUM=0D0 CXXSUM=0D0 DO 220 IX=1,NX CTA=ABS(BIN(IS+8+IX)) X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4) CSUM=CSUM+CTA CXSUM=CXSUM+CTA*X CXXSUM=CXXSUM+CTA*X**2 220 CONTINUE XMEAN=CXSUM/MAX(CSUM,1D-20) XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2)) WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6), &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3) C...Formats for output. 5000 FORMAT(/5X,'Histogram no',I5,' : no entries') 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X, &I2,':',I2/) 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/) 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100) 5400 FORMAT(/8X,'Contents',3X,A100) 5500 FORMAT(9X,'*10**',I2,3X,A100) 5600 FORMAT(/8X,'Low edge',3X,A100) 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow =' &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X, &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4) RETURN END C********************************************************************* C...PYNULL C...Resets bin contents of a histogram. SUBROUTINE PYNULL(ID) C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...Commonblock. COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYBINS/ IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN IS=INDX(ID) IF(IS.EQ.0) RETURN DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1)) BIN(IX)=0D0 100 CONTINUE RETURN END C********************************************************************* C...PYDUMP C...Dumps histogram contents on file for reading by other program. C...Can also read back own dump. SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI) C...Double precision declaration. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...Commonblock. COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) SAVE /PYBINS/ C...Local arrays and character variables. DIMENSION IHI(*),ISS(100),VAL(5) CHARACTER TITLE*60,FORMAT*13 C...Dump all histograms that have been booked, C...including titles and ranges, one after the other. IF(MDUMP.EQ.1) THEN C...Loop over histograms and find which are wanted and booked. IF(NHI.LE.0) THEN NW=IHIST(1) ELSE NW=NHI ENDIF DO 130 IW=1,NW IF(NHI.EQ.0) THEN ID=IW ELSE ID=IHI(IW) ENDIF IS=INDX(ID) IF(IS.NE.0) THEN C...Write title, histogram size, filling statistics. NX=NINT(BIN(IS+1)) DO 100 IT=1,20 IEQ=NINT(BIN(IS+8+NX+IT)) TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)// & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256)) 100 CONTINUE WRITE(LFN,5100) ID,TITLE WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3) WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7), & BIN(IS+8) C...Write histogram contents, in groups of five. DO 120 IXG=1,(NX+4)/5 DO 110 IXV=1,5 IX=5*IXG+IXV-5 IF(IX.LE.NX) THEN VAL(IXV)=BIN(IS+8+IX) ELSE VAL(IXV)=0D0 ENDIF 110 CONTINUE WRITE(LFN,5400) (VAL(IXV),IXV=1,5) 120 CONTINUE C...Go to next histogram; finish. ELSEIF(NHI.GT.0) THEN CALL PYERRM(8,'(PYDUMP:) unknown histogram number') ENDIF 130 CONTINUE C...Read back in histograms dumped MDUMP=1. ELSEIF(MDUMP.EQ.2) THEN C...Read histogram number, title and range, and book. 140 READ(LFN,5100,END=170) ID,TITLE READ(LFN,5200) NX,XL,XU CALL PYBOOK(ID,TITLE,NX,XL,XU) IS=INDX(ID) C...Read filling statistics. READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8) BIN(IS+5)=DBLE(NENTRY) C...Read histogram contents, in groups of five. DO 160 IXG=1,(NX+4)/5 READ(LFN,5400) (VAL(IXV),IXV=1,5) DO 150 IXV=1,5 IX=5*IXG+IXV-5 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV) 150 CONTINUE 160 CONTINUE C...Go to next histogram; finish. GOTO 140 170 CONTINUE C...Write histogram contents in column format, C...convenient e.g. for GNUPLOT input. ELSEIF(MDUMP.EQ.3) THEN C...Find addresses to wanted histograms. NSS=0 IF(NHI.LE.0) THEN NW=IHIST(1) ELSE NW=NHI ENDIF DO 180 IW=1,NW IF(NHI.EQ.0) THEN ID=IW ELSE ID=IHI(IW) ENDIF IS=INDX(ID) IF(IS.NE.0.AND.NSS.LT.100) THEN NSS=NSS+1 ISS(NSS)=IS ELSEIF(NSS.GE.100) THEN CALL PYERRM(8,'(PYDUMP:) too many histograms requested') ELSEIF(NHI.GT.0) THEN CALL PYERRM(8,'(PYDUMP:) unknown histogram number') ENDIF 180 CONTINUE C...Check that they have common number of x bins. Fix format. NX=NINT(BIN(ISS(1)+1)) DO 190 IW=2,NSS IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN CALL PYERRM(8,'(PYDUMP:) different number of bins') RETURN ENDIF 190 CONTINUE FORMAT='(1P,000E12.4)' WRITE(FORMAT(5:7),'(I3)') NSS+1 C...Write histogram contents; first column x values. DO 200 IX=1,NX X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4) WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS) 200 CONTINUE ENDIF C...Formats for output. 5100 FORMAT(I5,5X,A60) 5200 FORMAT(I5,1P,2D12.4) 5300 FORMAT(I12,1P,3D12.4) 5400 FORMAT(1P,5D12.4) RETURN END C********************************************************************* C...PYKCUT C...Dummy routine, which the user can replace in order to make cuts on C...the kinematics on the parton level before the matrix elements are C...evaluated and the event is generated. The cross-section estimates C...will automatically take these cuts into account, so the given C...values are for the allowed phase space region only. MCUT=0 means C...that the event has passed the cuts, MCUT=1 that it has failed. SUBROUTINE PYKCUT(MCUT) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYDAT1/,/PYINT1/,/PYINT2/ C...Set default value (accepting event) for MCUT. MCUT=0 C...Read out subprocess number. ISUB=MINT(1) ISTSB=ISET(ISUB) C...Read out tau, y*, cos(theta), tau' (where defined, else =0). TAU=VINT(21) YST=VINT(22) CTH=0D0 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23) TAUP=0D0 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26) C...Calculate x_1, x_2, x_F. IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN X1=SQRT(TAU)*EXP(YST) X2=SQRT(TAU)*EXP(-YST) ELSE X1=SQRT(TAUP)*EXP(YST) X2=SQRT(TAUP)*EXP(-YST) ENDIF XF=X1-X2 C...Calculate shat, that, uhat, p_T^2. SHAT=TAU*VINT(2) SQM3=VINT(63) SQM4=VINT(64) RM3=SQM3/SHAT RM4=SQM4/SHAT BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) RPTS=4D0*VINT(71)**2/SHAT BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS)) RM34=2D0*RM3*RM4 RSQM=1D0+RM34 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L) THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH) UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH) PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2)) C...Decisions by user to be put here. C...Stop program if this routine is ever called. C...You should not copy these lines to your own routine. WRITE(MSTU(11),5000) IF(PYR(0).LT.10D0) STOP C...Format for error printout. 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ', &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/ &1X,'Execution stopped!') RETURN END C********************************************************************* C...PYEVWT C...Dummy routine, which the user can replace in order to multiply the C...standard PYTHIA differential cross-section by a process- and C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds C...to generation of weighted events, with weight 1/WTXS, while for C...MSTP(142)=2 it corresponds to a modification of the underlying C...physics. SUBROUTINE PYEVWT(WTXS) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) COMMON/PYINT1/MINT(400),VINT(400) COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) SAVE /PYDAT1/,/PYINT1/,/PYINT2/ C...Set default weight for WTXS. WTXS=1D0 C...Read out subprocess number. ISUB=MINT(1) ISTSB=ISET(ISUB) C...Read out tau, y*, cos(theta), tau' (where defined, else =0). TAU=VINT(21) YST=VINT(22) CTH=0D0 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23) TAUP=0D0 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26) C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2. X1=VINT(41) X2=VINT(42) XF=X1-X2 SHAT=VINT(44) THAT=VINT(45) UHAT=VINT(46) PT2=VINT(48) C...Modifications by user to be put here. C...Stop program if this routine is ever called. C...You should not copy these lines to your own routine. WRITE(MSTU(11),5000) IF(PYR(0).LT.10D0) STOP C...Format for error printout. 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ', &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/ &1X,'Execution stopped!') RETURN END C********************************************************************* C...UPINIT C...Dummy routine, to be replaced by a user implementing external C...processes. Is supposed to fill the HEPRUP commonblock with info C...on incoming beams and allowed processes. SUBROUTINE UPINIT C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...User process initialization commonblock. INTEGER MAXPUP PARAMETER (MAXPUP=100) INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), &LPRUP(MAXPUP) SAVE /HEPRUP/ RETURN END C********************************************************************* C...UPEVNT C...Dummy routine, to be replaced by a user implementing external C...processes. Depending on cross section model chosen, it either has C...to generate a process of the type IDPRUP requested, or pick a type C...itself and generate this event. The event is to be stored in the C...HEPEUP commonblock, including (often) an event weight. SUBROUTINE UPEVNT C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) C...User process event common block. INTEGER MAXNUP PARAMETER (MAXNUP=500) INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), &VTIMUP(MAXNUP),SPINUP(MAXNUP) SAVE /HEPEUP/ RETURN END C********************************************************************* C...PYTAUD C...Dummy routine, to be replaced by user, to handle the decay of a C...polarized tau lepton. C...Input: C...ITAU is the position where the decaying tau is stored in /PYJETS/. C...IORIG is the position where the mother of the tau is stored; C... is 0 when the mother is not stored. C...KFORIG is the flavour of the mother of the tau; C... is 0 when the mother is not known. C...Note that IORIG=0 does not necessarily imply KFORIG=0; C... e.g. in B hadron semileptonic decays the W propagator C... is not explicitly stored but the W code is still unambiguous. C...Output: C...NDECAY is the number of decay products in the current tau decay. C...These decay products should be added to the /PYJETS/ common block, C...in positions N+1 through N+NDECAY. For each product I you must C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2), C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically. SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY) C...Double precision and integer declarations. IMPLICIT DOUBLE PRECISION(A-H, O-Z) IMPLICIT INTEGER(I-N) INTEGER PYK,PYCHGE,PYCOMP C...Commonblocks. COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) SAVE /PYJETS/,/PYDAT1/ C...Stop program if this routine is ever called. C...You should not copy these lines to your own routine. NDECAY=ITAU+IORIG+KFORIG WRITE(MSTU(11),5000) 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) IMPLICIT INTEGER(I-N) 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. AIX. C CALL IDATE(IMON,IDAY,IYEAR) C IDATI(1)=IYEAR C IDATI(2)=IMON C IDATI(3)=IDAY C CALL ITIME(IHOUR,IMIN,ISEC) C IDATI(4)=IHOUR C IDATI(5)=IMIN C IDATI(6)=ISEC C...Example 3: DEC Fortran, IRIX, IRIX64. C CALL IDATE(IMON,IDAY,IYEAR) C IDATI(1)=IYEAR C IDATI(2)=IMON C IDATI(3)=IDAY C CALL TIME(ATIME) C IHOUR=0 C IMIN=0 C ISEC=0 C READ(ATIME(1:2),'(I2)') IHOUR C READ(ATIME(4:5),'(I2)') IMIN C READ(ATIME(7:8),'(I2)') ISEC C IDATI(4)=IHOUR C IDATI(5)=IMIN C IDATI(6)=ISEC C...Example 4: GNU LINUX libU77, SunOS. c CALL IDATE(IDTEMP) c IDATI(1)=IDTEMP(3) c IDATI(2)=IDTEMP(2) c IDATI(3)=IDTEMP(1) c CALL ITIME(IDTEMP) c IDATI(4)=IDTEMP(1) c IDATI(5)=IDTEMP(2) c IDATI(6)=IDTEMP(3) C...Common code to ensure right century. IDATI(1)=2000+MOD(IDATI(1),100) RETURN END