Index: branches/rel-2.3.0/release_note-2.3.0.txt =================================================================== --- branches/rel-2.3.0/release_note-2.3.0.txt (revision 0) +++ branches/rel-2.3.0/release_note-2.3.0.txt (revision 484) @@ -0,0 +1,31 @@ +*** ATTENTION *** + +To cure unintuitive behaviour of the simple medium model (medium-simple.f) when running for small nuclei the meaning of the parameter TI specifying the initial temperature changes: it is now the initial temperature in the center (x=y=0) of a central (b=0) collision (previously is was the initial temperature averaged over the transverse plane of a b=0 collision). + +THIS IS NOT BACKWARD COMPATIBLE! + +The conversion factor going from the old to the new definition is roughly 1.35 for Pb. If you don't want to change your parameter settings, you can compile jewel-2.3.0 with the medium-simple.f file from the 2.2.0 release. + +***************** + + +The other changes compared to the previous version 2.2.0 are: + +* Jewel has moved to LHAPDF6. Nuclear pdf sets can now be accessed directly through LHAPDF6. The parameter NSET has therefore dissappeared and the parameter MASS is now an integer. + +* Re-scattering of hard recoiling partons is now possible. It is disabled by default and can be enabled by setting SCATRECOIL to 'true'. The parameter RECHARDCUT specifies which part of the recoil population is allowed to re-scatter: recoils with momentum larger than RECHARDCUT*3*T in the local fluid rest frame can re-scatter. The default value of RECHARDCUT is 5. Enabling re-scattering of recoils dramatically increases the number of particles treated in an event and can lead to an overflow of the event record. The run time also increases considerably. + +* The dummy particles needed for subtraction of thermal momenta are now massive and placed at the same rapditiy and pseudo-rapidity as the thermal momentum. + +* There are new options the treatment of recoiling partons, which can be chosen with the parameter KINMODE. The options are + KINMODE = 0: recoiling partons are massless + KINMODE = 1 (default): recoiling partons keep their thermal masses + KINMODE = 2: recoiling partons can go off-shell and radiate provided the momentum transfer is large enough, otherwise they keep their thermal mass + +* There are different options for how the subtraction of thermal momenta can be done, regulated by RECMODE (note that the actual subtraction has to be performed externally, RECMODE only affects the information written out by Jewel). +Recoils that have momentum smaller than RECSOFTCUT*3*T in the local fluid rest frame are classified as soft and are removed from the event record. The default value of RECSOFTCUT is 0. + RECMODE = 0 (default): for recoils not classified as soft the incoming thermal momenta are written out for subtraction, the dummy particles point in the direction of the incoming thermal momenta + RECMODE = 1: for recoils not classified as soft the incoming thermal momenta are written out for subtraction, but the dummy particles point in the direction of the scattered (i.e. recoiling) thermal momentum + RECMODE = 2: the difference q = p_out - p_in between thermal (four)momenta before and after scattering is written out (these have to be added to the event), the dummy particles point in the direction of the q-vectors (note that re-scattering of recoils is not possible in this mode) + RECMODE = 3: like option 2 for soft recoils and like option 0 for the others + Index: branches/rel-2.3.0/pythia6425mod-lhapdf6.f =================================================================== --- branches/rel-2.3.0/pythia6425mod-lhapdf6.f (revision 0) +++ branches/rel-2.3.0/pythia6425mod-lhapdf6.f (revision 484) @@ -0,0 +1,80920 @@ +C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C++ This version of PYTHIA 6.4.25 was modified to run with the ++ +C++ jet quenching Monte Carlo JEWEL. It is not an official release ++ +C++ of PYTHIA and may not be used for anything else. ++ +C++ ++ +C++ Modifications with respect to the official PYTHIA version: ++ +C++ * The event record was enlarged to 23000 lines. ++ +C++ * The LHAPDF interface was activated and modified such that ++ +C++ nuclear PDF's can be used. ++ +C++ * A customised version of PYEVWT was introduced to allow for ++ +C++ the generation of weighted events. ++ +C++ ++ +C++ Korinna Zapp ++ +C++ (Oct. 2013) ++ +C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +C +C********************************************************************* +C********************************************************************* +C* ** +C* Mar 2011 ** +C* ** +C* The Lund Monte Carlo ** +C* ** +C* PYTHIA version 6.4 ** +C* ** +C* Torbjorn Sjostrand ** +C* Department of Theoretical Physics ** +C* Lund University ** +C* Solvegatan 14A, S-223 62 Lund, Sweden ** +C* E-mail torbjorn@thep.lu.se ** +C* ** +C* SUSY and Technicolor parts by ** +C* Stephen Mrenna ** +C* Computing Division ** +C* Generators and Detector Simulation Group ** +C* Fermi National Accelerator Laboratory ** +C* MS 234, Batavia, IL 60510, USA ** +C* phone + 1 - 630 - 840 - 2556 ** +C* E-mail mrenna@fnal.gov ** +C* ** +C* New multiple interactions and more SUSY parts by ** +C* Peter Skands ** +C* CERN/PH, CH-1211 Geneva, Switzerland ** +C* phone +41 - 22 - 767 2447 ** +C* E-mail peter.skands@cern.ch ** +C* ** +C* Several parts are written by Hans-Uno Bengtsson ** +C* PYSHOW is written together with Mats Bengtsson ** +C* PYMAEL is written by Emanuel Norrbin ** +C* advanced popcorn baryon production written by Patrik Eden ** +C* code for virtual photons mainly written by Christer Friberg ** +C* code for low-mass strings mainly written by Emanuel Norrbin ** +C* Bose-Einstein code mainly written by Leif Lonnblad ** +C* CTEQ parton distributions are by the CTEQ collaboration ** +C* GRV 94 parton distributions are by Glueck, Reya and Vogt ** +C* SaS photon parton distributions together with Gerhard Schuler ** +C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt ** +C* MSSM Higgs mass calculation code by M. Carena, ** +C* J.R. Espinosa, M. Quiros and C.E.M. Wagner ** +C* UED implementation by M. Elkacimi, D. Goujdami, H. Przysiezniak ** +C* PYGAUS adapted from CERN library (K.S. Kolbig) ** +C* NRQCD/colour octet production of onium by S. Wolf ** +C* ** +C* The latest program version and documentation is found on WWW ** +C* http://www.thep.lu.se/~torbjorn/Pythia.html ** +C* ** +C* Copyright Torbjorn Sjostrand, Lund 2010 ** +C* ** +C********************************************************************* +C********************************************************************* +C * +C List of subprograms in order of appearance, with main purpose * +C (S = subroutine, F = function, B = block data) * +C * +C B PYDATA to contain all default values * +C S PYCKBD to check that BLOCK DATA has been correctly loaded * +C S PYTEST to test the proper functioning of the package * +C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records * +C * +C S PYINIT to administer the initialization procedure * +C S PYEVNT to administer the generation of an event * +C S PYEVNW ditto, for new multiple interactions scenario * +C S PYSTAT to print cross-section and other information * +C S PYUPEV to administer the generation of an LHA hard process * +C S PYUPIN to provide initialization needed for LHA input * +C S PYLHEF to produce a Les Houches Event File from run * +C S PYINRE to initialize treatment of resonances * +C S PYINBM to read in beam, target and frame choices * +C S PYINKI to initialize kinematics of incoming particles * +C S PYINPR to set up the selection of included processes * +C S PYXTOT to give total, elastic and diffractive cross-sect. * +C S PYMAXI to find differential cross-section maxima * +C S PYPILE to select multiplicity of pileup events * +C S PYSAVE to save alternatives for gamma-p and gamma-gamma * +C S PYGAGA to handle lepton -> lepton + gamma branchings * +C S PYRAND to select subprocess and kinematics for event * +C S PYSCAT to set up kinematics and colour flow of event * +C S PYEVOL handler for pT-ordered ISR and multiple interactions * +C S PYSSPA to simulate initial state spacelike showers * +C S PYPTIS to do pT-ordered initial state spacelike showers * +C S PYMEMX auxiliary to PYSSPA/PYPTIS for ME correction maximum * +C S PYMEWT auxiliary to PYSSPA/.. for matrix element correction * +C S PYPTMI to do pT-ordered multiple interactions * +C F PYFCMP to give companion quark x*f distribution * +C F PYPCMP to calculate momentum integral for companion quarks * +C S PYUPRE to rearranges contents of the HEPEUP commonblock * +C S PYADSH to administrate sequential final-state showers * +C S PYVETO to allow the generation of an event to be aborted * +C S PYRESD to perform resonance decays * +C S PYMULT to generate multiple interactions - old scheme * +C S PYREMN to add on target remnants - old scheme * +C S PYMIGN to generate multiple interactions - new scheme * +C S PYMIHK to connect colours in mult. int. - new scheme * +C S PYCTTR to translate PYTHIA colour information to LHA1 tags * +C S PYMIHG to collapse two pairs of LHA1 colour tags. * +C S PYMIRM to add on target remnants in mult. int.- new scheme * +C S PYFSCR to perform final state colour reconnections - -"- * +C S PYDIFF to set up kinematics for diffractive events * +C S PYDISG to set up kinematics, remnant and showers for DIS * +C S PYDOCU to compute cross-sections and handle documentation * +C S PYFRAM to perform boosts between different frames * +C S PYWIDT to calculate full and partial widths of resonances * +C S PYOFSH to calculate partial width into off-shell channels * +C S PYRECO to handle colour reconnection in W+W- events * +C S PYKLIM to calculate borders of allowed kinematical region * +C S PYKMAP to construct value of kinematical variable * +C S PYSIGH to calculate differential cross-sections * +C S PYSGQC auxiliary to PYSIGH for QCD processes * +C S PYSGHF auxiliary to PYSIGH for heavy flavour processes * +C S PYSGWZ auxiliary to PYSIGH for W and Z processes * +C S PYSGHG auxiliary to PYSIGH for Higgs processes * +C S PYSGSU auxiliary to PYSIGH for supersymmetry processes * +C S PYSGTC auxiliary to PYSIGH for technicolor processes * +C S PYSGEX auxiliary to PYSIGH for various exotic processes * +C S PYPDFU to evaluate parton distributions * +C S PYPDFL to evaluate parton distributions at low x and Q^2 * +C S PYPDEL to evaluate electron parton distributions * +C S PYPDGA to evaluate photon parton distributions (generic) * +C S PYGGAM to evaluate photon parton distributions (SaS sets) * +C S PYGVMD to evaluate VMD part of photon parton distributions * +C S PYGANO to evaluate anomalous part of photon PDFs * +C S PYGBEH to evaluate Bethe-Heitler part of photon PDFs * +C S PYGDIR to evaluate direct contribution to photon PDFs * +C S PYPDPI to evaluate pion parton distributions * +C S PYPDPR to evaluate proton parton distributions * +C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions * +C S PYGRVL to evaluate the GRV 94L proton parton distributions * +C S PYGRVM to evaluate the GRV 94M proton parton distributions * +C S PYGRVD to evaluate the GRV 94D proton parton distributions * +C F PYGRVV auxiliary to the PYGRV* routines * +C F PYGRVW auxiliary to the PYGRV* routines * +C F PYGRVS auxiliary to the PYGRV* routines * +C F PYCT5L to evaluate the CTEQ 5L proton parton distributions * +C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions * +C S PYPDPO to evaluate old proton parton distributions * +C F PYHFTH to evaluate threshold factor for heavy flavour * +C S PYSPLI to find flavours left in hadron when one removed * +C F PYGAMM to evaluate ordinary Gamma function Gamma(x) * +C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) * +C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) * +C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) * +C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H * +C S PYSTBH to evaluate matrix element for t + b + H processes * +C S PYTBHB auxiliary to PYSTBH * +C S PYTBHG auxiliary to PYSTBH * +C S PYTBHQ auxiliary to PYSTBH * +C F PYTBHS auxiliary to PYSTBH * +C * +C S PYMSIN to initialize the supersymmetry simulation * +C S PYSLHA to interface to SUSY spectrum and decay calculators * +C S PYAPPS to determine MSSM parameters from SUGRA input * +C S PYSUGI to determine MSSM parameters using ISASUSY * +C S PYFEYN to determine MSSM Higgs parameters using FEYNHIGGS * +C F PYRNMQ to determine running squark masses * +C S PYTHRG to calculate sfermion third-gen. mass eigenstates * +C S PYINOM to calculate neutralino/chargino mass eigenstates * +C F PYRNM3 to determine running M3, gluino mass * +C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix * +C S PYHGGM to determine Higgs mass spectrum * +C S PYSUBH to determine Higgs masses in the MSSM * +C S PYPOLE to determine Higgs masses in the MSSM * +C S PYRGHM auxiliary to PYPOLE * +C S PYGFXX auxiliary to PYRGHM * +C F PYFINT auxiliary to PYPOLE * +C F PYFISB auxiliary to PYFINT * +C S PYSFDC to calculate sfermion decay partial widths * +C S PYGLUI to calculate gluino decay partial widths * +C S PYTBBN to calculate 3-body decay of gluino to neutralino * +C S PYTBBC to calculate 3-body decay of gluino to chargino * +C S PYNJDC to calculate neutralino decay partial widths * +C S PYCJDC to calculate chargino decay partial widths * +C F PYXXZ6 auxiliary for ino 3-body decays * +C F PYXXGA auxiliary for ino -> ino + gamma decay * +C F PYX2XG auxiliary for ino -> ino + gauge boson decay * +C F PYX2XH auxiliary for ino -> ino + Higgs decay * +C S PYHEXT to calculate non-SM Higgs decay partial widths * +C F PYH2XX auxiliary for H -> ino + ino decay * +C F PYGAUS to perform Gaussian integration * +C F PYGAU2 copy of PYGAUS to allow two-dimensional integration * +C F PYSIMP to perform Simpson integration * +C F PYLAMF to evaluate the lambda kinematics function * +C S PYTBDY to perform 3-body decay of gauginos * +C S PYTECM to calculate techni_rho/omega masses * +C S PYXDIN to initialize Universal Extra Dimensions * +C S PYUEDC to compute UED mass radiative corrections * +C S PYXUED to compute UED cross sections * +C S PYGRAM to generate UED G* (excited graviton) mass spectrum * +C F PYGRAW to compute UED partial widths to G* * +C F PYWDKK to compute UED differential partial widths to G* * +C S PYEICG to calculate eigenvalues of a 4*4 complex matrix * +C S PYCMQR auxiliary to PYEICG * +C S PYCMQ2 auxiliary to PYEICG * +C S PYCDIV auxiliary to PYCMQR * +C S PYCSRT auxiliary to PYCMQR * +C S PYTHAG auxiliary to PYCMQR * +C S PYCBAL auxiliary to PYEICG * +C S PYCBA2 auxiliary to PYEICG * +C S PYCRTH auxiliary to PYEICG * +C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 * +C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 * +C S PYWIDX to calculate decay widths from within PYWIDT * +C S PYRVSF to calculate R-violating sfermion decay widths * +C S PYRVNE to calculate R-violating neutralino decay widths * +C S PYRVCH to calculate R-violating chargino decay widths * +C S PYRVGL to calculate R-violating gluino decay widths * +C F PYRVSB auxiliary to PYRVSF * +C S PYRVGW to calculate R-Violating 3-body widths * +C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. * +C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.* +C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. * +C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. * +C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. * +C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. * +C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. * +C F PYRVR auxiliary to PYRVG1, Breit-Wigner * +C F PYRVS auxiliary to PYRVG2 & PYRVG4 * +C * +C S PY1ENT to fill one entry (= parton or particle) * +C S PY2ENT to fill two entries * +C S PY3ENT to fill three entries * +C S PY4ENT to fill four entries * +C S PY2FRM to interface to generic two-fermion generator * +C S PY4FRM to interface to generic four-fermion generator * +C S PY6FRM to interface to generic six-fermion generator * +C S PY4JET to generate a shower from a given 4-parton config * +C S PY4JTW to evaluate the weight od a shower history for above * +C S PY4JTS to set up the parton configuration for above * +C S PYJOIN to connect entries with colour flow information * +C S PYGIVE to fill (or query) commonblock variables * +C S PYONOF to allow easy control of particle decay modes * +C S PYTUNE to select a predefined 'tune' for min-bias and UE * +C S PYEXEC to administrate fragmentation and decay chain * +C S PYPREP to rearrange showered partons along strings * +C S PYSTRF to do string fragmentation of jet system * +C S PYJURF to find boost to string junction rest frame * +C S PYINDF to do independent fragmentation of one or many jets * +C S PYDECY to do the decay of a particle * +C S PYDCYK to select parton and hadron flavours in decays * +C S PYKFDI to select parton and hadron flavours in fragm * +C S PYNMES to select number of popcorn mesons * +C S PYKFIN to calculate falvour prod. ratios from input params. * +C S PYPTDI to select transverse momenta in fragm * +C S PYZDIS to select longitudinal scaling variable in fragm * +C S PYSHOW to do m-ordered timelike parton shower evolution * +C S PYPTFS to do pT-ordered timelike parton shower evolution * +C F PYMAEL auxiliary to PYSHOW & PYPTFS: gluon emission ME's * +C S PYBOEI to include Bose-Einstein effects (crudely) * +C S PYBESQ auxiliary to PYBOEI * +C F PYMASS to give the mass of a particle or parton * +C F PYMRUN to give the running MSbar mass of a quark * +C S PYNAME to give the name of a particle or parton * +C F PYCHGE to give three times the electric charge * +C F PYCOMP to compress standard KF flavour code to internal KC * +C S PYERRM to write error messages and abort faulty run * +C F PYALEM to give the alpha_electromagnetic value * +C F PYALPS to give the alpha_strong value * +C F PYANGL to give the angle from known x and y components * +C F PYR to provide a random number generator * +C S PYRGET to save the state of the random number generator * +C S PYRSET to set the state of the random number generator * +C S PYROBO to rotate and/or boost an event * +C S PYEDIT to remove unwanted entries from record * +C S PYLIST to list event record or particle data * +C S PYLOGO to write a logo * +C S PYUPDA to update particle data * +C F PYK to provide integer-valued event information * +C F PYP to provide real-valued event information * +C S PYSPHE to perform sphericity analysis * +C S PYTHRU to perform thrust analysis * +C S PYCLUS to perform three-dimensional cluster analysis * +C S PYCELL to perform cluster analysis in (eta, phi, E_T) * +C S PYJMAS to give high and low jet mass of event * +C S PYFOWO to give Fox-Wolfram moments * +C S PYTABU to analyze events, with tabular output * +C * +C S PYEEVT to administrate the generation of an e+e- event * +C S PYXTEE to give the total cross-section at given CM energy * +C S PYRADK to generate initial state photon radiation * +C S PYXKFL to select flavour of primary qqbar pair * +C S PYXJET to select (matrix element) jet multiplicity * +C S PYX3JT to select kinematics of three-jet event * +C S PYX4JT to select kinematics of four-jet event * +C S PYXDIF to select angular orientation of event * +C S PYONIA to perform generation of onium decay to gluons * +C * +C S PYBOOK to book a histogram * +C S PYFILL to fill an entry in a histogram * +C S PYFACT to multiply histogram contents by a factor * +C S PYOPER to perform operations between histograms * +C S PYHIST to print and reset all histograms * +C S PYPLOT to print a single histogram * +C S PYNULL to reset contents of a single histogram * +C S PYDUMP to dump histogram contents onto a file * +C * +C S PYSTOP routine to handle Fortran STOP condition * +C * +C S PYKCUT dummy routine for user kinematical cuts * +C S PYEVWT dummy routine for weighting events * +C S UPINIT dummy routine to initialize user processes * +C S UPEVNT dummy routine to generate a user process event * +C S UPVETO dummy routine to abort event at parton level * +C S PDFSET dummy routine to be removed when using PDFLIB * +C S STRUCTM dummy routine to be removed when using PDFLIB * +C S STRUCTP dummy routine to be removed when using PDFLIB * +C S SUGRA dummy routine to be removed when linking with ISAJET * +C F VISAJE dummy functn. to be removed when linking with ISAJET * +C S SSMSSM dummy routine to be removed when linking with ISAJET * +C S FHSETFLAGS dummy routine -"- FEYNHIGGS * +C S FHSETPARA dummy routine -"- FEYNHIGGS * +C S FHHIGGSCORR dummy routine -"- FEYNHIGGS * +C S PYTAUD dummy routine for interface to tau decay libraries * +C S PYTIME dummy routine for giving date and time * +C * +C********************************************************************* + +C...PYDATA +C...Default values for switches and parameters, +C...and particle, decay and process data. + + BLOCK DATA PYDATA + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYDAT4/CHAF(500,2) + CHARACTER CHAF*16 + COMMON/PYDATR/MRPY(6),RRPY(100) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT6/PROC(0:500) + CHARACTER PROC*28 + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYPUED/IUED(0:99),RUED(0:99) + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100), + & AU(3,3),AD(3,3),AE(3,3) + COMMON/PYLH3C/CPRO(2),CVER(2) + CHARACTER CPRO*12,CVER*12 + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/, + &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/, + &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,/PYPUED/, + &/PYBINS/,/PYLH3P/,/PYLH3C/ + +C...PYDAT1, containing status codes and most parameters. + DATA MSTU/ + & 0, 0, 0, 23000,23000, 500, 8000, 0, 0, 2, + 1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0, + 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0, + 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0, + 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0, + 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 7 30*0, + 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0, + & 80*0/ + DATA (PARU(I),I=1,100)/ + & 3.141592653589793D0, 6.283185307179586D0, + & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0, + 1 0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0, + 4 0D0, 0D0, 0.0001D0, 0D0, 0D0, + 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0, + 6 40*0D0/ + DATA (PARU(I),I=101,200)/ + & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5, + & 0D0, 0D0, 0D0, 0D0, 0D0, + 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0, + 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, + 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, + 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0, + 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0, + 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/ + DATA MSTJ/ + & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0, + 1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0, + 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0, + 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3, + 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0, + 6 40*0, + & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2, + 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, + 2 80*0/ + DATA PARJ/ + & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0, + & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0, + 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0, + 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0, + 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0, + 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0, + 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0, + 5 0D0, 0D0, 0D0, 1.0D0, 0D0, + 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0, + 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0, + 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4, + 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0, + 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0, + 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0, + 4 10*0D0, + 5 10*0D0, + 6 10*0D0, + 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0, + 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0, + 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0, + 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0, + 9 5*0D0/ + +C...PYDAT2, with particle data and flavour treatment parameters. + DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0, + &-3,0,-3,6*0,3,9*0,3,2*0,3,4*0,-1,41*0,2,-1,20*0,3*3,7*0,3*3,3*0, + &3*3,3*0,3*3,6*0,3*3,3*0,3*3,4*0,-2,-3,2*1,2*0,4,2*3,6,2*-2,2*-3, + &0,2*1,2*0,2*3,-2,2*-3,2*0,-3,2*1,2*0,3,0,2*4,2*3,2*6,3,2*1,2*0, + &2*3,2*0,4,2*3,2*6,2*3,6,2*-2,2*-3,0,-3,0,2*1,2*0,2*3,0,3,2*-2, + &2*-3,2*0,2*-3,0,2*1,2*0,2*3,2*0,2*3,-2,2*-3,2*0,2*-3,2*0,-3,2*0, + &2*3,4*0,2*3,2*0,2*3,2*0,2*3,4*0,2*3,2*0,2*3,3*0,3,2*0,3,0,3,0,3, + &2*0,3,0,3,3*0,-1,2,-1,2,-1,2,-3,0,-3,0,-3,4*0,3,2*0,3,0,-1,2,-1, + &2,-1,2,-3,0,-3,0,-3,2*0,3,3*0,3,8*0,-1,2,-3,6*0,3,2*6,0,3,4*0,3, + &7*0,3, +C...UED singlet and doublet quarks, leptons, and KK g, gamma, Z, and W + &81*0,-1,2,-1,2,-1,2,-1,2,-1,2,-1,2, + &3*-3,0,-3,0,-3,0,-3, + &3*0,3, + &25*0/ + DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1, + &2*0,-1,3*0,2*-1,3*0,2*-1,4*0,-1,5*0,2*-1,4*0,2*-1,5*0,2*-1,6*0, + &-1,7*0,2*-1,5*0,2*-1,6*0,2*-1,7*0,2*-1,8*0,-1,56*0,6*1,6*0,2,7*0, + &6*1,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2, + &83*0,12*1,9*0,2,3*0,25*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,7*0,1, + &81*0,21*1,3*0,1,25*0/ + DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, + &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36, + &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57, + &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78, + &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99, + &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315, + &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441, + &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553, + &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101, + &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314, + &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214, + &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412, + &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142, + &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322, + &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442, + &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111, + &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331, + &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511, + &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113, + &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/ + DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443, + &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011, + &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023, + &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003, + &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015, + &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223, + &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001, + &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023, + &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440, + &9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551, + &3000115,3000215, + &81*0, +C...UED singlet and doublet quarks and leptons, and KK g, gamma, Z, and W. + &6100001,6100002,6100003,6100004,6100005,6100006, + &5100001,5100002,5100003,5100004,5100005,5100006, + &6100011,6100013,6100015, + &5100012,5100011,5100014,5100013,5100016,5100015, + &5100021,5100022,5100023,5100024, + &25*0/ + DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0, + &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0, + &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0, + &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0, + &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0, + &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0, + &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0, + &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0, + &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0, + &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0, + &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0, + &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0, + &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0, + &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0, + &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0, + &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0, + &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0, + &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0, + &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0, + &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/ + DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0, + &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0, + &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0, + &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0, + &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0, + &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0, + &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0, + &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0, + &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0, + &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0, + &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0, + &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0, + &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,3*3.1D0, + &3*9.5D0,2*250D0, + &81*0, +C...UED + &586.,588.,586.,588.,586.,586.,6*598., + &3*505.,6*516.,640.,501.,536.,536.,25*0.D0/ + 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.0208D0,0.01195D0,0.03705D0,0.09511D0,1.89978D0,1.60746D0, + &0.13396D0,200.47294D0,0.02296D0,0.18886D0,94.66794D0,6.08718D0, + &0D0,2.17482D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0, + &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0, + &7*0D0,6*0.01D0,0.25499D0,0.28446D0,131*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.20797D0,0.11949D0,0.37048D0,0.95114D0,18.99785D0,16.07463D0, + &1.33964D0,450D0,0.22959D0,1.88863D0,360D0,60.8718D0,0D0, + &21.74824D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0, + &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0, + &8.80013D0,13*0D0,2.54987D0,2.84456D0, + &81*0, +C...UED + &12*0.2D0,9*0.1D0,0.2,10.,0.07,0.3,25*0.D0/ + 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,120*0D0,131*0D0/ + + DATA PARF/ + & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0, + 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0, + 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0, + 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0, + 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0, + 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0, + 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0, + 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0, + 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 9 0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0, 4*0D0, + & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0, + 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 3 60*0D0, + 4 0.2D0, 0.5D0, 8*0D0, + 5 1800*0D0/ + DATA ((VCKM(I,J),J=1,4),I=1,4)/ + & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0, + & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0, + & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0, + & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/ + +C...PYDAT3, with particle decay parameters and data. + DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0, + &4*1,3*0,2*1,40*0,3*1,16*0,3*1,2*0,9*1,0,32*1,2*0,1,3*0,1,2*0,2*1, + &2*0,3*1,2*0,4*1,0,5*1,2*0,4*1,2*0,5*1,2*0,6*1,0,7*1,2*0,5*1,2*0, + &6*1,2*0,7*1,2*0,8*1,0,75*1,0,7*1,0,1,0,1,0,26*1,7*0,8*1, + &81*0, +C...UED + &5*1,0,5*1,0,13*1,25*0/ + DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82, + &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420, + &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581, + &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736, + &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945, + &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0, + &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077, + &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173, + &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201, + &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256, + &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299, + &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407, + &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471, + &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506, + &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543, + &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592, + &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162, + &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0, + &3924,0,3960,0,3996,4004,4012,4020,4217,4243,4270,4023,4029,4036, + &4043,4050,4056,4062,4071,4075,4079,4082,4084,4104,4126,4148,4170/ + DATA (MDCY(I,2),I= 352, 500)/4185,4197,4204,7*0,4211,4212,4213, + &4214,4215,4216,4296,4322, + &81*0, +C...UED + %5001,5003,5005,5007,5009,5011,5013,5016,5019,5022,5025,5028, + &5031,5032,5033, + &5034,5035,5036,5037,5038,5039,5040,5064,5065,5083, + &25*0/ + DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3, + &2*0,9,12,16,20,79,6*0,22,0,23,86,83,27,3*0,9,1,40*0,1,4,9,16*0,2, + &5,2*9,2*2,7,8,6,9,2*2,3,10,6,3,11,6,11,6,63,3,8,61,2,8,33,2,4,1, + &3,2,36,1,8,36,1,8,39,1,4,31,1,4,1,9,2,2*0,1,3*0,3,2*0,3,1,2*0,2, + &3,4,2*0,1,3*3,0,5,2,3,2,4,2*0,2*1,76,4,2*0,4*1,4,2*0,1,2,1,2,4,1, + &0,7*4,2*0,2*1,17,2*9,2*0,4*1,2*9,2*0,4*1,9,1,9,2*0,8*9,0,9*9,4*1, + &5,3,2,5,2,5,7,4,7*2,1,9*2,1,2*2,14,2*2,4,9*2,11,14,45,24,45,24, + &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49, + &28,49,28,36,0,36,0,36,0,3*8,3,26,27,26,6,3*7,2*6,9,2*4,3,2,20, + &3*22,15,12,2*7,7*0,6*1,26,30, + &81*0, +C...UED + &6*2,6*3,9*1,24,1,18,6,25*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,1249*1,2*-1,377*1,2*-1, + &1921*1,2*-1,6*1,2*-1,133*1,2*-1,6*1,2*-1,10*1,-1,3*1,-1,3*1,5*-1, + &3*1,-1,16*1,2*-1,6*1,2*-1,16*1,2*-1,6*1,2*-1,13*1,-1,3*1,-1,3*1, + &5*-1,3*1,-1, + &649*0, +C...UED + &10*1,2*0,15*1,3*0,9*1,5*1,0,5*1,0,5*1,0,5*1,0, + &1,24*1,2912*0/ + DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102, + &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41, + &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53, + &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0, + &18*53,6*32,4*0,12,2*42,2*11,9*42,0,2,3,15*0,4*42,5*0,3,12*0,2, + &3*0,1,0,3,16*0,2*3,15*0,2*42,2*3,18*0,2*3,3*0,1,11*0,22*42,41*0, + &2*3,9*0,16*42,45*0,3,10*0,10*42,20*0,2*13,6*0,12,2*0,12,0,12, + &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42, + &19*0,48,3*13,2*42,6*0,2*11,28*42,5*0,32,3*0,4*32,2*4,0,32,45*0, + &14*42,52*0,10*13,2*42,2*11,4*0,2*42,2*11,6*0,2*42,2*11,0,2*42, + &2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11,2*42,2*11, + &2*0,3*42,8*0,48,3*13,20*42,4*0,18*42,4*0,9*42,0,162*42,50*0,2*12, + &17*0,2*32,33*0,12,9*0,32,2*0,12,11*0,4*32,2*4,5*0,2404*53,4*32, + &3*0,6*32,3*0,4*32,3*0,50*32,3*53,12*0,8*32,12*0,66*51,6*32,9*0, + &9*32,17*0,6*51,10*0,8*32,15*0,16*32,14*0,8*32,18*0,8*32,18*0, + &16*32, +C...UED + &653*0,30*0,9*0,12*0,37*0,2912*0/ + DATA (BRAT(I) ,I= 1, 348)/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.000353D0,0.04359D0,0.795274D0, + &4*0D0,0.000339D0,0.095746D0,0D0,0.060724D0,0.003054D0,0.000919D0, + &64*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.000029D0, + &0.000536D0,5*0D0,0.000074D0,0D0,0.000417D0,0.000015D0,0.000061D0/ + DATA (BRAT(I) ,I= 349, 655)/0.306789D0,0.689189D0,0D0,0.00289D0, + &69*0D0,0.000001D0,0.000072D0,0.001333D0,4*0D0,0.000001D0, + &0.000184D0,0D0,0.003108D0,0.000015D0,0.000003D0,2*0D0,0.995284D0, + &66*0D0,0.000014D0,0.082234D0,2*0D0,0.000013D0,0.003746D0,0D0, + &0.913992D0,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,0.302D0,0.0302D0,0.0212D0,0.0016D0/ + DATA (BRAT(I) ,I= 656, 831)/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,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/ + DATA (BRAT(I) ,I= 832, 997)/0.079D0,0.095D0,0.052D0,0.0078D0, + &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0, + &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0, + &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0, + &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0, + &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0, + &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0, + &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0, + &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0, + &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0, + &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0, + &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0, + &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0, + &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0, + &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0, + &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0, + &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0, + &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0, + &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0, + &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/ + DATA (BRAT(I) ,I= 998,1188)/0.122D0,0.006D0,0.012D0,0.035D0, + &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0, + &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0, + &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0, + &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0, + &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0, + &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0, + &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0, + &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0, + &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0, + &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0, + &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0, + &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0, + &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0, + &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0, + &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0, + &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0, + &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0, + &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0, + &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/ + DATA (BRAT(I) ,I=1189,1381)/2*0.08D0,0.76D0,3*0.08D0,0.76D0, + &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0, + &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0, + &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0, + &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0, + &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0, + &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0, + &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0, + &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0, + &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/ + DATA (BRAT(I) ,I=1382,1582)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, + &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, + &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, + &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, + &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, + &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, + &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, + &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0, + &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0, + &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0, + &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0, + &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0, + &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0, + &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0, + &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0, + &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0, + &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0, + &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0, + &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0, + &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/ + DATA (BRAT(I) ,I=1583,4150)/0.008D0,0.024D0,0.425D0,0.02D0, + &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,0.024396D0, + &0.045285D0,0.83119D0,2*0D0,0.000349D0,0.09878D0,0D0,0.019884D0, + &0.02341D0,0.362776D0,0.550787D0,2*0D0,0.000152D0,0.042991D0, + &0.013695D0,0.025421D0,0.466595D0,2*0D0,0.000196D0,0.055451D0, + &0.438642D0,0.445781D0,0D0,0.554219D0,4*0.00335D0,0.522257D0, + &0.464343D0,6*0D0,1D0,6*0D0,1D0,4*0.013853D0,0.562703D0, + &0.376702D0,0.00518D0,4*0.006254D0,0.974985D0,7*0D0,4*0.148299D0, + &0.015351D0,0D0,0.182109D0,0.167099D0,0.042247D0,0.850973D0, + &0.005411D0,0.045025D0,0.098591D0,0.849898D0,0.021617D0, + &0.030018D0,0.098466D0,0.294448D0,0.10945D0,0.596102D0,0.389906D0, + &0.610094D0,3*0.0633D0,0.063299D0,0.063295D0,0.056281D0,2*0D0, + &6*0.020495D0,2*0D0,0.327919D0,0.04099D0,0.045236D0,0.090112D0, + &0.19874D0,0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0, + &0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0, + &0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0, + &0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0, + &0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0, + &0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0, + &0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0/ + DATA (BRAT(I) ,I=4151,4281)/0.010236D0,0.198928D0,0.000149D0, + &0.000006D0,0.000368D0,0.080733D0,0.199344D0,0.010234D0, + &0.000003D0,0.010236D0,0.198928D0,0.000149D0,0.000006D0, + &0.000368D0,0.080733D0,4*0D0,0.184738D0,0.104588D0,0.184738D0, + &0.104587D0,0.184731D0,0.09582D0,0.022902D0,0.008429D0,0.015602D0, + &0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0, + &0.015602D0,0.28959D0,0.01487D0,0.000008D0,0.01487D0,0.289061D0, + &0.000492D0,0.000009D0,0.000536D0,0.27911D0,2*0.037151D0, + &0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,0.001805D0, + &0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0,0.090428D0, + &0.001808D0,0.81372D0,0D0,6*1D0,0.095602D0,2*0.338272D0, + &0.156896D0,0.019193D0,0.017993D0,0.001168D0,0.001462D0, + &0.009608D0,0.003306D0,0.002132D0,0.003127D0,0.002132D0, + &0.003127D0,0.00213D0,3*0D0,0.001411D0,0.00045D0,0.001411D0, + &0.00045D0,0.001411D0,0.00045D0,2*0D0,0.097996D0,0.399787D0, + &0.262464D0,0.185427D0,0.022683D0,0.007648D0,0.004259D0, + &0.005925D0,0.000304D0,2*0D0,0.000304D0,0.005914D0,0.000002D0, + &2*0D0,0.000011D0,0.001258D0,5*0D0,3*0.002005D0,0D0,0.272178D0, + &0.022112D0,0.255165D0,0.015534D0,2*0.108965D0,0.031557D0, + &0.005562D0,0.044965D0,0.004674D0,0.007637D0,0.020597D0/ + DATA (BRAT(I) ,I=4282,8000)/0.007636D0,0.020595D0,0.007616D0, + &3*0D0,0.017298D0,0.004782D0,0.017298D0,0.004782D0,0.017297D0, + &0.004782D0,2*0D0,0.055332D0,2*0.319757D0,0.121576D0,2*0.001556D0, + &4*0D0,0.0277D0,0.021481D0,0.027699D0,0.021477D0,0.027658D0,3*0D0, + &0.006071D0,0.01208D0,0.006071D0,0.01208D0,0.006069D0,0.01208D0, + &2*0D0,0.035891D0,0.209476D0,0.129084D0,0.286631D0,0.10742D0, + &0.109486D0,4*0D0,0.035282D0,0.001812D0,2*0D0,0.001812D0, + &0.035215D0,0.000021D0,0D0,0.000001D0,0.000065D0,0.011965D0,5*0D0, + &2*0.011947D0,0.011946D0,0D0, + &649*0.D0, +C....UED + &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0, + &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0, + &0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0, + &0.33D0,0.66D0,0.01D0,0.98D0,0.D0,0.02D0,0.33D0,0.66D0,0.01D0, + &9*1.D0, + &24*0.0416667, + &1., + &3*0.D0,6*0.08333D0, + &3*0.D0,6*0.08333D0, + &6*0.166667D0, + &2912*0.D0/ + DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25, + &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23, + &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22, + &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12, + &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25, + &-37,23,24,37,1,2,3,4,5,6,7,8,21,1,2,3,4,5,6,7,8,11,13,15,17,1,2, + &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13, + &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022, + &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001, + &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002, + &1000003,2000003,1000003,-1000003,1000004,2000004,1000004, + &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006, + &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012, + &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013, + &1000014,2000014,1000014,-1000014,1000015,2000015,1000015, + &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12, + &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13, + &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24, + &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024, + &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/ + DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003, + &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005, + &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006, + &1000011,2000011,1000011,-1000011,1000012,2000012,1000012, + &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014, + &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016, + &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23, + &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024, + &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002, + &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004, + &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005, + &1000006,2000006,1000006,-1000006,1000011,2000011,1000011, + &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013, + &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015, + &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3, + &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035, + &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011, + &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2, + &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221, + &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/ + DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331, + &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211, + &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313, + &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313, + &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111, + &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311, + &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223, + &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211, + &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421, + &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311, + &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311, + &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311, + &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11, + &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321, + &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82, + &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443, + &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12, + &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2, + &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16, + &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/ + DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14, + &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521, + &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212, + &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222, + &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322, + &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13, + &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322, + &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214, + &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2, + &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13, + &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12, + &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2, + &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2, + &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16, + &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16, + &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2, + &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2, + &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12, + &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16, + &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/ + DATA (KFDP(I,1),I=1403,1713)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2, + &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12, + &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221, + &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313, + &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313, + &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443, + &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513, + &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113, + &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413, + &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443, + &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555, + &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035, + &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11, + &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6, + &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001, + &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3, + &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035, + &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11, + &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6, + &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/ + DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021, + &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022, + &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021, + &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16, + &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023, + &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022, + &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024, + &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012, + &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024, + &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011, + &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037, + &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014, + &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024, + &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013, + &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037, + &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016, + &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024, + &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015, + &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001, + &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/ + DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004, + &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005, + &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025, + &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024, + &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11, + &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12, + &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13, + &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14, + &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15, + &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16, + &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2, + &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12, + &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14, + &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12, + &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11, + &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14, + &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13, + &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16, + &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15, + &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/ + DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039, + &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024, + &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037, + &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037, + &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037, + &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002, + &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004, + &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005, + &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011, + &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013, + &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015, + &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016, + &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14, + &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16, + &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11, + &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12, + &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13, + &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14, + &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15, + &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/ + DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4, + &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025, + &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002, + &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006, + &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011, + &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015, + &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11, + &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14, + &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15, + &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12, + &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14, + &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14, + &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16, + &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16, + &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3, + &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024, + &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024, + &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037, + &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037, + &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/ + DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002, + &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004, + &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005, + &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011, + &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013, + &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015, + &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016, + &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14, + &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16, + &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11, + &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12, + &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13, + &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14, + &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15, + &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16, + &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039, + &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024, + &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024, + &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037, + &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/ + DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037, + &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002, + &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004, + &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006, + &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011, + &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013, + &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015, + &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12, + &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14, + &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12, + &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11, + &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14, + &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13, + &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16, + &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15, + &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2, + &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024, + &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025, + &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004, + &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/ + DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014, + &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015, + &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11, + &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14, + &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16, + &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12, + &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12, + &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14, + &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16, + &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16, + &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1, + &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022, + &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002, + &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13, + &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037, + &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001, + &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039, + &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003, + &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11, + &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/ + DATA (KFDP(I,1),I=3783,4156)/1000039,1000024,1000037,1000022, + &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003, + &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024, + &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006, + &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12, + &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039, + &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006, + &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1, + &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035, + &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14, + &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023, + &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12, + &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037, + &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016, + &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5, + &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21, + &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,9*11,9*-11,11,-11,11,-11,9*13,9*-13,13,-13,13,-13, + &9*15/ + DATA (KFDP(I,1),I=4157,8000)/9*-15,15,-15,15,-15,1,2,3,4,5,6,11, + &12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,-15, + &3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,2*24, + &2*3000211,2*22,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17, + &18,2*24,3*3000211,2*24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23, + &22,23,24,3000211,24,3000211,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15, + &16,17,18,2*24,-24,23,2*22,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13, + &14,15,16,17,18,2*22,23,2*24,23,22,2*24,23,4*-1,4*-3,4*-5,4*-7, + &-11,-13,-15,-17, + &649*0, +C...UED + &5100023,5100022,5100023,5100022,5100023,5100022, + &5100023,5100022,5100023,5100022,5100023,5100022, + &5100023,-5100024,5100022,5100023,5100024,5100022, + &5100023,-5100024,5100022,5100023,5100024,5100022, + &5100023,-5100024,5100022,5100023,5100024,5100022, + &9*5100022, + &6100001,6100002,6100003,6100004,6100005,6100006, + &5100001,5100002,5100003,5100004,5100005,5100006, + &-6100001,-6100002,-6100003,-6100004,-6100005,-6100006, + &-5100001,-5100002,-5100003,-5100004,-5100005,-5100006, + &39, + &6100011,6100013,6100015, + &5100011,5100013,5100015, + %5100012,5100014,5100016, + &-6100011,-6100013,-6100015, + &-5100011,-5100013,-5100015, + %-5100012,-5100014,-5100016, + &-5100011,-5100013,-5100015, + &5100012,5100014,5100016, + &2912*0/ + DATA (KFDP(I,2),I= 1, 339)/3*1,2,4,6,8,1,3*2,1,3,5,7,2,3*3,2,4, + &6,8,3,3*4,1,3,5,7,4,3*5,2,4,6,8,5,3*6,1,3,5,7,6,5,6*1000006,3*7, + &2,4,6,8,7,4,6,3*8,1,3,5,7,8,5,7,2*11,12,11,12,2*11,2*13,14,13,14, + &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321, + &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211, + &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211, + &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21, + &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8, + &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8, + &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23, + &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023, + &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001, + &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003, + &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005, + &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011, + &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013, + &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015, + &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6, + &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8, + &2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,23,22,25,-1,-2,-3,-4,-5,-6/ + DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23, + &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025, + &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024, + &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002, + &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005, + &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011, + &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013, + &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015, + &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6, + &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022, + &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035, + &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001, + &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004, + &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006, + &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012, + &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014, + &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016, + &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037, + &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005, + &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/ + DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1, + &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211, + &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111, + &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111, + &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111, + &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14, + &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223, + &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22, + &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213, + &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213, + &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211, + &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213, + &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310, + &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111, + &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113, + &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82, + &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213, + &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22, + &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213, + &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/ + DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111, + &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431, + &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22, + &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3, + &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21, + &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211, + &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211, + &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111, + &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211, + &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211, + &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213, + &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203, + &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22, + &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1, + &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13, + &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3, + &4,1,3,11,13,15,1,4,3,4,1,3,2*111,2*211,11,13,15,1,4,3,4,1,3,11, + &13,15,1,4,3,4,1,3,4*22,11,13,15,1,4,3,4,1,3,22,11,13,15,1,4,3,4, + &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1, + &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3/ + DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3, + &4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4, + &1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1, + &3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,4,1,3, + &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113, + &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310, + &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311, + &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311, + &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211, + &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311, + &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111, + &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13, + &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5, + &1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3, + &-5,2,2*1,4*2,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3, + &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4, + &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,2*24,2*37,4,1,3,5,1,3,5,1,3,5,-3, + &2*-5,5,2*6,4*5,2*-24,2*-37,5,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3, + &4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6,2*5,4*6,2*24,2*37,6,4,-15, + &16,1,3,5,1,3,5,1,3,5,-3,2*-5,11,2*12,4*11,2*-24,-37,13,15,11,15/ + DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5, + &1,3,5,12,2*11,4*12,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5, + &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3, + &5,1,3,5,1,3,5,14,2*13,4*14,2*24,2*37,11,13,15,11,13,15,1,3,5,1,3, + &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11, + &13,15,1,3,5,1,3,5,1,3,5,16,2*15,4*16,2*24,2*37,11,13,15,11,13,15, + &1,3,5,1,3,5,1,3,5,21,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5, + &5,-5,5,-6,6,-6,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6,1,3,5,2,4,6, + &1,-1,3,-3,5,-5,1,-1,3,-3,5,-5,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3, + &-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2, + &-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5, + &-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4, + &-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1, + &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13, + &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15, + &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1, + &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6, + &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5, + &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4, + &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3/ + DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22, + &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11, + &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3, + &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5, + &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14, + &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13, + &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15, + &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1, + &1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6, + &6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5, + &5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4, + &4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3, + &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24, + &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37, + &2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,2*14,2*-15,2*16,-1, + &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15, + &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2, + &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5, + &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4, + &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/ + DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4, + &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1, + &2*4,-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,22,23,25,35,36,22,23,11,13, + &15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4, + &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13, + &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3, + &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13, + &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13, + &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15, + &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1, + &-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6, + &-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3, + &-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2,2, + &-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5, + &-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,23,25,35,36, + &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14, + &16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36, + &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15, + &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4, + &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/ + DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16, + &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15, + &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11, + &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3, + &3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-2,2,-1,1,-2, + &2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4,4,-5,5,-6,6,-5,5,-6,6,-5, + &5,-6,6,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,3,-4,4,-3,3,-4, + &4,-5,5,-6,6,-5,5,-6,6,-5,5,-6,6,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,-1, + &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11, + &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11, + &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13, + &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15, + &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16, + &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13, + &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3, + &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2, + &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5, + &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4, + &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4, + &-3,4,-3,3*6,-5,2*4,-3,3*6,-5,2*6,1,2*2,4*1,23,25,35,36,2*-24/ + DATA (KFDP(I,2),I=3670,4183)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5, + &6,1,2,3,4,5,6,1,2,3,4,5,6,-3,-5,-3,-5,-3,-5,2,2*1,4*2,23,25,35, + &36,2*24,2*37,2,1,3,5,1,3,5,1,3,5,-3,2*-5,3,2*4,4*3,23,25,35,36, + &2*-24,2*-37,3,1,3,5,1,3,5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4, + &5,6,-1,-5,-1,-5,-1,-5,4,2*3,4*4,23,25,35,36,2*24,2*37,4,1,3,5,1, + &3,5,1,3,5,-3,2*-5,5,2*6,4*5,23,25,35,36,2*-24,2*-37,5,1,3,5,1,3, + &5,1,3,5,1,2,3,4,5,6,1,2,3,4,5,6,1,2,3,4,5,6,-1,-3,-1,-3,-1,-3,6, + &2*5,4*6,23,25,35,36,2*24,2*37,6,1,3,5,1,3,5,1,3,5,-3,2*-5,11, + &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11, + &13,15,1,3,5,1,3,5,1,3,5,13,2*14,4*13,23,25,35,36,2*-24,2*-37,13, + &15,11,15,11,13,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,15,2*16,4*15, + &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3, + &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16, + &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-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,3*-1,3*-3,3*-5,3*1,3*3,3*5,-13,13,-15,15,3*-1,3*-3, + &3*-5,3*1,3*3,3*5,-11,11,-15,15,3*-1,3*-3,3*-5,3*1,3*3,3*5,-11,11, + &-13,13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16/ + DATA (KFDP(I,2),I=4184,8000)/9900016,2,4,6,2,4,6,2,4,6,9900012, + &9900014,9900016,-11,-13,-15,-13,2*-15,24,-11,-13,-15,-13,2*-15, + &9900024,6*21,-24,-3000211,-24,-3000211,3000111,3000221,3000111, + &3000221,2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17, + &-18,23,3000111,23,3000111,22,3000221,22,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, + &2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24, + &-3000211,3000211,3000221,3000113,3000223,-3000213,3000213, + &3000113,3000223,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16, + &-17,-18,24,3000211,24,3000111,3000221,3000211,3000213,3000113, + &3000223,3000213,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18, + &649*0, +C...UED + &1,1,2,2,3,3,4,4,5,5,6,6, + &1,2,1,2,1,2,3,4,3,4,3,4,5,6,5,6,5,6, + &11,13,15,12,11,14,13,16,15, + &-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6, + &1,2,3,4,5,6,1,2,3,4,5,6, + &22, + &-11,-13,-15,-11,-13,-15,-12,-14,-16, + &11,13,15,11,13,15,12,14,16, + &12,14,16,-11,-13,-15, + &2912*0/ + DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130, + &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221, + &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130, + &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211, + &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111, + &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221, + &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331, + &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0, + &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211, + &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311, + &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310, + &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0, + &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0, + &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413, + &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211, + &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423, + &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211, + &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433, + &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443, + &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/ + DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0, + &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112, + &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0, + &4*3,4*0,4*3,6*0,4*3,0,28*3,2*0,3*4122,8*0,4,1,4,3,2*2,4*4,1,4,3, + &2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*0,4*4,1,4,3, + &2*2,0,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2, + &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4, + &3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2, + &4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4,3,2*2,4*4,1,4, + &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0, + &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1, + &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6, + &6,-2,2,-4,4,-6,6,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3, + &-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5, + &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5, + &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1, + &-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,-3,3, + &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11, + &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11, + &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/ + DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5, + &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5, + &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1, + &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3, + &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14, + &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12, + &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15, + &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15, + &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5, + &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5, + &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1, + &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1, + &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5, + &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,3*0,12,14,16,2,4,0,12,14,16,2, + &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16, + &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11, + &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1, + &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3, + &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5, + &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1/ + DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3, + &2*6,5,-5,3,-3,5,-5,1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,7*0, + &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14, + &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12, + &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15, + &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15, + &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5, + &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5, + &-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1, + &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1, + &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5, + &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16, + &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0, + &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16, + &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4, + &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15, + &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1, + &-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1, + &-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3, + &-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/ + DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5, + &-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,-3,3,-5,5,-5,5,-3,3,-5,5, + &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4, + &4*0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4,0,12,14,16,2,4, + &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16, + &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15, + &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15, + &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1, + &2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3, + &2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5, + &2*2,1,-1,2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,2*6,5,-5,3,-3,5,-5, + &1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,351*0,-5,95*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,3831*0/ + DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211, + &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113, + &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0, + &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111, + &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111, + &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321, + &-311,20*0,-3,43*0,6*1,39*0,6*2,42*0,6*3,14*0,8*4,4*0,4*-5,4*0, + &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81, + &4*0,4*81,6*0,4*81,0,28*81,13*0,6*2101,18*81,4*0,18*81,4*0,9*81,0, + &162*81,31*0,-211,111,6516*0/ + DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0, + &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211, + &3*111,-211,111,7193*0/ + +C...PYDAT4, with particle names (character strings). + DATA (CHAF(I,1),I= 1, 202)/'d','u','s','c','b','t','b''','t''', + &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-', + &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0', + &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ', + &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ', + &'junction',' ','system','cluster','string','indep.','CMshower', + &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon', + &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega', + &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi', + &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+', + &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+', + &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b', + &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0', + &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-', + &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+', + &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0', + &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1', + &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0', + &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0', + &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/ + DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+', + &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0', + &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+', + &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-', + &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0', + &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0', + &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-', + &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-', + &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+', + &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1', + &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c', + &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+', + &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1', + &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0', + &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L', + &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL', + &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+', + &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R', + &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR', + &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/ + DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc', + &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc', + &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*', + &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++', + &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di', + &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]', + &'bb~[3S18]','bb~[1S08]','bb~[3P08]','a_tc0','a_tc+', + &81*' ', +C...UED + &'d*_S','u*_S','s*_S','c*_S','b*_S','t*_S', + &'d*_D','u*_D','s*_D','c*_D','b*_D','t*_D', + &'e*_S-','mu*_S-','tau*_S-', + &'nu*_eD','e*_D-','nu*_muD','mu*_D-','nu*_tauD','tau*_D-', + &'g*','gamma*','Z*0','W*+',25*' '/ + 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-',7*' ','a_tc-', + &81*' ', +C...UED + &'d*_Sbar','u*_Sbar','s*_Sbar','c*_Sbar','b*_Sbar','t*_Sbar', + &'d*_Dbar','u*_Dbar','s*_Dbar','c*_Dbar','b*_Dbar','t*_Dbar', + &'e*_Sbar+','mu*_Sbar+','tau*_Sbar+', + &'nu*_eDbar','e*_Dbar+', + &'nu*_muDbar','mu*_Dbar+', + &'nu*_tauDbar','tau*_Dbar+', + &'g*','gamma*','Z*0','W*-',25*' '/ + +C...PYDATR, with initial values for the random number generator. + DATA MRPY/19780503,0,0,97,33,0/ + +C...Default values for allowed processes and kinematics constraints. + DATA MSEL/1/ + DATA MSUB/500*0/ + DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0, + &5*1,5*0,6*1,4*0,4*1,16*0,16*0,4*1,4*0,6*1,5*0,5*1,0,5*1,5*0, + &6*1,4*0,4*1,16*0/ + DATA CKIN/ + & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0, + & 1.0D0, -10D0, 10D0, -40D0, 40D0, + 1 -40D0, 40D0, -40D0, 40D0, -40D0, + 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0, + 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0, + 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0, + 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0, + 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0, + 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0, + 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0, + 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0, + 5 -1.0D0, 0D0, 0D0, 0D0, 0D0, + 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0, + 6 -1D0, 0D0, -1D0, 0D0, -1D0, + 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0, + 7 0.99D0, 2D0, -1D0, 0D0, 0D0, + 8 120*0D0/ + +C...Default values for main switches and parameters. Reset information. + DATA (MSTP(I),I=1,100)/ + & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0, + 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3, + 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1, + 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0, + 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0, + 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7, + 6 2, 3, 2, 2, 1, 5, 2, 3, 0, 0, + 7 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, + 8 1, 4, 100, 1, 1, 2, 4, 1, 1, 0, + 9 1, 3, 1, 3, 1, 0, 0, 0, 0, 0/ + DATA (MSTP(I),I=101,200)/ + & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0, + 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, + 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0, + 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0, + 4 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, + 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0, + 8 6, 425, 2011, 03, 23, 0, 0, 0, 0, 0, + 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ + DATA (PARP(I),I=1,100)/ + & 0.25D0, 10D0, 8*0D0, + 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0, + 2 10*0D0, + 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0, + 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0, + 5 10*0D0, + 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0, + 7 4.0D0, 0.25D0, 5*0D0, 0.025D0, 2.0D0, 0.1D0, + 8 1.90D0, 2.0D0, 0.5D0, 0.4D0, 0.90D0, + 8 0.95D0, 0.7D0, 0.5D0, 1800D0, 0.25D0, + 9 2.0D0,0.40D0,5.0D0,1.0D0,0.0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/ + DATA (PARP(I),I=101,200)/ + & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0, + 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0, + 2 1.0D0, 0.4D0, 8*0D0, + 3 0.01D0, 9*0D0, + 4 1.16D0, 0.0119D0, 0.01D0, 0.01D0, 0.05D0, + 4 9.28D0, 0.15D0, 0.02D0, 0.48D0, 0.09D0, + 5 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, + 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0, + 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0, + 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0, + 8 0.3D0, 0.64D0, + 9 0.64D0, 5.0D0, 1.0D4, 1.0D4, 6*0D0/ + DATA MSTI/200*0/ + DATA PARI/200*0D0/ + DATA MINT/400*0/ + DATA VINT/400*0D0/ + +C...Constants for the generation of the various processes. + DATA (ISET(I),I=1,100)/ + & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2, + 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2, + 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2, + 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1, + 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1, + 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2, + 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2, + 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2, + 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/ + DATA (ISET(I),I=101,200)/ + & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2, + 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2, + 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2, + 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2, + 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2, + 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2, + 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2, + 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2, + 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/ + DATA (ISET(I),I=201,300)/ + & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2, + 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2, + 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2, + 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1, + 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/ + DATA (ISET(I),I=301,500)/ + & 2, 9*-2, 9*2, 21*-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, 2, 2, 2, + 8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2, + 9 1, 1, 2, 2, 2, 5*-2, + & 5, 5, 18*-2, + 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2, + 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 7 2, 2, 2, 2, 2, 2, 2, 2, 2, -2, + 8 2, 2, 18*-2/ + DATA ((KFPR(I,J),J=1,2),I=1,50)/ + & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0, + & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0, + 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23, + 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24, + 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24, + 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23, + 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23, + 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23, + 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23, + 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/ + DATA ((KFPR(I,J),J=1,2),I=51,100)/ + 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0, + 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24, + 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22, + 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211, + 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0, + 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ + DATA ((KFPR(I,J),J=1,2),I=101,150)/ + & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0, + & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25, + 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22, + 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0, + 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0, + 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0, + 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0, + 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/ + DATA ((KFPR(I,J),J=1,2),I=151,200)/ + 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0, + 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0, + 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0, + 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0, + 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0, + 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0, + 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35, + 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36, + 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0, + 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ + DATA ((KFPR(I,J),J=1,2),I=201,240)/ + & 1000011, 1000011, 2000011, 2000011, 1000011, + & 2000011, 1000013, 1000013, 2000013, 2000013, + & 1000013, 2000013, 1000015, 1000015, 2000015, + & 2000015, 1000015, 2000015, 1000011, 1000012, + 1 1000015, 1000016, 2000015, 1000016, 1000012, + 1 1000012, 1000016, 1000016, 0, 0, + 1 1000022, 1000022, 1000023, 1000023, 1000025, + 1 1000025, 1000035, 1000035, 1000022, 1000023, + 2 1000022, 1000025, 1000022, 1000035, 1000023, + 2 1000025, 1000023, 1000035, 1000025, 1000035, + 2 1000024, 1000024, 1000037, 1000037, 1000024, + 2 1000037, 1000022, 1000024, 1000023, 1000024, + 3 1000025, 1000024, 1000035, 1000024, 1000022, + 3 1000037, 1000023, 1000037, 1000025, 1000037, + 3 1000035, 1000037, 1000021, 1000022, 1000021, + 3 1000023, 1000021, 1000025, 1000021, 1000035/ + DATA ((KFPR(I,J),J=1,2),I=241,280)/ + 4 1000021, 1000024, 1000021, 1000037, 1000021, + 4 1000021, 1000021, 1000021, 0, 0, + 4 1000002, 1000022, 2000002, 1000022, 1000002, + 4 1000023, 2000002, 1000023, 1000002, 1000025, + 5 2000002, 1000025, 1000002, 1000035, 2000002, + 5 1000035, 1000001, 1000024, 2000005, 1000024, + 5 1000001, 1000037, 2000005, 1000037, 1000002, + 5 1000021, 2000002, 1000021, 0, 0, + 6 1000006, 1000006, 2000006, 2000006, 1000006, + 6 2000006, 1000006, 1000006, 2000006, 2000006, + 6 0, 0, 0, 0, 0, + 6 0, 0, 0, 0, 0, + 7 1000002, 1000002, 2000002, 2000002, 1000002, + 7 2000002, 1000002, 1000002, 2000002, 2000002, + 7 1000002, 2000002, 1000002, 1000002, 2000002, + 7 2000002, 1000002, 1000002, 2000002, 2000002/ + DATA ((KFPR(I,J),J=1,2),I=281,350)/ + 8 1000005, 1000002, 2000005, 2000002, 1000005, + 8 2000002, 1000005, 1000002, 2000005, 2000002, + 8 1000005, 2000002, 1000005, 1000005, 2000005, + 8 2000005, 1000005, 1000005, 2000005, 2000005, + 9 1000005, 1000005, 2000005, 2000005, 1000005, + 9 2000005, 1000005, 1000021, 2000005, 1000021, + 9 1000005, 2000005, 37, 25, 37, + 9 35, 36, 25, 36, 35, + & 37, 37, 18*0, +C...UED: 311-319 + & 5100021, 5100021, + & 5100002, 5100021, + & 5100002, 5100001, + & 5100002, -5100002, + & 5100002, -5100002, + & 5100002, -6100001, + & 5100002, -5100001, + & 5100002, 6100001, + & 5100001, -5100001, + & 42*0, + 4 9900041, 0, 9900042, 0, 9900041, + 4 11, 9900042, 11, 9900041, 13, + 4 9900042, 13, 9900041, 15, 9900042, + 4 15, 9900041, 9900041, 9900042, 9900042/ + DATA ((KFPR(I,J),J=1,2),I=351,400)/ + 5 9900041, 0, 9900042, 0, 9900023, + 5 0, 9900024, 0, 0, 0, + 5 0, 0, 0, 0, 0, + 5 0, 0, 0, 0, 0, + 6 24, 24, 24, 3000211, 3000211, + 6 3000211, 22, 3000111, 22, 3000221, + 6 23, 3000111, 23, 3000221, 24, + 6 3000211, 0, 0, 24, 23, + 7 24, 3000111, 3000211, 23, 3000211, + 7 3000111, 22, 3000211, 23, 3000211, + 7 24, 3000111, 24, 3000221, 22, + 7 24, 22, 23, 23, 23, + 8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0, + 8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0, + 9 5000039, 0, 5000039, 0, 21, + 9 5000039, 0, 5000039, 21, 5000039, + 9 10*0/ + DATA ((KFPR(I,J),J=1,2),I=401,500)/ + & 37, 6, 37, 6, 36*0, + 2 443, 21, 9900443, 21, 9900441, + 2 21, 9910441, 21, 0, 9900443, + 2 0, 9900441, 0, 9910441, 21, + 2 9900443, 21, 9900441, 21, 9910441, + 3 10441, 21, 20443, 21, 445, 21, 0, 10441, 0, 20443, + 3 0, 445, 21, 10441, 21, 20443, 21, 445, 42*0, + 6 553, 21, 9900553, 21, 9900551, + 6 21, 9910551, 21, 0, 9900553, + 6 0, 9900551, 0, 9910551, 21, + 6 9900553, 21, 9900551, 21, 9910551, + 7 10551, 21, 20553, 21, 555, 21, 0, 10551, 0, 20553, + 7 0, 555, 21, 10551, 21, 20553, 21, 555, 42*0/ + DATA COEF/10000*0D0/ + DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/ + &4,0,3,0,2,0,1,0,3,0,4,0,1,0,2,0,2,0,0,1,4,0,0,3,3,0,0,4,1,0,0,2, + &3,0,0,4,1,4,3,2,4,0,0,3,4,2,1,3,2,0,4,1,4,0,2,3,4,0,3,4,2,0,1,2, + &3,2,1,0,1,4,3,0,4,3,3,0,2,1,1,0,3,2,1,4,1,0,0,2,2,4,3,1,2,0,0,1, + &3,2,1,4,1,4,3,2,4,2,1,3,4,2,1,3,3,4,4,3,1,2,2,1,2,0,3,1,2,0,0,0, + &4,2,1,0,0,0,1,0,3,0,0,3,1,2,0,0,4,0,0,4,0,0,1,2,2,0,0,1,4,4,3,3, + &2,2,1,1,4,4,3,3,3,3,4,4,1,1,2,2,3,2,1,3,1,2,0,0,4,2,1,4,0,0,1,2, + &4,0,0,0,4,0,1,3,0,0,3,0,2,4,3,0,3,4,0,0,1,0,0,1,0,0,3,4,2,0,0,2, + &3,0,0,0,1,0,0,0,0,0,3,0,2,0,0,0,2,0,3,1,2,0,0,0,3,2,1,0,1,0,0,0, + &4,4,3,3,2,2,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + &0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ + +C...Treatment of resonances. + DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1, + &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,2*1, + &81*0,21*1,4*1,25*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- ', + &9*' ', 'g + g -> g* + g* ', + &'q + g -> q*_D + g* ', 'qi + qj -> q*_Di + q*_Dj ', + &'g + g -> q*_D + q*_Dbar ', 'q + qbar -> q*_D + q*_Dbar ', + &'qi + qbarj -> q*Di + q*Sbarj', 'qi + qjbar -> q*Di + q*Dbarj', + &'qi + qj -> q*_Di + q*_Sj ', 'qi + qibar -> q*Dj + q*Dbarj', + &21*' '/ + 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'f + fbar'' -> gamma W+/-(ETC)','f + fbar -> gamma Z0 (ETC)', + 7'f + fbar -> Z0 Z0 (ETC) '/ + DATA (PROC(I),I=381,420)/ + 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)', + 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ', + 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ', + 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ', + 8' ', ' ', + 9'f + fbar -> G* ', 'g + g -> G* ', + 9'q + qbar -> g + G* ', 'q + g -> q + G* ', + 9'g + g -> g + G* ', ' ', + 9 4*' ', + &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ', + & 18*' '/ + DATA (PROC(I),I=421,460)/ + 2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ', + 2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ', + 2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ', + 2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ', + 2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ', + 3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ', + 3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ', + 3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ', + 3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ', + 3'q + q~ -> g + cc~[3P2(1)] ', + 3 21 *' '/ + DATA (PROC(I),I=461,500)/ + 6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ', + 6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ', + 6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ', + 6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ', + 6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ', + 7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ', + 7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ', + 7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ', + 7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ', + 7'q + q~ -> g + bb~[3P2(1)] ', + 7 21 *' '/ + +C...Cross sections and slope offsets. + DATA SIGT/294*0D0/ + +C...Supersymmetry switches and parameters. + DATA IMSS/0, + & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, + 1 89*0/ + DATA RMSS/0D0, + & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0, + 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0, + 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0, + 3 10*0D0, + 4 0D0,1D0,8*0D0, + 5 49*0D0/ +C...Initial values for R-violating SUSY couplings. +C...Should not be changed here. See PYMSIN. + DATA RVLAM/27*0D0/ + DATA RVLAMP/27*0D0/ + DATA RVLAMB/27*0D0/ + +C...Technicolor switches and parameters + DATA ITCM/0, + & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 1 89*0/ + DATA RTCM/0D0, + & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0, + 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0, + 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0, + 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0, + 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 1D0, 3*200D0, + 4 200D0, 48*0D0/ + +C...UED switches and parameters. +C... IUED(0) empty IUED vector element +C... IUED(1) UED ON(=1)/OFF(=0) switch +C... IUED(2) ON(=1)/OFF(=0) switch for gravity mediated decays +C... IUED(3) NFLAVOURS Number of KK excitation quark flavours +C... IUED(4) N the number of large extra dimensions +C... IUED(5) Selects whether the code takes Lambda (=0) +C... or Lambda*R (=1) as input. +C... IUED(6) With radiative corrections to the masses (=1) +C... or without (=0) +C... +C... RUED(0) empty RUED vector element +C... RUED(1) RINV (1/R) the curvature of the extra dimension +C... RUED(2) XMD the (4+N)-dimensional Planck scale +C... RUED(3) LAMUED (Lambda cutoff scale) +C... RUED(4) LAMUED/RINV (feasible values are order of 10-20) +C... + DATA IUED/0,0,0,5,6,0,1,93*0/ + DATA RUED/0.D0,1000D0,5000D0,20000.,20.,95*0D0/ + +C...Data for histogramming routines. + DATA IHIST/1000,20000,55,1/ + DATA INDX/1000*0/ + +C...Data for SUSY Les Houches Accord. + DATA CPRO/'PYTHIA ','PYTHIA '/ + DATA CVER/'6.4 ','6.4 '/ + DATA MODSEL/200*0/ + DATA PARMIN/100*0D0/ + DATA RMSOFT/101*0D0/ + DATA AU/9*0D0/ + DATA AD/9*0D0/ + DATA AE/9*0D0/ + + END + +C********************************************************************* + +C...PYCKBD +C...Check that BLOCK DATA PYDATA has been loaded. +C...Should not be required, except that some compilers/linkers +C...are pretty buggy in this respect. + + SUBROUTINE PYCKBD + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/ + +C...Check a few variables to see they have been sensibly initialized. + IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0 + &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR. + &MSTP(1).GT.5) THEN +C...If not, abort the run right away. + WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!' + WRITE(*,*) 'The program execution is stopped now!' + CALL PYSTOP(8) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYTEST +C...A simple program (disguised as subroutine) to run at installation +C...as a check that the program works as intended. + + SUBROUTINE PYTEST(MTEST) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/ +C...Local arrays. + DIMENSION PSUM(5),PINI(6),PFIN(6) + +C...Save defaults for values that are changed. + MSTJ1=MSTJ(1) + MSTJ3=MSTJ(3) + MSTJ11=MSTJ(11) + MSTJ42=MSTJ(42) + MSTJ43=MSTJ(43) + MSTJ44=MSTJ(44) + PARJ17=PARJ(17) + PARJ22=PARJ(22) + PARJ43=PARJ(43) + PARJ54=PARJ(54) + MST101=MSTJ(101) + MST104=MSTJ(104) + MST105=MSTJ(105) + MST107=MSTJ(107) + MST116=MSTJ(116) + +C...First part: loop over simple events to be generated. + IF(MTEST.GE.1) CALL PYTABU(20) + NERR=0 + DO 180 IEV=1,500 + +C...Reset parameter values. Switch on some nonstandard features. + MSTJ(1)=1 + MSTJ(3)=0 + MSTJ(11)=1 + MSTJ(42)=2 + MSTJ(43)=4 + MSTJ(44)=2 + PARJ(17)=0.1D0 + PARJ(22)=1.5D0 + PARJ(43)=1D0 + PARJ(54)=-0.05D0 + MSTJ(101)=5 + MSTJ(104)=5 + MSTJ(105)=0 + MSTJ(107)=1 + IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3 + +C...Ten events each for some single jets configurations. + IF(IEV.LE.50) THEN + ITY=(IEV+9)/10 + MSTJ(3)=-1 + IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2 + IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0) + IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0) + IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0) + IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0) + IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0) + +C...Ten events each for some simple jet systems; string fragmentation. + ELSEIF(IEV.LE.130) THEN + ITY=(IEV-41)/10 + IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0) + IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0) + IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0) + IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0) + IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0) + IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0) + IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0) + IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0, + & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) + +C...Seventy events with independent fragmentation and momentum cons. + ELSEIF(IEV.LE.200) THEN + ITY=1+(IEV-131)/16 + MSTJ(2)=1+MOD(IEV-131,4) + MSTJ(3)=1+MOD((IEV-131)/4,4) + IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0) + IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0) + IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0, + & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) + IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0, + & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0) + +C...A hundred events with random jets (check invariant mass). + ELSEIF(IEV.LE.300) THEN + 100 DO 110 J=1,5 + PSUM(J)=0D0 + 110 CONTINUE + NJET=2D0+6D0*PYR(0) + DO 130 I=1,NJET + KFL=21 + IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0)) + IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0)) + EJET=5D0+20D0*PYR(0) + THETA=ACOS(2D0*PYR(0)-1D0) + PHI=6.2832D0*PYR(0) + IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI) + IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI) + IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1 + IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL) + DO 120 J=1,4 + PSUM(J)=PSUM(J)+P(I,J) + 120 CONTINUE + 130 CONTINUE + IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT. + & (PSUM(5)+PARJ(32))**2) GOTO 100 + +C...Fifty e+e- continuum events with matrix elements. + ELSEIF(IEV.LE.350) THEN + MSTJ(101)=2 + CALL PYEEVT(0,40D0) + +C...Fifty e+e- continuum event with varying shower options. + ELSEIF(IEV.LE.400) THEN + MSTJ(42)=1+MOD(IEV,2) + MSTJ(43)=1+MOD(IEV/2,4) + MSTJ(44)=MOD(IEV/8,3) + CALL PYEEVT(0,90D0) + +C...Fifty e+e- continuum events with coherent shower. + ELSEIF(IEV.LE.450) THEN + CALL PYEEVT(0,500D0) + +C...Fifty Upsilon decays to ggg or gammagg with coherent shower. + ELSE + CALL PYONIA(5,9.46D0) + ENDIF + +C...Generate event. Find total momentum, energy and charge. + DO 140 J=1,4 + PINI(J)=PYP(0,J) + 140 CONTINUE + PINI(6)=PYP(0,6) + CALL PYEXEC + DO 150 J=1,4 + PFIN(J)=PYP(0,J) + 150 CONTINUE + PFIN(6)=PYP(0,6) + +C...Check conservation of energy, momentum and charge; +C...usually exact, but only approximate for single jets. + MERR=0 + IF(IEV.LE.50) THEN + IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0) + & MERR=MERR+1 + EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3) + IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1 + IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1 + ELSE + DO 160 J=1,4 + IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1 + 160 CONTINUE + IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1 + ENDIF + IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6), + & (PFIN(J),J=1,4),PFIN(6) + +C...Check that all KF codes are known ones, and that partons/particles +C...satisfy energy-momentum-mass relation. Store particle statistics. + DO 170 I=1,N + IF(K(I,1).GT.20) GOTO 170 + IF(PYCOMP(K(I,2)).EQ.0) THEN + WRITE(MSTU(11),5100) I + MERR=MERR+1 + ENDIF + PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2 + IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0) + & THEN + WRITE(MSTU(11),5200) I + MERR=MERR+1 + ENDIF + 170 CONTINUE + IF(MTEST.GE.1) CALL PYTABU(21) + +C...List all erroneous events and some normal ones. + IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN + IF(MERR.GE.1) WRITE(MSTU(11),6400) + CALL PYLIST(2) + ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN + CALL PYLIST(1) + ENDIF + +C...Stop execution if too many errors. + IF(MERR.NE.0) NERR=NERR+1 + IF(NERR.GE.10) THEN + WRITE(MSTU(11),6300) + CALL PYLIST(1) + CALL PYSTOP(9) + ENDIF + 180 CONTINUE + +C...Summarize result of run. + IF(MTEST.GE.1) CALL PYTABU(22) + +C...Reset commonblock variables changed during run. + MSTJ(1)=MSTJ1 + MSTJ(3)=MSTJ3 + MSTJ(11)=MSTJ11 + MSTJ(42)=MSTJ42 + MSTJ(43)=MSTJ43 + MSTJ(44)=MSTJ44 + PARJ(17)=PARJ17 + PARJ(22)=PARJ22 + PARJ(43)=PARJ43 + PARJ(54)=PARJ54 + MSTJ(101)=MST101 + MSTJ(104)=MST104 + MSTJ(105)=MST105 + MSTJ(107)=MST107 + MSTJ(116)=MST116 + +C...Second part: complete events of various kinds. +C...Common initial values. Loop over initiating conditions. + MSTP(122)=MAX(0,MIN(2,MTEST)) + MDCY(PYCOMP(111),1)=0 + DO 230 IPROC=1,8 + +C...Reset process type, kinematics cuts, and the flags used. + MSEL=0 + DO 190 ISUB=1,500 + MSUB(ISUB)=0 + 190 CONTINUE + CKIN(1)=2D0 + CKIN(3)=0D0 + MSTP(2)=1 + MSTP(11)=0 + MSTP(33)=0 + MSTP(81)=1 + MSTP(82)=1 + MSTP(111)=1 + MSTP(131)=0 + MSTP(133)=0 + PARP(131)=0.01D0 + +C...Prompt photon production at fixed target. + IF(IPROC.EQ.1) THEN + PZSUM=300D0 + PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212) + PQSUM=2D0 + MSEL=10 + CKIN(3)=5D0 + CALL PYINIT('FIXT','pi+','p',PZSUM) + +C...QCD processes at ISR energies. + ELSEIF(IPROC.EQ.2) THEN + PESUM=63D0 + PZSUM=0D0 + PQSUM=2D0 + MSEL=1 + CKIN(3)=5D0 + CALL PYINIT('CMS','p','p',PESUM) + +C...W production + multiple interactions at CERN Collider. + ELSEIF(IPROC.EQ.3) THEN + PESUM=630D0 + PZSUM=0D0 + PQSUM=0D0 + MSEL=12 + CKIN(1)=20D0 + MSTP(82)=4 + MSTP(2)=2 + MSTP(33)=3 + CALL PYINIT('CMS','p','pbar',PESUM) + +C...W/Z gauge boson pairs + pileup events at the Tevatron. + ELSEIF(IPROC.EQ.4) THEN + PESUM=1800D0 + PZSUM=0D0 + PQSUM=0D0 + MSUB(22)=1 + MSUB(23)=1 + MSUB(25)=1 + CKIN(1)=200D0 + MSTP(111)=0 + MSTP(131)=1 + MSTP(133)=2 + PARP(131)=0.04D0 + CALL PYINIT('CMS','p','pbar',PESUM) + +C...Higgs production at LHC. + ELSEIF(IPROC.EQ.5) THEN + PESUM=15400D0 + PZSUM=0D0 + PQSUM=2D0 + MSUB(3)=1 + MSUB(102)=1 + MSUB(123)=1 + MSUB(124)=1 + PMAS(25,1)=300D0 + CKIN(1)=200D0 + MSTP(81)=0 + MSTP(111)=0 + CALL PYINIT('CMS','p','p',PESUM) + +C...Z' production at SSC. + ELSEIF(IPROC.EQ.6) THEN + PESUM=40000D0 + PZSUM=0D0 + PQSUM=2D0 + MSEL=21 + PMAS(32,1)=600D0 + CKIN(1)=400D0 + MSTP(81)=0 + MSTP(111)=0 + CALL PYINIT('CMS','p','p',PESUM) + +C...W pair production at 1 TeV e+e- collider. + ELSEIF(IPROC.EQ.7) THEN + PESUM=1000D0 + PZSUM=0D0 + PQSUM=0D0 + MSUB(25)=1 + MSUB(69)=1 + MSTP(11)=1 + CALL PYINIT('CMS','e+','e-',PESUM) + +C...Deep inelastic scattering at a LEP+LHC ep collider. + ELSEIF(IPROC.EQ.8) THEN + P(1,1)=0D0 + P(1,2)=0D0 + P(1,3)=8000D0 + P(2,1)=0D0 + P(2,2)=0D0 + P(2,3)=-80D0 + PESUM=8080D0 + PZSUM=7920D0 + PQSUM=0D0 + MSUB(10)=1 + CKIN(3)=50D0 + MSTP(111)=0 + CALL PYINIT('3MOM','p','e-',PESUM) + ENDIF + +C...Generate 20 events of each required type. + DO 220 IEV=1,20 + CALL PYEVNT + PESUMM=PESUM + IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM + +C...Check conservation of energy/momentum/flavour. + PINI(1)=0D0 + PINI(2)=0D0 + PINI(3)=PZSUM + PINI(4)=PESUMM + PINI(6)=PQSUM + DO 200 J=1,4 + PFIN(J)=PYP(0,J) + 200 CONTINUE + PFIN(6)=PYP(0,6) + MERR=0 + DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3)) + DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2)) + DEVQ=ABS(PFIN(6)-PINI(6)) + IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR. + & DEVQ.GT.0.1D0) MERR=1 + IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6), + & (PFIN(J),J=1,4),PFIN(6) + +C...Check that all KF codes are known ones, and that partons/particles +C...satisfy energy-momentum-mass relation. + DO 210 I=1,N + IF(K(I,1).GT.20) GOTO 210 + IF(PYCOMP(K(I,2)).EQ.0) THEN + WRITE(MSTU(11),5100) I + MERR=MERR+1 + ENDIF + PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2* + & SIGN(1D0,P(I,5)) + IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2) + & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN + WRITE(MSTU(11),5200) I + MERR=MERR+1 + ENDIF + 210 CONTINUE + +C...Listing of erroneous events, and first event of each type. + IF(MERR.GE.1) NERR=NERR+1 + IF(NERR.GE.10) THEN + WRITE(MSTU(11),6300) + CALL PYLIST(1) + CALL PYSTOP(9) + ENDIF + IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN + IF(MERR.GE.1) WRITE(MSTU(11),6400) + CALL PYLIST(1) + ENDIF + 220 CONTINUE + +C...List statistics for each process type. + IF(MTEST.GE.1) CALL PYSTAT(1) + 230 CONTINUE + +C...Summarize result of run. + IF(NERR.EQ.0) WRITE(MSTU(11),6500) + IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR + +C...Format statements for output. + 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ', + &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X, + &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X, + &4(1X,F12.5),1X,F8.2) + 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code') + 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ', + &'kinematics') + 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ', + &'wrong.'/5X,'Execution will be stopped after listing of event.') + 6400 FORMAT(5X,'Faulty event follows:') + 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.') + 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/ + &5X,'This should not have happened!') + + RETURN + END + +C********************************************************************* + +C...PYHEPC +C...Converts PYTHIA event record contents to or from +C...the standard event record commonblock. + + SUBROUTINE PYHEPC(MCONV) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ +C...HEPEVT commonblock. + PARAMETER (NMXHEP=4000) + COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), + &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) + DOUBLE PRECISION PHEP,VHEP + SAVE /HEPEVT/ + +C...Store HEPEVT commonblock size (for interfacing issues). + MSTU(8)=NMXHEP + +C...Initialize variable(s) + INEW = 1 + +C...Conversion from PYTHIA to standard, the easy part. + IF(MCONV.EQ.1) THEN + NEVHEP=0 + IF(N.GT.NMXHEP) CALL PYERRM(8, + & '(PYHEPC:) no more space in /HEPEVT/') + NHEP=MIN(N,NMXHEP) + DO 150 I=1,NHEP + ISTHEP(I)=0 + IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1 + IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2 + IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3 + IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1) + IDHEP(I)=K(I,2) + JMOHEP(1,I)=K(I,3) + JMOHEP(2,I)=0 + IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN + JDAHEP(1,I)=K(I,4) + JDAHEP(2,I)=K(I,5) + ELSE + JDAHEP(1,I)=0 + JDAHEP(2,I)=0 + ENDIF + DO 100 J=1,5 + PHEP(J,I)=P(I,J) + 100 CONTINUE + DO 110 J=1,4 + VHEP(J,I)=V(I,J) + 110 CONTINUE + +C...Check if new event (from pileup). + IF(I.EQ.1) THEN + INEW=1 + ELSE + IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I + ENDIF + +C...Fill in missing mother information. + IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN + IMO1=I-2 + 120 IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0) + & THEN + IMO1=IMO1-1 + GOTO 120 + ENDIF + JMOHEP(1,I)=IMO1 + JMOHEP(2,I)=IMO1+1 + ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN + I1=K(I,3)-1 + 130 I1=I1+1 + IF(I1.GE.I) CALL PYERRM(8, + & '(PYHEPC:) translation of inconsistent event history') + IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130 + KC=PYCOMP(K(I1,2)) + IF(I1.LT.I.AND.KC.EQ.0) GOTO 130 + IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130 + JMOHEP(2,I)=I1 + ELSEIF(K(I,2).EQ.94) THEN + NJET=2 + IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3 + IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4 + JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5)) + IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)= + & MOD(K(I+1,4)/MSTU(5),MSTU(5)) + ENDIF + +C...Fill in missing daughter information. + IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN + DO 140 I1=JDAHEP(1,I),JDAHEP(2,I) + I2=MOD(K(I1,4)/MSTU(5),MSTU(5)) + JDAHEP(1,I2)=I + 140 CONTINUE + ENDIF + IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150 + I1=JMOHEP(1,I) + IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150 + IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150 + IF(JDAHEP(1,I1).EQ.0) THEN + JDAHEP(1,I1)=I + ELSE + JDAHEP(2,I1)=I + ENDIF + 150 CONTINUE + DO 160 I=1,NHEP + IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160 + IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I) + 160 CONTINUE + +C...Conversion from standard to PYTHIA, the easy part. + ELSE + IF(NHEP.GT.MSTU(4)) CALL PYERRM(8, + & '(PYHEPC:) no more space in /PYJETS/') + N=MIN(NHEP,MSTU(4)) + NKQ=0 + KQSUM=0 + DO 190 I=1,N + K(I,1)=0 + IF(ISTHEP(I).EQ.1) K(I,1)=1 + IF(ISTHEP(I).EQ.2) THEN + K(I,1)=11 + IF(K(I,4).GT.0.AND.(K(I,4).EQ.K(I,5)).AND. + $ (K(K(I,4),2).GE.91.AND.K(K(I,4),2).LE.93).AND. + $ (I.LT.N).AND.(K(I,4).EQ.K(I+1,4))) K(I,1)=12 + ENDIF + IF(ISTHEP(I).EQ.3) K(I,1)=21 + K(I,2)=IDHEP(I) + K(I,3)=JMOHEP(1,I) + K(I,4)=JDAHEP(1,I) + K(I,5)=JDAHEP(2,I) + DO 170 J=1,5 + P(I,J)=PHEP(J,I) + 170 CONTINUE + DO 180 J=1,4 + V(I,J)=VHEP(J,I) + 180 CONTINUE + V(I,5)=0D0 + IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN + I1=JDAHEP(1,I) + IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))* + & PHEP(5,I)/PHEP(4,I) + ENDIF + +C...Fill in missing information on colour connection in jet systems. + IF(ISTHEP(I).EQ.1) THEN + KC=PYCOMP(K(I,2)) + KQ=0 + IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) + IF(KQ.NE.0) NKQ=NKQ+1 + IF(KQ.NE.2) KQSUM=KQSUM+KQ + IF(KQ.NE.0.AND.KQSUM.NE.0) THEN + K(I,1)=2 + ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN + IF(K(I+1,2).EQ.21) K(I,1)=2 + ENDIF + ENDIF + 190 CONTINUE + IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8, + & '(PYHEPC:) input parton configuration not colour singlet') + ENDIF + + END + +C********************************************************************* + +C...PYINIT +C...Initializes the generation procedure; finds maxima of the +C...differential cross-sections to be used for weighting. + + SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYDAT4/CHAF(500,2) + CHARACTER CHAF*16 + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYPUED/IUED(0:99),RUED(0:99) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/, + &/PYINT1/,/PYINT2/,/PYINT5/,/PYPUED/ +C...Local arrays and character variables. + DIMENSION ALAMIN(20),NFIN(20) + CHARACTER*(*) FRAME,BEAM,TARGET + CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6 + +C...Interface to PDFLIB. + COMMON/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS + COMMON/W50512/QCDL4,QCDL5 + SAVE /W50511/,/W50512/ + DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5 + CHARACTER*20 PARM(20) + DATA VALUE/20*0D0/,PARM/20*' '/ + +C...Data:Lambda and n_f values for parton distributions.. + DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0, + &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/, + &NFIN/20*4/ + DATA CHLH/'lepton','hadron'/ + +C...Check that BLOCK DATA PYDATA has been loaded. + CALL PYCKBD + +C...Reset MINT and VINT arrays. Write headers. + MSTI(53)=0 + DO 100 J=1,400 + MINT(J)=0 + VINT(J)=0D0 + 100 CONTINUE + IF(MSTU(12).NE.12345) CALL PYLIST(0) + IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) + +C...Reset error counters. + MSTU(23)=0 + MSTU(27)=0 + MSTU(30)=0 + +C...Reset processes that should not be on. + MSUB(96)=0 + MSUB(97)=0 + +C...Select global FSR/ISR/UE parameter set = 'tune' +C...See routine PYTUNE for details + IF (MSTP(5).NE.0) THEN + MSTP5=MSTP(5) + CALL PYTUNE(MSTP5) + ENDIF + +C...Call user process initialization routine. + IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN + MSEL=0 + CALL UPINIT + MSEL=0 + ENDIF + +C...Maximum 4 generations; set maximum number of allowed flavours. + MSTP(1)=MIN(4,MSTP(1)) + MSTU(114)=MIN(MSTU(114),2*MSTP(1)) + MSTP(58)=MIN(MSTP(58),2*MSTP(1)) + +C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton. + DO 120 I=-20,20 + VINT(180+I)=0D0 + IA=IABS(I) + IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN + DO 110 J=1,MSTP(1) + IB=2*J-1+MOD(IA,2) + IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110 + IPM=(5-ISIGN(1,I))/2 + IDC=J+MDCY(IA,2)+2 + IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)= + & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2) + 110 CONTINUE + ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN + VINT(180+I)=1D0 + ENDIF + 120 CONTINUE + +C...Initialize parton distributions: PDFLIB. + IF(MSTP(52).EQ.2) THEN + PARM(1)='NPTYPE' + VALUE(1)=1 + PARM(2)='NGROUP' + VALUE(2)=MSTP(51)/1000 + PARM(3)='NSET' + VALUE(3)=MOD(MSTP(51),1000) + PARM(4)='TMAS' + VALUE(4)=PMAS(6,1) + call setlhaparm('SILENT') + CALL PDFSET(PARM,VALUE) + MINT(93)=1000000+MSTP(51) + ENDIF + +C...Choose Lambda value to use in alpha-strong. + MSTU(111)=MSTP(2) + IF(MSTP(3).GE.2) THEN + ALAM=0.2D0 + NF=4 + IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN + ALAM=ALAMIN(MSTP(51)) + NF=NFIN(MSTP(51)) + ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN + ALAM=QCDL5 + NF=5 + ELSEIF(MSTP(52).EQ.2) THEN + ALAM=QCDL4 + NF=4 + ENDIF + PARP(1)=ALAM + PARP(61)=ALAM + PARP(72)=ALAM + PARU(112)=ALAM + MSTU(112)=NF + IF(MSTP(3).EQ.3) PARJ(81)=ALAM + ENDIF + +C...Initialize the UED masses and widths + IF (IUED(1).EQ.1) CALL PYXDIN + +C...Initialize the SUSY generation: couplings, masses, +C...decay modes, branching ratios, and so on. + CALL PYMSIN +C...Initialize widths and partial widths for resonances. + CALL PYINRE +C...Set Z0 mass and width for e+e- routines. + PARJ(123)=PMAS(23,1) + PARJ(124)=PMAS(23,2) + +C...Identify beam and target particles and frame of process. + CHFRAM=FRAME//' ' + CHBEAM=BEAM//' ' + CHTARG=TARGET//' ' + CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN) + IF(MINT(65).EQ.1) GOTO 170 + +C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives. +C...For e-gamma allow 2 alternatives. + MINT(121)=1 + IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN + IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. + & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3 + IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6 + IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. + & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2 + ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN + IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. + & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3 + IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9 + ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN + IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. + & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2 + IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4 + ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN + IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND. + & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4 + IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13 + ENDIF + MINT(123)=MSTP(14) + IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR. + &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0 + IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN + IF(MSTP(14).EQ.11) MINT(123)=0 + IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5 + IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6 + IF(MSTP(14).EQ.15) MINT(123)=2 + IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7 + IF(MSTP(14).EQ.19) MINT(123)=3 + ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN + IF(MSTP(14).EQ.21) MINT(123)=0 + IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4 + IF(MSTP(14).EQ.24) MINT(123)=1 + ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN + IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8 + IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9 + ENDIF + +C...Set up kinematics of process. + CALL PYINKI(0) + +C...Set up kinematics for photons inside leptons. + IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA) + +C...Precalculate flavour selection weights. + CALL PYKFIN + +C...Loop over gamma-p or gamma-gamma alternatives. + CKIN3=CKIN(3) + MSAV48=0 + DO 160 IGA=1,MINT(121) + CKIN(3)=CKIN3 + MINT(122)=IGA + +C...Select partonic subprocesses to be included in the simulation. + CALL PYINPR + MINT(101)=1 + MINT(102)=1 + MINT(103)=MINT(11) + MINT(104)=MINT(12) + +C...Count number of subprocesses on. + MINT(48)=0 + DO 130 ISUB=1,500 + IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND. + & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN + MSUB(ISUB)=0 + ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND. + & MSUB(ISUB).EQ.1) THEN + WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42)) + CALL PYSTOP(1) + ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN + WRITE(MSTU(11),5300) ISUB + CALL PYSTOP(1) + ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN + WRITE(MSTU(11),5400) ISUB + CALL PYSTOP(1) + ELSEIF(MSUB(ISUB).EQ.1) THEN + MINT(48)=MINT(48)+1 + ENDIF + 130 CONTINUE + +C...Stop or raise warning flag if no subprocesses on. + IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN + IF(MSTP(127).NE.1) THEN + WRITE(MSTU(11),5500) + CALL PYSTOP(1) + ELSE + WRITE(MSTU(11),5700) + MSTI(53)=1 + ENDIF + ENDIF + MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94) + MSAV48=MSAV48+MINT(48) + +C...Reset variables for cross-section calculation. + DO 150 I=0,500 + DO 140 J=1,3 + NGEN(I,J)=0 + XSEC(I,J)=0D0 + 140 CONTINUE + 150 CONTINUE + +C...Find parametrized total cross-sections. + CALL PYXTOT + VINT(318)=VINT(317) + +C...Maxima of differential cross-sections. + IF(MSTP(121).LE.1) CALL PYMAXI + +C...Initialize possibility of pileup events. + IF(MINT(121).GT.1) MSTP(131)=0 + IF(MSTP(131).NE.0) CALL PYPILE(1) + +C...Initialize multiple interactions with variable impact parameter. + IF(MINT(50).EQ.1) THEN + PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) + IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR. + & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82)) + IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN + MINT(35)=1 + CALL PYMULT(1) + MINT(35)=3 + CALL PYMIGN(1) + ENDIF + ENDIF + +C...Save results for gamma-p and gamma-gamma alternatives. + IF(MINT(121).GT.1) CALL PYSAVE(1,IGA) + 160 CONTINUE + +C...Initialization finished. + IF(MSAV48.EQ.0) THEN + IF(MSTP(127).NE.1) THEN + WRITE(MSTU(11),5500) + CALL PYSTOP(1) + ELSE + WRITE(MSTU(11),5700) + MSTI(53)=1 + ENDIF + ENDIF + 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600) + +C...Formats for initialization information. + 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ', + &'routines',1X,17('*')) + 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6, + &'-',A6,' interactions.'/1X,'Execution stopped!') + 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/ + &1X,'Execution stopped!') + 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/ + &1X,'Execution stopped!') + 5500 FORMAT(1X,'Error: no subprocess switched on.'/ + &1X,'Execution stopped.') + 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X, + &22('*')) + 5700 FORMAT(1X,'Error: no subprocess switched on.'/ + &1X,'Execution will stop if you try to generate events.') + + RETURN + END + +C********************************************************************* + +C...PYEVNT +C...Administers the generation of a high-pT event via calls to +C...a number of subroutines. + + SUBROUTINE PYEVNT + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYCTAG/NCT,MCT(4000,2) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/, + &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/ +C...Local array. + DIMENSION VTX(4) + +C...Optionally let PYEVNW do the whole job. + IF(MSTP(81).GE.20) THEN + CALL PYEVNW + RETURN + ENDIF + +C...Stop if no subprocesses on. + IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN + WRITE(MSTU(11),5100) + CALL PYSTOP(1) + ENDIF + +C...Initial values for some counters. + MSTU(1)=0 + MSTU(2)=0 + N=0 + MINT(5)=MINT(5)+1 + MINT(7)=0 + MINT(8)=0 + MINT(30)=0 + MINT(83)=0 + MINT(84)=MSTP(126) + MSTU(24)=0 + MSTU70=0 + MSTJ14=MSTJ(14) +C...Normally, use K(I,4:5) colour info rather than /PYCTAG/. + NCT=0 + MINT(33)=0 + +C...Let called routines know call is from PYEVNT (not PYEVNW). + MINT(35)=1 + IF (MSTP(81).GE.10) MINT(35)=2 + +C...If variable energies: redo incoming kinematics and cross-section. + MSTI(61)=0 + IF(MSTP(171).EQ.1) THEN + CALL PYINKI(1) + IF(MSTI(61).EQ.1) THEN + MINT(5)=MINT(5)-1 + RETURN + ENDIF + IF(MINT(121).GT.1) CALL PYSAVE(3,1) + CALL PYXTOT + ENDIF + +C...Loop over number of pileup events; check space left. + IF(MSTP(131).LE.0) THEN + NPILE=1 + ELSE + CALL PYPILE(2) + NPILE=MINT(81) + ENDIF + DO 270 IPILE=1,NPILE + IF(MINT(84)+100.GE.MSTU(4)) THEN + CALL PYERRM(11, + & '(PYEVNT:) no more space in PYJETS for pileup events') + IF(MSTU(21).GE.1) GOTO 280 + ENDIF + MINT(82)=IPILE + +C...Generate variables of hard scattering. + MINT(51)=0 + MSTI(52)=0 + 100 CONTINUE + IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1 + MINT(31)=0 + MINT(39)=0 + MINT(51)=0 + MINT(57)=0 + CALL PYRAND + IF(MSTI(61).EQ.1) THEN + MINT(5)=MINT(5)-1 + RETURN + ENDIF + IF(MINT(51).EQ.2) RETURN + ISUB=MINT(1) + IF(MSTP(111).EQ.-1) GOTO 260 + +C...Loopback point if PYPREP fails, especially for junction topologies. + NPREP=0 + MNT31S=MINT(31) + 110 NPREP=NPREP+1 + MINT(31)=MNT31S + + IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN +C...Hard scattering (including low-pT): +C...reconstruct kinematics and colour flow of hard scattering. + MINT31=MINT(31) + 120 MINT(31)=MINT31 + MINT(51)=0 + CALL PYSCAT + IF(MINT(51).EQ.1) GOTO 100 + IPU1=MINT(84)+1 + IPU2=MINT(84)+2 + IF(ISUB.EQ.95) GOTO 140 + +C...Reset statistics on activity in event. + DO 130 J=351,359 + MINT(J)=0 + VINT(J)=0D0 + 130 CONTINUE + +C...Showering of initial state partons (optional). + NFIN=N + ALAMSV=PARJ(81) + PARJ(81)=PARP(72) + IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12) + & CALL PYSSPA(IPU1,IPU2) + PARJ(81)=ALAMSV + IF(MINT(51).EQ.1) GOTO 100 + +C...pT-ordered FSR off ISR (optional, must have at least 2 partons) + IF (NPART.GE.2.AND.(MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12)) THEN + PTMAX=0.5*SQRT(PARP(71))*VINT(55) + CALL PYPTFS(3,PTMAX,0D0,PTGEN) + ENDIF + +C...Showering of final state partons (optional). + ALAMSV=PARJ(81) + PARJ(81)=PARP(72) + IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10) + & THEN + IPU3=MINT(84)+3 + IPU4=MINT(84)+4 + IF(ISET(ISUB).EQ.5) IPU4=-3 + QMAX=VINT(55) + IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55) + CALL PYSHOW(IPU3,IPU4,QMAX) + ELSEIF(ISET(ISUB).EQ.11) THEN + CALL PYADSH(NFIN) + ENDIF + PARJ(81)=ALAMSV + +C...Allow possibility for user to abort event generation. + IVETO=0 + IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) + IF(IVETO.EQ.1) GOTO 100 + +C...Decay of final state resonances. + MINT(32)=0 + IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0) + IF(MINT(51).EQ.1) GOTO 100 + MINT(52)=N + + +C...Multiple interactions - PYTHIA 6.3 intermediate style. + 140 IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN + IF(ISUB.EQ.95) MINT(31)=MINT(31)+1 + CALL PYMIGN(6) + IF(MINT(51).EQ.1) GOTO 100 + MINT(53)=N + +C...Beam remnant flavour and colour assignments - new scheme. + CALL PYMIHK + IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) + & GOTO 120 + IF(MINT(51).EQ.1) GOTO 100 + +C...Primordial kT and beam remnant momentum sharing - new scheme. + CALL PYMIRM + IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) + & GOTO 120 + IF(MINT(51).EQ.1) GOTO 100 + IF(ISUB.EQ.95) MINT(31)=MINT(31)-1 + +C...Multiple interactions - PYTHIA 6.2 style. + ELSEIF(MINT(111).NE.12) THEN + IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN + CALL PYMULT(6) + MINT(53)=N + ENDIF + +C...Hadron remnants and primordial kT. + CALL PYREMN(IPU1,IPU2) + IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO + & 110 + IF(MINT(51).EQ.1) GOTO 100 + ENDIF + + ELSEIF(ISUB.NE.99) THEN +C...Diffractive and elastic scattering. + CALL PYDIFF + + ELSE +C...DIS scattering (photon flux external). + CALL PYDISG + IF(MINT(51).EQ.1) GOTO 100 + ENDIF + +C...Check that no odd resonance left undecayed. + MINT(54)=N + IF(MSTP(111).GE.1) THEN + NFIX=N + DO 150 I=MINT(84)+1,NFIX + IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND. + & K(I,2).NE.22) THEN + KCA=PYCOMP(K(I,2)) + IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN + CALL PYRESD(I) + IF(MINT(51).EQ.1) GOTO 100 + ENDIF + ENDIF + 150 CONTINUE + ENDIF + +C...Boost hadronic subsystem to overall rest frame. +C..(Only relevant when photon inside lepton beam.) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA) + +C...Recalculate energies from momenta and masses (if desired). + IF(MSTP(113).GE.1) THEN + DO 160 I=MINT(83)+1,N + IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+ + & P(I,2)**2+P(I,3)**2+P(I,5)**2) + 160 CONTINUE + NRECAL=N + ENDIF + +C...Colour reconnection before string formation + IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1) + +C...Rearrange partons along strings, check invariant mass cuts. + MSTU(28)=0 + IF(MSTP(111).LE.0) MSTJ(14)=-1 + CALL PYPREP(MINT(84)+1) + MSTJ(14)=MSTJ14 + IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN + MSTU(24)=0 + GOTO 100 + ENDIF + IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110 + IF (MINT(51).EQ.1) GOTO 100 + IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100 + IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN + DO 190 I=MINT(84)+1,N + IF(K(I,2).EQ.94) THEN + DO 180 I1=I+1,MIN(N,I+10) + IF(K(I1,3).EQ.I) THEN + K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5)) + IF(K(I1,3).EQ.0) THEN + DO 170 II=MINT(84)+1,I-1 + IF(K(II,2).EQ.K(I1,2)) THEN + IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR. + & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II + ENDIF + 170 CONTINUE + IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3) + ENDIF + ENDIF + 180 CONTINUE + ENDIF + 190 CONTINUE + CALL PYEDIT(12) + CALL PYEDIT(14) + IF(MSTP(125).EQ.0) CALL PYEDIT(15) + IF(MSTP(125).EQ.0) MINT(4)=0 + DO 210 I=MINT(83)+1,N + IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN + DO 200 I1=I+1,N + IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1 + IF(K(I1,3).EQ.I) K(I,5)=I1 + 200 CONTINUE + ENDIF + 210 CONTINUE + ENDIF + +C...Introduce separators between sections in PYLIST event listing. + IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN + MSTU70=1 + MSTU(71)=N + ELSEIF(IPILE.EQ.1) THEN + MSTU70=3 + MSTU(71)=2 + MSTU(72)=MINT(4) + MSTU(73)=N + ENDIF + +C...Go back to lab frame (needed for vertices, also in fragmentation). + CALL PYFRAM(1) + +C...Set nonvanishing production vertex (optional). + IF(MSTP(151).EQ.1) THEN + DO 220 J=1,4 + VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))* + & SIN(PARU(2)*PYR(0)) + 220 CONTINUE + DO 240 I=MINT(83)+1,N + DO 230 J=1,4 + V(I,J)=V(I,J)+VTX(J) + 230 CONTINUE + 240 CONTINUE + ENDIF + +C...Perform hadronization (if desired). + IF(MSTP(111).GE.1) THEN + CALL PYEXEC + IF(MSTU(24).NE.0) GOTO 100 + ENDIF + IF(MSTP(113).GE.1) THEN + DO 250 I=NRECAL,N + IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+ + & P(I,2)**2+P(I,3)**2+P(I,5)**2) + 250 CONTINUE + ENDIF + IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14) + +C...Store event information and calculate Monte Carlo estimates of +C...subprocess cross-sections. + 260 IF(IPILE.EQ.1) CALL PYDOCU + +C...Set counters for current pileup event and loop to next one. + MSTI(41)=IPILE + IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB + IF(MSTU70.LT.10) THEN + MSTU70=MSTU70+1 + MSTU(70+MSTU70)=N + ENDIF + MINT(83)=N + MINT(84)=N+MSTP(126) + IF(IPILE.LT.NPILE) CALL PYFRAM(2) + 270 CONTINUE + +C...Generic information on pileup events. Reconstruct missing history. + IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN + PARI(91)=VINT(132) + PARI(92)=VINT(133) + PARI(93)=VINT(134) + IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131) + ENDIF + CALL PYEDIT(16) + +C...Transform to the desired coordinate frame. + 280 CALL PYFRAM(MSTP(124)) + MSTU(70)=MSTU70 + PARU(21)=VINT(1) + +C...Error messages + 5100 FORMAT(1X,'Error: no subprocess switched on.'/ + &1X,'Execution stopped.') + + RETURN + END + +C********************************************************************* + +C...PYEVNW +C...Administers the generation of a high-pT event via calls to +C...a number of subroutines for the new multiple interactions and +C...showering framework. + + SUBROUTINE PYEVNW + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYCTAG/NCT,MCT(4000,2) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), + & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), + & XMI(2,240),PT2MI(240),IMISEP(0:240) + SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/, + & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/ +C...Local arrays. + DIMENSION VTX(4) + +C...Stop if no subprocesses on. + IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN + WRITE(MSTU(11),5100) + CALL PYSTOP(1) + ENDIF + +C...Initial values for some counters. + MSTU(1)=0 + MSTU(2)=0 + N=0 + MINT(5)=MINT(5)+1 + MINT(7)=0 + MINT(8)=0 + MINT(30)=0 + MINT(83)=0 + MINT(84)=MSTP(126) + MSTU(24)=0 + MSTU70=0 + MSTJ14=MSTJ(14) +C...Normally, use K(I,4:5) colour info rather than /PYCT/. + NCT=0 + MINT(33)=0 +C...Zero counters for pT-ordered showers (failsafe) + NPART=0 + NPARTD=0 + +C...Let called routines know call is from PYEVNW (not PYEVNT). + MINT(35)=3 + +C...If variable energies: redo incoming kinematics and cross-section. + MSTI(61)=0 + IF(MSTP(171).EQ.1) THEN + CALL PYINKI(1) + IF(MSTI(61).EQ.1) THEN + MINT(5)=MINT(5)-1 + RETURN + ENDIF + IF(MINT(121).GT.1) CALL PYSAVE(3,1) + CALL PYXTOT + ENDIF + +C...Loop over number of pileup events; check space left. + IF(MSTP(131).LE.0) THEN + NPILE=1 + ELSE + CALL PYPILE(2) + NPILE=MINT(81) + ENDIF + DO 300 IPILE=1,NPILE + IF(MINT(84)+100.GE.MSTU(4)) THEN + CALL PYERRM(11, + & '(PYEVNW:) no more space in PYJETS for pileup events') + IF(MSTU(21).GE.1) GOTO 310 + ENDIF + MINT(82)=IPILE + +C...Generate variables of hard scattering. + MINT(51)=0 + MSTI(52)=0 + LOOPHS =0 + 100 CONTINUE + LOOPHS = LOOPHS + 1 + IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1 + IF(LOOPHS.GE.10) THEN + CALL PYERRM(19,'(PYEVNW:) failed to evolve shower or ' + & //'multiple interactions. Returning.') + MINT(51)=1 + RETURN + ENDIF + MINT(31)=0 + MINT(39)=0 + MINT(36)=0 + MINT(51)=0 + MINT(57)=0 + CALL PYRAND + IF(MSTI(61).EQ.1) THEN + MINT(5)=MINT(5)-1 + RETURN + ENDIF + IF(MINT(51).EQ.2) RETURN + ISUB=MINT(1) + IF(MSTP(111).EQ.-1) GOTO 290 + +C...Loopback point if PYPREP fails, especially for junction topologies. + NPREP=0 + MNT31S=MINT(31) + 110 NPREP=NPREP+1 + MINT(31)=MNT31S + + IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN +C...Hard scattering (including low-pT): +C...reconstruct kinematics and colour flow of hard scattering. + MINT31=MINT(31) + 120 MINT(31)=MINT31 + MINT(51)=0 + CALL PYSCAT + IF(MINT(51).EQ.1) GOTO 100 + NPARTD=N + NFIN=N + +C...Intertwined initial state showers and multiple interactions. +C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL. +C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL. + MSTP61=MSTP(61) + IF (MINT(47).LT.2) MSTP(61)=0 + MSTP81=MSTP(81) + IF (MINT(50).EQ.0) MSTP(81)=0 + IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND. + & MINT(111).NE.12) THEN +C...Absolute max pT2 scale for evolution: phase space limit. + PT2MXS=0.25D0*VINT(2) +C...Check if more constrained by ISR and MI max scales: + PT2MXS=MIN(PT2MXS,MAX(MAX(1D0,PARP(67))*VINT(56),VINT(62))) +C...Loopback point in case of failure in evolution. + LOOP=0 + 130 LOOP=LOOP+1 + MINT(51)=0 + IF(LOOP.GT.100) THEN + CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or ' + & //'multiple interactions. Trying new point.') + MINT(51)=1 + RETURN + ENDIF + +C...Pre-initialization of interleaved MI/ISR/JI evolution, only done +C...once per event. (E.g. compute constants and save variables to be +C...restored later in case of failure.) + IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2) + +C...Initialize interleaved MI/ISR/JI evolution. +C...PT2MAX: absolute upper limit for evolution - Initialization may +C... return a PT2MAX which is lower than this. +C...PT2MIN: absolute lower limit for evolution - Initialization may +C... return a PT2MIN which is larger than this (e.g. Lambda_QCD). + PT2MAX=PT2MXS + PT2MIN=0D0 + CALL PYEVOL(0,PT2MAX,PT2MIN) +C...If failed to initialize evolution, generate a new hard process + IF (MINT(51).EQ.1) GOTO 100 + +C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN. +C...In principle factorized, so can be stopped and restarted. +C...Example: stop/start at pT=10 GeV. (Commented out for now.) +C PT2MED=MAX(10D0**2,PT2MIN) +C CALL PYEVOL(1,PT2MAX,PT2MED) +C IF (MINT(51).EQ.1) GOTO 160 +C PT2MAX=PT2MED + CALL PYEVOL(1,PT2MAX,PT2MIN) +C...If fatal error (e.g., massive hard-process initiator, but no available +C...phase space for creation), generate a new hard process + IF (MINT(51).EQ.2) GOTO 100 +C...If smaller error, just try running evolution again + IF (MINT(51).EQ.1) GOTO 130 + +C...Finalize interleaved MI/ISR/JI evolution. + CALL PYEVOL(2,PT2MAX,PT2MIN) + IF (MINT(51).EQ.1) GOTO 130 + + ENDIF + MSTP(61)=MSTP61 + MSTP(81)=MSTP81 + IF(MINT(51).EQ.1) GOTO 100 +C...(MINT(52) is actually obsolete in this routine. Set anyway +C...to ensure PYDOCU stable.) + MINT(52)=N + MINT(53)=N + +C...Beam remnants - new scheme. + 140 IF(MINT(50).EQ.1) THEN + IF (ISUB.EQ.95) MINT(31)=1 + +C...Beam remnant flavour and colour assignments - new scheme. + CALL PYMIHK + IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) + & GOTO 120 + IF(MINT(51).EQ.1) GOTO 100 + +C...Primordial kT and beam remnant momentum sharing - new scheme. + CALL PYMIRM + IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) + & GOTO 120 + IF(MINT(51).EQ.1) GOTO 100 + IF (ISUB.EQ.95) MINT(31)=0 + ELSEIF(MINT(111).NE.12) THEN +C...Hadron remnants and primordial kT - old model. +C...Happens e.g. for direct photon on one side. + IPU1=IMI(1,1,1) + IPU2=IMI(2,1,1) + CALL PYREMN(IPU1,IPU2) + IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO + & 110 + IF(MINT(51).EQ.1) GOTO 100 +C...PYREMN does not set colour tags for BRs, so needs to be done now. + DO 160 I=MINT(53)+1,N + DO 150 KCS=4,5 + IDA=MOD(K(I,KCS),MSTU(5)) + IF (IDA.NE.0) THEN + MCT(I,KCS-3)=MCT(IDA,6-KCS) + ELSE + MCT(I,KCS-3)=0 + ENDIF + 150 CONTINUE + 160 CONTINUE +C...Instruct PYPREP to use colour tags + MINT(33)=1 + + DO 360 MQGST=1,2 + DO 350 I=MINT(84)+1,N + +C...Look for coloured string endpoint, or (later) leftover gluon. + IF (K(I,1).NE.3) GOTO 350 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 350 + KQ=KCHG(KC,2) + IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350 + +C... Pick up loose string end with no previous tag. + KCS=4 + IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5 + IF(MCT(I,KCS-3).NE.0) GOTO 350 + + CALL PYCTTR(I,KCS,I) + IF(MINT(51).NE.0) RETURN + + 350 CONTINUE + 360 CONTINUE +C...Now delete any colour processing information if set (since partons +C...otherwise not FS showered!) + DO 170 I=MINT(84)+1,N + IF (I.LE.N) THEN + K(I,4)=MOD(K(I,4),MSTU(5)**2) + K(I,5)=MOD(K(I,5),MSTU(5)**2) + ENDIF + 170 CONTINUE + ENDIF + +C...Showering of final state partons (optional). + ALAMSV=PARJ(81) + PARJ(81)=PARP(72) + IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10) + & THEN + QMAX=VINT(55) + IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55) + CALL PYPTFS(1,QMAX,0D0,PTGEN) +C...External processes: handle successive showers. + ELSEIF(ISET(ISUB).EQ.11) THEN + CALL PYADSH(NFIN) + ENDIF + PARJ(81)=ALAMSV + +C...Allow possibility for user to abort event generation. + IVETO=0 + IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm + IF(IVETO.EQ.1) THEN +C...........No reason to count this as an error + LOOPHS = LOOPHS-1 + GOTO 100 + ENDIF + + +C...Decay of final state resonances. + MINT(32)=0 + IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN + CALL PYRESD(0) + IF(MINT(51).NE.0) GOTO 100 + ENDIF + + IF(MINT(51).EQ.1) GOTO 100 + + ELSEIF(ISUB.NE.99) THEN +C...Diffractive and elastic scattering. + CALL PYDIFF + + ELSE +C...DIS scattering (photon flux external). + CALL PYDISG + IF(MINT(51).EQ.1) GOTO 100 + ENDIF + +C...Check that no odd resonance left undecayed. + MINT(54)=N + IF(MSTP(111).GE.1) THEN + NFIX=N + DO 180 I=MINT(84)+1,NFIX + IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND. + & K(I,2).NE.22) THEN + KCA=PYCOMP(K(I,2)) + IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN + CALL PYRESD(I) + IF(MINT(51).EQ.1) GOTO 100 + ENDIF + ENDIF + 180 CONTINUE + ENDIF + +C...Boost hadronic subsystem to overall rest frame. +C..(Only relevant when photon inside lepton beam.) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA) + +C...Recalculate energies from momenta and masses (if desired). + IF(MSTP(113).GE.1) THEN + DO 190 I=MINT(83)+1,N + IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+ + & P(I,2)**2+P(I,3)**2+P(I,5)**2) + 190 CONTINUE + NRECAL=N + ENDIF + +C...Colour reconnection before string formation + CALL PYFSCR(MINT(84)+1) + +C...Rearrange partons along strings, check invariant mass cuts. + MSTU(28)=0 + IF(MSTP(111).LE.0) MSTJ(14)=-1 + CALL PYPREP(MINT(84)+1) + MSTJ(14)=MSTJ14 + IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN + MSTU(24)=0 + GOTO 100 + ENDIF + IF(MINT(51).EQ.1) GOTO 110 + IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100 + IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN + DO 220 I=MINT(84)+1,N + IF(K(I,2).EQ.94) THEN + DO 210 I1=I+1,MIN(N,I+10) + IF(K(I1,3).EQ.I) THEN + K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5)) + IF(K(I1,3).EQ.0) THEN + DO 200 II=MINT(84)+1,I-1 + IF(K(II,2).EQ.K(I1,2)) THEN + IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR. + & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II + ENDIF + 200 CONTINUE + IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3) + ENDIF + ENDIF + 210 CONTINUE +C...Also collapse particles decaying to themselves (if same KS) +C...Sep 22 2009: Commented out by PS following suggestion by TS to fix +C...problem with history point-backs in new shower, where a particle is +C...copied with a new momentum when it is the recoiler. +C ELSEIF (K(I,1).GT.0.AND.K(I,4).EQ.K(I,5).AND.K(I,4).GT.0 +C & .AND.K(I,4).LT.N) THEN +C IDA=K(I,4) +C IF (K(IDA,1).EQ.K(I,1).AND.K(IDA,2).EQ.K(I,2)) THEN +C K(I,1)=0 +C ENDIF + ENDIF + 220 CONTINUE + CALL PYEDIT(12) + CALL PYEDIT(14) + IF(MSTP(125).EQ.0) CALL PYEDIT(15) + IF(MSTP(125).EQ.0) MINT(4)=0 + DO 240 I=MINT(83)+1,N + IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN + DO 230 I1=I+1,N + IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1 + IF(K(I1,3).EQ.I) K(I,5)=I1 + 230 CONTINUE + ENDIF + 240 CONTINUE + ENDIF + +C...Introduce separators between sections in PYLIST event listing. + IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN + MSTU70=1 + MSTU(71)=N + ELSEIF(IPILE.EQ.1) THEN + MSTU70=3 + MSTU(71)=2 + MSTU(72)=MINT(4) + MSTU(73)=N + ENDIF + +C...Go back to lab frame (needed for vertices, also in fragmentation). + CALL PYFRAM(1) + +C...Set nonvanishing production vertex (optional). + IF(MSTP(151).EQ.1) THEN + DO 250 J=1,4 + VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))* + & SIN(PARU(2)*PYR(0)) + 250 CONTINUE + DO 270 I=MINT(83)+1,N + DO 260 J=1,4 + V(I,J)=V(I,J)+VTX(J) + 260 CONTINUE + 270 CONTINUE + ENDIF + +C...Perform hadronization (if desired). + IF(MSTP(111).GE.1) THEN + CALL PYEXEC + IF(MSTU(24).NE.0) GOTO 100 + ENDIF + IF(MSTP(113).GE.1) THEN + DO 280 I=NRECAL,N + IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+ + & P(I,2)**2+P(I,3)**2+P(I,5)**2) + 280 CONTINUE + ENDIF + IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14) + +C...Store event information and calculate Monte Carlo estimates of +C...subprocess cross-sections. + 290 IF(IPILE.EQ.1) CALL PYDOCU + +C...Set counters for current pileup event and loop to next one. + MSTI(41)=IPILE + IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB + IF(MSTU70.LT.10) THEN + MSTU70=MSTU70+1 + MSTU(70+MSTU70)=N + ENDIF + MINT(83)=N + MINT(84)=N+MSTP(126) + IF(IPILE.LT.NPILE) CALL PYFRAM(2) + 300 CONTINUE + +C...Generic information on pileup events. Reconstruct missing history. + IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN + PARI(91)=VINT(132) + PARI(92)=VINT(133) + PARI(93)=VINT(134) + IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131) + ENDIF + CALL PYEDIT(16) + +C...Transform to the desired coordinate frame. + 310 CALL PYFRAM(MSTP(124)) + MSTU(70)=MSTU70 + PARU(21)=VINT(1) + +C...Error messages + 5100 FORMAT(1X,'Error: no subprocess switched on.'/ + &1X,'Execution stopped.') + + RETURN + END + + +C*********************************************************************** + +C...PYSTAT +C...Prints out information about cross-sections, decay widths, branching +C...ratios, kinematical limits, status codes and parameter values. + + SUBROUTINE PYSTAT(MSTAT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) + PARAMETER (EPS=1D-3) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT6/PROC(0:500) + CHARACTER PROC*28, CHTMP*16 + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/ +C...Local arrays, character variables and data. + DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10) + CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16, + &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28, + &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28 + CHARACTER*24 CHD0, CHDC(10) + CHARACTER*6 DNAME(3) + DATA PROGA/ + &'VMD/hadron * VMD ','VMD/hadron * direct ', + &'VMD/hadron * anomalous ','direct * direct ', + &'direct * anomalous ','anomalous * anomalous '/ + DATA DISGA/'e * VMD','e * anomalous'/ + DATA PROGG9/ + &'direct * direct ','direct * VMD ', + &'direct * anomalous ','VMD * direct ', + &'VMD * VMD ','VMD * anomalous ', + &'anomalous * direct ','anomalous * VMD ', + &'anomalous * anomalous ','DIS * VMD ', + &'DIS * anomalous ','VMD * DIS ', + &'anomalous * DIS '/ + DATA PROGG4/ + &'direct * direct ','direct * resolved ', + &'resolved * direct ','resolved * resolved '/ + DATA PROGG2/ + &'direct * hadron ','resolved * hadron '/ + DATA PROGP4/ + &'VMD * hadron ','direct * hadron ', + &'anomalous * hadron ','DIS * hadron '/ + DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/, + &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ', + &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ', + &' y*_small ',' eta*_large ',' eta*_small ', + &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ', + &' x_2 ',' x_F ',' cos(theta_hard) ', + &'m''_hard (GeV/c^2) ',' tau ',' y* ', + &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ', + &' tau'' '/ + DATA DNAME /'q ','lepton','nu '/ + +C...Cross-sections. + IF(MSTAT.LE.1) THEN + IF(MINT(121).GT.1) CALL PYSAVE(5,0) + WRITE(MSTU(11),5000) + WRITE(MSTU(11),5100) + WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3) + DO 100 I=1,500 + IF(MSUB(I).NE.1) GOTO 100 + WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3) + 100 CONTINUE + IF(MINT(121).GT.1) THEN + WRITE(MSTU(11),5300) + DO 110 IGA=1,MINT(121) + CALL PYSAVE(3,IGA) + IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN + WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1), + & XSEC(0,3) + ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN + WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1), + & XSEC(0,3) + ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN + WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1), + & XSEC(0,3) + ELSEIF(MINT(121).EQ.4) THEN + WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1), + & XSEC(0,3) + ELSEIF(MINT(121).EQ.2) THEN + WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1), + & XSEC(0,3) + ELSE + WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1), + & XSEC(0,3) + ENDIF + 110 CONTINUE + CALL PYSAVE(5,0) + ENDIF + WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27), + & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2))) + +C...Decay widths and branching ratios. + ELSEIF(MSTAT.EQ.2) THEN + WRITE(MSTU(11),5500) + WRITE(MSTU(11),5600) + DO 140 KC=1,500 + KF=KCHG(KC,4) + CALL PYNAME(KF,CHKF) + IOFF=0 + IF(KC.LE.22) THEN + IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140 + IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140 + IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1 + IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1 + IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1 + ELSE + IF(MWID(KC).LE.0) GOTO 140 + IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR. + & KF/KSUSY1.EQ.2)) GOTO 140 + ENDIF +C...Off-shell branchings. + IF(IOFF.EQ.1) THEN + NGP=0 + IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2 + IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10), + & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0 + DO 120 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + NGP1=0 + IF(IABS(KFDP(IDC,1)).LE.20) NGP1= + & (MOD(IABS(KFDP(IDC,1)),10)+1)/2 + NGP2=0 + IF(IABS(KFDP(IDC,2)).LE.20) NGP2= + & (MOD(IABS(KFDP(IDC,2)),10)+1)/2 + CALL PYNAME(KFDP(IDC,1),CHD1) + CALL PYNAME(KFDP(IDC,2),CHD2) + IF(KFDP(IDC,3).EQ.0) THEN + IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND. + & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10), + & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0 + ELSE + CALL PYNAME(KFDP(IDC,3),CHD3) + IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND. + & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10), + & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0 + ENDIF + 120 CONTINUE +C...On-shell decays. + ELSE + CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE) + BRFIN=1D0 + IF(WDTE(0,0).LE.0D0) BRFIN=0D0 + WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0, + & STATE(MDCY(KC,1)),BRFIN + DO 130 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + NGP1=0 + IF(IABS(KFDP(IDC,1)).LE.20) NGP1= + & (MOD(IABS(KFDP(IDC,1)),10)+1)/2 + NGP2=0 + IF(IABS(KFDP(IDC,2)).LE.20) NGP2= + & (MOD(IABS(KFDP(IDC,2)),10)+1)/2 + BRPRI=0D0 + IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0) + BRFIN=0D0 + IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0) + CALL PYNAME(KFDP(IDC,1),CHD1) + CALL PYNAME(KFDP(IDC,2),CHD2) + IF(KFDP(IDC,3).EQ.0) THEN + IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1)) + & WRITE(MSTU(11),5800) IDC,CHD1(1:10), + & CHD2(1:10),WDTP(J),BRPRI, + & STATE(MDME(IDC,1)),BRFIN + ELSE + CALL PYNAME(KFDP(IDC,3),CHD3) + IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1)) + & WRITE(MSTU(11),5900) IDC,CHD1(1:10), + & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI, + & STATE(MDME(IDC,1)),BRFIN + ENDIF + 130 CONTINUE + ENDIF + 140 CONTINUE + WRITE(MSTU(11),6000) + +C...Allowed incoming partons/particles at hard interaction. + ELSEIF(MSTAT.EQ.3) THEN + WRITE(MSTU(11),6100) + CALL PYNAME(MINT(11),CHAU) + CHIN(1)=CHAU(1:12) + CALL PYNAME(MINT(12),CHAU) + CHIN(2)=CHAU(1:12) + WRITE(MSTU(11),6200) CHIN(1),CHIN(2) + DO 150 I=-20,22 + IF(I.EQ.0) GOTO 150 + IA=IABS(I) + IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150 + IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150 + CALL PYNAME(I,CHAU) + WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU, + & STATE(KFIN(2,I)) + 150 CONTINUE + WRITE(MSTU(11),6400) + +C...User-defined limits on kinematical variables. + ELSEIF(MSTAT.EQ.4) THEN + WRITE(MSTU(11),6500) + WRITE(MSTU(11),6600) + SHRMAX=CKIN(2) + IF(SHRMAX.LT.0D0) SHRMAX=VINT(1) + WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX + PTHMIN=MAX(CKIN(3),CKIN(5)) + PTHMAX=CKIN(4) + IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX + WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX + WRITE(MSTU(11),6900) CHKIN(3),CKIN(6) + DO 160 I=4,14 + WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I) + 160 CONTINUE + SPRMAX=CKIN(32) + IF(SPRMAX.LT.0D0) SPRMAX=VINT(1) + WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX + WRITE(MSTU(11),7000) + +C...Status codes and parameter values. + ELSEIF(MSTAT.EQ.5) THEN + WRITE(MSTU(11),7100) + WRITE(MSTU(11),7200) + DO 170 I=1,100 + WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I), + & PARP(100+I) + 170 CONTINUE + +C...List of all processes implemented in the program. + ELSEIF(MSTAT.EQ.6) THEN + WRITE(MSTU(11),7400) + WRITE(MSTU(11),7500) + DO 180 I=1,500 + IF(ISET(I).LT.0) GOTO 180 + WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2) + 180 CONTINUE + WRITE(MSTU(11),7700) + + ELSEIF(MSTAT.EQ.7) THEN + WRITE (MSTU(11),8000) + NMODES(0)=0 + NMODES(10)=0 + NMODES(9)=0 + DO 290 ILR=1,2 + DO 280 KFSM=1,16 + KFSUSY=ILR*KSUSY1+KFSM + NRVDC=0 +C...SDOWN DECAYS + IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN + NRVDC=3 + DO 190 I=1,NRVDC + PBRAT(I)=0D0 + NMODES(I)=0 + 190 CONTINUE + CALL PYNAME(KFSUSY,CHTMP) + CHD0=CHTMP//' ' + CHDC(1)=DNAME(3) // ' + ' // DNAME(1) + CHDC(2)=DNAME(2) // ' + ' // DNAME(1) + CHDC(3)=DNAME(1) // ' + ' // DNAME(1) + KC=PYCOMP(KFSUSY) + DO 200 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + ID1=IABS(KFDP(IDC,1)) + ID2=IABS(KFDP(IDC,2)) + IF (KFDP(IDC,3).EQ.0) THEN + IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 + & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN + PBRAT(1)=PBRAT(1)+BRAT(IDC) + NMODES(1)=NMODES(1)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND + & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN + PBRAT(2)=PBRAT(2)+BRAT(IDC) + NMODES(2)=NMODES(2)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND + & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN + PBRAT(3)=PBRAT(3)+BRAT(IDC) + NMODES(3)=NMODES(3)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + ENDIF + 200 CONTINUE + ENDIF +C...SUP DECAYS + IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN + NRVDC=2 + DO 210 I=1,NRVDC + NMODES(I)=0 + PBRAT(I)=0D0 + 210 CONTINUE + CALL PYNAME(KFSUSY,CHTMP) + CHD0=CHTMP//' ' + CHDC(1)=DNAME(2) // ' + ' // DNAME(1) + CHDC(2)=DNAME(1) // ' + ' // DNAME(1) + KC=PYCOMP(KFSUSY) + DO 220 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + ID1=IABS(KFDP(IDC,1)) + ID2=IABS(KFDP(IDC,2)) + IF (KFDP(IDC,3).EQ.0) THEN + IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2 + & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN + PBRAT(1)=PBRAT(1)+BRAT(IDC) + NMODES(1)=NMODES(1)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2 + & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN + PBRAT(2)=PBRAT(2)+BRAT(IDC) + NMODES(2)=NMODES(2)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + ENDIF + 220 CONTINUE + ENDIF +C...SLEPTON DECAYS + IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN + NRVDC=2 + DO 230 I=1,NRVDC + PBRAT(I)=0D0 + NMODES(I)=0 + 230 CONTINUE + CALL PYNAME(KFSUSY,CHTMP) + CHD0=CHTMP//' ' + CHDC(1)=DNAME(3) // ' + ' // DNAME(2) + CHDC(2)=DNAME(1) // ' + ' // DNAME(1) + KC=PYCOMP(KFSUSY) + DO 240 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + ID1=IABS(KFDP(IDC,1)) + ID2=IABS(KFDP(IDC,2)) + IF (KFDP(IDC,3).EQ.0) THEN + IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 + & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN + PBRAT(1)=PBRAT(1)+BRAT(IDC) + NMODES(1)=NMODES(1)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2 + & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN + PBRAT(2)=PBRAT(2)+BRAT(IDC) + NMODES(2)=NMODES(2)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + ENDIF + 240 CONTINUE + ENDIF +C...SNEUTRINO DECAYS + IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1) + & THEN + NRVDC=2 + DO 250 I=1,NRVDC + PBRAT(I)=0D0 + NMODES(I)=0 + 250 CONTINUE + CALL PYNAME(KFSUSY,CHTMP) + CHD0=CHTMP//' ' + CHDC(1)=DNAME(2) // ' + ' // DNAME(2) + CHDC(2)=DNAME(1) // ' + ' // DNAME(1) + KC=PYCOMP(KFSUSY) + DO 260 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + ID1=IABS(KFDP(IDC,1)) + ID2=IABS(KFDP(IDC,2)) + IF (KFDP(IDC,3).EQ.0) THEN + IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2 + & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN + PBRAT(1)=PBRAT(1)+BRAT(IDC) + NMODES(1)=NMODES(1)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2 + & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN + NMODES(2)=NMODES(2)+1 + PBRAT(2)=PBRAT(2)+BRAT(IDC) + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + ENDIF + 260 CONTINUE + ENDIF + IF (NRVDC.NE.0) THEN + DO 270 I=1,NRVDC + WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I) + NMODES(0)=NMODES(0)+NMODES(I) + 270 CONTINUE + ENDIF + 280 CONTINUE + 290 CONTINUE + DO 370 KFSM=21,37 + KFSUSY=KSUSY1+KFSM + NRVDC=0 +C...NEUTRALINO DECAYS + IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN + NRVDC=4 + DO 300 I=1,NRVDC + PBRAT(I)=0D0 + NMODES(I)=0 + 300 CONTINUE + CALL PYNAME(KFSUSY,CHTMP) + CHD0=CHTMP//' ' + CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2) + CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + KC=PYCOMP(KFSUSY) + DO 310 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + ID1=IABS(KFDP(IDC,1)) + ID2=IABS(KFDP(IDC,2)) + ID3=IABS(KFDP(IDC,3)) + IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 + & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR + & .ID3.EQ.13.OR.ID3.EQ.15)) THEN + PBRAT(1)=PBRAT(1)+BRAT(IDC) + NMODES(1)=NMODES(1)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND + & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1 + & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(2)=PBRAT(2)+BRAT(IDC) + NMODES(2)=NMODES(2)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND + & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1 + & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(3)=PBRAT(3)+BRAT(IDC) + NMODES(3)=NMODES(3)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND + & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1 + & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(4)=PBRAT(4)+BRAT(IDC) + NMODES(4)=NMODES(4)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + 310 CONTINUE + ENDIF +C...CHARGINO DECAYS + IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN + NRVDC=5 + DO 320 I=1,NRVDC + PBRAT(I)=0D0 + NMODES(I)=0 + 320 CONTINUE + CALL PYNAME(KFSUSY,CHTMP) + CHD0=CHTMP//' ' + CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2) + CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2) + CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + KC=PYCOMP(KFSUSY) + DO 330 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + ID1=IABS(KFDP(IDC,1)) + ID2=IABS(KFDP(IDC,2)) + ID3=IABS(KFDP(IDC,3)) + IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 + & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR + & .ID3.EQ.14.OR.ID3.EQ.16)) THEN + PBRAT(1)=PBRAT(1)+BRAT(IDC) + NMODES(1)=NMODES(1)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND + & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ + & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN + PBRAT(1)=PBRAT(1)+BRAT(IDC) + NMODES(1)=NMODES(1)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND + & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ + & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN + PBRAT(2)=PBRAT(2)+BRAT(IDC) + NMODES(2)=NMODES(2)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND + & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ + & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN + PBRAT(3)=PBRAT(3)+BRAT(IDC) + NMODES(3)=NMODES(3)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND + & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ + & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(3)=PBRAT(3)+BRAT(IDC) + NMODES(3)=NMODES(3)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND + & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ + & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN + PBRAT(4)=PBRAT(4)+BRAT(IDC) + NMODES(4)=NMODES(4)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND + & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ + & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(4)=PBRAT(4)+BRAT(IDC) + NMODES(4)=NMODES(4)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND + & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ + & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(5)=PBRAT(5)+BRAT(IDC) + NMODES(5)=NMODES(5)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND + & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ + & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(5)=PBRAT(5)+BRAT(IDC) + NMODES(5)=NMODES(5)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + 330 CONTINUE + ENDIF +C...GLUINO DECAYS + IF (KFSM.EQ.21) THEN + NRVDC=3 + DO 340 I=1,NRVDC + PBRAT(I)=0D0 + NMODES(I)=0 + 340 CONTINUE + CALL PYNAME(KFSUSY,CHTMP) + CHD0=CHTMP//' ' + CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1) + KC=PYCOMP(KFSUSY) + DO 350 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + ID1=IABS(KFDP(IDC,1)) + ID2=IABS(KFDP(IDC,2)) + ID3=IABS(KFDP(IDC,3)) + IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2 + & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR + & .ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(1)=PBRAT(1)+BRAT(IDC) + NMODES(1)=NMODES(1)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND + & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1 + & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(2)=PBRAT(2)+BRAT(IDC) + NMODES(2)=NMODES(2)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND + & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1 + & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN + PBRAT(3)=PBRAT(3)+BRAT(IDC) + NMODES(3)=NMODES(3)+1 + IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1 + IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1 + ENDIF + 350 CONTINUE + ENDIF + + IF (NRVDC.NE.0) THEN + DO 360 I=1,NRVDC + WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I) + NMODES(0)=NMODES(0)+NMODES(I) + 360 CONTINUE + ENDIF + 370 CONTINUE + WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9) + + IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN + WRITE (MSTU(11),8500) + DO 400 IRV=1,3 + DO 390 JRV=1,3 + DO 380 KRV=1,3 + WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV) + & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV) + 380 CONTINUE + 390 CONTINUE + 400 CONTINUE + WRITE (MSTU(11),8600) + ENDIF + ENDIF + +C...Formats for printouts. + 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ', + &'Events and Cross-sections',1X,9('*')) + 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X, + &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X, + &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'), + &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X, + &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X, + &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X, + &'I',12X,'I') + 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P, + &D10.3,1X,'I') + 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/ + &1X,'I',34X,'I',28X,'I',12X,'I') + 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')// + &1X,'********* Total number of errors, excluding junctions =', + &1X,I8,' *************'/ + &1X,'********* Total number of errors, including junctions =', + &1X,I8,' *************'/ + &1X,'********* Total number of warnings = ', + &1X,I8,' *************'/ + &1X,'********* Fraction of events that fail fragmentation ', + &'cuts =',1X,F8.5,' *********'/) + 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ', + &'Ratios',1X,27('*')) + 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/ + &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X, + &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X, + &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/ + &1X,98('=')) + 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X, + &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X, + &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I') + 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X, + &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X, + &1P,D10.3,0P,1X,'I') + 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X, + &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X, + &1P,D10.3,0P,1X,'I') + 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('=')) + 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/', + &'Particles at Hard Interaction',1X,7('*')) + 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X, + &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X, + &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X, + &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X, + &78('=')/1X,'I',38X,'I',37X,'I') + 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I') + 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('=')) + 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ', + &'Kinematical Variables',1X,12('*')) + 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I') + 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P, + &16X,'I') + 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A, + &1X,'<',1X,1P,D10.3,0P,16X,'I') + 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I') + 7000 FORMAT(1X,'I',76X,'I'/1X,78('=')) + 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ', + &'Parameter Values',1X,12('*')) + 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X, + &'PARP(I)'/) + 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3) + 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes', + &1X,13('*')) + 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X, + &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X, + &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I') + 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I') + 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('=')) + 8000 FORMAT(1X/ 1X/ + & 17X,'Sums over R-Violating branching ratios',1X/ 1X + & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X + & ,'Mother --> Sum over final state flavours',4X,'I',2X + & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I' + & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I') + 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X + & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/ + & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X + & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I' + & /1X,70('=')) + 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X, + & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I') + 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I') + 8500 FORMAT(1X/ 1X/ + & 1X,'R-Violating couplings',1X/ 1X / + & 1X,55('=')/ + & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X + & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X + & ,'I',15X,'I',15X,'I',15X,'I') + 8600 FORMAT(1X,55('=')) + 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P + & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I') + + RETURN + END + +C********************************************************************* + +C...PYUPEV +C...Administers the hard-process generation required for output to the +C...Les Houches event record. + + SUBROUTINE PYUPEV + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYCTAG/NCT,MCT(4000,2) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT4/MWID(500),WIDS(500,5) + SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/, + &/PYINT1/,/PYINT2/,/PYINT4/ + +C...HEPEUP for output. + INTEGER MAXNUP + PARAMETER (MAXNUP=500) + INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP + DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP + COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), + &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), + &VTIMUP(MAXNUP),SPINUP(MAXNUP) + SAVE /HEPEUP/ + +C...Stop if no subprocesses on. + IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN + WRITE(MSTU(11),5100) + STOP + ENDIF + +C...Special flags for hard-process generation only. + MSTP71=MSTP(71) + MSTP(71)=0 + MST128=MSTP(128) + MSTP(128)=1 + +C...Initial values for some counters. + N=0 + MINT(5)=MINT(5)+1 + MINT(7)=0 + MINT(8)=0 + MINT(30)=0 + MINT(83)=0 + MINT(84)=MSTP(126) + MSTU(24)=0 + MSTU70=0 + MSTJ14=MSTJ(14) +C...Normally, use K(I,4:5) colour info rather than /PYCTAG/. + MINT(33)=0 + +C...If variable energies: redo incoming kinematics and cross-section. + MSTI(61)=0 + IF(MSTP(171).EQ.1) THEN + CALL PYINKI(1) + IF(MSTI(61).EQ.1) THEN + MINT(5)=MINT(5)-1 + RETURN + ENDIF + IF(MINT(121).GT.1) CALL PYSAVE(3,1) + CALL PYXTOT + ENDIF + +C...Do not allow pileup events. + MINT(82)=1 + +C...Generate variables of hard scattering. + MINT(51)=0 + MSTI(52)=0 + 100 CONTINUE + IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1 + MINT(31)=0 + MINT(51)=0 + MINT(57)=0 + CALL PYRAND + IF(MSTI(61).EQ.1) THEN + MINT(5)=MINT(5)-1 + RETURN + ENDIF + IF(MINT(51).EQ.2) RETURN + ISUB=MINT(1) + + IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN +C...Hard scattering (including low-pT): +C...reconstruct kinematics and colour flow of hard scattering. + MINT31=MINT(31) + 110 MINT(31)=MINT31 + MINT(51)=0 + CALL PYSCAT + IF(MINT(51).EQ.1) GOTO 100 + IPU1=MINT(84)+1 + IPU2=MINT(84)+2 + +C...Decay of final state resonances. + MINT(32)=0 + IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95) + & CALL PYRESD(0) + IF(MINT(51).EQ.1) GOTO 100 + MINT(52)=N + +C...Longitudinal boost of hard scattering. + BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42)) + CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ) + + ELSEIF(ISUB.NE.99) THEN +C...Diffractive and elastic scattering. + CALL PYDIFF + + ELSE +C...DIS scattering (photon flux external). + CALL PYDISG + IF(MINT(51).EQ.1) GOTO 100 + ENDIF + +C...Check that no odd resonance left undecayed. + MINT(54)=N + NFIX=N + DO 120 I=MINT(84)+1,NFIX + IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND. + & K(I,2).NE.22) THEN + KCA=PYCOMP(K(I,2)) + IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN + CALL PYRESD(I) + IF(MINT(51).EQ.1) GOTO 100 + ENDIF + ENDIF + 120 CONTINUE + +C...Boost hadronic subsystem to overall rest frame. +C..(Only relevant when photon inside lepton beam.) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA) + +C...Store event information and calculate Monte Carlo estimates of +C...subprocess cross-sections. + 130 CALL PYDOCU + +C...Transform to the desired coordinate frame. + 140 CALL PYFRAM(MSTP(124)) + MSTU(70)=MSTU70 + PARU(21)=VINT(1) + +C...Restore special flags for hard-process generation only. + MSTP(71)=MSTP71 + MSTP(128)=MST128 + +C...Trace colour tags; convert to LHA style labels. + NCT=100 + DO 150 I=MINT(84)+1,N + MCT(I,1)=0 + MCT(I,2)=0 + 150 CONTINUE + DO 160 I=MINT(84)+1,N + KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2)) + IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN + IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0) + & THEN + IMO=MOD(K(I,4)/MSTU(5),MSTU(5)) + IDA=MOD(K(I,4),MSTU(5)) + IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND. + & MCT(IMO,2).NE.0) THEN + MCT(I,1)=MCT(IMO,2) + ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND. + & MCT(IMO,1).NE.0) THEN + MCT(I,1)=MCT(IMO,1) + ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND. + & MCT(IDA,2).NE.0) THEN + MCT(I,1)=MCT(IDA,2) + ELSE + NCT=NCT+1 + MCT(I,1)=NCT + ENDIF + ENDIF + IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0) + & THEN + IMO=MOD(K(I,5)/MSTU(5),MSTU(5)) + IDA=MOD(K(I,5),MSTU(5)) + IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND. + & MCT(IMO,1).NE.0) THEN + MCT(I,2)=MCT(IMO,1) + ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND. + & MCT(IMO,2).NE.0) THEN + MCT(I,2)=MCT(IMO,2) + ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND. + & MCT(IDA,1).NE.0) THEN + MCT(I,2)=MCT(IDA,1) + ELSE + NCT=NCT+1 + MCT(I,2)=NCT + ENDIF + ENDIF + ENDIF + 160 CONTINUE + +C...Put event in HEPEUP commonblock. + NUP=N-MINT(84) + IDPRUP=MINT(1) + XWGTUP=1D0 + SCALUP=VINT(53) + AQEDUP=VINT(57) + AQCDUP=VINT(58) + DO 180 I=1,NUP + IDUP(I)=K(I+MINT(84),2) + IF(I.LE.2) THEN + ISTUP(I)=-1 + MOTHUP(1,I)=0 + MOTHUP(2,I)=0 + ELSEIF(K(I+4,3).EQ.0) THEN + ISTUP(I)=1 + MOTHUP(1,I)=1 + MOTHUP(2,I)=2 + ELSE + ISTUP(I)=1 + MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84) + MOTHUP(2,I)=0 + ENDIF + IF(I.GE.3.AND.K(I+MINT(84),3).GT.0) + & ISTUP(K(I+MINT(84),3)-MINT(84))=2 + ICOLUP(1,I)=MCT(I+MINT(84),1) + ICOLUP(2,I)=MCT(I+MINT(84),2) + DO 170 J=1,5 + PUP(J,I)=P(I+MINT(84),J) + 170 CONTINUE + VTIMUP(I)=V(I,5) + SPINUP(I)=9D0 + 180 CONTINUE + +C...Optionally write out event to disk. Minimal size for time/spin fields. + IF(MSTP(162).GT.0) THEN + WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP + DO 190 I=1,NUP + IF(VTIMUP(I).EQ.0D0) THEN + WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I), + & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5), + & ' 0. 9.' + ELSE + WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I), + & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5), + & VTIMUP(I),' 9.' + ENDIF + 190 CONTINUE + +C...Optional extra line with parton-density information. + IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16), + & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30) + ENDIF + +C...Error messages and other print formats. + 5100 FORMAT(1X,'Error: no subprocess switched on.'/ + &1X,'Execution stopped.') + 5200 FORMAT(1P,2I6,4E14.6) + 5300 FORMAT(1P,I8,5I5,5E18.10,A6) + 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3) + 5500 FORMAT(1P,'#pdf ',2I5,5E18.10) + + RETURN + END + +C********************************************************************* + +C...PYUPIN +C...Fills the HEPRUP commonblock with info on incoming beams and allowed +C...processes, and optionally stores that information on file. + + SUBROUTINE PYUPIN + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/ + +C...User process initialization commonblock. + INTEGER MAXPUP + PARAMETER (MAXPUP=100) + INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP + DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP + COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), + &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), + &LPRUP(MAXPUP) + SAVE /HEPRUP/ + +C...Store info on incoming beams. + IDBMUP(1)=K(1,2) + IDBMUP(2)=K(2,2) + EBMUP(1)=P(1,4) + EBMUP(2)=P(2,4) + PDFGUP(1)=0 + PDFGUP(2)=0 + PDFSUP(1)=MSTP(51) + PDFSUP(2)=MSTP(51) + +C...Event weighting strategy. + IDWTUP=3 + +C...Info on individual processes. + NPRUP=0 + DO 100 ISUB=1,500 + IF(MSUB(ISUB).EQ.1) THEN + NPRUP=NPRUP+1 + XSECUP(NPRUP)=1D9*XSEC(ISUB,3) + XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3)))) + XMAXUP(NPRUP)=1D0 + LPRUP(NPRUP)=ISUB + ENDIF + 100 CONTINUE + +C...Write info to file. + IF(MSTP(161).GT.0) THEN + WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2), + & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP + DO 110 IPR=1,NPRUP + WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR), + & LPRUP(IPR) + 110 CONTINUE + ENDIF + +C...Formats for printout. + 5100 FORMAT(1P,2I8,2E14.6,6I6) + 5200 FORMAT(1P,3E14.6,I6) + + RETURN + END + + +C********************************************************************* + +C...Combine the two old-style Pythia initialization and event files +C...into a single Les Houches Event File. + + SUBROUTINE PYLHEF + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...PYTHIA commonblock: only used to provide read/write units and version. + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + SAVE /PYPARS/ + +C...User process initialization commonblock. + INTEGER MAXPUP + PARAMETER (MAXPUP=100) + INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP + DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP + COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), + &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), + &LPRUP(MAXPUP) + SAVE /HEPRUP/ + +C...User process event common block. + INTEGER MAXNUP + PARAMETER (MAXNUP=500) + INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP + DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP + COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), + &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), + &VTIMUP(MAXNUP),SPINUP(MAXNUP) + SAVE /HEPEUP/ + +C...Lines to read in assumed never longer than 200 characters. + PARAMETER (MAXLEN=200) + CHARACTER*(MAXLEN) STRING + +C...Format for reading lines. + CHARACTER*6 STRFMT + STRFMT='(A000)' + WRITE(STRFMT(3:5),'(I3)') MAXLEN + +C...Rewind initialization and event files. + REWIND MSTP(161) + REWIND MSTP(162) + +C...Write header info. + WRITE(MSTP(163),'(A)') '' + WRITE(MSTP(163),'(A)') '' + +C...Read first line of initialization info and get number of processes. + READ(MSTP(161),'(A)',END=400,ERR=400) STRING + READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1), + &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP + +C...Copy initialization lines, omitting trailing blanks. +C...Embed in ... block. + WRITE(MSTP(163),'(A)') '' + DO 140 IPR=0,NPRUP + IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING + LEN=MAXLEN+1 + 120 LEN=LEN-1 + IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120 + WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN) + 140 CONTINUE + WRITE(MSTP(163),'(A)') '' + +C...Begin event loop. Read first line of event info or already done. + READ(MSTP(162),'(A)',END=320,ERR=400) STRING + 200 CONTINUE + +C...Look at first line to know number of particles in event. + READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP + +C...Begin an block. Copy event lines, omitting trailing blanks. + WRITE(MSTP(163),'(A)') '' + DO 240 I=0,NUP + IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING + LEN=MAXLEN+1 + 220 LEN=LEN-1 + IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220 + WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN) + 240 CONTINUE + +C...Copy trailing comment lines - with a # in the first column - as is. + 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING + IF(STRING(1:1).EQ.'#') THEN + LEN=MAXLEN+1 + 280 LEN=LEN-1 + IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280 + WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN) + GOTO 260 + ENDIF + +C..End the block. Loop back to look for next event. + WRITE(MSTP(163),'(A)') '' + GOTO 200 + +C...Successfully reached end of event loop: write closing tag +C...and remove temporary intermediate files (unless asked not to). + 300 WRITE(MSTP(163),'(A)') '' + 320 WRITE(MSTP(163),'(A)') '' + IF(MSTP(164).EQ.1) RETURN + CLOSE(MSTP(161),ERR=400,STATUS='DELETE') + CLOSE(MSTP(162),ERR=400,STATUS='DELETE') + RETURN + +C...Error exit. + 400 WRITE(*,*) ' PYLHEF file joining failed!' + + RETURN + END + +C********************************************************************* + +C...PYINRE +C...Calculates full and effective widths of gauge bosons, stores +C...masses and widths, rescales coefficients to be used for +C...resonance production generation. + + SUBROUTINE PYINRE + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYDAT4/CHAF(500,2) + CHARACTER CHAF*16 + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT6/PROC(0:500) + CHARACTER PROC*28 + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/, + &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/ +C...Local arrays and data. + CHARACTER PRTMP*9 + DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400), + &WDTEM(0:400,0:5),KCORD(500),PMORD(500) + +C...Born level couplings in MSSM Higgs doublet sector. + XW=PARU(102) + XWV=XW + IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2 + XW1=1D0-XW + IF(MSTP(4).EQ.2) THEN + TANBE=PARU(141) + RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2 + SQMZ=PMAS(23,1)**2 + SQMW=PMAS(24,1)**2 + SQMH=PMAS(25,1)**2 + SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH) + SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE)) + SQMHC=SQMA+SQMW + IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN + WRITE(MSTU(11),5000) + CALL PYSTOP(101) + ENDIF + PMAS(35,1)=SQRT(SQMHP) + PMAS(36,1)=SQRT(SQMA) + PMAS(37,1)=SQRT(SQMHC) + ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)* + & (SQMA-SQMZ))) + BESU=ATAN(TANBE) + PARU(142)=1D0 + PARU(143)=1D0 + PARU(161)=-SIN(ALSU)/COS(BESU) + PARU(162)=COS(ALSU)/SIN(BESU) + PARU(163)=PARU(161) + PARU(164)=SIN(BESU-ALSU) + PARU(165)=PARU(164) + PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW + PARU(171)=COS(ALSU)/COS(BESU) + PARU(172)=SIN(ALSU)/SIN(BESU) + PARU(173)=PARU(171) + PARU(174)=COS(BESU-ALSU) + PARU(175)=PARU(174) + PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)* + & SIN(BESU+ALSU) + PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU) + PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW + PARU(181)=TANBE + PARU(182)=1D0/TANBE + PARU(183)=PARU(181) + PARU(184)=0D0 + PARU(185)=PARU(184) + PARU(186)=COS(BESU-ALSU) + PARU(187)=SIN(BESU-ALSU) + PARU(188)=PARU(186) + PARU(189)=PARU(187) + PARU(190)=0D0 + PARU(195)=COS(BESU-ALSU) + ENDIF + +C...Reset effective widths of gauge bosons. + DO 110 I=1,500 + DO 100 J=1,5 + WIDS(I,J)=1D0 + 100 CONTINUE + 110 CONTINUE + +C...Order resonances by increasing mass (except Z0 and W+/-). + NRES=0 + DO 140 KC=1,500 + KF=KCHG(KC,4) + IF(KF.EQ.0) GOTO 140 + IF(MWID(KC).EQ.0) GOTO 140 + IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN + IF(MSTP(1).LE.3) GOTO 140 + ENDIF + IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN + IF(IMSS(1).LE.0) GOTO 140 + ENDIF + NRES=NRES+1 + PMRES=PMAS(KC,1) + IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0 + DO 120 I1=NRES-1,1,-1 + IF(PMRES.GE.PMORD(I1)) GOTO 130 + KCORD(I1+1)=KCORD(I1) + PMORD(I1+1)=PMORD(I1) + 120 CONTINUE + 130 KCORD(I1+1)=KC + PMORD(I1+1)=PMRES + 140 CONTINUE + +C...Loop over possible resonances. + DO 180 I=1,NRES + KC=KCORD(I) + KF=KCHG(KC,4) + +C...Check that no fourth generation channels on by mistake. + IF(MSTP(1).LE.3) THEN + DO 150 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + KFA1=IABS(KFDP(IDC,1)) + KFA2=IABS(KFDP(IDC,2)) + IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR. + & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18) + & MDME(IDC,1)=-1 + 150 CONTINUE + ENDIF + +C...Check that no supersymmetric channels on by mistake. + IF(IMSS(1).LE.0) THEN + DO 160 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + KFA1S=IABS(KFDP(IDC,1))/KSUSY1 + KFA2S=IABS(KFDP(IDC,2))/KSUSY1 + IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2) + & MDME(IDC,1)=-1 + 160 CONTINUE + ENDIF + +C...Find mass and evaluate width. + PMR=PMAS(KC,1) + IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1 + IF(MWID(KC).EQ.3) MINT(63)=1 + CALL PYWIDT(KF,PMR**2,WDTP,WDTE) + MINT(51)=0 + +C...Evaluate suppression factors due to non-simulated channels. + IF(KCHG(KC,3).EQ.0) THEN + WDTP0I=0D0 + IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0) + WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+ + & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+ + & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2 + WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I + WIDS(KC,3)=0D0 + WIDS(KC,4)=0D0 + WIDS(KC,5)=0D0 + ELSE + IF(MWID(KC).EQ.3) MINT(63)=1 + CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM) + MINT(51)=0 + WDTP0I=0D0 + IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0) + WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+ + & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+ + & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+ + & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2 + WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I + WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I + WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+ + & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+ + & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2 + WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+ + & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+ + & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2 + ENDIF + +C...Set resonance widths and branching ratios; +C...also on/off switch for decays. + IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN + PMAS(KC,2)=WDTP(0) + PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2)) + IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41) + DO 170 J=1,MDCY(KC,3) + IDC=J+MDCY(KC,2)-1 + BRAT(IDC)=0D0 + IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0) + 170 CONTINUE + ENDIF + 180 CONTINUE + +C...Flavours of leptoquark: redefine charge and name. + KFLQQ=KFDP(MDCY(42,2),1) + KFLQL=KFDP(MDCY(42,2),2) + KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+ + &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL) + LL=1 + IF(IABS(KFLQL).EQ.13) LL=2 + IF(IABS(KFLQL).EQ.15) LL=3 + CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)// + &CHAF(IABS(KFLQL),1)(1:LL)//' ' + CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar ' + +C...Special cases in treatment of gamma*/Z0: redefine process name. + IF(MSTP(43).EQ.1) THEN + PROC(1)='f + fbar -> gamma*' + PROC(15)='f + fbar -> g + gamma*' + PROC(19)='f + fbar -> gamma + gamma*' + PROC(30)='f + g -> f + gamma*' + PROC(35)='f + gamma -> f + gamma*' + ELSEIF(MSTP(43).EQ.2) THEN + PROC(1)='f + fbar -> Z0' + PROC(15)='f + fbar -> g + Z0' + PROC(19)='f + fbar -> gamma + Z0' + PROC(30)='f + g -> f + Z0' + PROC(35)='f + gamma -> f + Z0' + ELSEIF(MSTP(43).EQ.3) THEN + PROC(1)='f + fbar -> gamma*/Z0' + PROC(15)='f + fbar -> g + gamma*/Z0' + PROC(19)='f+ fbar -> gamma + gamma*/Z0' + PROC(30)='f + g -> f + gamma*/Z0' + PROC(35)='f + gamma -> f + gamma*/Z0' + ENDIF + +C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name. + IF(MSTP(44).EQ.1) THEN + PROC(141)='f + fbar -> gamma*' + ELSEIF(MSTP(44).EQ.2) THEN + PROC(141)='f + fbar -> Z0' + ELSEIF(MSTP(44).EQ.3) THEN + PROC(141)='f + fbar -> Z''0' + ELSEIF(MSTP(44).EQ.4) THEN + PROC(141)='f + fbar -> gamma*/Z0' + ELSEIF(MSTP(44).EQ.5) THEN + PROC(141)='f + fbar -> gamma*/Z''0' + ELSEIF(MSTP(44).EQ.6) THEN + PROC(141)='f + fbar -> Z0/Z''0' + ELSEIF(MSTP(44).EQ.7) THEN + PROC(141)='f + fbar -> gamma*/Z0/Z''0' + ENDIF + +C...Special cases in treatment of WW -> WW: redefine process name. + IF(MSTP(45).EQ.1) THEN + PROC(77)='W+ + W+ -> W+ + W+' + ELSEIF(MSTP(45).EQ.2) THEN + PROC(77)='W+ + W- -> W+ + W-' + ELSEIF(MSTP(45).EQ.3) THEN + PROC(77)='W+/- + W+/- -> W+/- + W+/-' + ENDIF + +C...Initialize Generic Processes + KFGEN=9900001 + KCGEN=PYCOMP(KFGEN) + IF(KCGEN.GT.0) THEN + IDCY=MDCY(KCGEN,2) + IF(IDCY.GT.0) THEN + KFF1=KFDP(IDCY+1,1) + KFF2=KFDP(IDCY+1,2) + KCF1=PYCOMP(KFF1) + KCF2=PYCOMP(KFF2) + IJ1=1 + IJ2=1 + KCI1=PYCOMP(KFDP(IDCY,1)) + IF(KFDP(IDCY,1).LT.0) IJ1=2 + KCI2=PYCOMP(KFDP(IDCY,2)) + IF(KFDP(IDCY,2).LT.0) IJ2=2 + ITMP1=0 + 190 ITMP1=ITMP1+1 + IF(CHAF(KCI1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.4) + & GOTO 190 + ITMP2=0 + 200 ITMP2=ITMP2+1 + IF(CHAF(KCI2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.4) + & GOTO 200 + PRTMP=CHAF(KCI1,IJ1)(1:ITMP1)//'+'//CHAF(KCI2,IJ2)(1:ITMP2) + ITMP3=0 + 205 ITMP3=ITMP3+1 + IF(PRTMP(ITMP3+1:ITMP3+1).NE.' '.AND.ITMP3.LT.9) + & GOTO 205 + PROC(481)=PRTMP(1:ITMP3)//' -> '//CHAF(KCGEN,1) + IJ1=1 + IJ2=1 + IF(KFF1.LT.0) IJ1=2 + IF(KFF2.LT.0) IJ2=2 + ITMP1=0 + 210 ITMP1=ITMP1+1 + IF(CHAF(KCF1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.8) + & GOTO 210 + ITMP2=0 + 220 ITMP2=ITMP2+1 + IF(CHAF(KCF2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.8) + & GOTO 220 + PROC(482)=PRTMP(1:ITMP3)//' -> '//CHAF(KCF1,IJ1)(1:ITMP1)// + & '+'//CHAF(KCF2,IJ2)(1:ITMP2) + ENDIF + 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(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/ + +C...Local arrays, character variables and data. + CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26, + &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16 + DIMENSION LEN(3),KCDE(39),PM(2) + DATA CHALP/'abcdefghijklmnopqrstuvwxyz', + &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + DATA CHCDE/ 'e- ','e+ ','nu_e ', + &'nu_ebar ','mu- ','mu+ ','nu_mu ', + &'nu_mubar ','tau- ','tau+ ','nu_tau ', + &'nu_taubar ','pi+ ','pi- ','n0 ', + &'nbar0 ','p+ ','pbar- ','gamma ', + &'lambda0 ','sigma- ','sigma0 ','sigma+ ', + &'xi- ','xi0 ','omega- ','pi0 ', + &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ', + &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ', + &'k+ ','k- ','ks0 ','kl0 '/ + DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16, + &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222, + &3312,3322,3334,111,110,990,6*22,321,-321,310,130/ + +C...Store initial energy. Default frame. + VINT(290)=WIN + MINT(111)=0 + +C...Special user process initialization; convert to normal input. + IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN + MINT(111)=11 + IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12 + CALL PYNAME(IDBMUP(1),CHNAME) + CHBEAM=CHNAME(1:12) + CALL PYNAME(IDBMUP(2),CHNAME) + CHTARG=CHNAME(1:12) + ENDIF + +C...Convert character variables to lowercase and find their length. + CHCOM(1)=CHFRAM + CHCOM(2)=CHBEAM + CHCOM(3)=CHTARG + DO 130 I=1,3 + LEN(I)=12 + DO 110 LL=12,1,-1 + IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1 + DO 100 LA=1,26 + IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)= + & CHALP(1)(LA:LA) + 100 CONTINUE + 110 CONTINUE + CHIDNT(I)=CHCOM(I) + +C...Fix up bar, underscore and charge in particle name (if needed). + DO 120 LL=1,10 + IF(CHIDNT(I)(LL:LL).EQ.'~') THEN + CHTEMP=CHIDNT(I) + CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' ' + ENDIF + 120 CONTINUE + IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN + CHTEMP=CHIDNT(I) + CHIDNT(I)='nu_'//CHTEMP(3:7) + ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN + CHIDNT(I)(1:3)='n0 ' + ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN + CHIDNT(I)(1:5)='nbar0' + ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN + CHIDNT(I)(1:3)='p+ ' + ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR. + & CHIDNT(I)(1:2).EQ.'p-') THEN + CHIDNT(I)(1:5)='pbar-' + ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN + CHIDNT(I)(7:7)='0' + ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN + CHIDNT(I)(1:7)='reggeon' + ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN + CHIDNT(I)(1:7)='pomeron' + ENDIF + 130 CONTINUE + +C...Identify free initialization. + IF(CHCOM(1)(1:2).EQ.'no') THEN + MINT(65)=1 + RETURN + ENDIF + +C...Identify incoming beam and target particles. + DO 160 I=1,2 + DO 140 J=1,39 + IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J) + 140 CONTINUE + PM(I)=PYMASS(MINT(10+I)) + VINT(2+I)=PM(I) + MINT(140+I)=0 + IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN + CHTEMP=CHIDNT(I+1)(7:12)//' ' + DO 150 J=1,12 + IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J) + 150 CONTINUE + PM(I)=PYMASS(MINT(140+I)) + VINT(302+I)=PM(I) + ENDIF + 160 CONTINUE + IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2)) + IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3)) + IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7) + +C...Identify choice of frame and input energies. + CHINIT=' ' + +C...Events defined in the CM frame. + IF(CHCOM(1)(1:2).EQ.'cm') THEN + MINT(111)=1 + S=WIN**2 + IF(MSTP(122).GE.1) THEN + IF(CHCOM(2)(1:1).NE.'e') THEN + LOFFS=(31-(LEN(2)+LEN(3)))/2 + CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '// + & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// + & ' collider'//' ' + ELSE + LOFFS=(30-(LEN(2)+LEN(3)))/2 + CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '// + & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// + & ' collider'//' ' + ENDIF + WRITE(MSTU(11),5200) CHINIT + WRITE(MSTU(11),5300) WIN + ENDIF + +C...Events defined in fixed target frame. + ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN + MINT(111)=2 + S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2) + IF(MSTP(122).GE.1) THEN + LOFFS=(29-(LEN(2)+LEN(3)))/2 + CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// + & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// + & ' fixed target'//' ' + WRITE(MSTU(11),5200) CHINIT + WRITE(MSTU(11),5400) WIN + WRITE(MSTU(11),5500) SQRT(S) + ENDIF + +C...Frame defined by user three-vectors. + ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN + MINT(111)=3 + P(1,5)=PM(1) + P(2,5)=PM(2) + P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2) + P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2) + S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2- + & (P(1,3)+P(2,3))**2 + IF(MSTP(122).GE.1) THEN + LOFFS=(22-(LEN(2)+LEN(3)))/2 + CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// + & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// + & ' user configuration'//' ' + WRITE(MSTU(11),5200) CHINIT + WRITE(MSTU(11),5600) + WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4) + WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4) + WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) + ENDIF + +C...Frame defined by user four-vectors. + ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN + MINT(111)=4 + PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2 + P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1) + PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2 + P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2) + S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2- + & (P(1,3)+P(2,3))**2 + IF(MSTP(122).GE.1) THEN + LOFFS=(22-(LEN(2)+LEN(3)))/2 + CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// + & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// + & ' user configuration'//' ' + WRITE(MSTU(11),5200) CHINIT + WRITE(MSTU(11),5600) + WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4) + WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4) + WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) + ENDIF + +C...Frame defined by user five-vectors. + ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN + MINT(111)=5 + S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2- + & (P(1,3)+P(2,3))**2 + IF(MSTP(122).GE.1) THEN + LOFFS=(22-(LEN(2)+LEN(3)))/2 + CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// + & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// + & ' user configuration'//' ' + WRITE(MSTU(11),5200) CHINIT + WRITE(MSTU(11),5600) + WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4) + WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4) + WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) + ENDIF + +C...Frame defined by HEPRUP common block. + ELSEIF(MINT(111).GE.11) THEN + S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))- + & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2 + IF(MSTP(122).GE.1) THEN + LOFFS=(22-(LEN(2)+LEN(3)))/2 + CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '// + & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))// + & ' user configuration'//' ' + WRITE(MSTU(11),5200) CHINIT + WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2) + WRITE(MSTU(11),5500) SQRT(MAX(0D0,S)) + ENDIF + +C...Unknown frame. Error for too low CM energy. + ELSE + WRITE(MSTU(11),5800) CHFRAM(1:LEN(1)) + CALL PYSTOP(7) + ENDIF + IF(S.LT.PARP(2)**2) THEN + WRITE(MSTU(11),5900) SQRT(S) + CALL PYSTOP(7) + ENDIF + +C...Formats for initialization and error information. + 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/ + &1X,'Execution stopped!') + 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/ + &1X,'Execution stopped!') + 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I') + 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy', + &19X,'I'/1X,'I',76X,'I'/1X,78('=')) + 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I') + 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X, + &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('=')) + 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X, + &'pz (GeV/c)',6X,'E (GeV)',9X,'I') + 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I') + 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/ + &1X,'Execution stopped!') + 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ', + &'generation.'/1X,'Execution stopped!') + 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X, + &'GeV beam energies',13X,'I') + + RETURN + END + +C********************************************************************* + +C...PYINKI +C...Sets up kinematics, including rotations and boosts to/from CM frame. + + SUBROUTINE PYINKI(MODKI) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...User process initialization commonblock. + INTEGER MAXPUP + PARAMETER (MAXPUP=100) + INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP + DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP + COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), + &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), + &LPRUP(MAXPUP) + SAVE /HEPRUP/ + +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/ + +C...Set initial flavour state. + N=2 + DO 100 I=1,2 + K(I,1)=1 + K(I,2)=MINT(10+I) + IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I) + 100 CONTINUE + +C...Reset boost. Do kinematics for various cases. + DO 110 J=6,10 + VINT(J)=0D0 + 110 CONTINUE + +C...Set up kinematics for events defined in CM frame. + IF(MINT(111).EQ.1) THEN + WIN=VINT(290) + IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290) + S=WIN**2 + P(1,5)=VINT(3) + P(2,5)=VINT(4) + IF(MINT(141).NE.0) P(1,5)=VINT(303) + IF(MINT(142).NE.0) P(2,5)=VINT(304) + P(1,1)=0D0 + P(1,2)=0D0 + P(2,1)=0D0 + P(2,2)=0D0 + P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/ + & (4D0*S)) + P(2,3)=-P(1,3) + P(1,4)=SQRT(P(1,3)**2+P(1,5)**2) + P(2,4)=SQRT(P(2,3)**2+P(2,5)**2) + +C...Set up kinematics for fixed target events. + ELSEIF(MINT(111).EQ.2) THEN + WIN=VINT(290) + IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290) + P(1,5)=VINT(3) + P(2,5)=VINT(4) + IF(MINT(141).NE.0) P(1,5)=VINT(303) + IF(MINT(142).NE.0) P(2,5)=VINT(304) + P(1,1)=0D0 + P(1,2)=0D0 + P(2,1)=0D0 + P(2,2)=0D0 + P(1,3)=WIN + P(1,4)=SQRT(P(1,3)**2+P(1,5)**2) + P(2,3)=0D0 + P(2,4)=P(2,5) + S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4) + VINT(10)=P(1,3)/(P(1,4)+P(2,4)) + CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10)) + +C...Set up kinematics for events in user-defined frame. + ELSEIF(MINT(111).EQ.3) THEN + P(1,5)=VINT(3) + P(2,5)=VINT(4) + IF(MINT(141).NE.0) P(1,5)=VINT(303) + IF(MINT(142).NE.0) P(2,5)=VINT(304) + P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2) + P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2) + DO 120 J=1,3 + VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4)) + 120 CONTINUE + CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) + VINT(7)=PYANGL(P(1,1),P(1,2)) + CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) + VINT(6)=PYANGL(P(1,3),P(1,1)) + CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) + S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3)) + +C...Set up kinematics for events with user-defined four-vectors. + ELSEIF(MINT(111).EQ.4) THEN + PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2 + P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1) + PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2 + P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2) + DO 130 J=1,3 + VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4)) + 130 CONTINUE + CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) + VINT(7)=PYANGL(P(1,1),P(1,2)) + CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) + VINT(6)=PYANGL(P(1,3),P(1,1)) + CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) + S=(P(1,4)+P(2,4))**2 + +C...Set up kinematics for events with user-defined five-vectors. + ELSEIF(MINT(111).EQ.5) THEN + DO 140 J=1,3 + VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4)) + 140 CONTINUE + CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) + VINT(7)=PYANGL(P(1,1),P(1,2)) + CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) + VINT(6)=PYANGL(P(1,3),P(1,1)) + CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) + S=(P(1,4)+P(2,4))**2 + +C...Set up kinematics for events with external user processes. + ELSEIF(MINT(111).GE.11) THEN + P(1,5)=VINT(3) + P(2,5)=VINT(4) + IF(MINT(141).NE.0) P(1,5)=VINT(303) + IF(MINT(142).NE.0) P(2,5)=VINT(304) + P(1,1)=0D0 + P(1,2)=0D0 + P(2,1)=0D0 + P(2,2)=0D0 + P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2)) + P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2)) + P(1,4)=EBMUP(1) + P(2,4)=EBMUP(2) + VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4)) + CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10)) + S=(P(1,4)+P(2,4))**2 + ENDIF + +C...Return or error for too low CM energy. + IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN + IF(MSTP(172).LE.1) THEN + CALL PYERRM(23, + & '(PYINKI:) too low invariant mass in this event') + ELSE + MSTI(61)=1 + RETURN + ENDIF + ENDIF + +C...Save information on incoming particles. + VINT(1)=SQRT(S) + VINT(2)=S + IF(MINT(111).GE.4) THEN + IF(MINT(141).EQ.0) THEN + VINT(3)=P(1,5) + IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2 + ELSE + VINT(303)=P(1,5) + ENDIF + IF(MINT(142).EQ.0) THEN + VINT(4)=P(2,5) + IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2 + ELSE + VINT(304)=P(2,5) + ENDIF + ENDIF + VINT(5)=P(1,3) + IF(MODKI.EQ.0) VINT(289)=S + DO 150 J=1,5 + V(1,J)=0D0 + V(2,J)=0D0 + VINT(290+J)=P(1,J) + VINT(295+J)=P(2,J) + 150 CONTINUE + +C...Store pT cut-off and related constants to be used in generation. + IF(MODKI.EQ.0) VINT(285)=CKIN(3) + IF(MSTP(82).LE.1) THEN + PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90) + ELSE + PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) + ENDIF + VINT(149)=4D0*PTMN**2/S + VINT(154)=PTMN + + RETURN + END + +C********************************************************************* + +C...PYINPR +C...Selects partonic subprocesses to be included in the simulation. + + SUBROUTINE PYINPR + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...User process initialization commonblock. + INTEGER MAXPUP + PARAMETER (MAXPUP=100) + INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP + DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP + COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), + &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), + &LPRUP(MAXPUP) + SAVE /HEPRUP/ + +C...Commonblocks and character variables. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/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/PYINT6/PROC(0:500) + CHARACTER PROC*28 + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT2/,/PYINT6/ + CHARACTER CHIPR*10 + + +C...Reset processes to be included. + IF(MSEL.NE.0) THEN + DO 100 I=1,500 + MSUB(I)=0 + 100 CONTINUE + ENDIF + +C...Set running pTmin scale. + IF(MSTP(82).LE.1) THEN + PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90) + ELSE + PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90) + ENDIF + +C...Begin by assuming incoming photon to enter subprocess. + IF(MINT(11).EQ.22) MINT(15)=22 + IF(MINT(12).EQ.22) MINT(16)=22 + +C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous. + IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN + MSUB(10)=1 + MINT(123)=MINT(122)+1 + +C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30 +C...allow mixture. +C...Here also set a few parameters otherwise normally not touched. + ELSEIF(MINT(121).GT.1) THEN + +C...Parton distributions dampened at small Q2; go to low energies, +C...alpha_s <1; no minimum pT cut-off a priori. + IF(MSTP(18).EQ.2) THEN + MSTP(57)=3 + PARP(2)=2D0 + PARU(115)=1D0 + CKIN(5)=0.2D0 + CKIN(6)=0.2D0 + ENDIF + +C...Define pT cut-off parameters and whether run involves low-pT. + PTMVMD=PTMRUN + VINT(154)=PTMVMD + PTMDIR=PTMVMD + IF(MSTP(18).EQ.2) PTMDIR=PARP(15) + PTMANO=PTMVMD + IF(MSTP(15).EQ.5) PTMANO=0.60D0+ + & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2 + IPTL=1 + IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0 + IF(MSEL.EQ.2) IPTL=1 + +C...Set up for p/gamma * gamma; real or virtual photons. + IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND. + & MSTP(14).EQ.30)) THEN + +C...Set up for p/VMD * VMD. + IF(MINT(122).EQ.1) THEN + MINT(123)=2 + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + IF(IPTL.EQ.1) MSUB(95)=1 + IF(MSEL.EQ.2) THEN + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + ENDIF + IF(IPTL.EQ.1) CKIN(3)=0D0 + +C...Set up for p/VMD * direct gamma. + ELSEIF(MINT(122).EQ.2) THEN + MINT(123)=0 + IF(MINT(121).EQ.6) MINT(123)=5 + MSUB(131)=1 + MSUB(132)=1 + MSUB(135)=1 + MSUB(136)=1 + IF(IPTL.EQ.1) CKIN(3)=PTMDIR + +C...Set up for p/VMD * anomalous gamma. + ELSEIF(MINT(122).EQ.3) THEN + MINT(123)=3 + IF(MINT(121).EQ.6) MINT(123)=7 + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + IF(IPTL.EQ.1) MSUB(95)=1 + IF(MSEL.EQ.2) THEN + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + ENDIF + IF(IPTL.EQ.1) CKIN(3)=0D0 + +C...Set up for DIS * p. + ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR. + & IABS(MINT(12)).GT.100)) THEN + MINT(123)=8 + IF(IPTL.EQ.1) MSUB(99)=1 + +C...Set up for direct * direct gamma (switch off leptons). + ELSEIF(MINT(122).EQ.4) THEN + MINT(123)=0 + MSUB(137)=1 + MSUB(138)=1 + MSUB(139)=1 + MSUB(140)=1 + DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 + IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) + 110 CONTINUE + IF(IPTL.EQ.1) CKIN(3)=PTMDIR + +C...Set up for direct * anomalous gamma. + ELSEIF(MINT(122).EQ.5) THEN + MINT(123)=6 + MSUB(131)=1 + MSUB(132)=1 + MSUB(135)=1 + MSUB(136)=1 + IF(IPTL.EQ.1) CKIN(3)=PTMANO + +C...Set up for anomalous * anomalous gamma. + ELSEIF(MINT(122).EQ.6) THEN + MINT(123)=3 + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + IF(IPTL.EQ.1) MSUB(95)=1 + IF(MSEL.EQ.2) THEN + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + ENDIF + IF(IPTL.EQ.1) CKIN(3)=0D0 + ENDIF + +C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom. + ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN + +C...Set up for direct * direct gamma (switch off leptons). + IF(MINT(122).EQ.1) THEN + MINT(123)=0 + MSUB(137)=1 + MSUB(138)=1 + MSUB(139)=1 + MSUB(140)=1 + DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 + IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) + 120 CONTINUE + IF(IPTL.EQ.1) CKIN(3)=PTMDIR + +C...Set up for direct * VMD and VMD * direct gamma. + ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN + MINT(123)=5 + MSUB(131)=1 + MSUB(132)=1 + MSUB(135)=1 + MSUB(136)=1 + IF(IPTL.EQ.1) CKIN(3)=PTMDIR + +C...Set up for direct * anomalous and anomalous * direct gamma. + ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN + MINT(123)=6 + MSUB(131)=1 + MSUB(132)=1 + MSUB(135)=1 + MSUB(136)=1 + IF(IPTL.EQ.1) CKIN(3)=PTMANO + +C...Set up for VMD*VMD. + ELSEIF(MINT(122).EQ.5) THEN + MINT(123)=2 + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + IF(IPTL.EQ.1) MSUB(95)=1 + IF(MSEL.EQ.2) THEN + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + ENDIF + IF(IPTL.EQ.1) CKIN(3)=0D0 + +C...Set up for VMD * anomalous and anomalous * VMD gamma. + ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN + MINT(123)=7 + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + IF(IPTL.EQ.1) MSUB(95)=1 + IF(MSEL.EQ.2) THEN + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + ENDIF + IF(IPTL.EQ.1) CKIN(3)=0D0 + +C...Set up for anomalous * anomalous gamma. + ELSEIF(MINT(122).EQ.9) THEN + MINT(123)=3 + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + IF(IPTL.EQ.1) MSUB(95)=1 + IF(MSEL.EQ.2) THEN + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + ENDIF + IF(IPTL.EQ.1) CKIN(3)=0D0 + +C...Set up for DIS * VMD and VMD * DIS gamma. + ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN + MINT(123)=8 + IF(IPTL.EQ.1) MSUB(99)=1 + +C...Set up for DIS * anomalous and anomalous * DIS gamma. + ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN + MINT(123)=9 + IF(IPTL.EQ.1) MSUB(99)=1 + ENDIF + +C...Set up for gamma* * p; virtual photons = dir, res. + ELSEIF(MINT(121).EQ.2) THEN + +C...Set up for direct * p. + IF(MINT(122).EQ.1) THEN + MINT(123)=0 + MSUB(131)=1 + MSUB(132)=1 + MSUB(135)=1 + MSUB(136)=1 + IF(IPTL.EQ.1) CKIN(3)=PTMDIR + +C...Set up for resolved * p. + ELSEIF(MINT(122).EQ.2) THEN + MINT(123)=1 + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + IF(IPTL.EQ.1) MSUB(95)=1 + IF(MSEL.EQ.2) THEN + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + ENDIF + IF(IPTL.EQ.1) CKIN(3)=0D0 + ENDIF + +C...Set up for gamma* * gamma*; virtual photons = dir, res. + ELSEIF(MINT(121).EQ.4) THEN + +C...Set up for direct * direct gamma (switch off leptons). + IF(MINT(122).EQ.1) THEN + MINT(123)=0 + MSUB(137)=1 + MSUB(138)=1 + MSUB(139)=1 + MSUB(140)=1 + DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 + IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) + 130 CONTINUE + IF(IPTL.EQ.1) CKIN(3)=PTMDIR + +C...Set up for direct * resolved and resolved * direct gamma. + ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN + MINT(123)=5 + MSUB(131)=1 + MSUB(132)=1 + MSUB(135)=1 + MSUB(136)=1 + IF(IPTL.EQ.1) CKIN(3)=PTMDIR + +C...Set up for resolved * resolved gamma. + ELSEIF(MINT(122).EQ.4) THEN + MINT(123)=2 + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + IF(IPTL.EQ.1) MSUB(95)=1 + IF(MSEL.EQ.2) THEN + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + ENDIF + IF(IPTL.EQ.1) CKIN(3)=0D0 + ENDIF + +C...End of special set up for gamma-p and gamma-gamma. + ENDIF + CKIN(1)=2D0*CKIN(3) + ENDIF + +C...Flavour information for individual beams. + DO 140 I=1,2 + MINT(40+I)=1 + IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2 + IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2 + MINT(44+I)=MINT(40+I) + IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR. + & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3 + 140 CONTINUE + +C...If two real gammas, whereof one direct, pick the first. +C...For two virtual photons, keep requested order. + IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN + IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN + MINT(41)=1 + MINT(45)=1 + ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR. + & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN + MINT(41)=1 + MINT(45)=1 + ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR. + & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN + MINT(42)=1 + MINT(46)=1 + ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2 + & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN + MINT(41)=1 + MINT(45)=1 + ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4 + & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN + MINT(42)=1 + MINT(46)=1 + ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN + MINT(41)=1 + MINT(45)=1 + ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN + MINT(42)=1 + MINT(46)=1 + ENDIF + ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN + IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN + IF(MINT(11).EQ.22) THEN + MINT(41)=1 + MINT(45)=1 + ELSE + MINT(42)=1 + MINT(46)=1 + ENDIF + ENDIF + IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26, + & '(PYINPR:) unallowed MSTP(14) code for single photon') + ENDIF + +C...Flavour information on combination of incoming particles. + MINT(43)=2*MINT(41)+MINT(42)-2 + MINT(44)=MINT(43) + IF(MINT(123).LE.0) THEN + IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2 + IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1 + ELSEIF(MINT(123).LE.3) THEN + IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2 + IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1 + ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN + MINT(43)=4 + MINT(44)=1 + ENDIF + MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2 + IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5 + IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6 + IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7 + MINT(50)=0 + IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1 + MINT(107)=0 + MINT(108)=0 + IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN + IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12) + & MINT(107)=2 + IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13) + & MINT(107)=3 + IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4 + IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR. + & MINT(122).EQ.10) MINT(108)=2 + IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR. + & MINT(122).EQ.11) MINT(108)=3 + IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4 + ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN + IF(MINT(122).GE.3) MINT(107)=1 + IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1 + ELSEIF(MINT(121).EQ.2) THEN + IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1 + IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1 + ELSE + IF(MINT(11).EQ.22) THEN + MINT(107)=MINT(123) + IF(MINT(123).GE.4) MINT(107)=0 + IF(MINT(123).EQ.7) MINT(107)=2 + IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4 + IF(MSTP(14).EQ.28) MINT(107)=2 + IF(MSTP(14).EQ.29) MINT(107)=3 + IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4) + & MINT(107)=4 + ENDIF + IF(MINT(12).EQ.22) THEN + MINT(108)=MINT(123) + IF(MINT(123).GE.4) MINT(108)=MINT(123)-3 + IF(MINT(123).EQ.7) MINT(108)=3 + IF(MSTP(14).EQ.26) MINT(108)=2 + IF(MSTP(14).EQ.27) MINT(108)=3 + IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4 + IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4) + & MINT(108)=4 + ENDIF + IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR. + & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN + MINTTP=MINT(107) + MINT(107)=MINT(108) + MINT(108)=MINTTP + ENDIF + ENDIF + IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0 + IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0 + +C...Select default processes according to incoming beams +C...(already done for gamma-p and gamma-gamma with +C...MSTP(14) = 10, 20, 25 or 30). + IF(MINT(121).GT.1) THEN + ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN + + IF(MINT(43).EQ.1) THEN +C...Lepton + lepton -> gamma/Z0 or W. + IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1 + IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1 + + ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND. + & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN +C...Unresolved photon + lepton: Compton scattering. + MSUB(133)=1 + MSUB(134)=1 + + ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22 + & .OR.MINT(12).EQ.22)) THEN +C...DIS as pure gamma* + f -> f process. + MSUB(99)=1 + + ELSEIF(MINT(43).LE.3) THEN +C...Lepton + hadron: deep inelastic scattering. + MSUB(10)=1 + + ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND. + & MINT(12).EQ.22) THEN +C...Two unresolved photons: fermion pair production, +C...exclude lepton pairs. + DO 150 ISUB=137,140 + MSUB(ISUB)=1 + 150 CONTINUE + DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1 + IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1)) + 160 CONTINUE + PTMDIR=PTMRUN + IF(MSTP(18).EQ.2) PTMDIR=PARP(15) + IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR + CKIN(1)=MAX(CKIN(1),2D0*CKIN(3)) + + ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22)) + & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND. + & MINT(12).EQ.22)) THEN +C...Unresolved photon + hadron: photon-parton scattering. + DO 170 ISUB=131,136 + MSUB(ISUB)=1 + 170 CONTINUE + + ELSEIF(MSEL.EQ.1) THEN +C...High-pT QCD processes: + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + PTMN=PTMRUN + VINT(154)=PTMN + IF(CKIN(3).LT.PTMN) MSUB(95)=1 + IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0 + + ELSE +C...All QCD processes: + MSUB(11)=1 + MSUB(12)=1 + MSUB(13)=1 + MSUB(28)=1 + MSUB(53)=1 + MSUB(68)=1 + MSUB(91)=1 + MSUB(92)=1 + MSUB(93)=1 + MSUB(94)=1 + MSUB(95)=1 + ENDIF + + ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN +C...Heavy quark production. + MSUB(81)=1 + MSUB(82)=1 + MSUB(84)=1 + DO 180 J=1,MIN(8,MDCY(21,3)) + MDME(MDCY(21,2)+J-1,1)=0 + 180 CONTINUE + MDME(MDCY(21,2)+MSEL-1,1)=1 + MSUB(85)=1 + DO 190 J=1,MIN(12,MDCY(22,3)) + MDME(MDCY(22,2)+J-1,1)=0 + 190 CONTINUE + MDME(MDCY(22,2)+MSEL-1,1)=1 + + ELSEIF(MSEL.EQ.10) THEN +C...Prompt photon production: + MSUB(14)=1 + MSUB(18)=1 + MSUB(29)=1 + + ELSEIF(MSEL.EQ.11) THEN +C...Z0/gamma* production: + MSUB(1)=1 + + ELSEIF(MSEL.EQ.12) THEN +C...W+/- production: + MSUB(2)=1 + + ELSEIF(MSEL.EQ.13) THEN +C...Z0 + jet: + MSUB(15)=1 + MSUB(30)=1 + + ELSEIF(MSEL.EQ.14) THEN +C...W+/- + jet: + MSUB(16)=1 + MSUB(31)=1 + + ELSEIF(MSEL.EQ.15) THEN +C...Z0 & W+/- pair production: + MSUB(19)=1 + MSUB(20)=1 + MSUB(22)=1 + MSUB(23)=1 + MSUB(25)=1 + + ELSEIF(MSEL.EQ.16) THEN +C...h0 production: + MSUB(3)=1 + MSUB(102)=1 + MSUB(103)=1 + MSUB(123)=1 + MSUB(124)=1 + + ELSEIF(MSEL.EQ.17) THEN +C...h0 & Z0 or W+/- pair production: + MSUB(24)=1 + MSUB(26)=1 + + ELSEIF(MSEL.EQ.18) THEN +C...h0 production; interesting processes in e+e-. + MSUB(24)=1 + MSUB(103)=1 + MSUB(123)=1 + MSUB(124)=1 + + ELSEIF(MSEL.EQ.19) THEN +C...h0, H0 and A0 production; interesting processes in e+e-. + MSUB(24)=1 + MSUB(103)=1 + MSUB(123)=1 + MSUB(124)=1 + MSUB(153)=1 + MSUB(171)=1 + MSUB(173)=1 + MSUB(174)=1 + MSUB(158)=1 + MSUB(176)=1 + MSUB(178)=1 + MSUB(179)=1 + + ELSEIF(MSEL.EQ.21) THEN +C...Z'0 production: + MSUB(141)=1 + + ELSEIF(MSEL.EQ.22) THEN +C...W'+/- production: + MSUB(142)=1 + + ELSEIF(MSEL.EQ.23) THEN +C...H+/- production: + MSUB(143)=1 + + ELSEIF(MSEL.EQ.24) THEN +C...R production: + MSUB(144)=1 + + ELSEIF(MSEL.EQ.25) THEN +C...LQ (leptoquark) production. + MSUB(145)=1 + MSUB(162)=1 + MSUB(163)=1 + MSUB(164)=1 + + ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN +C...Production of one heavy quark (W exchange): + MSUB(83)=1 + DO 200 J=1,MIN(8,MDCY(21,3)) + MDME(MDCY(21,2)+J-1,1)=0 + 200 CONTINUE + MDME(MDCY(21,2)+MSEL-31,1)=1 + +CMRENNA++Define SUSY alternatives. + ELSEIF(MSEL.EQ.39) THEN +C...Turn on all SUSY processes. + IF(MINT(43).EQ.4) THEN +C...Hadron-hadron processes. + DO 210 I=201,296 + IF(ISET(I).GE.0) MSUB(I)=1 + 210 CONTINUE + ELSEIF(MINT(43).EQ.1) THEN +C...Lepton-lepton processes: QED production of squarks. + DO 220 I=201,214 + MSUB(I)=1 + 220 CONTINUE + MSUB(210)=0 + MSUB(211)=0 + MSUB(212)=0 + DO 230 I=216,228 + MSUB(I)=1 + 230 CONTINUE + DO 240 I=261,263 + MSUB(I)=1 + 240 CONTINUE + MSUB(277)=1 + MSUB(278)=1 + ENDIF + + ELSEIF(MSEL.EQ.40) THEN +C...Gluinos and squarks. + IF(MINT(43).EQ.4) THEN + MSUB(243)=1 + MSUB(244)=1 + MSUB(258)=1 + MSUB(259)=1 + MSUB(261)=1 + MSUB(262)=1 + MSUB(264)=1 + MSUB(265)=1 + DO 250 I=271,296 + MSUB(I)=1 + 250 CONTINUE + ELSEIF(MINT(43).EQ.1) THEN + MSUB(277)=1 + MSUB(278)=1 + ENDIF + + ELSEIF(MSEL.EQ.41) THEN +C...Stop production. + MSUB(261)=1 + MSUB(262)=1 + MSUB(263)=1 + IF(MINT(43).EQ.4) THEN + MSUB(264)=1 + MSUB(265)=1 + ENDIF + + ELSEIF(MSEL.EQ.42) THEN +C...Slepton production. + DO 260 I=201,214 + MSUB(I)=1 + 260 CONTINUE + IF(MINT(43).NE.4) THEN + MSUB(210)=0 + MSUB(211)=0 + MSUB(212)=0 + ENDIF + + ELSEIF(MSEL.EQ.43) THEN +C...Neutralino/Chargino + Gluino/Squark. + IF(MINT(43).EQ.4) THEN + DO 270 I=237,242 + MSUB(I)=1 + 270 CONTINUE + DO 280 I=246,254 + MSUB(I)=1 + 280 CONTINUE + MSUB(256)=1 + ENDIF + + ELSEIF(MSEL.EQ.44) THEN +C...Neutralino/Chargino pair production. + IF(MINT(43).EQ.4) THEN + DO 290 I=216,236 + MSUB(I)=1 + 290 CONTINUE + ELSEIF(MINT(43).EQ.1) THEN + DO 300 I=216,228 + MSUB(I)=1 + 300 CONTINUE + ENDIF + + ELSEIF(MSEL.EQ.45) THEN +C...Sbottom production. + MSUB(287)=1 + MSUB(288)=1 + IF(MINT(43).EQ.4) THEN + DO 310 I=281,296 + MSUB(I)=1 + 310 CONTINUE + ENDIF + + ELSEIF(MSEL.EQ.50) THEN +C...Pair production of technipions and gauge bosons. + DO 320 I=361,368 + MSUB(I)=1 + 320 CONTINUE + IF(MINT(43).EQ.4) THEN + DO 330 I=370,377 + MSUB(I)=1 + 330 CONTINUE + ENDIF + + ELSEIF(MSEL.EQ.51) THEN +C...QCD 2 -> 2 processes with compositeness/technicolor modifications. + DO 340 I=381,386 + MSUB(I)=1 + 340 CONTINUE + + ELSEIF(MSEL.EQ.61) THEN +C...Charmonium production in colour octet model, with recoiling parton. + DO 342 I=421,439 + MSUB(I)=1 + 342 CONTINUE + + ELSEIF(MSEL.EQ.62) THEN +C...Bottomonium production in colour octet model, with recoiling parton. + DO 344 I=461,479 + MSUB(I)=1 + 344 CONTINUE + + ELSEIF(MSEL.EQ.63) THEN +C...Charmonium and bottomonium production in colour octet model. + DO 346 I=421,439 + MSUB(I)=1 + MSUB(I+40)=1 + 346 CONTINUE + ENDIF + +C...Find heaviest new quark flavour allowed in processes 81-84. + KFLQM=1 + DO 350 I=1,MIN(8,MDCY(21,3)) + IDC=I+MDCY(21,2)-1 + IF(MDME(IDC,1).LE.0) GOTO 350 + KFLQM=I + 350 CONTINUE + IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9)) + &KFLQM=MSTP(7) + MINT(55)=KFLQM + KFPR(81,1)=KFLQM + KFPR(81,2)=KFLQM + KFPR(82,1)=KFLQM + KFPR(82,2)=KFLQM + KFPR(83,1)=KFLQM + KFPR(84,1)=KFLQM + KFPR(84,2)=KFLQM + +C...Find heaviest new fermion flavour allowed in process 85. + KFLFM=1 + DO 360 I=1,MIN(12,MDCY(22,3)) + IDC=I+MDCY(22,2)-1 + IF(MDME(IDC,1).LE.0) GOTO 360 + KFLFM=KFDP(IDC,1) + 360 CONTINUE + IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND. + &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7) + MINT(56)=KFLFM + KFPR(85,1)=KFLFM + KFPR(85,2)=KFLFM + +C...Initialize Generic Processes + KFGEN=9900001 + KCGEN=PYCOMP(KFGEN) + IF(KCGEN.GT.0) THEN + IDCY=MDCY(KCGEN,2) + IF(IDCY.GT.0) THEN + KFF1=KFDP(IDCY+1,1) + KFF2=KFDP(IDCY+1,2) + KCF1=PYCOMP(KFF1) + KCF2=PYCOMP(KFF2) + JCOL1=IABS(KCHG(KCF1,2)) + IF(JCOL1.EQ.1) THEN + KF1=KFF1 + KF2=KFF2 + ELSE + KF1=KFF2 + KF2=KFF1 + ENDIF + KFPR(481,1)=KF1 + KFPR(481,2)=KF2 + KFPR(482,1)=KF1 + KFPR(482,2)=KF2 + ENDIF + IF(KFDP(IDCY,1).EQ.21.OR.KFDP(IDCY,2).EQ.21) THEN + KFIN(1,0)=1 + KFIN(2,0)=1 + ENDIF + ENDIF + +C...Import relevant information on external user processes. + IF(MINT(111).GE.11) THEN + IPYPR=0 + DO 390 IUP=1,NPRUP +C...Find next empty PYTHIA process number slot and enable it. + 370 IPYPR=IPYPR+1 + IF(IPYPR.GT.500) CALL PYERRM(26, + & '(PYINPR.) no more empty slots for user processes') + IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370 + IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370 + ISET(IPYPR)=11 +C...Overwrite KFPR with references back to process number and ID. + KFPR(IPYPR,1)=IUP + KFPR(IPYPR,2)=LPRUP(IUP) +C...Process title. + WRITE(CHIPR,'(I10)') LPRUP(IUP) + ICHIN=1 + DO 380 ICH=1,9 + IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1 + 380 CONTINUE + PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' ' +C...Switch on process. + MSUB(IPYPR)=1 + 390 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYXTOT +C...Parametrizes total, elastic and diffractive cross-sections +C...for different energies and beams. Donnachie-Landshoff for +C...total and Schuler-Sjostrand for elastic and diffractive. +C...Process code IPROC: +C...= 1 : p + p; +C...= 2 : pbar + p; +C...= 3 : pi+ + p; +C...= 4 : pi- + p; +C...= 5 : pi0 + p; +C...= 6 : phi + p; +C...= 7 : J/psi + p; +C...= 11 : rho + rho; +C...= 12 : rho + phi; +C...= 13 : rho + J/psi; +C...= 14 : phi + phi; +C...= 15 : phi + J/psi; +C...= 16 : J/psi + J/psi; +C...= 21 : gamma + p (DL); +C...= 22 : gamma + p (VDM). +C...= 23 : gamma + pi (DL); +C...= 24 : gamma + pi (VDM); +C...= 25 : gamma + gamma (DL); +C...= 26 : gamma + gamma (VDM). + + SUBROUTINE PYXTOT + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/ +C...Local arrays. + DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20), + &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8), + &CEFFD(10,9),SIGTMP(6,0:5) + +C...Common constants. + DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/, + &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/, + &FACDD/0.0084D0/ + +C...Number of multiple processes to be evaluated (= 0 : undefined). + DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/ +C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta). + DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0, + &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0, + &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/ + DATA YPAR/ + &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0, + &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0, + &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/ + +C...Beam and target hadron class: +C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi. + DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/ + DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/ +C...Characteristic class masses, slope parameters, beta = sqrt(X). + DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/ + DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/ + DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/ + +C...Fitting constants used in parametrizations of diffractive results. + DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/ + DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/ + DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/ + &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0, + &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0, + &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0, + &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0, + &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0, + &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0, + &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0, + &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0, + &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0, + &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/ + DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/ + &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0, + &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0, + &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0, + &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0, + &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0, + &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0, + &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0, + &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0, + &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0, + &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0, + &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0, + &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0, + &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0, + &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0, + &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/ + +C...Parameters. Combinations of the energy. + AEM=PARU(101) + PMTH=PARP(102) + S=VINT(2) + SRT=VINT(1) + SEPS=S**EPS + SETA=S**ETA + SLOG=LOG(S) + +C...Ratio of gamma/pi (for rescaling in parton distributions). + VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/ + &(XPAR(5)*SEPS+YPAR(5)*SETA) + VINT(317)=1D0 + IF(MINT(50).NE.1) RETURN + +C...Order flavours of incoming particles: KF1 < KF2. + IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN + KF1=IABS(MINT(11)) + KF2=IABS(MINT(12)) + IORD=1 + ELSE + KF1=IABS(MINT(12)) + KF2=IABS(MINT(11)) + IORD=2 + ENDIF + ISGN12=ISIGN(1,MINT(11)*MINT(12)) + +C...Find process number (for lookup tables). + IF(KF1.GT.1000) THEN + IPROC=1 + IF(ISGN12.LT.0) IPROC=2 + ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN + IPROC=3 + IF(ISGN12.LT.0) IPROC=4 + IF(KF1.EQ.111) IPROC=5 + ELSEIF(KF1.GT.100) THEN + IPROC=11 + ELSEIF(KF2.GT.1000) THEN + IPROC=21 + IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22 + ELSEIF(KF2.GT.100) THEN + IPROC=23 + IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24 + ELSE + IPROC=25 + IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26 + ENDIF + +C... Number of multiple processes to be stored; beam/target side. + NPR=NPROC(IPROC) + MINT(101)=1 + MINT(102)=1 + IF(NPR.EQ.3) THEN + MINT(100+IORD)=4 + ELSEIF(NPR.EQ.6) THEN + MINT(101)=4 + MINT(102)=4 + ENDIF + N1=0 + IF(MINT(101).EQ.4) N1=4 + N2=0 + IF(MINT(102).EQ.4) N2=4 + +C...Do not do any more for user-set or undefined cross-sections. + IF(MSTP(31).LE.0) RETURN + IF(NPR.EQ.0) CALL PYERRM(26, + &'(PYXTOT:) cross section for this process not yet implemented') + +C...Parameters. Combinations of the energy. + AEM=PARU(101) + PMTH=PARP(102) + S=VINT(2) + SRT=VINT(1) + SEPS=S**EPS + SETA=S**ETA + SLOG=LOG(S) + +C...Loop over multiple processes (for VDM). + DO 110 I=1,NPR + IF(NPR.EQ.1) THEN + IPR=IPROC + ELSEIF(NPR.EQ.3) THEN + IPR=I+4 + IF(KF2.LT.1000) IPR=I+10 + ELSEIF(NPR.EQ.6) THEN + IPR=I+10 + ENDIF + +C...Evaluate hadron species, mass, slope contribution and fit number. + IHA=IHADA(IPR) + IHB=IHADB(IPR) + PMA=PMHAD(IHA) + PMB=PMHAD(IHB) + BHA=BHAD(IHA) + BHB=BHAD(IHB) + ISD=IFITSD(IPR) + IDD=IFITDD(IPR) + +C...Skip if energy too low relative to masses. + DO 100 J=0,5 + SIGTMP(I,J)=0D0 + 100 CONTINUE + IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110 + +C...Total cross-section. Elastic slope parameter and cross-section. + SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA + BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0 + SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL + +C...Diffractive scattering A + B -> X + B. + BSD=2D0*BHB + SQML=(PMA+PMTH)**2 + SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2) + SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/ + & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP) + BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S + SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/ + & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB) + SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2) + +C...Diffractive scattering A + B -> A + X. + BSD=2D0*BHA + SQML=(PMB+PMTH)**2 + SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6) + SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/ + & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP) + BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S + SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/ + & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX) + SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2) + +C...Order single diffractive correctly. + IF(IORD.EQ.2) THEN + SIGSAV=SIGTMP(I,2) + SIGTMP(I,2)=SIGTMP(I,3) + SIGTMP(I,3)=SIGSAV + ENDIF + +C...Double diffractive scattering A + B -> X1 + X2. + YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2) + DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2 + SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP) + IF(YEFF.LE.0) SUM1=0D0 + SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2) + SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC)))) + SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC)))) + SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/ + & (2D0*ALP) + SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC)))) + SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC)))) + SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/ + & (2D0*ALP) + BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S + SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC))) + SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)* + & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX) + SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4) + +C...Non-diffractive by unitarity. + SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)- + & SIGTMP(I,4) + 110 CONTINUE + +C...Put temporary results in output array: only one process. + IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN + DO 120 J=0,5 + SIGT(0,0,J)=SIGTMP(1,J) + 120 CONTINUE + +C...Beam multiple processes. + ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN + IF(MINT(107).EQ.2) THEN + VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2 + ELSE + VINT(317)=16D0*PARP(15)**2*VINT(154)**2/ + & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307))) + ENDIF + IF(MSTP(20).GT.0) THEN + VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20) + ENDIF + DO 140 I=1,4 + IF(MINT(107).EQ.2) THEN + CONV=(AEM/PARP(160+I))*VINT(317) + ELSEIF(VINT(154).GT.PARP(15)) THEN + CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2* + & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317) + ELSE + CONV=0D0 + ENDIF + I1=MAX(1,I-1) + DO 130 J=0,5 + SIGT(I,0,J)=CONV*SIGTMP(I1,J) + 130 CONTINUE + 140 CONTINUE + DO 150 J=0,5 + SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J) + 150 CONTINUE + +C...Target multiple processes. + ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN + IF(MINT(108).EQ.2) THEN + VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2 + ELSE + VINT(317)=16D0*PARP(15)**2*VINT(154)**2/ + & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308))) + ENDIF + IF(MSTP(20).GT.0) THEN + VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20) + ENDIF + DO 170 I=1,4 + IF(MINT(108).EQ.2) THEN + CONV=(AEM/PARP(160+I))*VINT(317) + ELSEIF(VINT(154).GT.PARP(15)) THEN + CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2* + & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317) + ELSE + CONV=0D0 + ENDIF + IV=MAX(1,I-1) + DO 160 J=0,5 + SIGT(0,I,J)=CONV*SIGTMP(IV,J) + 160 CONTINUE + 170 CONTINUE + DO 180 J=0,5 + SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J) + 180 CONTINUE + +C...Both beam and target multiple processes. + ELSE + IF(MINT(107).EQ.2) THEN + VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2 + ELSE + VINT(317)=16D0*PARP(15)**2*VINT(154)**2/ + & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307))) + ENDIF + IF(MINT(108).EQ.2) THEN + VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2 + ELSE + VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/ + & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308))) + ENDIF + IF(MSTP(20).GT.0) THEN + VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+ + & VINT(308)))**MSTP(20) + ENDIF + DO 210 I1=1,4 + DO 200 I2=1,4 + IF(MINT(107).EQ.2) THEN + CONV=(AEM/PARP(160+I1))*VINT(317) + ELSEIF(VINT(154).GT.PARP(15)) THEN + CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2* + & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317) + ELSE + CONV=0D0 + ENDIF + IF(MINT(108).EQ.2) THEN + CONV=CONV*(AEM/PARP(160+I2)) + ELSEIF(VINT(154).GT.PARP(15)) THEN + CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2* + & (1D0/PARP(15)**2-1D0/VINT(154)**2) + ELSE + CONV=0D0 + ENDIF + IF(I1.LE.2) THEN + IV=MAX(1,I2-1) + ELSEIF(I2.LE.2) THEN + IV=MAX(1,I1-1) + ELSEIF(I1.EQ.I2) THEN + IV=2*I1-2 + ELSE + IV=5 + ENDIF + DO 190 J=0,5 + JV=J + IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J + SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV) + 190 CONTINUE + 200 CONTINUE + 210 CONTINUE + DO 230 J=0,5 + DO 220 I=1,4 + SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J) + SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J) + 220 CONTINUE + SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J) + 230 CONTINUE + ENDIF + +C...Scale up uniformly for Donnachie-Landshoff parametrization. + IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN + RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0) + DO 260 I1=0,N1 + DO 250 I2=0,N2 + DO 240 J=0,5 + SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J) + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYMAXI +C...Finds optimal set of coefficients for kinematical variable selection +C...and the maximum of the part of the differential cross-section used +C...in the event weighting. + + SUBROUTINE PYMAXI + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) + +C...User process initialization commonblock. + INTEGER MAXPUP + PARAMETER (MAXPUP=100) + INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP + DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP + COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), + &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), + &LPRUP(MAXPUP) + SAVE /HEPRUP/ + +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT6/PROC(0:500) + CHARACTER PROC*28 + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYTCCO/COEFX(194:380,2) + COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/, + &/PYTCSM/,/TCPARA/ +C...Local arrays, character variables and data. + LOGICAL IOK + CHARACTER CVAR(4)*4 + DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500), + &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9), + &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2),WTRSAV(9),TEMPC(9), + &IQ(9),IP(9) + 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 + ITECH=0 + DO 460 ISUB=1,500 + MINT(1)=ISUB + MINT(51)=0 + +C...Find maximum weight factors for photon flux. + IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN + IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA) + ENDIF + +C...Select subprocess to study: skip cases not applicable. + IF(ISET(ISUB).EQ.11) THEN + IF(MSUB(ISUB).NE.1) GOTO 460 +C...User process intialization: cross section model dependent. + IF(IABS(IDWTUP).EQ.1) THEN + IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL + & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process') + XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1))) + ELSE + IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND. + & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL + & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process') + IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL + & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process') + XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1))) + ENDIF + IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)= + & WTGAGA*XSEC(ISUB,1) + NPOSI=NPOSI+1 + GOTO 450 + ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN + CALL PYSIGH(NCHN,SIGS) + XSEC(ISUB,1)=SIGS + IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)= + & WTGAGA*XSEC(ISUB,1) + IF(MSUB(ISUB).NE.1) GOTO 460 + NPOSI=NPOSI+1 + GOTO 450 + ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN + CALL PYSIGH(NCHN,SIGS) + XSEC(ISUB,1)=SIGS + IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)= + & WTGAGA*XSEC(ISUB,1) + IF(XSEC(ISUB,1).EQ.0D0) THEN + MSUB(ISUB)=0 + ELSE + NPOSI=NPOSI+1 + ENDIF + GOTO 450 + ELSEIF(ISUB.EQ.96) THEN + IF(MINT(50).EQ.0) GOTO 460 + IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0) + & GOTO 460 + IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460 + ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR. + & ISUB.EQ.53.OR.ISUB.EQ.68) THEN + IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460 + ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN + IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460 + ELSE + IF(MSUB(ISUB).NE.1) GOTO 460 + ENDIF + ISTSB=ISET(ISUB) + IF(ISUB.EQ.96) ISTSB=2 + IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB + MWTXS=0 + IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+ + & MSUB(94)+MSUB(95).EQ.0) MWTXS=1 + +C...Find resonances (explicit or implicit in cross-section). + MINT(72)=0 + KFR1=0 + IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN + KFR1=KFPR(ISUB,1) + ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165 + & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN + KFR1=23 + ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172 + & .OR.ISUB.EQ.177) THEN + KFR1=24 + ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN + KFR1=25 + IF(MSTP(46).EQ.5) THEN + KFR1=89 + PMAS(89,1)=PARP(45) + PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2) + ENDIF + ELSEIF(ISUB.EQ.481) THEN + KFR1=9900001 + ENDIF + CKMX=CKIN(2) + IF(CKMX.LE.0D0) CKMX=VINT(1) + KCR1=PYCOMP(KFR1) + IF(KCR1.EQ.0) KFR1=0 + IF(KFR1.NE.0) THEN + IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR. + & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0 + ENDIF + IF(KFR1.NE.0) THEN + TAUR1=PMAS(KCR1,1)**2/VINT(2) + GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2) + MINT(72)=1 + MINT(73)=KFR1 + VINT(73)=TAUR1 + VINT(74)=GAMR1 + ENDIF + KFR2=0 + KFR3=0 + IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR. + $ (ISUB.GE.361.AND.ISUB.LE.380)) + $ THEN + KFR2=23 + IF(ISUB.EQ.141) THEN + KCR2=PYCOMP(KFR2) + IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR. + & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN + KFR2=0 + ELSE + TAUR2=PMAS(KCR2,1)**2/VINT(2) + GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2) + MINT(72)=2 + MINT(74)=KFR2 + VINT(75)=TAUR2 + VINT(76)=GAMR2 + ENDIF + ELSEIF(ITECH.EQ.0) THEN + ALPRHT=2.16D0*(3D0/DBLE(ITCM(1))) + ITECH=1 + KFR1=KTECHN+113 + KCR1=PYCOMP(KFR1) + KFR2=KTECHN+223 + KCR2=PYCOMP(KFR2) + KFR3=KTECHN+115 + KCR3=PYCOMP(KFR3) + IRES=0 +C...Order the resonances + IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN + KCT=KCR3 + KCR3=KCR2 + KCR2=KCT + ENDIF + IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN + KCT=KCR3 + KCR3=KCR1 + KCR1=KCT + ENDIF + IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN + KCT=KCR2 + KCR2=KCR1 + KCR1=KCT + ENDIF + DO 101 I=1,3 + IF(I.EQ.1) THEN + SHN0=PMAS(KCR1,1)**2 + ELSEIF(I.EQ.2) THEN + IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101 + SHN0=PMAS(KCR2,1)**2 + ELSEIF(I.EQ.3) THEN + IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101 + SHN0=PMAS(KCR3,1)**2 + ENDIF + AEM=PYALEM(SHN0) + FAR=SQRT(AEM/ALPRHT) + SHN=SHN0*(1D0-FAR) + CALL PYTECM(SHN,S1,WIDO,1) + RES=SHN-S1 + SHN=S1*.99D0 + SHSTEP=2D0 + 102 SHN=SHN+SHSTEP + CALL PYTECM(SHN,S1,WIDO,1) + IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN + IOK=.FALSE. + IF(IRES.GT.0) THEN + IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE. + ELSEIF(IRES.EQ.0) THEN + IOK=.TRUE. + ENDIF + IF(IOK) THEN + IRES=IRES+1 + XMAS(IRES)=SQRT(S1) + XWID(IRES)=WIDO + ENDIF + ENDIF + RES=SHN-S1 + IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102 + 101 CONTINUE + JRES=0 + KFR1=KTECHN+213 + KCR1=PYCOMP(KFR1) + KFR2=KTECHN+215 + KCR2=PYCOMP(KFR2) + IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN + KCT=KCR2 + KCR2=KCR1 + KCR1=KCT + ENDIF + DO 103 I=1,2 + IF(I.EQ.1) THEN + SHN0=PMAS(KCR1,1)**2 + ELSEIF(I.EQ.2) THEN + IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103 + SHN0=PMAS(KCR2,1)**2 + ENDIF + AEM=PYALEM(SHN0) + FAR=SQRT(AEM/ALPRHT) + SHN=SHN0*(1D0-FAR) + CALL PYTECM(SHN,S1,WIDO,2) + RES=SHN-S1 + SHN=S1*.99D0 + SHSTEP=2D0 + 104 SHN=SHN+SHSTEP + CALL PYTECM(SHN,S1,WIDO,2) + IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN + IOK=.FALSE. + IF(JRES.GT.0) THEN + IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE. + ELSEIF(JRES.EQ.0) THEN + IOK=.TRUE. + ENDIF + IF(IOK) THEN + JRES=JRES+1 + YMAS(JRES)=SQRT(S1) + YWID(JRES)=WIDO + ENDIF + ENDIF + RES=SHN-S1 + IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104 + 103 CONTINUE + ENDIF + IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR. + & ISUB.EQ.379.OR.ISUB.EQ.380) THEN + MINT(72)=IRES + IF(IRES.GE.1) THEN + VINT(73)=XMAS(1)**2/VINT(2) + VINT(74)=XMAS(1)*XWID(1)/VINT(2) + TAUR1=VINT(73) + GAMR1=VINT(74) + XM1=XMAS(1) + XG1=XWID(1) + KFR1=1 + ENDIF + IF(IRES.GE.2) THEN + VINT(75)=XMAS(2)**2/VINT(2) + VINT(76)=XMAS(2)*XWID(2)/VINT(2) + TAUR2=VINT(75) + GAMR2=VINT(76) + XM2=XMAS(2) + XG2=XWID(2) + KFR2=2 + ENDIF + IF(IRES.EQ.3) THEN + VINT(77)=XMAS(3)**2/VINT(2) + VINT(78)=XMAS(3)*XWID(3)/VINT(2) + TAUR3=VINT(77) + GAMR3=VINT(78) + XM3=XMAS(3) + XG3=XWID(3) + KFR3=3 + ENDIF +C...Charged current: rho+- and a+- + ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN + MINT(72)=IRES + IF(JRES.GE.1) THEN + VINT(73)=YMAS(1)**2/VINT(2) + VINT(74)=YMAS(1)*YWID(1)/VINT(2) + KFR1=1 + TAUR1=VINT(73) + GAMR1=VINT(74) + XM1=YMAS(1) + XG1=YWID(1) + ENDIF + IF(JRES.GE.2) THEN + VINT(75)=YMAS(2)**2/VINT(2) + VINT(76)=YMAS(2)*YWID(2)/VINT(2) + KFR2=2 + TAUR2=VINT(73) + GAMR2=VINT(74) + XM2=YMAS(2) + XG2=YWID(2) + ENDIF + KFR3=0 + ENDIF + IF(ISUB.NE.141) THEN + IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1) + & .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0 + IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2) + & .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0 + IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3) + & .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0 + IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN + + ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN + MINT(72)=2 + ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN + MINT(72)=2 + MINT(74)=KFR3 + VINT(75)=TAUR3 + VINT(76)=GAMR3 + ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN + MINT(72)=2 + MINT(73)=KFR2 + VINT(73)=TAUR2 + VINT(74)=GAMR2 + MINT(74)=KFR3 + VINT(75)=TAUR3 + VINT(76)=GAMR3 + ELSEIF(KFR1.NE.0) THEN + MINT(72)=1 + ELSEIF(KFR2.NE.0) THEN + MINT(72)=1 + MINT(73)=KFR2 + VINT(73)=TAUR2 + VINT(74)=GAMR2 + ELSEIF(KFR3.NE.0) THEN + MINT(72)=1 + MINT(73)=KFR3 + VINT(73)=TAUR3 + VINT(74)=GAMR3 + ELSE + MINT(72)=0 + ENDIF + ELSE + IF(KFR2.NE.0.AND.KFR1.NE.0) THEN + + 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 + ELSE + MINT(72)=0 + ENDIF + ENDIF + ENDIF + +C...Find product masses and minimum pT of process. + SQM3=0D0 + SQM4=0D0 + MINT(71)=0 + VINT(71)=CKIN(3) + VINT(80)=1D0 + IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN + NBW=0 + DO 110 I=1,2 + PMMN(I)=0D0 + IF(KFPR(ISUB,I).EQ.0) THEN + ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT. + & PARP(41)) THEN + IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2 + IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2 + ELSE + NBW=NBW+1 +C...This prevents SUSY/t particles from becoming too light. + KFLW=KFPR(ISUB,I) + IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN + KCW=PYCOMP(KFLW) + PMMN(I)=PMAS(KCW,1) + DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1 + IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN + PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+ + & PMAS(PYCOMP(KFDP(IDC,2)),1) + IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+ + & PMAS(PYCOMP(KFDP(IDC,3)),1) + PMMN(I)=MIN(PMMN(I),PMSUM) + ENDIF + 100 CONTINUE + ELSEIF(KFLW.EQ.6) THEN + PMMN(I)=PMAS(24,1)+PMAS(5,1) + ENDIF + ENDIF + 110 CONTINUE + IF(NBW.GE.1) THEN + CKIN41=CKIN(41) + CKIN43=CKIN(43) + CKIN(41)=MAX(PMMN(1),CKIN(41)) + CKIN(43)=MAX(PMMN(2),CKIN(43)) + CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4) + CKIN(41)=CKIN41 + CKIN(43)=CKIN43 + IF(MINT(51).EQ.1) THEN + WRITE(MSTU(11),5100) ISUB + MSUB(ISUB)=0 + GOTO 460 + ENDIF + SQM3=PQM3**2 + SQM4=PQM4**2 + ENDIF + IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1 + IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5)) + IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN + VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90) + ELSEIF(ISUB.EQ.96) THEN + VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90) + ENDIF + ENDIF + VINT(63)=SQM3 + VINT(64)=SQM4 + +C...Prepare for additional variable choices in 2 -> 3. + IF(ISTSB.EQ.5) THEN + VINT(201)=0D0 + IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1) + VINT(206)=VINT(201) + IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1) + VINT(204)=PMAS(23,1) + IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1) + IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1) + IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182 + & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) + & VINT(204)=VINT(201) + VINT(209)=VINT(204) + IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206) + ENDIF + +C...Number of points for each variable: tau, tau', y*, cos(theta-hat). + IPEAK7=0 + 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) THEN + NPTS(1)=NPTS(1)+1 + IPEAK7=1 + ENDIF + 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 + IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361 + & .AND.ISUB.LE.380)) THEN + DO 125 J=1,2 + COEFX(ISUB,J)=0D0 + 125 CONTINUE + ENDIF + 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(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN + MTAU=7 + ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN + MTAU=MTAU+1 + ENDIF + RTAU=0.5D0 +C...Special case when both resonances have same mass, +C...as is often the case in process 194. +c IF(MINT(72).GE.2) THEN +c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT. +c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN +c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN +c RTAU=0.4D0 +c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN +c RTAU=0.6D0 +c ENDIF +c ENDIF +c 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).GE.8) THEN + ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3 + ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/ + & GAMR3 + ENDIF + IF(IPEAK7.EQ.1) 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) THEN + IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN + IBIN=IBIN-1 + ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN + IBIN=3+2*MINT(72) + ENDIF + ENDIF + 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(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN + WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72)) + & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU) + ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN + WTMAT(IBIN,7)=WTMAT(IBIN,7) + & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU) + ENDIF + IF(MINT(72).EQ.3) THEN + WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7) + & +(ATAU1/ATAU8)/(TAU+TAUR3) + WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7) + & +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2) + 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) + WTRSAV(IBIN)=WTREL(IBIN) + 200 CONTINUE +C...Auxiliary vectors to record order of permutations + DO I=1,NBIN + IP(I) = I + IQ(I) = I + ENDDO + DO 230 IRED=1,NBIN-1 + MROW=IRED + RESMAX=ABS(WTREL(MROW)) +C...Find row with largest residual + DO JBIN=IRED+1,NBIN + IF(RESMAX.LT.ABS(WTREL(JBIN))) THEN + MROW=JBIN + RESMAX=ABS(WTREL(MROW)) + ENDIF + ENDDO + IF(RESMAX.LT.1D-20) THEN + MSOLV=0 + GOTO 260 + ENDIF + MCOL = IRED + AMAX = ABS(WTMAT(MROW,MCOL)) +C...Find column with largest entry + DO JBIN=IRED+1,NBIN + IF (AMAX.LT.ABS(WTMAT(MROW,JBIN))) THEN + MCOL = JBIN + AMAX = ABS(WTMAT(MROW,MCOL)) + ENDIF + ENDDO +C...Swap rows if necessary + IF(MROW.NE.IRED) THEN + DO JBIN=1,NBIN + TMPE=WTMAT(IRED,JBIN) + WTMAT(IRED,JBIN)=WTMAT(MROW,JBIN) + WTMAT(MROW,JBIN)=TMPE + ENDDO + TMPE=WTREL(IRED) + WTREL(IRED)=WTREL(MROW) + WTREL(MROW)=TMPE + MTMP=IQ(IRED) + IQ(IRED)=IQ(MROW) + IQ(MROW)=MTMP + ENDIF +C...Swap columns if necessary + IF(MCOL.NE.IRED) THEN + DO JBIN=1,NBIN + TMPE=WTMAT(JBIN,IRED) + WTMAT(JBIN,IRED)=WTMAT(JBIN,MCOL) + WTMAT(JBIN,MCOL)=TMPE + ENDDO + MTMP=IP(IRED) + IP(IRED)=IP(MCOL) + IP(MCOL)=MTMP + ENDIF +C...Begin eliminating equations + DO 220 IBIN=IRED+1,NBIN + IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN + MSOLV=0 + GOTO 260 + ENDIF +C RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED) + RQTU=WTMAT(IBIN,IRED) + RQTL=WTMAT(IRED,IRED) +C...Switch order of operations + WTREL(IBIN)=WTREL(IBIN)-RQTU* + $ (WTREL(IRED)/RQTL) + DO 210 ICOE=IRED,NBIN + WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)- + $ RQTU*(WTMAT(IRED,ICOE)/RQTL) + 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 + IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN + MSOLV=0 + GOTO 260 + ENDIF + COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED) + TEMPC(IRED)=COEFU(IRED) + 250 CONTINUE +C...Return to original order + DO IBIN=1,NBIN + MTMP=IP(IBIN) + COEFU(MTMP)=TEMPC(IBIN) + ENDDO + 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, + & WTRSAV(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) THEN + IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN + ICOF=7 + ENDIF + ENDIF + IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1 + IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN + COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN) + ELSE + COEF(ISUB,ICOF)=COEFO(IBIN) + ENDIF + 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 +C...Add extra headroom for UED + IF(ISUB.GT.310.AND.ISUB.LT.320) XSEC(ISUB,1)=XSEC(ISUB,1)*1.1D0 + IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)= + & WTGAGA*XSEC(ISUB,1) + 450 CONTINUE + IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)= + & PARP(174)*XSEC(ISUB,1) + IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1) + 460 CONTINUE + MINT(51)=0 + +C...Print summary table. + IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN + IF(MSTP(127).NE.1) THEN + WRITE(MSTU(11),5900) + CALL PYSTOP(1) + ELSE + WRITE(MSTU(11),6400) + MSTI(53)=1 + ENDIF + ENDIF + IF(MSTP(122).GE.1) THEN + WRITE(MSTU(11),6000) + WRITE(MSTU(11),6100) + DO 470 ISUB=1,500 + IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470 + IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470 + IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0) + & GOTO 470 + IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470 + IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13 + & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470 + IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470 + WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1) + 470 CONTINUE + WRITE(MSTU(11),6300) + ENDIF + +C...Format statements for maximization results. + 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ', + &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X, + &'cth',9X,'tau''',7X,'sigma') + 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ', + &'phase space.'/1X,'Process switched off!') + 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4) + 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ', + &'cross-section.'/1X,'Process switched off!') + 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4) + 5500 FORMAT(1X,1P,10D11.3) + 5600 FORMAT(1X,'Result for ',A4,':',9F9.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(23000,5),P(23000,5),V(23000,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) + COMMON/PYTCCO/COEFX(194:380,2) + COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/, + &/TCPARA/ +C...Local arrays. + DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2) + +C...Parameters and data used in elastic/diffractive treatment. + DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/, + &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/ + +C...Initial values, specifically for (first) semihard interaction. + MINT(10)=0 + MINT(17)=0 + MINT(18)=0 + VINT(143)=1D0 + VINT(144)=1D0 + VINT(157)=0D0 + VINT(158)=0D0 + MFAIL=0 + IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1 + ISUB=0 + ISTSB=0 + LOOP=0 + 100 LOOP=LOOP+1 + MINT(51)=0 + MINT(143)=1 + VINT(97)=1D0 + +C...Start by assuming incoming photon is entering subprocess. + IF(MINT(11).EQ.22) THEN + MINT(15)=22 + VINT(307)=VINT(3)**2 + ENDIF + IF(MINT(12).EQ.22) THEN + MINT(16)=22 + VINT(308)=VINT(4)**2 + ENDIF + MINT(103)=MINT(11) + MINT(104)=MINT(12) + +C...Choice of process type - first event of pileup. + INMULT=0 + IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN + ELSEIF(MINT(82).EQ.1) THEN + +C...For gamma-p or gamma-gamma first pick between alternatives. + IGA=0 + IF(MINT(121).GT.1) CALL PYSAVE(4,IGA) + MINT(122)=IGA + +C...For real gamma + gamma with different nature, flip at random. + IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND. + & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN + MINTSV=MINT(41) + MINT(41)=MINT(42) + MINT(42)=MINTSV + MINTSV=MINT(45) + MINT(45)=MINT(46) + MINT(46)=MINTSV + MINTSV=MINT(107) + MINT(107)=MINT(108) + MINT(108)=MINTSV + IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47) + ENDIF + +C...Pick process type, possibly by user process machinery. +C...(If the latter, also event will be picked here.) + IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN + CALL UPEVNT + CALL PYUPRE + ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN + CALL UPEVNT + CALL PYUPRE + ISUB=0 + 110 ISUB=ISUB+1 + IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND. + & ISUB.LT.500) GOTO 110 + ELSE + RSUB=XSEC(0,1)*PYR(0) + DO 120 I=1,500 + IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120 + ISUB=I + RSUB=RSUB-XSEC(I,1) + IF(RSUB.LE.0D0) GOTO 130 + 120 CONTINUE + 130 IF(ISUB.EQ.95) ISUB=96 + IF(ISUB.EQ.96) INMULT=1 + IF(ISET(ISUB).EQ.11) THEN + IDPRUP=KFPR(ISUB,2) + CALL UPEVNT + CALL PYUPRE + ENDIF + ENDIF + +C...Choice of inclusive process type - pileup events. + ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN + RSUB=VINT(131)*PYR(0) + ISUB=96 + IF(RSUB.GT.SIGT(0,0,5)) ISUB=94 + IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93 + IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92 + IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2)) + & ISUB=91 + IF(ISUB.EQ.96) INMULT=1 + ENDIF + +C...Choice of photon energy and flux factor inside lepton. + IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN + CALL PYGAGA(3,WTGAGA) + IF(ISUB.GE.131.AND.ISUB.LE.140) THEN + CKIN(3)=MAX(VINT(285),VINT(154)) + CKIN(1)=2D0*CKIN(3) + ENDIF +C...When necessary set direct/resolved photon by hand. + ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN + IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0 + IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0 + ENDIF + +C...Restrict direct*resolved processes to pTmin >= Q, +C...to avoid doublecounting with DIS. + IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN + IF(MINT(15).EQ.22) THEN + CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3))) + ELSE + CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4))) + ENDIF + CKIN(1)=2D0*CKIN(3) + ENDIF + +C...Set up for multiple interactions (may include impact parameter). + IF(INMULT.EQ.1) THEN + IF(MINT(35).LE.1) CALL PYMULT(2) + IF(MINT(35).GE.2) CALL PYMIGN(2) + ENDIF + +C...Loopback point for minimum bias in photon physics. + LOOP2=0 + 140 LOOP2=LOOP2+1 + IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143) + IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143) + IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1) + &NGEN(97,1)=NGEN(97,1)+MINT(143) + MINT(1)=ISUB + ISTSB=ISET(ISUB) + +C...Random choice of flavour for some SUSY processes. + IF(ISUB.GE.201.AND.ISUB.LE.301) THEN +C...~e_L ~nu_e or ~mu_L ~nu_mu. + IF(ISUB.EQ.210) THEN + KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0)) + KFPR(ISUB,2)=KFPR(ISUB,1)+1 +C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar). + ELSEIF(ISUB.EQ.213) THEN + KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0)) + KFPR(ISUB,2)=KFPR(ISUB,1) +C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b. + ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND. + & ISUB.NE.257) THEN + IF(ISUB.GE.258) THEN + RKF=4D0 + ELSE + RKF=5D0 + ENDIF + IF(MOD(ISUB,2).EQ.0) THEN + KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0)) + ELSE + KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0)) + ENDIF +C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c. + ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN + IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN + KSU1=KSUSY1 + KSU2=KSUSY1 + ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN + KSU1=KSUSY2 + KSU2=KSUSY2 + ELSEIF(PYR(0).LT.0.5D0) THEN + KSU1=KSUSY1 + KSU2=KSUSY2 + ELSE + KSU1=KSUSY2 + KSU2=KSUSY1 + ENDIF + KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0)) + KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0)) +C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c. + ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN + KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0)) + KFPR(ISUB,2)=KFPR(ISUB,1) + ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN + KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0)) + KFPR(ISUB,2)=KFPR(ISUB,1) +C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c. + ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN + IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN + KSU1=KSUSY1 + KSU2=KSUSY1 + ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN + KSU1=KSUSY2 + KSU2=KSUSY2 + ELSEIF(PYR(0).LT.0.5D0) THEN + KSU1=KSUSY1 + KSU2=KSUSY2 + ELSE + KSU1=KSUSY2 + KSU2=KSUSY1 + ENDIF + IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN + RKF=5D0 + ELSE + RKF=4D0 + ENDIF + KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0)) + ENDIF + ENDIF + +C...Random choice of flavours for some UED processes +c...The production processes can generate a doublet pair, +c...a singlet pair, or a doublet + singlet. + IF(ISUB.EQ.313)THEN +C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj + IF(PYR(0).LE.0.1)THEN + KFPR(ISUB,1)=5100001 + ELSE + KFPR(ISUB,1)=5100002 + ENDIF + KFPR(ISUB,2)=KFPR(ISUB,1) + ELSEIF(ISUB.EQ.314.OR.ISUB.EQ.315)THEN +C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar +C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar + IF(PYR(0).LE.0.1)THEN + KFPR(ISUB,1)=5100001 + ELSE + KFPR(ISUB,1)=5100002 + ENDIF + KFPR(ISUB,2)=-KFPR(ISUB,1) + ELSEIF(ISUB.EQ.316)THEN +C...qi + qbarj -> q*_Di + q*_Sbarj + IF(PYR(0).LE.0.5)THEN + KFPR(ISUB,1)=5100001 +c Changed from private pythia6410_ued code +c KFPR(ISUB,2)=-5010001 + KFPR(ISUB,2)=-6100002 + ELSE + KFPR(ISUB,1)=5100002 +c Changed from private pythia6410_ued code +c KFPR(ISUB,2)=-5010002 + KFPR(ISUB,2)=-6100001 + ENDIF + ELSEIF(ISUB.EQ.317)THEN +C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj + IF(PYR(0).LE.0.5)THEN + KFPR(ISUB,1)=5100001 + KFPR(ISUB,2)=-5100002 + ELSE + KFPR(ISUB,1)=5100002 + KFPR(ISUB,2)=-5100001 + ENDIF + ELSEIF(ISUB.EQ.318)THEN +C...qi + qj -> q*_Di + q*_Sj + IF(PYR(0).LE.0.5)THEN + KFPR(ISUB,1)=5100001 + KFPR(ISUB,2)=6100002 + ELSE + KFPR(ISUB,1)=5100002 + KFPR(ISUB,2)=6100001 + 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.481) THEN + KFR1=9900001 + ENDIF + CKMX=CKIN(2) + IF(CKMX.LE.0D0) CKMX=VINT(1) + KCR1=PYCOMP(KFR1) + IF(KCR1.EQ.0) KFR1=0 + IF(KFR1.NE.0) THEN + IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR. + & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0 + ENDIF + IF(KFR1.NE.0) THEN + TAUR1=PMAS(KCR1,1)**2/VINT(2) + GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2) + MINT(72)=1 + MINT(73)=KFR1 + VINT(73)=TAUR1 + VINT(74)=GAMR1 + ENDIF + KFR2=0 + KFR3=0 + IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR. + $(ISUB.GE.361.AND.ISUB.LE.380)) + $THEN + KFR2=23 + IF(ISUB.EQ.141) THEN + KCR2=PYCOMP(KFR2) + IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR. + & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN + KFR2=0 + ELSE + TAUR2=PMAS(KCR2,1)**2/VINT(2) + GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2) + MINT(72)=2 + MINT(74)=KFR2 + VINT(75)=TAUR2 + VINT(76)=GAMR2 + ENDIF +C...3 resonances at work: rho, omega, a + ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368) + & .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN + MINT(72)=IRES + IF(IRES.GE.1) THEN + VINT(73)=XMAS(1)**2/VINT(2) + VINT(74)=XMAS(1)*XWID(1)/VINT(2) + TAUR1=VINT(73) + GAMR1=VINT(74) + KFR1=1 + ENDIF + IF(IRES.GE.2) THEN + VINT(75)=XMAS(2)**2/VINT(2) + VINT(76)=XMAS(2)*XWID(2)/VINT(2) + TAUR2=VINT(75) + GAMR2=VINT(76) + KFR2=2 + ENDIF + IF(IRES.EQ.3) THEN + VINT(77)=XMAS(3)**2/VINT(2) + VINT(78)=XMAS(3)*XWID(3)/VINT(2) + TAUR3=VINT(77) + GAMR3=VINT(78) + KFR3=3 + ENDIF +C...Charged current: rho+- and a+- + ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN + MINT(72)=IRES + IF(JRES.GE.1) THEN + VINT(73)=YMAS(1)**2/VINT(2) + VINT(74)=YMAS(1)*YWID(1)/VINT(2) + KFR1=1 + TAUR1=VINT(73) + GAMR1=VINT(74) + ENDIF + IF(JRES.GE.2) THEN + VINT(75)=YMAS(2)**2/VINT(2) + VINT(76)=YMAS(2)*YWID(2)/VINT(2) + KFR2=2 + TAUR2=VINT(73) + GAMR2=VINT(74) + ENDIF + KFR3=0 + ENDIF + IF(ISUB.NE.141) THEN + IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN + + ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN + MINT(72)=2 + ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN + MINT(72)=2 + MINT(74)=KFR3 + VINT(75)=TAUR3 + VINT(76)=GAMR3 + ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN + MINT(72)=2 + MINT(73)=KFR2 + VINT(73)=TAUR2 + VINT(74)=GAMR2 + MINT(74)=KFR3 + VINT(75)=TAUR3 + VINT(76)=GAMR3 + ELSEIF(KFR1.NE.0) THEN + MINT(72)=1 + ELSEIF(KFR2.NE.0) THEN + MINT(72)=1 + MINT(73)=KFR2 + VINT(73)=TAUR2 + VINT(74)=GAMR2 + ELSEIF(KFR3.NE.0) THEN + MINT(72)=1 + MINT(73)=KFR3 + VINT(73)=TAUR3 + VINT(74)=GAMR3 + ELSE + MINT(72)=0 + ENDIF + ELSE + IF(KFR2.NE.0.AND.KFR1.NE.0) THEN + + 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 + ELSE + MINT(72)=0 + ENDIF + ENDIF + ENDIF + +C...Find product masses and minimum pT of process, +C...optionally with broadening according to a truncated Breit-Wigner. + VINT(63)=0D0 + VINT(64)=0D0 + MINT(71)=0 + VINT(71)=CKIN(3) + IF(MINT(82).GE.2) VINT(71)=0D0 + VINT(80)=1D0 + IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN + NBW=0 + DO 160 I=1,2 + PMMN(I)=0D0 + IF(KFPR(ISUB,I).EQ.0) THEN + ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT. + & PARP(41)) THEN + VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2 + ELSE + NBW=NBW+1 +C...This prevents SUSY/t particles from becoming too light. + KFLW=KFPR(ISUB,I) + IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN + KCW=PYCOMP(KFLW) + PMMN(I)=PMAS(KCW,1) + DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1 + IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN + PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+ + & PMAS(PYCOMP(KFDP(IDC,2)),1) + IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+ + & PMAS(PYCOMP(KFDP(IDC,3)),1) + PMMN(I)=MIN(PMMN(I),PMSUM) + ENDIF + 150 CONTINUE + ELSEIF(KFLW.EQ.6) THEN + PMMN(I)=PMAS(24,1)+PMAS(5,1) + ENDIF + ENDIF + 160 CONTINUE + IF(NBW.GE.1) THEN + CKIN41=CKIN(41) + CKIN43=CKIN(43) + CKIN(41)=MAX(PMMN(1),CKIN(41)) + CKIN(43)=MAX(PMMN(2),CKIN(43)) + CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4) + CKIN(41)=CKIN41 + CKIN(43)=CKIN43 + IF(MINT(51).EQ.1) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + IF(MFAIL.EQ.1) THEN + MSTI(61)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + VINT(63)=PQM3**2 + VINT(64)=PQM4**2 + ENDIF + IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1 + IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5)) + ENDIF + +C...Prepare for additional variable choices in 2 -> 3. + IF(ISTSB.EQ.5) THEN + VINT(201)=0D0 + IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1) + VINT(206)=VINT(201) + IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1) + VINT(204)=PMAS(23,1) + IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) + & VINT(204)=PMAS(24,1) + IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1) + IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR. + & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) + & VINT(204)=VINT(201) + VINT(209)=VINT(204) + IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206) + ENDIF + +C...Select incoming VDM particle (rho/omega/phi/J/psi). + IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND. + &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN + VRN=PYR(0)*SIGT(0,0,5) + IF(MINT(101).LE.1) THEN + I1MN=0 + I1MX=0 + ELSE + I1MN=1 + I1MX=MINT(101) + ENDIF + IF(MINT(102).LE.1) THEN + I2MN=0 + I2MX=0 + ELSE + I2MN=1 + I2MX=MINT(102) + ENDIF + DO 180 I1=I1MN,I1MX + KFV1=110*I1+3 + DO 170 I2=I2MN,I2MX + KFV2=110*I2+3 + VRN=VRN-SIGT(I1,I2,5) + IF(VRN.LE.0D0) GOTO 190 + 170 CONTINUE + 180 CONTINUE + 190 IF(MINT(101).GE.2) MINT(103)=KFV1 + IF(MINT(102).GE.2) MINT(104)=KFV2 + ENDIF + + IF(ISTSB.EQ.0) THEN +C...Elastic scattering or single or double diffractive scattering. + +C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass. + MINT(103)=MINT(11) + MINT(104)=MINT(12) + PMM(1)=VINT(3) + PMM(2)=VINT(4) + IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN + JJ=ISUB-90 + VRN=PYR(0)*SIGT(0,0,JJ) + IF(MINT(101).LE.1) THEN + I1MN=0 + I1MX=0 + ELSE + I1MN=1 + I1MX=MINT(101) + ENDIF + IF(MINT(102).LE.1) THEN + I2MN=0 + I2MX=0 + ELSE + I2MN=1 + I2MX=MINT(102) + ENDIF + DO 210 I1=I1MN,I1MX + KFV1=110*I1+3 + DO 200 I2=I2MN,I2MX + KFV2=110*I2+3 + VRN=VRN-SIGT(I1,I2,JJ) + IF(VRN.LE.0D0) GOTO 220 + 200 CONTINUE + 210 CONTINUE + 220 IF(MINT(101).GE.2) THEN + MINT(103)=KFV1 + PMM(1)=PYMASS(KFV1) + ENDIF + IF(MINT(102).GE.2) THEN + MINT(104)=KFV2 + PMM(2)=PYMASS(KFV2) + ENDIF + ENDIF + VINT(67)=PMM(1) + VINT(68)=PMM(2) + +C...Select mass for GVMD states (rejecting previous assignment). + Q0S=4D0*PARP(15)**2 + Q1S=4D0*VINT(154)**2 + LOOP3=0 + 230 LOOP3=LOOP3+1 + DO 240 JT=1,2 + IF(MINT(106+JT).EQ.3) THEN + PS=VINT(2+JT)**2 + PMM(JT)=SQRT((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 +C...Additional check to handle techni-processes with extra resonance +C....Only modify tau treatment + IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380)) + & THEN + IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3) + & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8 + IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3) + & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7) + & +COEFX(ISUB,1)) MTAU=9 + ENDIF + CALL PYKMAP(1,MTAU,PYR(0)) + +C...2 -> 3, 4 processes: +C...Choose tau' according to h4(tau,tau')/tau', where +C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' + +C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1. + IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN + CALL PYKLIM(4) + IF(MINT(51).NE.0) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + IF(MFAIL.EQ.1) THEN + MSTI(61)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + RTAUP=PYR(0) + MTAUP=1 + IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2 + IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3 + CALL PYKMAP(4,MTAUP,PYR(0)) + ENDIF + +C...Choose y* according to h2(y*), where +C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) + +C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) + +C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min, +C...and c1 + c2 + c3 + c4 + c5 = 1. + CALL PYKLIM(2) + IF(MINT(51).NE.0) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + IF(MFAIL.EQ.1) THEN + MSTI(61)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + RYST=PYR(0) + MYST=1 + IF(RYST.GT.COEF(ISUB,8)) MYST=2 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+ + & COEF(ISUB,11)) MYST=5 + CALL PYKMAP(2,MYST,PYR(0)) + +C...2 -> 2 processes: +C...Choose cos(theta-hat) (cth) according to h3(cth), where +C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) + +C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2, +C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products), +C...and c0 + c1 + c2 + c3 + c4 = 1. + CALL PYKLIM(3) + IF(MINT(51).NE.0) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + IF(MFAIL.EQ.1) THEN + MSTI(61)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN + RCTH=PYR(0) + MCTH=1 + IF(RCTH.GT.COEF(ISUB,13)) MCTH=2 + IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3 + IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4 + IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+ + & COEF(ISUB,16)) MCTH=5 + CALL PYKMAP(3,MCTH,PYR(0)) + ENDIF + +C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing. + IF(ISTSB.EQ.5) THEN + CALL PYKMAP(5,0,0D0) + IF(MINT(51).NE.0) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + IF(MFAIL.EQ.1) THEN + MSTI(61)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + ENDIF + +C...DIS as f + gamma* -> f process: set dummy values. + ELSEIF(ISTSB.EQ.8) THEN + VINT(21)=0.9D0 + VINT(22)=0D0 + VINT(23)=0D0 + VINT(47)=0D0 + VINT(48)=0D0 + +C...Low-pT or multiple interactions (first semihard interaction). + ELSEIF(ISTSB.EQ.9) THEN + IF(MINT(35).LE.1) CALL PYMULT(3) + IF(MINT(35).GE.2) CALL PYMIGN(3) + ISUB=MINT(1) + +C...Study user-defined process: kinematics plus weight. + ELSEIF(ISTSB.EQ.11) THEN + IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL + & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process') + MSTI(51)=0 + IF(NUP.LE.0) THEN + MINT(51)=2 + MSTI(51)=1 + IF(MINT(82).EQ.1) THEN + NGEN(0,1)=NGEN(0,1)-1 + NGEN(ISUB,1)=NGEN(ISUB,1)-1 + ENDIF + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + RETURN + ENDIF + +C...Extract cross section event weight. + IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN + SIGS=1D-9*XWGTUP + ELSE + SIGS=1D-9*XSECUP(KFPR(ISUB,1)) + ENDIF + IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN + VINT(97)=SIGN(1D0,XWGTUP) + ELSE + VINT(97)=1D-9*XWGTUP + ENDIF + +C...Construct 'trivial' kinematical variables needed. + KFL1=IDUP(1) + KFL2=IDUP(2) + VINT(41)=PUP(4,1)/EBMUP(1) + VINT(42)=PUP(4,2)/EBMUP(2) + IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN + CALL PYERRM(9,'(PYRAND:) x > 1 in external event '// + & '(listing follows):') + CALL PYLIST(7) + ENDIF + 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 + + IF(ISTSB.LE.10) THEN +C... If internal process, call PYSIGH + CALL PYSIGH(NCHN,SIGS) + ELSE +C... If external process, still have to set MI starting scale + IF (MSTP(86).EQ.1) THEN +C... Limit phase space by xT2 of hard interaction +C... (gives undercounting of MI when ext proc != dijets) + XT2GMX = VINT(25) + ELSE +C... All accessible phase space allowed +C... (gives double counting of MI when ext proc = dijets) + XT2GMX = (1D0-VINT(41))*(1D0-VINT(42)) + ENDIF + VINT(62)=0.25D0*XT2GMX*VINT(2) + VINT(61)=SQRT(MAX(0D0,VINT(62))) + ENDIF + + SIGSOR=SIGS + SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316) + +C...Multiply cross section by lepton -> photon flux factor. + IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN + SIGS=WTGAGA*SIGS + DO 290 ICHN=1,NCHN + SIGH(ICHN)=WTGAGA*SIGH(ICHN) + 290 CONTINUE + SIGLPT=WTGAGA*SIGLPT + ENDIF + +C...Multiply cross-section by user-defined weights. + IF(MSTP(173).EQ.1) THEN + SIGS=PARP(173)*SIGS + DO 300 ICHN=1,NCHN + SIGH(ICHN)=PARP(173)*SIGH(ICHN) + 300 CONTINUE + SIGLPT=PARP(173)*SIGLPT + ENDIF + WTXS=1D0 + SIGSWT=SIGS + VINT(99)=1D0 + VINT(100)=1D0 + IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN + IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+ + & MSUB(95).EQ.0) CALL PYEVWT(WTXS) + SIGSWT=WTXS*SIGS + VINT(99)=WTXS + IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS + ENDIF + +C...Calculations for Monte Carlo estimate of all cross-sections. + IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN + IF(MSTP(142).LE.1) THEN + XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS + ELSE + XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT + ENDIF + ELSEIF(MINT(82).EQ.1) THEN + XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS + ENDIF + IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND. + &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT + +C...Multiple interactions: store results of cross-section calculation. + IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN + VINT(153)=SIGSOR + IF(MINT(35).LE.1) CALL PYMULT(4) + IF(MINT(35).GE.2) CALL PYMIGN(4) + ENDIF + +C...Ratio of actual to maximum cross section. + IF(ISTSB.NE.11) THEN + VIOL=SIGSWT/XSEC(ISUB,1) + IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174) + ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN + VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1)) + ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN + VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1))) + ELSE + VIOL=1D0 + ENDIF + +C...Check that weight not negative. + IF(MSTP(123).LE.0) THEN + IF(VIOL.LT.-1D-3) THEN + WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1 + IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21), + & VINT(22),VINT(23),VINT(26) + CALL PYSTOP(2) + ENDIF + ELSE + IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN + VINT(109)=VIOL + IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1 + IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21), + & VINT(22),VINT(23),VINT(26) + ENDIF + ENDIF + +C...Weighting using estimate of maximum of differential cross-section. + RATND=1D0 + IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN + IF(VIOL.LT.PYR(0)) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0 + GOTO 100 + ENDIF + ELSEIF(MFAIL.EQ.0) THEN + RATND=SIGLPT/XSEC(95,1) + VIOL=VIOL/RATND + IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN + IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND. + & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143) + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + ISUB=0 + GOTO 100 + ENDIF + IF(VIOL.LT.PYR(0)) THEN + GOTO 140 + ENDIF + ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN + IF(VIOL.LT.PYR(0)) THEN + MSTI(61)=1 + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + RETURN + ENDIF + ELSE + RATND=SIGLPT/XSEC(95,1) + IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN + MSTI(61)=1 + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + RETURN + ENDIF + VIOL=VIOL/RATND + IF(VIOL.LT.PYR(0)) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + GOTO 100 + ENDIF + ENDIF + +C...Check for possible violation of estimated maximum of differential +C...cross-section used in weighting. + IF(MSTP(123).LE.0) THEN + IF(VIOL.GT.1D0) THEN + WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1 + IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21), + & VINT(22),VINT(23),VINT(26) + CALL PYSTOP(2) + ENDIF + ELSEIF(MSTP(123).EQ.1) THEN + IF(VIOL.GT.VINT(108)) THEN + VINT(108)=VIOL + IF(VIOL.GT.1.0001D0) THEN + MINT(10)=1 + WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1 + IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21), + & VINT(22),VINT(23),VINT(26) + ENDIF + ENDIF + ELSEIF(VIOL.GT.VINT(108)) THEN + VINT(108)=VIOL + IF(VIOL.GT.1D0) THEN + MINT(10)=1 + IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1 + IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2)) + & THEN + XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1)) + IF(KFPR(ISUB,1).LE.9) THEN + IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1), + & XMAXUP(KFPR(ISUB,1)) + ELSEIF(KFPR(ISUB,1).LE.99) THEN + IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1), + & XMAXUP(KFPR(ISUB,1)) + ELSE + IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1), + & XMAXUP(KFPR(ISUB,1)) + ENDIF + ENDIF + IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN + XDIF=XSEC(ISUB,1)*(VIOL-1D0) + XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF + IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96)) + & XSEC(0,1)=XSEC(0,1)+XDIF + IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21), + & VINT(22),VINT(23),VINT(26) + IF(ISUB.LE.9) THEN + IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1) + ELSEIF(ISUB.LE.99) THEN + IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1) + ELSE + IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1) + ENDIF + ENDIF + VINT(108)=1D0 + ENDIF + ENDIF + +C...Multiple interactions: choose impact parameter (if not already done). + IF(MINT(39).EQ.0) VINT(148)=1D0 + IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND. + &MSTP(82).GE.3) THEN + IF(MINT(35).LE.1) CALL PYMULT(5) + IF(MINT(35).GE.2) CALL PYMIGN(5) + IF(VINT(150).LT.PYR(0)) THEN + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + IF(MFAIL.EQ.1) THEN + MSTI(61)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + ENDIF + IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1 + IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN + IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143) + IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1 + ENDIF + IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1 + +C...Choose flavour of reacting partons (and subprocess). + IF(ISTSB.GE.11) GOTO 320 + RSIGS=SIGS*PYR(0) + QT2=VINT(48) + RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)* + &(VINT(1)/PARP(89))**PARP(90))**2))**2) + IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR. + &PYR(0).GT.RQQBAR)) THEN + DO 310 ICHN=1,NCHN + KFL1=ISIG(ICHN,1) + KFL2=ISIG(ICHN,2) + MINT(2)=ISIG(ICHN,3) + RSIGS=RSIGS-SIGH(ICHN) + IF(RSIGS.LE.0D0) GOTO 320 + 310 CONTINUE + +C...Multiple interactions: choose qqbar preferentially at small pT. + ELSEIF(ISUB.EQ.96) THEN + MINT(105)=MINT(103) + MINT(109)=MINT(107) + CALL PYSPLI(MINT(11),21,KFL1,KFLDUM) + MINT(105)=MINT(104) + MINT(109)=MINT(108) + CALL PYSPLI(MINT(12),21,KFL2,KFLDUM) + MINT(1)=11 + MINT(2)=1 + IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2 + +C...Low-pT: choose string drawing configuration. + ELSE + KFL1=21 + KFL2=21 + RSIGS=6D0*PYR(0) + MINT(2)=1 + IF(RSIGS.GT.1D0) MINT(2)=2 + IF(RSIGS.GT.2D0) MINT(2)=3 + ENDIF + +C...Reassign QCD process. Partons before initial state radiation. + 320 IF(MINT(2).GT.10) THEN + MINT(1)=MINT(2)/10 + MINT(2)=MOD(MINT(2),10) + ENDIF + IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)= + &NGEN(MINT(1),2)+1 + MINT(15)=KFL1 + MINT(16)=KFL2 + MINT(13)=MINT(15) + MINT(14)=MINT(16) + VINT(141)=VINT(41) + VINT(142)=VINT(42) + VINT(151)=0D0 + VINT(152)=0D0 + +C...Calculate x value of photon for parton inside photon inside e. + DO 350 JT=1,2 + MINT(18+JT)=0 + VINT(154+JT)=0D0 + MSPLI=0 + IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1 + IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1 + IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1 + IF(MSPLI.EQ.2) THEN + KFLH=MINT(14+JT) + XHRD=VINT(140+JT) + Q2HRD=VINT(54) + MINT(105)=MINT(102+JT) + MINT(109)=MINT(106+JT) + VINT(120)=VINT(2+JT) + IF(MSTP(57).LE.1) THEN + CALL PYPDFU(22,XHRD,Q2HRD,XPQ) + ELSE + CALL PYPDFL(22,XHRD,Q2HRD,XPQ) + ENDIF + WTMX=4D0*XPQ(KFLH) + IF(MSTP(13).EQ.2) THEN + Q2PMS=Q2HRD/PMAS(11,1)**2 + WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2)) + ENDIF + 330 XE=XHRD**PYR(0) + XG=MIN(1D0-1D-10,XHRD/XE) + IF(MSTP(57).LE.1) THEN + CALL PYPDFU(22,XG,Q2HRD,XPQ) + ELSE + CALL PYPDFL(22,XG,Q2HRD,XPQ) + ENDIF + WT=(1D0+(1D0-XE)**2)*XPQ(KFLH) + IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2)) + IF(WT.LT.PYR(0)*WTMX) GOTO 330 + MINT(18+JT)=1 + VINT(154+JT)=XE + DO 340 KFLS=-25,25 + XSFX(JT,KFLS)=XPQ(KFLS) + 340 CONTINUE + ENDIF + 350 CONTINUE + +C...Pick scale where photon is resolved. + Q0S=PARP(15)**2 + Q1S=VINT(154)**2 + VINT(283)=0D0 + IF(MINT(107).EQ.3) THEN + IF(MSTP(66).EQ.1) THEN + VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0) + ELSEIF(MSTP(66).EQ.2) THEN + PS=VINT(3)**2 + Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* + & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) + Q2INT=SQRT(Q0S*Q2EFF) + VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0) + ELSEIF(MSTP(66).EQ.3) THEN + VINT(283)=Q0S*(Q1S/Q0S)**PYR(0) + ELSEIF(MSTP(66).GE.4) THEN + PS=0.25D0*VINT(3)**2 + VINT(283)=(Q0S+PS)*(Q1S+PS)/ + & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS + ENDIF + ENDIF + VINT(284)=0D0 + IF(MINT(108).EQ.3) THEN + IF(MSTP(66).EQ.1) THEN + VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0) + ELSEIF(MSTP(66).EQ.2) THEN + PS=VINT(4)**2 + Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* + & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) + Q2INT=SQRT(Q0S*Q2EFF) + VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0) + ELSEIF(MSTP(66).EQ.3) THEN + VINT(284)=Q0S*(Q1S/Q0S)**PYR(0) + ELSEIF(MSTP(66).GE.4) THEN + PS=0.25D0*VINT(4)**2 + VINT(284)=(Q0S+PS)*(Q1S+PS)/ + & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS + ENDIF + ENDIF + IF(MINT(121).GT.1) CALL PYSAVE(2,IGA) + +C...Format statements for differential cross-section maximum violations. + 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X, + &'in event',1X,I7,'D0'/1X,'Execution stopped!') + 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P, + &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3) + 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X, + &'in event',1X,I7) + 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X, + &'in event',1X,I7,'D0'/1X,'Execution stopped!') + 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X, + &'in event',1X,I7) + 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3) + 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3) + 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3) + 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3) + 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3) + 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3) + + RETURN + END + +C********************************************************************* + +C...PYSCAT +C...Finds outgoing flavours and event type; sets up the kinematics +C...and colour flow of the hard scattering + + SUBROUTINE PYSCAT + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Parameter statement for maximum size of showers. + PARAMETER (MAXNUR=1000) + +C...User process event common block. + INTEGER MAXNUP + PARAMETER (MAXNUP=500) + INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP + DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP + COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), + &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), + &VTIMUP(MAXNUP),SPINUP(MAXNUP) + SAVE /HEPEUP/ + +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYPUED/IUED(0:99),RUED(0:99) + SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/, + &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/, + &/PYTCSM/,/PYPUED/ +C...Local arrays and saved variables + DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2), + &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100) + INTEGER IOKFLA(6),IIFLAV +C...UED related declarations: +C...equivalences between ordered particles (451->475) +C...and UED particle code (5 000 000 + id) + DIMENSION IUEDEQ(475),MUED(2) + DATA (IUEDEQ(I),I=451,475)/ + & 6100001,6100002,6100003,6100004,6100005,6100006, + & 5100001,5100002,5100003,5100004,5100005,5100006, + & 6100011,6100013,6100015, + & 5100012,5100011,5100014,5100013,5100016,5100015, + & 5100021,5100022,5100023,5100024/ + 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 + VINT(J)=VINTSV(J) + 100 CONTINUE + ENDIF + +C...Convert H' or A process into equivalent H one + IHIGG=1 + KFHIGG=25 + IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND. + &ISUB.LE.190)) THEN + IHIGG=2 + IF(MOD(ISUB-1,10).GE.5) IHIGG=3 + KFHIGG=33+IHIGG + IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3 + IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102 + IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103 + IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24 + IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26 + IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123 + IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124 + IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121 + IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122 + IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111 + IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112 + IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113 + ENDIF + + IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1) + +C...Convert bottomonium process into equivalent charmonium ones. + IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40 + +C...Choice of subprocess, number of documentation lines + IDOC=6+ISET(ISUB) + IF(ISUB.EQ.95) IDOC=8 + IF(ISET(ISUB).EQ.5) IDOC=9 + IF(ISET(ISUB).EQ.11) IDOC=4+NUP + MINT(3)=IDOC-6 + IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2 + MINT(4)=IDOC + IPU1=MINT(84)+1 + IPU2=MINT(84)+2 + IPU3=MINT(84)+3 + IPU4=MINT(84)+4 + IPU5=MINT(84)+5 + IPU6=MINT(84)+6 + +C...Reset K, P and V vectors. Store incoming particles + DO 120 JT=1,MSTP(126)+100 + I=MINT(83)+JT + IF(I.GT.MSTU(4)) GOTO 120 + DO 110 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 110 CONTINUE + 120 CONTINUE + DO 140 JT=1,2 + I=MINT(83)+JT + K(I,1)=21 + K(I,2)=MINT(10+JT) + DO 130 J=1,5 + P(I,J)=VINT(285+5*JT+J) + 130 CONTINUE + 140 CONTINUE + MINT(6)=2 + KFRES=0 + +C...Store incoming partons in their CM-frame. Save pdf value. + SH=VINT(44) + SHR=SQRT(SH) + SHP=VINT(26)*VINT(2) + SHPR=SQRT(SHP) + SHUSER=SHR + IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR + DO 150 JT=1,2 + I=MINT(84)+JT + K(I,1)=14 + K(I,2)=MINT(14+JT) + K(I,3)=MINT(83)+2+JT + P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1) + P(I,4)=0.5D0*SHUSER + IF(MINT(14+JT).GE.-40.AND.MINT(14+JT).LE.40) THEN + VINT(38+JT)=XSFX(JT,MINT(14+JT)) + ELSE + VINT(38+JT)=1D0 + ENDIF + 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.EQ.314.OR.ISUB.EQ.319.OR.ISUB.EQ.316.OR. + &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN + IGLGA=21 + IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22 + CALL PYWIDT(IGLGA,SH,WDTP,WDTE) + 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0) + DO 190 I=1,MDCY(IGLGA,3) + KFLF=KFDP(I+MDCY(IGLGA,2)-1,1) + RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4)) + IF(RKFL.LE.0D0) GOTO 200 + 190 CONTINUE + 200 CONTINUE + IF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319 + & .OR.ISUB.EQ.316).AND.MINT(2).LE.2) THEN + IF(KFLF.GE.4) GOTO 180 + ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319. + & OR.ISUB.EQ.316).AND.MINT(2).LE.4) THEN + KFLF=4 + MINT(2)=MINT(2)-2 + ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319. + & OR.ISUB.EQ.316) THEN + KFLF=5 + MINT(2)=MINT(2)-4 + ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2 + & .AND.IABS(KFLF).GE.3) THEN + FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/ + & VINT(44)**2 + FACCIB=VINT(46)**2/RTCM(41)**4 + IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180 + ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN + KFLF=5 + MINT(2)=1 + ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN + IF(KFLF.EQ.5) GOTO 180 + ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN + IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180 + ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN + IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180 + ENDIF + ENDIF + +C...Final state flavours and colour flow: default values + JS=1 + MINT(21)=MINT(15) + MINT(22)=MINT(16) + MINT(23)=0 + MINT(24)=0 + KCC=20 + KCS=ISIGN(1,MINT(15)) + + IF(ISET(ISUB).EQ.11) THEN +C...User-defined processes: find products + MINT(3)=0 + DO 210 IUP=3,NUP + IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN + ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN + MINT(21+IUP)=IDUP(IUP) + ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR. + & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN + ELSEIF(IDUP(IUP).EQ.0) THEN + ELSE + MINT(3)=MINT(3)+1 + IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP) + ENDIF + 210 CONTINUE + + ELSEIF(ISUB.LE.10) THEN + IF(ISUB.EQ.1) THEN +C...f + fbar -> gamma*/Z0 + KFRES=23 + + ELSEIF(ISUB.EQ.2) THEN +C...f + fbar' -> W+/- + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + KFRES=ISIGN(24,KCH1+KCH2) + + ELSEIF(ISUB.EQ.3) THEN +C...f + fbar -> h0 (or H0, or A0) + KFRES=KFHIGG + + ELSEIF(ISUB.EQ.4) THEN +C...gamma + W+/- -> W+/- + + ELSEIF(ISUB.EQ.5) THEN +C...Z0 + Z0 -> h0 + XH=SH/SHP + MINT(21)=MINT(15) + MINT(22)=MINT(16) + PMQ(1)=PYMASS(MINT(21)) + PMQ(2)=PYMASS(MINT(22)) + 220 JT=INT(1.5D0+PYR(0)) + ZMIN=2D0*PMQ(JT)/SHPR + ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ + & (SHPR*(SHPR-PMQ(3-JT))) + ZMAX=MIN(1D0-XH,ZMAX) + Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) + IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. + & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220 + SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 220 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) + CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) + Z(3-JT)=1D0-XH/(1D0-Z(JT)) + SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 220 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) + CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) + PHIR=PARU(2)*PYR(0) + CPHI=COS(PHIR) + ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* + & SQRT(1D0-CTHE(2)**2)*CPHI + Z1=2D0-Z(JT) + Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) + Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP + Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* + & PMQ(3-JT)**2/SHP)) + ZMIN=2D0*PMQ(3-JT)/SHPR + ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) + ZMAX=MIN(1D0-XH,ZMAX) + IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220 + KCC=22 + KFRES=25 + + ELSEIF(ISUB.EQ.6) THEN +C...Z0 + W+/- -> W+/- + + ELSEIF(ISUB.EQ.7) THEN +C...W+ + W- -> Z0 + + ELSEIF(ISUB.EQ.8) THEN +C...W+ + W- -> h0 + XH=SH/SHP + 230 DO 260 JT=1,2 + I=MINT(14+JT) + IA=IABS(I) + IF(IA.LE.10) THEN + RVCKM=VINT(180+I)*PYR(0) + DO 240 J=1,MSTP(1) + IB=2*J-1+MOD(IA,2) + IPM=(5-ISIGN(1,I))/2 + IDC=J+MDCY(IA,2)+2 + IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240 + MINT(20+JT)=ISIGN(IB,I) + RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) + IF(RVCKM.LE.0D0) GOTO 250 + 240 CONTINUE + ELSE + IB=2*((IA+1)/2)-1+MOD(IA,2) + MINT(20+JT)=ISIGN(IB,I) + ENDIF + 250 PMQ(JT)=PYMASS(MINT(20+JT)) + 260 CONTINUE + JT=INT(1.5D0+PYR(0)) + ZMIN=2D0*PMQ(JT)/SHPR + ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ + & (SHPR*(SHPR-PMQ(3-JT))) + ZMAX=MIN(1D0-XH,ZMAX) + IF(ZMIN.GE.ZMAX) GOTO 230 + Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) + IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. + & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230 + SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 230 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) + CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) + Z(3-JT)=1D0-XH/(1D0-Z(JT)) + SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 230 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) + CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) + PHIR=PARU(2)*PYR(0) + CPHI=COS(PHIR) + ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* + & SQRT(1D0-CTHE(2)**2)*CPHI + Z1=2D0-Z(JT) + Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) + Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP + Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* + & PMQ(3-JT)**2/SHP)) + ZMIN=2D0*PMQ(3-JT)/SHPR + ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) + ZMAX=MIN(1D0-XH,ZMAX) + IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230 + KCC=22 + KFRES=25 + + ELSEIF(ISUB.EQ.10) THEN +C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2 + IF(MINT(2).EQ.1) THEN + KCC=22 + ELSE +C...W exchange: need to mix flavours according to CKM matrix + DO 280 JT=1,2 + I=MINT(14+JT) + IA=IABS(I) + IF(IA.LE.10) THEN + RVCKM=VINT(180+I)*PYR(0) + DO 270 J=1,MSTP(1) + IB=2*J-1+MOD(IA,2) + IPM=(5-ISIGN(1,I))/2 + IDC=J+MDCY(IA,2)+2 + IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270 + MINT(20+JT)=ISIGN(IB,I) + RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) + IF(RVCKM.LE.0D0) GOTO 280 + 270 CONTINUE + ELSE + IB=2*((IA+1)/2)-1+MOD(IA,2) + MINT(20+JT)=ISIGN(IB,I) + ENDIF + 280 CONTINUE + KCC=22 + ENDIF + ENDIF + + ELSEIF(ISUB.LE.20) THEN + IF(ISUB.EQ.11) THEN +C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2 + KCC=MINT(2) + IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 + + ELSEIF(ISUB.EQ.12) THEN +C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2 + MINT(21)=ISIGN(KFLF,MINT(15)) + MINT(22)=-MINT(21) + KCC=4 + + ELSEIF(ISUB.EQ.13) THEN +C...f + fbar -> g + g; th arbitrary + MINT(21)=21 + MINT(22)=21 + KCC=MINT(2)+4 + + ELSEIF(ISUB.EQ.14) THEN +C...f + fbar -> g + gamma; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=21 + MINT(23-JS)=22 + KCC=17+JS + + ELSEIF(ISUB.EQ.15) THEN +C...f + fbar -> g + Z0; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=21 + MINT(23-JS)=23 + KCC=17+JS + + ELSEIF(ISUB.EQ.16) THEN +C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2 + MINT(20+JS)=21 + MINT(23-JS)=ISIGN(24,KCH1+KCH2) + KCC=17+JS + + ELSEIF(ISUB.EQ.17) THEN +C...f + fbar -> g + h0; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=21 + MINT(23-JS)=25 + KCC=17+JS + + ELSEIF(ISUB.EQ.18) THEN +C...f + fbar -> gamma + gamma; th arbitrary + MINT(21)=22 + MINT(22)=22 + + ELSEIF(ISUB.EQ.19) THEN +C...f + fbar -> gamma + Z0; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=22 + MINT(23-JS)=23 + + ELSEIF(ISUB.EQ.20) THEN +C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or +C...(p(fbar')-p(W+))**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2 + MINT(20+JS)=22 + MINT(23-JS)=ISIGN(24,KCH1+KCH2) + ENDIF + + ELSEIF(ISUB.LE.30) THEN + IF(ISUB.EQ.21) THEN +C...f + fbar -> gamma + h0; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=22 + MINT(23-JS)=25 + + ELSEIF(ISUB.EQ.22) THEN +C...f + fbar -> Z0 + Z0; th arbitrary + MINT(21)=23 + MINT(22)=23 + + ELSEIF(ISUB.EQ.23) THEN +C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2 + MINT(20+JS)=23 + MINT(23-JS)=ISIGN(24,KCH1+KCH2) + + ELSEIF(ISUB.EQ.24) THEN +C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=23 + MINT(23-JS)=KFHIGG + + ELSEIF(ISUB.EQ.25) THEN +C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2 + MINT(21)=-ISIGN(24,MINT(15)) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.26) THEN +C...f + fbar' -> W+/- + h0 (or H0, or A0); +C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 + MINT(20+JS)=ISIGN(24,KCH1+KCH2) + MINT(23-JS)=KFHIGG + + ELSEIF(ISUB.EQ.27) THEN +C...f + fbar -> h0 + h0 + + ELSEIF(ISUB.EQ.28) THEN +C...f + g -> f + g; th = (p(f)-p(f))**2 + IF(MINT(15).EQ.21) JS=2 + KCC=MINT(2)+6 + IF(MINT(15).EQ.21) KCC=KCC+2 + IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15)) + IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16)) + + ELSEIF(ISUB.EQ.29) THEN +C...f + g -> f + gamma; th = (p(f)-p(f))**2 + IF(MINT(15).EQ.21) JS=2 + MINT(23-JS)=22 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.30) THEN +C...f + g -> f + Z0; th = (p(f)-p(f))**2 + IF(MINT(15).EQ.21) JS=2 + MINT(23-JS)=23 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + ENDIF + + ELSEIF(ISUB.LE.40) THEN + IF(ISUB.EQ.31) THEN +C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f' + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I) + RVCKM=VINT(180+I)*PYR(0) + DO 290 J=1,MSTP(1) + IB=2*J-1+MOD(IA,2) + IPM=(5-ISIGN(1,I))/2 + IDC=J+MDCY(IA,2)+2 + IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290 + MINT(20+JS)=ISIGN(IB,I) + RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) + IF(RVCKM.LE.0D0) GOTO 300 + 290 CONTINUE + 300 KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.32) THEN +C...f + g -> f + h0; th = (p(f)-p(f))**2 + IF(MINT(15).EQ.21) JS=2 + MINT(23-JS)=25 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.33) THEN +C...f + gamma -> f + g; th=(p(f)-p(f))**2 + IF(MINT(15).EQ.22) JS=2 + MINT(23-JS)=21 + KCC=24+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.34) THEN +C...f + gamma -> f + gamma; th=(p(f)-p(f))**2 + IF(MINT(15).EQ.22) JS=2 + KCC=22 + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.35) THEN +C...f + gamma -> f + Z0; th=(p(f)-p(f))**2 + IF(MINT(15).EQ.22) JS=2 + MINT(23-JS)=23 + KCC=22 + + ELSEIF(ISUB.EQ.36) THEN +C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2 + IF(MINT(15).EQ.22) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I) + IF(IA.LE.10) THEN + RVCKM=VINT(180+I)*PYR(0) + DO 310 J=1,MSTP(1) + IB=2*J-1+MOD(IA,2) + IPM=(5-ISIGN(1,I))/2 + IDC=J+MDCY(IA,2)+2 + IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310 + MINT(20+JS)=ISIGN(IB,I) + RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) + IF(RVCKM.LE.0D0) GOTO 320 + 310 CONTINUE + ELSE + IB=2*((IA+1)/2)-1+MOD(IA,2) + MINT(20+JS)=ISIGN(IB,I) + ENDIF + 320 KCC=22 + + ELSEIF(ISUB.EQ.37) THEN +C...f + gamma -> f + h0 + + ELSEIF(ISUB.EQ.38) THEN +C...f + Z0 -> f + g + + ELSEIF(ISUB.EQ.39) THEN +C...f + Z0 -> f + gamma + + ELSEIF(ISUB.EQ.40) THEN +C...f + Z0 -> f + Z0 + ENDIF + + ELSEIF(ISUB.LE.50) THEN + IF(ISUB.EQ.41) THEN +C...f + Z0 -> f' + W+/- + + ELSEIF(ISUB.EQ.42) THEN +C...f + Z0 -> f + h0 + + ELSEIF(ISUB.EQ.43) THEN +C...f + W+/- -> f' + g + + ELSEIF(ISUB.EQ.44) THEN +C...f + W+/- -> f' + gamma + + ELSEIF(ISUB.EQ.45) THEN +C...f + W+/- -> f' + Z0 + + ELSEIF(ISUB.EQ.46) THEN +C...f + W+/- -> f' + W+/- + + ELSEIF(ISUB.EQ.47) THEN +C...f + W+/- -> f' + h0 + + ELSEIF(ISUB.EQ.48) THEN +C...f + h0 -> f + g + + ELSEIF(ISUB.EQ.49) THEN +C...f + h0 -> f + gamma + + ELSEIF(ISUB.EQ.50) THEN +C...f + h0 -> f + Z0 + ENDIF + + ELSEIF(ISUB.LE.60) THEN + IF(ISUB.EQ.51) THEN +C...f + h0 -> f' + W+/- + + ELSEIF(ISUB.EQ.52) THEN +C...f + h0 -> f + h0 + + ELSEIF(ISUB.EQ.53) THEN +C...g + g -> f + fbar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFLF,KCS) + MINT(22)=-MINT(21) + KCC=MINT(2)+10 + + ELSEIF(ISUB.EQ.54) THEN +C...g + gamma -> f + fbar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFLF,KCS) + MINT(22)=-MINT(21) + KCC=27 + IF(MINT(16).EQ.21) KCC=28 + + ELSEIF(ISUB.EQ.55) THEN +C...g + Z0 -> f + fbar + + ELSEIF(ISUB.EQ.56) THEN +C...g + W+/- -> f + fbar' + + ELSEIF(ISUB.EQ.57) THEN +C...g + h0 -> f + fbar + + ELSEIF(ISUB.EQ.58) THEN +C...gamma + gamma -> f + fbar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFLF,KCS) + MINT(22)=-MINT(21) + KCC=21 + + ELSEIF(ISUB.EQ.59) THEN +C...gamma + Z0 -> f + fbar + + ELSEIF(ISUB.EQ.60) THEN +C...gamma + W+/- -> f + fbar' + ENDIF + + ELSEIF(ISUB.LE.70) THEN + IF(ISUB.EQ.61) THEN +C...gamma + h0 -> f + fbar + + ELSEIF(ISUB.EQ.62) THEN +C...Z0 + Z0 -> f + fbar + + ELSEIF(ISUB.EQ.63) THEN +C...Z0 + W+/- -> f + fbar' + + ELSEIF(ISUB.EQ.64) THEN +C...Z0 + h0 -> f + fbar + + ELSEIF(ISUB.EQ.65) THEN +C...W+ + W- -> f + fbar + + ELSEIF(ISUB.EQ.66) THEN +C...W+/- + h0 -> f + fbar' + + ELSEIF(ISUB.EQ.67) THEN +C...h0 + h0 -> f + fbar + + ELSEIF(ISUB.EQ.68) THEN +C...g + g -> g + g; th arbitrary + KCC=MINT(2)+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + + ELSEIF(ISUB.EQ.69) THEN +C...gamma + gamma -> W+ + W-; th arbitrary + MINT(21)=24 + MINT(22)=-24 + KCC=21 + + ELSEIF(ISUB.EQ.70) THEN +C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2 + IF(MINT(15).EQ.22) MINT(21)=23 + IF(MINT(16).EQ.22) MINT(22)=23 + KCC=21 + ENDIF + + ELSEIF(ISUB.LE.80) THEN + IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN +C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W- + XH=SH/SHP + MINT(21)=MINT(15) + MINT(22)=MINT(16) + PMQ(1)=PYMASS(MINT(21)) + PMQ(2)=PYMASS(MINT(22)) + 330 JT=INT(1.5D0+PYR(0)) + ZMIN=2D0*PMQ(JT)/SHPR + ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ + & (SHPR*(SHPR-PMQ(3-JT))) + ZMAX=MIN(1D0-XH,ZMAX) + Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) + IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. + & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330 + SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 330 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) + CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) + Z(3-JT)=1D0-XH/(1D0-Z(JT)) + SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 330 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) + CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) + PHIR=PARU(2)*PYR(0) + CPHI=COS(PHIR) + ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* + & SQRT(1D0-CTHE(2)**2)*CPHI + Z1=2D0-Z(JT) + Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) + Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP + Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* + & PMQ(3-JT)**2/SHP)) + ZMIN=2D0*PMQ(3-JT)/SHPR + ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) + ZMAX=MIN(1D0-XH,ZMAX) + IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330 + KCC=22 + + ELSEIF(ISUB.EQ.73) THEN +C...Z0 + W+/- -> Z0 + W+/- + JS=MINT(2) + XH=SH/SHP + 340 JT=3-MINT(2) + I=MINT(14+JT) + IA=IABS(I) + IF(IA.LE.10) THEN + RVCKM=VINT(180+I)*PYR(0) + DO 350 J=1,MSTP(1) + IB=2*J-1+MOD(IA,2) + IPM=(5-ISIGN(1,I))/2 + IDC=J+MDCY(IA,2)+2 + IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350 + MINT(20+JT)=ISIGN(IB,I) + RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) + IF(RVCKM.LE.0D0) GOTO 360 + 350 CONTINUE + ELSE + IB=2*((IA+1)/2)-1+MOD(IA,2) + MINT(20+JT)=ISIGN(IB,I) + ENDIF + 360 PMQ(JT)=PYMASS(MINT(20+JT)) + MINT(23-JT)=MINT(17-JT) + PMQ(3-JT)=PYMASS(MINT(23-JT)) + JT=INT(1.5D0+PYR(0)) + ZMIN=2D0*PMQ(JT)/SHPR + ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ + & (SHPR*(SHPR-PMQ(3-JT))) + ZMAX=MIN(1D0-XH,ZMAX) + IF(ZMIN.GE.ZMAX) GOTO 340 + Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) + IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. + & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340 + SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 340 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) + CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) + Z(3-JT)=1D0-XH/(1D0-Z(JT)) + SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 340 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) + CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) + PHIR=PARU(2)*PYR(0) + CPHI=COS(PHIR) + ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* + & SQRT(1D0-CTHE(2)**2)*CPHI + Z1=2D0-Z(JT) + Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) + Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP + Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* + & PMQ(3-JT)**2/SHP)) + ZMIN=2D0*PMQ(3-JT)/SHPR + ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) + ZMAX=MIN(1D0-XH,ZMAX) + IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340 + KCC=22 + + ELSEIF(ISUB.EQ.74) THEN +C...Z0 + h0 -> Z0 + h0 + + ELSEIF(ISUB.EQ.75) THEN +C...W+ + W- -> gamma + gamma + + ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN +C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W- + XH=SH/SHP + 370 DO 400 JT=1,2 + I=MINT(14+JT) + IA=IABS(I) + IF(IA.LE.10) THEN + RVCKM=VINT(180+I)*PYR(0) + DO 380 J=1,MSTP(1) + IB=2*J-1+MOD(IA,2) + IPM=(5-ISIGN(1,I))/2 + IDC=J+MDCY(IA,2)+2 + IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380 + MINT(20+JT)=ISIGN(IB,I) + RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) + IF(RVCKM.LE.0D0) GOTO 390 + 380 CONTINUE + ELSE + IB=2*((IA+1)/2)-1+MOD(IA,2) + MINT(20+JT)=ISIGN(IB,I) + ENDIF + 390 PMQ(JT)=PYMASS(MINT(20+JT)) + 400 CONTINUE + JT=INT(1.5D0+PYR(0)) + ZMIN=2D0*PMQ(JT)/SHPR + ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/ + & (SHPR*(SHPR-PMQ(3-JT))) + ZMAX=MIN(1D0-XH,ZMAX) + IF(ZMIN.GE.ZMAX) GOTO 370 + Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0) + IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT. + & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370 + SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 370 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP) + CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT))) + Z(3-JT)=1D0-XH/(1D0-Z(JT)) + SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP) + IF(SQC1.LT.1D-8) GOTO 370 + C1=SQRT(SQC1) + C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP) + CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1 + CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT))) + PHIR=PARU(2)*PYR(0) + CPHI=COS(PHIR) + ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)* + & SQRT(1D0-CTHE(2)**2)*CPHI + Z1=2D0-Z(JT) + Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP) + Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP + Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)* + & PMQ(3-JT)**2/SHP)) + ZMIN=2D0*PMQ(3-JT)/SHPR + ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT))) + ZMAX=MIN(1D0-XH,ZMAX) + IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370 + KCC=22 + + ELSEIF(ISUB.EQ.78) THEN +C...W+/- + h0 -> W+/- + h0 + + ELSEIF(ISUB.EQ.79) THEN +C...h0 + h0 -> h0 + h0 + + ELSEIF(ISUB.EQ.80) THEN +C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2 + IF(MINT(15).EQ.22) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I) + IB=3-IA + MINT(20+JS)=ISIGN(IB,I) + KCC=22 + ENDIF + + ELSEIF(ISUB.LE.90) THEN + IF(ISUB.EQ.81) THEN +C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2 + MINT(21)=ISIGN(MINT(55),MINT(15)) + MINT(22)=-MINT(21) + KCC=4 + + ELSEIF(ISUB.EQ.82) THEN +C...g + g -> Q + Qbar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(MINT(55),KCS) + MINT(22)=-MINT(21) + KCC=MINT(2)+10 + + ELSEIF(ISUB.EQ.83) THEN +C...f + q -> f' + Q; th = (p(f) - p(f'))**2 + KFOLD=MINT(16) + IF(MINT(2).EQ.2) KFOLD=MINT(15) + KFAOLD=IABS(KFOLD) + IF(KFAOLD.GT.10) THEN + KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1 + ELSE + RCKM=VINT(180+KFOLD)*PYR(0) + IPM=(5-ISIGN(1,KFOLD))/2 + KFANEW=-MOD(KFAOLD+1,2) + 410 KFANEW=KFANEW+2 + IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2 + IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN + IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM- + & VCKM(KFAOLD/2,(KFANEW+1)/2) + IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM- + & VCKM(KFANEW/2,(KFAOLD+1)/2) + ENDIF + IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410 + ENDIF + IF(MINT(2).EQ.1) THEN + MINT(21)=ISIGN(MINT(55),MINT(15)) + MINT(22)=ISIGN(KFANEW,MINT(16)) + ELSE + MINT(21)=ISIGN(KFANEW,MINT(15)) + MINT(22)=ISIGN(MINT(55),MINT(16)) + JS=2 + ENDIF + KCC=22 + + ELSEIF(ISUB.EQ.84) THEN +C...g + gamma -> Q + Qbar; th arbitary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(MINT(55),KCS) + MINT(22)=-MINT(21) + KCC=27 + IF(MINT(16).EQ.21) KCC=28 + + ELSEIF(ISUB.EQ.85) THEN +C...gamma + gamma -> F + Fbar; th arbitary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(MINT(56),KCS) + MINT(22)=-MINT(21) + KCC=21 + + ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN +C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g + MINT(21)=KFPR(ISUB,1) + MINT(22)=KFPR(ISUB,2) + KCC=24 + KCS=(-1)**INT(1.5D0+PYR(0)) + ENDIF + + ELSEIF(ISUB.LE.100) THEN + IF(ISUB.EQ.95) THEN +C...Low-pT ( = energyless g + g -> g + g) + KCC=MINT(2)+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + + ELSEIF(ISUB.EQ.96) THEN +C...Multiple interactions (should be reassigned to QCD process) + ENDIF + + ELSEIF(ISUB.LE.110) THEN + IF(ISUB.EQ.101) THEN +C...g + g -> gamma*/Z0 + KCC=21 + KFRES=22 + + ELSEIF(ISUB.EQ.102) THEN +C...g + g -> h0 (or H0, or A0) + KCC=21 + KFRES=KFHIGG + + ELSEIF(ISUB.EQ.103) THEN +C...gamma + gamma -> h0 (or H0, or A0) + KCC=21 + KFRES=KFHIGG + + ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN +C...g + g -> chi_0c or chi_2c. + KCC=21 + KFRES=KFPR(ISUB,1) + + ELSEIF(ISUB.EQ.106) THEN +C...g + g -> J/Psi + gamma + MINT(21)=KFPR(ISUB,1) + MINT(22)=KFPR(ISUB,2) + KCC=21 + + ELSEIF(ISUB.EQ.107) THEN +C...g + gamma -> J/Psi + g + MINT(21)=KFPR(ISUB,1) + MINT(22)=KFPR(ISUB,2) + KCC=22 + IF(MINT(16).EQ.22) KCC=33 + + ELSEIF(ISUB.EQ.108) THEN +C...gamma + gamma -> J/Psi + gamma + MINT(21)=KFPR(ISUB,1) + MINT(22)=KFPR(ISUB,2) + + ELSEIF(ISUB.EQ.110) THEN +C...f + fbar -> gamma + h0; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=22 + MINT(23-JS)=KFHIGG + ENDIF + + ELSEIF(ISUB.LE.120) THEN + IF(ISUB.EQ.111) THEN +C...f + fbar -> g + h0; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=21 + MINT(23-JS)=KFHIGG + KCC=17+JS + + ELSEIF(ISUB.EQ.112) THEN +C...f + g -> f + h0; th = (p(f) - p(f))**2 + IF(MINT(15).EQ.21) JS=2 + MINT(23-JS)=KFHIGG + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.113) THEN +C...g + g -> g + h0; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(23-JS)=KFHIGG + KCC=22+JS + KCS=(-1)**INT(1.5D0+PYR(0)) + + ELSEIF(ISUB.EQ.114) THEN +C...g + g -> gamma + gamma; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(21)=22 + MINT(22)=22 + KCC=21 + + ELSEIF(ISUB.EQ.115) THEN +C...g + g -> g + gamma; th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(23-JS)=22 + KCC=22+JS + KCS=(-1)**INT(1.5D0+PYR(0)) + + ELSEIF(ISUB.EQ.116) THEN +C...g + g -> gamma + Z0 + + ELSEIF(ISUB.EQ.117) THEN +C...g + g -> Z0 + Z0 + + ELSEIF(ISUB.EQ.118) THEN +C...g + g -> W+ + W- + ENDIF + + ELSEIF(ISUB.LE.140) THEN + IF(ISUB.EQ.121) THEN +C...g + g -> Q + Qbar + h0 + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS) + MINT(22)=-MINT(21) + KCC=11+INT(0.5D0+PYR(0)) + KFRES=KFHIGG + + ELSEIF(ISUB.EQ.122) THEN +C...q + qbar -> Q + Qbar + h0 + MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15)) + MINT(22)=-MINT(21) + KCC=4 + KFRES=KFHIGG + + ELSEIF(ISUB.EQ.123) THEN +C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as +C...inner process) + KCC=22 + KFRES=KFHIGG + + ELSEIF(ISUB.EQ.124) THEN +C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as +C...inner process) + DO 430 JT=1,2 + I=MINT(14+JT) + IA=IABS(I) + IF(IA.LE.10) THEN + RVCKM=VINT(180+I)*PYR(0) + DO 420 J=1,MSTP(1) + IB=2*J-1+MOD(IA,2) + IPM=(5-ISIGN(1,I))/2 + IDC=J+MDCY(IA,2)+2 + IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420 + MINT(20+JT)=ISIGN(IB,I) + RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2) + IF(RVCKM.LE.0D0) GOTO 430 + 420 CONTINUE + ELSE + IB=2*((IA+1)/2)-1+MOD(IA,2) + MINT(20+JT)=ISIGN(IB,I) + ENDIF + 430 CONTINUE + KCC=22 + KFRES=KFHIGG + + ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN +C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2 + IF(MINT(15).EQ.22) JS=2 + MINT(23-JS)=21 + KCC=24+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN +C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2 + IF(MINT(15).EQ.22) JS=2 + KCC=22 + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN +C...g + gamma*_(T,L) -> f + fbar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFLF,KCS) + MINT(22)=-MINT(21) + KCC=27 + IF(MINT(16).EQ.21) KCC=28 + + ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN +C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFLF,KCS) + MINT(22)=-MINT(21) + KCC=21 + + ENDIF + + ELSEIF(ISUB.LE.160) THEN + IF(ISUB.EQ.141) THEN +C...f + fbar -> gamma*/Z0/Z'0 + KFRES=32 + + ELSEIF(ISUB.EQ.142) THEN +C...f + fbar' -> W'+/- + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + KFRES=ISIGN(34,KCH1+KCH2) + + ELSEIF(ISUB.EQ.143) THEN +C...f + fbar' -> H+/- + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + KFRES=ISIGN(37,KCH1+KCH2) + + ELSEIF(ISUB.EQ.144) THEN +C...f + fbar' -> R + KFRES=ISIGN(41,MINT(15)+MINT(16)) + + ELSEIF(ISUB.EQ.145) THEN +C...q + l -> LQ (leptoquark) + IF(IABS(MINT(16)).LE.8) JS=2 + KFRES=ISIGN(42,MINT(14+JS)) + KCC=28+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.146) THEN +C...e + gamma -> e* (excited lepton) + IF(MINT(15).EQ.22) JS=2 + KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS)) + KCC=22 + + ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN +C...q + g -> q* (excited quark) + IF(MINT(15).EQ.21) JS=2 + KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS)) + KCC=30+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.149) THEN +C...g + g -> eta_tc + KFRES=KTECHN+331 + KCC=23 + KCS=(-1)**INT(1.5D0+PYR(0)) + ENDIF + + ELSEIF(ISUB.LE.200) THEN + IF(ISUB.EQ.161) THEN +C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I) + IB=IA+MOD(IA,2)-MOD(IA+1,2) + MINT(20+JS)=ISIGN(IB,I) + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.162) THEN +C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2 + IF(MINT(15).EQ.21) JS=2 + MINT(20+JS)=ISIGN(42,MINT(14+JS)) + KFLQL=KFDP(MDCY(42,2),2) + MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS)) + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.163) THEN +C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(42,KCS) + MINT(22)=-MINT(21) + KCC=MINT(2)+10 + + ELSEIF(ISUB.EQ.164) THEN +C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2 + MINT(21)=ISIGN(42,MINT(15)) + MINT(22)=-MINT(21) + KCC=4 + + ELSEIF(ISUB.EQ.165) THEN +C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2 + MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.166) THEN +C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2 + IF(MOD(MINT(15),2).EQ.0) THEN + MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15)) + MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16)) + ELSE + MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) + MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16)) + ENDIF + + ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN +C...q + q' -> q" + q* (excited quark) + KFQSTR=KFPR(ISUB,2) + KFQEXC=MOD(KFQSTR,KEXCIT) + JS=MINT(2) + MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS)) + IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC) + & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS)) + KCC=22 + JS=3-JS + + ELSEIF(ISUB.EQ.169) THEN +C...q + qbar -> e + e* (excited lepton) + KFQSTR=KFPR(ISUB,2) + KFQEXC=MOD(KFQSTR,KEXCIT) + JS=MINT(2) + MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS)) + MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS)) + JS=3-JS + + ELSEIF(ISUB.EQ.191) THEN +C...f + fbar -> rho_tc0. + KFRES=KTECHN+113 + + ELSEIF(ISUB.EQ.192) THEN +C...f + fbar' -> rho_tc+/- + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + KFRES=ISIGN(KTECHN+213,KCH1+KCH2) + + ELSEIF(ISUB.EQ.193) THEN +C...f + fbar -> omega_tc0. + KFRES=KTECHN+223 + + ELSEIF(ISUB.EQ.194) THEN +C...f + fbar -> f' + fbar' via mixture of s-channel +C...rho_tc and omega_tc; th=(p(f)-p(f'))**2 + MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.195) THEN +C...f + fbar' -> f'' + fbar''' via s-channel +C...rho_tc+ th=(p(f)-p(f'))**2 +C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2 + IF(MOD(MINT(15),2).EQ.0) THEN + MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15)) + MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16)) + ELSE + MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15)) + MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16)) + ENDIF + ENDIF + +CMRENNA++ + ELSEIF(ISUB.LE.215) THEN + IF(ISUB.EQ.201) THEN +C...f + fbar -> ~e_L + ~e_Lbar + MINT(21)=ISIGN(KSUSY1+11,KCS) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.202) THEN +C...f + fbar -> ~e_R + ~e_Rbar + MINT(21)=ISIGN(KSUSY2+11,KCS) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.203) THEN +C...f + fbar -> ~e_L + ~e_Rbar + IF(MINT(15).LT.0) JS=2 + IF(MINT(2).EQ.1) THEN + MINT(20+JS)=KFPR(ISUB,1) + MINT(23-JS)=-KFPR(ISUB,2) + ELSE + MINT(20+JS)=-KFPR(ISUB,1) + MINT(23-JS)=KFPR(ISUB,2) + ENDIF + + ELSEIF(ISUB.EQ.204) THEN +C...f + fbar -> ~mu_L + ~mu_Lbar + MINT(21)=ISIGN(KSUSY1+13,KCS) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.205) THEN +C...f + fbar -> ~mu_R + ~mu_Rbar + MINT(21)=ISIGN(KSUSY2+13,KCS) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.206) THEN +C...f + fbar -> ~mu_L + ~mu_Rbar + IF(MINT(15).LT.0) JS=2 + IF(MINT(2).EQ.1) THEN + MINT(20+JS)=KFPR(ISUB,1) + MINT(23-JS)=-KFPR(ISUB,2) + ELSE + MINT(20+JS)=-KFPR(ISUB,1) + MINT(23-JS)=KFPR(ISUB,2) + ENDIF + + ELSEIF(ISUB.EQ.207) THEN +C...f + fbar -> ~tau_1 + ~tau_1bar + MINT(21)=ISIGN(KSUSY1+15,KCS) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.208) THEN +C...f + fbar -> ~tau_2 + ~tau_2bar + MINT(21)=ISIGN(KSUSY2+15,KCS) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.209) THEN +C...f + fbar -> ~tau_1 + ~tau_2bar + IF(MINT(15).LT.0) JS=2 + IF(MINT(2).EQ.1) THEN + MINT(20+JS)=KFPR(ISUB,1) + MINT(23-JS)=-KFPR(ISUB,2) + ELSE + MINT(20+JS)=-KFPR(ISUB,1) + MINT(23-JS)=KFPR(ISUB,2) + ENDIF + + ELSEIF(ISUB.EQ.210) THEN +C...q + qbar' -> ~l_L + ~nulbar; th arbitrary + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2) + MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2) + + ELSEIF(ISUB.EQ.211) THEN +C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2) + MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2) + + ELSEIF(ISUB.EQ.212) THEN +C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2) + MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2) + + ELSEIF(ISUB.EQ.213) THEN +C...f + fbar -> ~nul + ~nulbar + MINT(21)=ISIGN(KFPR(ISUB,1),KCS) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.214) THEN +C...f + fbar -> ~nutau + ~nutaubar + MINT(21)=ISIGN(KSUSY1+16,KCS) + MINT(22)=-MINT(21) + ENDIF + + ELSEIF(ISUB.LE.225) THEN + IF(ISUB.EQ.216) THEN +C...f + fbar -> ~chi01 + ~chi01 + MINT(21)=KSUSY1+22 + MINT(22)=KSUSY1+22 + + ELSEIF(ISUB.EQ.217) THEN +C...f + fbar -> ~chi02 + ~chi02 + MINT(21)=KSUSY1+23 + MINT(22)=KSUSY1+23 + + ELSEIF(ISUB.EQ.218 ) THEN +C...f + fbar -> ~chi03 + ~chi03 + MINT(21)=KSUSY1+25 + MINT(22)=KSUSY1+25 + + ELSEIF(ISUB.EQ.219 ) THEN +C...f + fbar -> ~chi04 + ~chi04 + MINT(21)=KSUSY1+35 + MINT(22)=KSUSY1+35 + + ELSEIF(ISUB.EQ.220 ) THEN +C...f + fbar -> ~chi01 + ~chi02 + IF(MINT(15).LT.0) JS=2 +C IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+22 + MINT(23-JS)=KSUSY1+23 + + ELSEIF(ISUB.EQ.221 ) THEN +C...f + fbar -> ~chi01 + ~chi03 + IF(MINT(15).LT.0) JS=2 +C IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+22 + MINT(23-JS)=KSUSY1+25 + + ELSEIF(ISUB.EQ.222) THEN +C...f + fbar -> ~chi01 + ~chi04 + IF(MINT(15).LT.0) JS=2 +C IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+22 + MINT(23-JS)=KSUSY1+35 + + ELSEIF(ISUB.EQ.223) THEN +C...f + fbar -> ~chi02 + ~chi03 + IF(MINT(15).LT.0) JS=2 +C IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+23 + MINT(23-JS)=KSUSY1+25 + + ELSEIF(ISUB.EQ.224) THEN +C...f + fbar -> ~chi02 + ~chi04 + IF(MINT(15).LT.0) JS=2 +C IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+23 + MINT(23-JS)=KSUSY1+35 + + ELSEIF(ISUB.EQ.225) THEN +C...f + fbar -> ~chi03 + ~chi04 + IF(MINT(15).LT.0) JS=2 +C IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+25 + MINT(23-JS)=KSUSY1+35 + ENDIF + + ELSEIF(ISUB.LE.236) THEN + IF(ISUB.EQ.226) THEN +C...f + fbar -> ~chi+-1 + ~chi-+1 +C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + MINT(21)=ISIGN(KSUSY1+24,KCH1) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.227) THEN +C...f + fbar -> ~chi+-2 + ~chi-+2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + MINT(21)=ISIGN(KSUSY1+37,KCH1) + MINT(22)=-MINT(21) + + ELSEIF(ISUB.EQ.228) THEN +C...f + fbar -> ~chi+-1 + ~chi-+2 +C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2 +C...js=1 if pyr<.5, js=2 if pyr>.5 +C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2 +C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2 +C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2 +C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=INT(1-KCH1)/2 + IF(MINT(2).EQ.1) THEN + MINT(21)= ISIGN(KSUSY1+24,KCH1) + MINT(22)= -ISIGN(KSUSY1+37,KCH1) +c IF(KCH2.EQ.0) JS=2 + ELSE + MINT(21)= ISIGN(KSUSY1+37,KCH1) + MINT(22)= -ISIGN(KSUSY1+24,KCH1) + JS=2 +c IF(KCH2.EQ.1) JS=2 + ENDIF + + ELSEIF(ISUB.EQ.229) THEN +C...q + qbar' -> ~chi01 + ~chi+-1 +C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) +C...CHECK THIS + IF(MOD(MINT(15),2).EQ.0) JS=2 + MINT(20+JS)=KSUSY1+22 + MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) + + ELSEIF(ISUB.EQ.230) THEN +C...q + qbar' -> ~chi02 + ~chi+-1 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MOD(MINT(15),2).EQ.0) JS=2 + MINT(20+JS)=KSUSY1+23 + MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) + + ELSEIF(ISUB.EQ.231) THEN +C...q + qbar' -> ~chi03 + ~chi+-1 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MOD(MINT(15),2).EQ.0) JS=2 + MINT(20+JS)=KSUSY1+25 + MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) + + ELSEIF(ISUB.EQ.232) THEN +C...q + qbar' -> ~chi04 + ~chi+-1 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MOD(MINT(15),2).EQ.0) JS=2 + MINT(20+JS)=KSUSY1+35 + MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) + + ELSEIF(ISUB.EQ.233) THEN +C...q + qbar' -> ~chi01 + ~chi+-2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MOD(MINT(15),2).EQ.0) JS=2 + MINT(20+JS)=KSUSY1+22 + MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) + + ELSEIF(ISUB.EQ.234) THEN +C...q + qbar' -> ~chi02 + ~chi+-2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MOD(MINT(15),2).EQ.0) JS=2 + MINT(20+JS)=KSUSY1+23 + MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) + + ELSEIF(ISUB.EQ.235) THEN +C...q + qbar' -> ~chi03 + ~chi+-2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MOD(MINT(15),2).EQ.0) JS=2 + MINT(20+JS)=KSUSY1+25 + MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) + + ELSEIF(ISUB.EQ.236) THEN +C...q + qbar' -> ~chi04 + ~chi+-2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MOD(MINT(15),2).EQ.0) JS=2 + MINT(20+JS)=KSUSY1+35 + MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) + ENDIF + + ELSEIF(ISUB.LE.245) THEN + IF(ISUB.EQ.237) THEN +C...q + qbar -> ~chi01 + ~g +C...th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+21 + MINT(23-JS)=KSUSY1+22 + KCC=17+JS + + ELSEIF(ISUB.EQ.238) THEN +C...q + qbar -> ~chi02 + ~g +C...th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+21 + MINT(23-JS)=KSUSY1+23 + KCC=17+JS + + ELSEIF(ISUB.EQ.239) THEN +C...q + qbar -> ~chi03 + ~g +C...th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+21 + MINT(23-JS)=KSUSY1+25 + KCC=17+JS + + ELSEIF(ISUB.EQ.240) THEN +C...q + qbar -> ~chi04 + ~g +C...th arbitrary + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KSUSY1+21 + MINT(23-JS)=KSUSY1+35 + KCC=17+JS + + ELSEIF(ISUB.EQ.241) THEN +C...q + qbar' -> ~chi+-1 + ~g +C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+ +C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi- +C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi- +C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+ +C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + JS=1 + IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 + MINT(20+JS)=KSUSY1+21 + MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2) + KCC=17+JS + + ELSEIF(ISUB.EQ.242) THEN +C...q + qbar' -> ~chi+-2 + ~g +C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+ +C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi- +C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi- +C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+ +C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + JS=1 + IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 + MINT(20+JS)=KSUSY1+21 + MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2) + KCC=17+JS + + ELSEIF(ISUB.EQ.243) THEN +C...q + qbar -> ~g + ~g ; th arbitrary + MINT(21)=KSUSY1+21 + MINT(22)=KSUSY1+21 + KCC=MINT(2)+4 + + ELSEIF(ISUB.EQ.244) THEN +C...g + g -> ~g + ~g ; th arbitrary + KCC=MINT(2)+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=KSUSY1+21 + MINT(22)=KSUSY1+21 + ENDIF + + ELSEIF(ISUB.LE.260) THEN + IF(ISUB.EQ.246) THEN +C...qj + g -> ~qj_L + ~chi01 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY1+IA,I) + MINT(23-JS)=KSUSY1+22 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.247) THEN +C...qj + g -> ~qj_R + ~chi01 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY2+IA,I) + MINT(23-JS)=KSUSY1+22 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.248) THEN +C...qj + g -> ~qj_L + ~chi02 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY1+IA,I) + MINT(23-JS)=KSUSY1+23 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.249) THEN +C...qj + g -> ~qj_R + ~chi02 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY2+IA,I) + MINT(23-JS)=KSUSY1+23 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.250) THEN +C...qj + g -> ~qj_L + ~chi03 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY1+IA,I) + MINT(23-JS)=KSUSY1+25 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.251) THEN +C...qj + g -> ~qj_R + ~chi03 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY2+IA,I) + MINT(23-JS)=KSUSY1+25 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.252) THEN +C...qj + g -> ~qj_L + ~chi04 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY1+IA,I) + MINT(23-JS)=KSUSY1+35 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.253) THEN +C...qj + g -> ~qj_R + ~chi04 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY2+IA,I) + MINT(23-JS)=KSUSY1+35 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.254) THEN +C...qj + g -> ~qk_L + ~chi+-1 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I) + IB=-IA+INT((IA+1)/2)*4-1 + MINT(20+JS)=ISIGN(KSUSY1+IB,I) + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.255) THEN +C...qj + g -> ~qk_L + ~chi+-1 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I) + IB=-IA+INT((IA+1)/2)*4-1 + MINT(20+JS)=ISIGN(KSUSY2+IB,I) + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.256) THEN +C...qj + g -> ~qk_L + ~chi+-2 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + IB=-IA+INT((IA+1)/2)*4-1 + MINT(20+JS)=ISIGN(KSUSY1+IB,I) + MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I) + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.257) THEN +C...qj + g -> ~qk_R + ~chi+-2 + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + IB=-IA+INT((IA+1)/2)*4-1 + MINT(20+JS)=ISIGN(KSUSY2+IB,I) + MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I) + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.258) THEN +C...qj + g -> ~qj_L + ~g + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY1+IA,I) + MINT(23-JS)=KSUSY1+21 + KCC=MINT(2)+6 + IF(JS.EQ.2) KCC=KCC+2 + KCS=ISIGN(1,I) + + ELSEIF(ISUB.EQ.259) THEN +C...qj + g -> ~qj_R + ~g + IF(MINT(15).EQ.21) JS=2 + I=MINT(14+JS) + IA=IABS(I) + MINT(20+JS)=ISIGN(KSUSY2+IA,I) + MINT(23-JS)=KSUSY1+21 + KCC=MINT(2)+6 + IF(JS.EQ.2) KCC=KCC+2 + KCS=ISIGN(1,I) + ENDIF + + ELSEIF(ISUB.LE.270) THEN + IF(ISUB.EQ.261) THEN +C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2 + ISGN=1 + IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1 + MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS) + MINT(22)=-MINT(21) +C...Correct color combination + IF(MINT(43).EQ.4) KCC=4 + + ELSEIF(ISUB.EQ.262) THEN +C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2 + ISGN=1 + IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1 + MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS) + MINT(22)=-MINT(21) +C...Correct color combination + IF(MINT(43).EQ.4) KCC=4 + + ELSEIF(ISUB.EQ.263) THEN +C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2 + IF((KCS.GT.0.AND.MINT(2).EQ.1).OR. + & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN + MINT(21)=ISIGN(KFPR(ISUB,1),KCS) + MINT(22)=-ISIGN(KFPR(ISUB,2),KCS) + ELSE + JS=2 + MINT(21)=ISIGN(KFPR(ISUB,2),KCS) + MINT(22)=-ISIGN(KFPR(ISUB,1),KCS) + ENDIF +C...Correct color combination + IF(MINT(43).EQ.4) KCC=4 + + ELSEIF(ISUB.EQ.264) THEN +C...g + g -> ~t_1 + ~t_1bar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFPR(ISUB,1),KCS) + MINT(22)=-MINT(21) + KCC=MINT(2)+10 + + ELSEIF(ISUB.EQ.265) THEN +C...g + g -> ~t_2 + ~t_2bar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFPR(ISUB,1),KCS) + MINT(22)=-MINT(21) + KCC=MINT(2)+10 + ENDIF + + ELSEIF(ISUB.LE.301) 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) + + ELSEIF(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.330) THEN + IF(ISUB.EQ.311)THEN +C...g + g -> g* + g* (UED) + KCC=MINT(2)+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + MUED(1)=472 + MUED(2)=472 + MINT(21)=IUEDEQ(472) + MINT(22)=IUEDEQ(472) + ELSEIF(ISUB.EQ.312)THEN +C...q + g -> q*_D + g*, q*_S + g* +C...The two channels have the same cross section + KKFLMI=450 + IF(PYR(0).GT.0.5)KKFLMI=456 + IF(MINT(15).EQ.21) JS=2 + KCC=MINT(2)+6 + IF(MINT(15).EQ.21)KCC=KCC+2 + IF(MINT(15).NE.21)THEN + KCS=ISIGN(1,MINT(15)) + MUED(2)=472 + MUED(1)=KCS*(KKFLMI+IABS(MINT(15))) + MINT(22)=IUEDEQ(472) + MINT(21)=KCS*IUEDEQ(KKFLMI+IABS(MINT(15))) + ENDIF + IF(MINT(16).NE.21)THEN + KCS=ISIGN(1,MINT(16)) + MUED(2)=KCS*(KKFLMI+IABS(MINT(16))) + MUED(1)=472 + MINT(22)=KCS*IUEDEQ(KKFLMI+IABS(MINT(16))) + MINT(21)=IUEDEQ(472) + ENDIF + ELSEIF(ISUB.EQ.313)THEN +C...q + q' -> q*_D + q*_D',q*_S+q*_S' +C...The two channels have the same cross section + KKFLMI=450 + IF(PYR(0).GT.0.5)KKFLMI=456 + KCC=MINT(2) + IF(MINT(15).EQ.MINT(16))THEN + MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15))) + MUED(2)=MINT(21) + MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15))) + MINT(22)=MINT(21) + ELSE + MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15))) + MUED(2)=SIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16))) + MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15))) + MINT(22)=SIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16))) + ENDIF + IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 + ELSEIF(ISUB.EQ.314)THEN +C...g + g -> q*_D + q*_D_bar, q*_S + q*_S_bar +C...The two channels have the same cross section + KKFLMI=450 + IF(PYR(0).GT.0.5)KKFLMI=456 + KCS=(-1)**INT(1.5D0+PYR(0)) + XFLAOUT=PYR(0) + IF(XFLAOUT.LE.0.2)THEN + MUED(1)=ISIGN(1,KCS)*(KKFLMI+1) + MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+1) + ELSEIF(XFLAOUT.LE.0.4)THEN + MUED(1)=ISIGN(1,KCS)*(KKFLMI+2) + MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+2) + ELSEIF(XFLAOUT.LE.0.6)THEN + MUED(1)=ISIGN(1,KCS)*(KKFLMI+3) + MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+3) + ELSEIF(XFLAOUT.LE.0.8)THEN + MUED(1)=ISIGN(1,KCS)*(KKFLMI+4) + MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+4) + ELSE + MUED(1)=ISIGN(1,KCS)*(KKFLMI+5) + MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+5) + ENDIF + MINT(22)=-MINT(21) + MUED(2)=-MUED(1) + KCC=MINT(2)+10 + ELSEIF(ISUB.EQ.315)THEN +C...q + qbar -> q*_D + q*_D_bar, q*_S + q*_S_bar +C...The two channels have the same cross section + KKFLMI=450 + IF(PYR(0).GT.0.5)KKFLMI=456 + MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15))) + MUED(2)=-MINT(21) + MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15))) + MINT(22)=-MINT(21) + KCC=4 + ELSEIF(ISUB.EQ.316)THEN +C...q + qbar' -> q*_D + q*_S_bar' + MUED(1)=ISIGN(1,MINT(15))*(456+IABS(MINT(15))) + MUED(2)=ISIGN(1,MINT(16))*(450+IABS(MINT(16))) + MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15))) + MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16))) + KCC=MINT(2)+2 + ELSEIF(ISUB.EQ.317)THEN +C...q + qbar' -> q*_D + q*_D_bar', q*_S + q*_S_bar +C...The two channels have the same cross section + KKFLMI=450 + IF(PYR(0).GT.0.5)KKFLMI=456 + MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15))) + MUED(2)=ISIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16))) + MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15))) + MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16))) + KCC=MINT(2)+2 + ELSEIF(ISUB.EQ.318)THEN +C...q + q' -> q*_D + q*_S' + KCC=MINT(2) + MUED(1)=SIGN(1,MINT(15))*(456+IABS(MINT(15))) + MUED(2)=SIGN(1,MINT(16))*(450+IABS(MINT(16))) + MINT(21)=SIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15))) + MINT(22)=SIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16))) + ELSEIF(ISUB.EQ.319)THEN +C...q + qbar -> q*_D' + q*_D_bar', q*_S' + q*_S_bar' +C...The two channels have the same cross section + KKFLMI=450 + IF(PYR(0).GT.0.5)KKFLMI=456 + XFLAOUT=PYR(0) + IIFLAV=0 +C...N.B. NFLAVOURS=IUED(3) +C DO I=1,NFLAVOURS + DO 433 I=1,IUED(3) + IF(I.NE.IABS(MINT(15)))THEN + IIFLAV=IIFLAV+1 + IOKFLA(IIFLAV)=I + ENDIF + 433 CONTINUE + FLASTEP=1./(IUED(3)-1) + DO I=1,IUED(3)-1 + FLAVV=FLASTEP*I + IF(XFLAOUT.LE.FLAVV)THEN + MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IOKFLA(I)) + MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IOKFLA(I)) + GOTO 435 + ENDIF + ENDDO + 435 CONTINUE + IF(IABS(MUED(1)).LT.451.AND.IABS(MUED(1)).GT.462)THEN + WRITE(MSTU(11),*) 'IN PYSCAT: KK FLAVORS PROBLEM !!!' + CALL PYSTOP(5000000) + ENDIF + MINT(22)=-MINT(21) + KCC=4 + ENDIF + + 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.OR.ISUB.EQ.379.OR.ISUB.EQ.380) 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.OR.ISUB.EQ.378) THEN +C...f + fbar' -> neutral charged technicolor + IN=1 + IC=2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2 + MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2) + MINT(20+JS)=KFPR(ISUB,IN) + + ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN +C...f + fbar' -> charged neutral technicolor + IN=2 + IC=1 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2 + MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2) + MINT(23-JS)=KFPR(ISUB,IN) + ENDIF + + ELSEIF(ISUB.LE.400) THEN + IF(ISUB.EQ.381) THEN +C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions + KCC=MINT(2) + IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2 + + ELSEIF(ISUB.EQ.382) THEN +C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions + MINT(21)=ISIGN(KFLF,MINT(15)) + MINT(22)=-MINT(21) + KCC=4 + + ELSEIF(ISUB.EQ.383) THEN +C...f + fbar -> g + g; th arbitrary, TC extensions + MINT(21)=21 + MINT(22)=21 + KCC=MINT(2)+4 + + ELSEIF(ISUB.EQ.384) THEN +C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions + IF(MINT(15).EQ.21) JS=2 + KCC=MINT(2)+6 + IF(MINT(15).EQ.21) KCC=KCC+2 + IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15)) + IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16)) + + ELSEIF(ISUB.EQ.385) THEN +C...g + g -> f + fbar; th arbitrary, TC extensions + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFLF,KCS) + MINT(22)=-MINT(21) + KCC=MINT(2)+10 + + ELSEIF(ISUB.EQ.386) THEN +C...g + g -> g + g; th arbitrary, TC extensions + KCC=MINT(2)+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + + ELSEIF(ISUB.EQ.387) THEN +C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions + MINT(21)=ISIGN(MINT(55),MINT(15)) + MINT(22)=-MINT(21) + KCC=4 + + ELSEIF(ISUB.EQ.388) THEN +C...g + g -> Q + Qbar; th arbitrary, TC extensions + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(MINT(55),KCS) + MINT(22)=-MINT(21) + KCC=MINT(2)+10 + + ELSEIF(ISUB.EQ.391) THEN +C...f + fbar -> G*. + KFRES=KFPR(ISUB,1) + + ELSEIF(ISUB.EQ.392) THEN +C...g + g -> G*. + KCC=21 + KFRES=KFPR(ISUB,1) + + ELSEIF(ISUB.EQ.393) THEN +C...q + qbar -> g + G*; th arbitrary. + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KFPR(ISUB,1) + MINT(23-JS)=KFPR(ISUB,2) + KCC=17+JS + + ELSEIF(ISUB.EQ.394) THEN +C...q + g -> q + G*; th = (p(f) - p(f))**2 + IF(MINT(15).EQ.21) JS=2 + MINT(23-JS)=KFPR(ISUB,2) + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.EQ.395) THEN +C...g + g -> G* + g; th arbitrary. + IF(PYR(0).GT.0.5D0) JS=2 + MINT(23-JS)=KFPR(ISUB,2) + KCC=22+JS + ENDIF + + ELSEIF(ISUB.LE.420) THEN + IF(ISUB.EQ.401) THEN +C...g + g -> t + b + H+/- + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS) + MINT(22)=ISIGN(5,-KCS) + KCC=11+INT(0.5D0+PYR(0)) + KFRES=ISIGN(KFHIGG,-KCS) + + ELSEIF(ISUB.EQ.402) THEN +C...q + qbar -> t + b + H+/- + KFL=(-1)**INT(1.5D0+PYR(0)) + MINT(21)=ISIGN(INT(6.+.5*KFL),KCS) + MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS) + KCC=4 + KFRES=ISIGN(KFHIGG,-KFL*KCS) + ENDIF + +C...QUARKONIA+++ +C...Additional code by Stefan Wolf + ELSEIF(ISUB.LE.430) THEN + IF(ISUB.GE.421.AND.ISUB.LE.424) THEN +C...g + g -> QQ~[n] + g +C...MINT(21), MINT(22) copied from ISUB.EQ.86-89 +C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g] +C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421) +C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g] +C...or from ISUB.EQ.68 (for ISUB.NE.421) +C...[g + g -> g + g; th arbitrary] + MINT(21)=KFPR(ISUBSV,1) + MINT(22)=KFPR(ISUBSV,2) + IF(ISUB.EQ.421) THEN + KCC=24 + KCS=(-1)**INT(1.5D0+PYR(0)) + ELSE + KCC=MINT(2)+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + ENDIF + + ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN +C...q + g -> q + QQ~[n] +C...MINT(21), MINT(22) "copied" from ISUB.EQ.112 +C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)] +C...KCC copied from ISUB.EQ.28 +C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)] + IF(MINT(15).EQ.21) JS=2 + MINT(23-JS)=KFPR(ISUBSV,2) + KCC=MINT(2)+6 + IF(MINT(15).EQ.21) KCC=KCC+2 + IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15)) + IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16)) + + ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN +C...q + q~ -> g + QQ~[n] +C...MINT(21), MINT(22) "copied" from ISUB.EQ.111 +C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)] +C...KCC copied from ISUB.EQ.13 +C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)] + IF(PYR(0).GT.0.5) JS=2 + MINT(20+JS)=21 + MINT(23-JS)=KFPR(ISUBSV,2) + KCC=MINT(2)+4 + ENDIF + + ELSEIF(ISUB.LE.440) THEN + IF(ISUB.GE.431.AND.ISUB.LE.433) THEN +C...g + g -> QQ~[n] + g +C...MINT(21), MINT(22) copied from ISUB.EQ.86-89 +C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g] +C...KCC and KCS copied from ISUB.EQ.86-89 +C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g] + MINT(21)=KFPR(ISUBSV,1) + MINT(22)=KFPR(ISUBSV,2) + KCC=24 + KCS=(-1)**INT(1.5D0+PYR(0)) + + ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN +C...q + g -> q + QQ~[n] +C...MINT(21), MINT(22) "copied" from ISUB.EQ.112 +C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)] +C...KCC and KCS copied from ISUB.EQ.112 +C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)] + IF(MINT(15).EQ.21) JS=2 + MINT(23-JS)=KFPR(ISUBSV,2) + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + + ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN +C...q + q~ -> g + QQ~[n] +C...MINT(21), MINT(22) "copied" from ISUB.EQ.111 +C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)] +C...KCC copied from ISUB.EQ.111 +C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)] + IF(PYR(0).GT.0.5) JS=2 + MINT(20+JS)=21 + MINT(23-JS)=KFPR(ISUBSV,2) + KCC=17+JS +C...QUARKONIA--- + ENDIF + ELSEIF(ISUB.LE.500) THEN + IF(ISUB.EQ.481.OR.ISUB.EQ.482) THEN + KFRES=9900001 + KCRES=PYCOMP(KFRES) + MCOL=KCHG(KCRES,2) + MCHG=KCHG(KCRES,1) + IF(KCRES.EQ.0) + $ CALL PYERRM(21,"No resonance for Generic 2-> 2 Process") + IDCY=MDCY(KCRES,2) + IF(IDCY.EQ.0) + $ CALL PYERRM(21,"No decays for resonance in Generic 2->2") + KCI1=PYCOMP(MINT(15)) + KCI2=PYCOMP(MINT(16)) + ICOL1=ISIGN(KCHG(KCI1,2),MINT(15)) + ICOL2=ISIGN(KCHG(KCI2,2),MINT(16)) + KFF1=KFPR(ISUB,1) + KFF2=KFPR(ISUB,2) + KCF1=PYCOMP(KFF1) + KCF2=PYCOMP(KFF2) + JCOL1=SIGN(KCHG(KCF1,2),KFF1) + IF(JCOL1.EQ.-2) JCOL1=2 + JCOL2=SIGN(KCHG(KCF2,2),KFF2) + IF(JCOL2.EQ.-2) JCOL2=2 + KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15)) + KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16)) + KCHW=KCH1+KCH2 + KREL=1 + IF(MCHG.NE.0.AND.KCHW.EQ.-MCHG) KREL=-1 + IF(KCHG(KCF1,3).NE.0) KFF1=KFF1*KREL + IF(KCHG(KCF2,3).NE.0) KFF2=KFF2*KREL + IF(JCOL1.EQ.1.OR.JCOL1.EQ.-1) JCOL1=JCOL1*KREL + IF(JCOL2.EQ.1.OR.JCOL2.EQ.-1) JCOL2=JCOL2*KREL + IF((ICOL1.EQ.1.AND.ICOL2.EQ.-1).OR. + $ (ICOL2.EQ.1.AND.ICOL1.EQ.-1)) THEN + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KFF1 + MINT(23-JS)=KFF2 + IF(JCOL1.EQ.0.AND.JCOL2.EQ.0) THEN + + ELSEIF(JCOL1.EQ.0.AND.JCOL2.EQ.2) THEN + KCC=17+JS + MINT(20+JS)=KFF2 + MINT(23-JS)=KFF1 + ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.0) THEN + KCC=17+JS + MINT(20+JS)=KFF1 + MINT(23-JS)=KFF2 + ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.2.AND.MCOL.EQ.0) THEN + + ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN + KCC=MINT(2)+4 + ELSEIF((JCOL1.EQ.1.AND.JCOL2.EQ.-1).OR. + $ (JCOL1.EQ.-1.AND.JCOL2.EQ.1)) THEN + IF(ICOL1.EQ.JCOL1) THEN + JS=1 + MINT(21)=KFF1 + MINT(22)=KFF2 + ELSE + JS=2 + MINT(21)=KFF2 + MINT(22)=KFF1 + ENDIF + IF(MCOL.EQ.0) THEN + + ELSE + KCC=4 + ENDIF + ENDIF + ELSEIF((ICOL1.EQ.2.AND.(ICOL2.EQ.1.OR.ICOL2.EQ.-1)).OR. + $ (ICOL2.EQ.2.AND.(ICOL1.EQ.1.OR.ICOL1.EQ.-1))) THEN + IF((JCOL1.EQ.2.AND.ABS(JCOL2).EQ.1).OR. + $ (JCOL2.EQ.2.AND.ABS(JCOL1).EQ.1)) THEN + IF(MINT(15).EQ.21) JS=2 + KCC=MINT(2)+6 + IF(MINT(15).EQ.21) KCC=KCC+2 + IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15)) + IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16)) + IF(JCOL1.EQ.2) THEN + MINT(20+JS)=KFF2 + MINT(23-JS)=KFF1 + ELSE + MINT(20+JS)=KFF1 + MINT(23-JS)=KFF2 + ENDIF + ELSEIF((ABS(JCOL1).EQ.1.AND.JCOL2.EQ.0).OR. + $ (ABS(JCOL2).EQ.1.AND.JCOL1.EQ.0)) THEN + IF(MINT(15).EQ.21) JS=2 + KCC=15+JS + KCS=ISIGN(1,MINT(14+JS)) + IF(JCOL1.EQ.0) THEN + MINT(23-JS)=KFF1 + MINT(20+JS)=KFF2 + ELSE + MINT(23-JS)=KFF2 + MINT(20+JS)=KFF1 + ENDIF + ENDIF + ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND. + $ JCOL1.EQ.0.AND.JCOL2.EQ.0) THEN + IF(PYR(0).GT.0.5D0) JS=2 + KCC=21 + MINT(20+JS)=KFF1 + MINT(23-JS)=KFF2 + ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND. + $ ((JCOL1.EQ.0.AND.JCOL2.EQ.2).OR. + $ ((JCOL2.EQ.0.AND.JCOL1.EQ.2)))) THEN + IF(PYR(0).GT.0.5D0) JS=2 + KCC=22+JS + KCS=(-1)**INT(1.5D0+PYR(0)) + IF(JCOL1.EQ.0) THEN + MINT(23-JS)=KFF1 + MINT(20+JS)=KFF2 + ELSE + MINT(23-JS)=KFF2 + MINT(20+JS)=KFF1 + ENDIF + ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND. + $ ((JCOL1.EQ.1.AND.JCOL2.EQ.-1).OR. + $ ((JCOL2.EQ.1.AND.JCOL1.EQ.-1)))) THEN +C....two choices, 0 or 2 depending upon mother properties + IF(MCOL.EQ.2) THEN + KCS=(-1)**INT(1.5D0+PYR(0)) + KCC=MINT(2)+10 + IF(JCOL1.EQ.1) THEN + MINT(21)=KFF1*KCS + MINT(22)=KFF2*KCS + ELSE + MINT(22)=KFF1*KCS + MINT(21)=KFF2*KCS + ENDIF +c MINT(20+JS)=KFF1*KCS +c MINT(23-JS)=KFF2*KCS + ELSEIF(MCOL.EQ.0) THEN + KCC=21 + MINT(20+JS)=KFF1*KCS + MINT(23-JS)=KFF2*KCS + ENDIF + + ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND. + $ JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN +C....two choices, 0 or 2 depending upon mother properties + IF(MCOL.EQ.0) THEN + KCC=21 + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KFF1 + MINT(23-JS)=KFF2 + ELSEIF(MCOL.EQ.2) THEN + IF(PYR(0).GT.0.5D0) JS=2 + KCC=MINT(2)+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + MINT(20+JS)=KFF1 + MINT(23-JS)=KFF2 + ENDIF + ELSEIF((ICOL1.EQ.1.AND.ICOL2.EQ.1).OR. + $ (ICOL1.EQ.-1.AND.ICOL2.EQ.-1)) THEN + KCC=MINT(2) + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KFF1 + MINT(23-JS)=KFF2 + ELSEIF(ICOL1.EQ.0.AND.ICOL2.EQ.0.AND.MCOL.EQ.0) THEN + KCC=20 + IF(PYR(0).GT.0.5D0) JS=2 + MINT(20+JS)=KFF1 + MINT(23-JS)=KFF2 + ELSE + CALL PYERRM(21,"PYSCAT: No recognized Generic Process") + ENDIF + IF(ISUBSV.EQ.482) KFRES=0 + 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 +C...Search for daughters of intermediate colourless particles. + IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN + DO 475 IUPDAU=IUP+1,NUP + IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)= + & N+IUPDAU-IUP + IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP + 475 CONTINUE + ENDIF + DO 480 J=1,5 + P(N,J)=PUP(J,IUP) + 480 CONTINUE + V(N,5)=VTIMUP(IUP) + 490 CONTINUE + CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP) + +C...Arrange colour flow for user-defined processes + NLBL=0 + DO 540 IUP1=1,NUP + I1=MINT(84)+IUP1 + IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540 + IF(K(I1,1).EQ.1) K(I1,1)=3 + IF(K(I1,1).EQ.11) K(I1,1)=14 +C...Find a not yet considered colour/anticolour line. + DO 530 ISDE1=1,2 + IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530 + NMAT=0 + DO 500 ILBL=1,NLBL + IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1 + 500 CONTINUE + IF(NMAT.EQ.0) THEN + NLBL=NLBL+1 + ILAB(NLBL)=ICOLUP(ISDE1,IUP1) +C...Find all others belonging to same line. + I3=I1 + I4=0 + DO 520 IUP2=IUP1+1,NUP + I2=MINT(84)+IUP2 + DO 510 ISDE2=1,2 + IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN + IF(ISDE2.EQ.ISDE1) THEN + K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2 + K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3 + I3=I2 + ELSEIF(I4.NE.0) THEN + K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2 + K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4 + I4=I2 + ELSEIF(IUP2.LE.2) THEN + K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2 + K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1 + I4=I2 + ELSE + K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2 + K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1 + I4=I2 + ENDIF + ENDIF + 510 CONTINUE + 520 CONTINUE + ENDIF + 530 CONTINUE + 540 CONTINUE + + ELSEIF(IDOC.EQ.7) THEN +C...Resonance not decaying; store kinematics + I=MINT(83)+7 + K(IPU3,1)=1 + K(IPU3,2)=KFRES + K(IPU3,3)=I + P(IPU3,4)=SHUSER + P(IPU3,5)=SHUSER + K(I,1)=21 + K(I,2)=KFRES + P(I,4)=SHUSER + P(I,5)=SHUSER + N=IPU3 + MINT(21)=KFRES + MINT(22)=0 + +C...Special cases: colour flow in coloured resonances + KCRES=PYCOMP(KFRES) + IF(KCHG(KCRES,2).NE.0) THEN + K(IPU3,1)=3 + DO 550 J=1,2 + JC=J + IF(KCS.EQ.-1) JC=3-J + IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)= + & MINT(84)+ICOL(KCC,1,JC) + IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)= + & MINT(84)+ICOL(KCC,2,JC) + IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)= + & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC)) + 550 CONTINUE + ELSE + K(IPU1,4)=IPU2 + K(IPU1,5)=IPU2 + K(IPU2,4)=IPU1 + K(IPU2,5)=IPU1 + ENDIF + + ELSEIF(IDOC.EQ.8) THEN +C...2 -> 2 processes: store outgoing partons in their CM-frame + DO 560 JT=1,2 + I=MINT(84)+2+JT + KCA=PYCOMP(MINT(20+JT)) + K(I,1)=1 + IF(KCHG(KCA,2).NE.0) K(I,1)=3 + K(I,2)=MINT(20+JT) + K(I,3)=MINT(83)+IDOC+JT-2 + KFAA=IABS(K(I,2)) + IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN + P(I,5)=SQRT(VINT(63+MOD(JS+JT,2))) + ELSE + P(I,5)=PYMASS(K(I,2)) + ENDIF + IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND. + & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2)) + 560 CONTINUE + IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN + KFA1=IABS(MINT(21)) + KFA2=IABS(MINT(22)) + IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21)) + & THEN + MINT(51)=1 + RETURN + ENDIF + P(IPU3,5)=0D0 + P(IPU4,5)=0D0 + ENDIF + P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR) + P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2)) + P(IPU4,4)=SHR-P(IPU3,4) + P(IPU4,3)=-P(IPU3,3) + N=IPU4 + MINT(7)=MINT(83)+7 + MINT(8)=MINT(83)+8 + +C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4) + CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0) + + ELSEIF(IDOC.EQ.9) THEN +C...2 -> 3 processes: store outgoing partons in their CM frame + DO 570 JT=1,2 + I=MINT(84)+2+JT + KCA=PYCOMP(MINT(20+JT)) + K(I,1)=1 + IF(KCHG(KCA,2).NE.0) K(I,1)=3 + K(I,2)=MINT(20+JT) + K(I,3)=MINT(83)+IDOC+JT-3 + JTA=JT +C...t and b in opposide order in event list as compared to +C...matrix element? + IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT + IF(IABS(K(I,2)).LE.22) THEN + P(I,5)=PYMASS(K(I,2)) + ELSE + P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2))) + ENDIF + PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2)) + P(I,1)=PT*COS(VINT(198+5*JTA)) + P(I,2)=PT*SIN(VINT(198+5*JTA)) + 570 CONTINUE + K(IPU5,1)=1 + K(IPU5,2)=KFRES + K(IPU5,3)=MINT(83)+IDOC + P(IPU5,5)=SHR + P(IPU5,1)=-P(IPU3,1)-P(IPU4,1) + P(IPU5,2)=-P(IPU3,2)-P(IPU4,2) + PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2 + PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2 + PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2 + PMT3=SQRT(PMS3) + P(IPU5,3)=PMT3*SINH(VINT(211)) + P(IPU5,4)=PMT3*COSH(VINT(211)) + PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2 + SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2 + IF(SQL12.LE.0D0) THEN + MINT(51)=1 + RETURN + ENDIF + P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+ + & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12) + P(IPU4,3)=-P(IPU3,3)-P(IPU5,3) + IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN +C...t and b in opposide order in event list as compared to +C...matrix element + P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+ + & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12) + P(IPU3,3)=-P(IPU4,3)-P(IPU5,3) + END IF + P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2) + P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2) + MINT(23)=KFRES + N=IPU5 + MINT(7)=MINT(83)+7 + MINT(8)=MINT(83)+8 + + ELSEIF(IDOC.EQ.11) THEN +C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons + PHI(1)=PARU(2)*PYR(0) + PHI(2)=PHI(1)-PHIR + DO 580 JT=1,2 + I=MINT(84)+2+JT + K(I,1)=1 + IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3 + K(I,2)=MINT(20+JT) + K(I,3)=MINT(83)+IDOC+JT-2 + P(I,5)=PYMASS(K(I,2)) + IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN + MINT(51)=1 + RETURN + ENDIF + PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2)) + PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2)) + P(I,1)=PTABS*COS(PHI(JT)) + P(I,2)=PTABS*SIN(PHI(JT)) + P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1) + P(I,4)=0.5D0*SHPR*Z(JT) + IZW=MINT(83)+6+JT + K(IZW,1)=21 + K(IZW,2)=23 + IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))) + K(IZW,3)=IZW-2 + P(IZW,1)=-P(I,1) + P(IZW,2)=-P(I,2) + P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1) + P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT)) + P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2)) + 580 CONTINUE + I=MINT(83)+9 + K(IPU5,1)=1 + K(IPU5,2)=KFRES + K(IPU5,3)=I + P(IPU5,5)=SHR + P(IPU5,1)=-P(IPU3,1)-P(IPU4,1) + P(IPU5,2)=-P(IPU3,2)-P(IPU4,2) + P(IPU5,3)=-P(IPU3,3)-P(IPU4,3) + P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4) + K(I,1)=21 + K(I,2)=KFRES + DO 590 J=1,5 + P(I,J)=P(IPU5,J) + 590 CONTINUE + N=IPU5 + MINT(23)=KFRES + + ELSEIF(IDOC.EQ.12) THEN +C...Z0 and W+/- scattering: store bosons and outgoing partons + PHI(1)=PARU(2)*PYR(0) + PHI(2)=PHI(1)-PHIR + JTRAN=INT(1.5D0+PYR(0)) + DO 600 JT=1,2 + I=MINT(84)+2+JT + K(I,1)=1 + IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3 + K(I,2)=MINT(20+JT) + K(I,3)=MINT(83)+IDOC+JT-2 + P(I,5)=PYMASS(K(I,2)) + IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0 + PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2)) + PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2)) + P(I,1)=PTABS*COS(PHI(JT)) + P(I,2)=PTABS*SIN(PHI(JT)) + P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1) + P(I,4)=0.5D0*SHPR*Z(JT) + IZW=MINT(83)+6+JT + K(IZW,1)=21 + IF(MINT(14+JT).EQ.MINT(20+JT)) THEN + K(IZW,2)=23 + ELSE + K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT))) + ENDIF + K(IZW,3)=IZW-2 + P(IZW,1)=-P(I,1) + P(IZW,2)=-P(I,2) + P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1) + P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT)) + P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2)) + IPU=MINT(84)+4+JT + K(IPU,1)=3 + K(IPU,2)=KFPR(ISUB,JT) + IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2) + IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2) + K(IPU,3)=MINT(83)+8+JT + IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN + P(IPU,5)=PYMASS(K(IPU,2)) + ELSE + P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2))) + ENDIF + MINT(22+JT)=K(IPU,2) + 600 CONTINUE +C...Find rotation and boost for hard scattering subsystem + I1=MINT(83)+7 + I2=MINT(83)+8 + BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4)) + BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4)) + BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4)) + GAMCM=(P(I1,4)+P(I2,4))/SHR + BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3) + PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM + PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM + PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM + THECM=PYANGL(PZ,SQRT(PX**2+PY**2)) + PHICM=PYANGL(PX,PY) +C...Store hard scattering subsystem. Rotate and boost it + SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2* + & P(IPU6,5)**2 + PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH))) + CTHWZ=VINT(23) + STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2)) + PHIWZ=VINT(24)-PHICM + P(IPU5,1)=PABS*STHWZ*COS(PHIWZ) + P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ) + P(IPU5,3)=PABS*CTHWZ + P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2) + P(IPU6,1)=-P(IPU5,1) + P(IPU6,2)=-P(IPU5,2) + P(IPU6,3)=-P(IPU5,3) + P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2) + CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM) + DO 620 JT=1,2 + I1=MINT(83)+8+JT + I2=MINT(84)+4+JT + K(I1,1)=21 + K(I1,2)=K(I2,2) + DO 610 J=1,5 + P(I1,J)=P(I2,J) + 610 CONTINUE + 620 CONTINUE + N=IPU6 + MINT(7)=MINT(83)+9 + MINT(8)=MINT(83)+10 + ENDIF + + IF(ISET(ISUB).EQ.11) THEN + ELSEIF(IDOC.GE.8) THEN +C...Store colour connection indices + DO 630 J=1,2 + JC=J + IF(KCS.EQ.-1) JC=3-J + IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)= + & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC) + IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)= + & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC) + IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)= + & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC)) + IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)= + & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC)) + 630 CONTINUE + +C...Copy outgoing partons to documentation lines + IMAX=2 + IF(IDOC.EQ.9) IMAX=3 + DO 650 I=1,IMAX + I1=MINT(83)+IDOC-IMAX+I + I2=MINT(84)+2+I + K(I1,1)=21 + K(I1,2)=K(I2,2) + IF(IDOC.LE.9) K(I1,3)=0 + IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I + DO 640 J=1,5 + P(I1,J)=P(I2,J) + 640 CONTINUE + 650 CONTINUE + + ELSEIF(IDOC.EQ.9) THEN +C...Store colour connection indices + DO 660 J=1,2 + JC=J + IF(KCS.EQ.-1) JC=3-J + IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)= + & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+ + & MAX(0,MIN(1,ICOL(KCC,1,JC)-2)) + IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)= + & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+ + & MAX(0,MIN(1,ICOL(KCC,2,JC)-2)) + IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)= + & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC)) + IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)= + & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC)) + 660 CONTINUE + +C...Copy outgoing partons to documentation lines + DO 680 I=1,3 + I1=MINT(83)+IDOC-3+I + I2=MINT(84)+2+I + K(I1,1)=21 + K(I1,2)=K(I2,2) + K(I1,3)=0 + DO 670 J=1,5 + P(I1,J)=P(I2,J) + 670 CONTINUE + 680 CONTINUE + ENDIF + +C...Copy outgoing partons to list of allowed radiators. + NPART=0 + IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN + DO 690 I=MINT(84)+3,N + NPART=NPART+1 + IPART(NPART)=I + PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2) + 690 CONTINUE + ENDIF + +C...Low-pT events: remove gluons used for string drawing purposes + IF(ISUB.EQ.95) THEN + IF(MINT(35).LE.1) THEN + K(IPU3,1)=K(IPU3,1)+10 + K(IPU4,1)=K(IPU4,1)+10 + ENDIF + DO 700 J=41,66 + VINTSV(J)=VINT(J) + VINT(J)=0D0 + 700 CONTINUE + DO 720 I=MINT(83)+5,MINT(83)+8 + DO 710 J=1,5 + P(I,J)=0D0 + 710 CONTINUE + 720 CONTINUE + ENDIF + + RETURN + END + +C*********************************************************************** + +C...PYEVOL +C...Handles intertwined pT-ordered spacelike initial-state parton +C...and multiple interactions. + + SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN) +C...Mode = -1 : Initialize first time. Determine MAX and MIN scales. +C...MODE = 0 : (Re-)initialize ISR/MI evolution. +C...Mode = 1 : Evolve event from PT2MAX to PT2MIN. + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...External + EXTERNAL PYALPS + DOUBLE PRECISION PYALPS +C...Parameter statement for maximum size of showers. + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), + & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), + & XMI(2,240),PT2MI(240),IMISEP(0:240) + COMMON/PYCTAG/NCT,MCT(4000,2) + COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240), + & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX + COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240) +C...Local arrays and saved variables. + DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240) + SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3 + & ,PSAV,KSAV,VSAV + + SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/, + & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/ + +C---------------------------------------------------------------------- +C...MODE=-1: Pre-initialization. Store info on hard scattering etc, +C...done only once per event, while MODE=0 is repeated each time the +C...evolution needs to be restarted. + IF (MODE.EQ.-1) THEN + ISUBHD=MINT(1) + NSAV=N + NPARTS=NPART +C...Store hard scattering variables + M15SV=MINT(15) + M16SV=MINT(16) + M21SV=MINT(21) + M22SV=MINT(22) + DO 100 J=11,80 + VINTSV(J)=VINT(J) + 100 CONTINUE + DO 120 J=1,5 + DO 110 IS=1,4 + I=IS+MINT(84) + PSAV(IS,J)=P(I,J) + KSAV(IS,J)=K(I,J) + VSAV(IS,J)=V(I,J) + 110 CONTINUE + 120 CONTINUE + +C...Set shat for hardest scattering + SHAT(1)=VINT(44) + IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26) + & *VINT(2) + +C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below) + RMC=PMAS(4,1) + RMB=PMAS(5,1) + ALAM4=PARP(61) + IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0) + IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0) + ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0) + +C---------------------------------------------------------------------- +C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest +C...interaction initiators, with no previous evolution. Check the input +C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g. +C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be +C...smaller than the CM energy / 2.) + ELSEIF (MODE.EQ.0) THEN +C...Reset counters and switches + N=NSAV + NPART=NPARTS + MINT(30)=0 + MINT(31)=1 + MINT(36)=1 +C...Reset hard scattering variables + MINT(1)=ISUBHD + DO 130 J=11,80 + VINT(J)=VINTSV(J) + 130 CONTINUE + DO 150 J=1,5 + DO 140 IS=1,4 + I=IS+MINT(84) + P(I,J)=PSAV(IS,J) + K(I,J)=KSAV(IS,J) + V(I,J)=VSAV(IS,J) + P(MINT(83)+4+IS,J)=PSAV(IS,J) + V(MINT(83)+4+IS,J)=VSAV(IS,J) + 140 CONTINUE + 150 CONTINUE +C...Reset statistics on activity in event. + DO 160 J=351,359 + MINT(J)=0 + VINT(J)=0D0 + 160 CONTINUE +C...Reset extra companion reweighting factor + VINT(140)=1D0 + +C...We do not generate MI for soft process (ISUB=95), but the +C...initialization must be done regardless, for later purposes. + MINT(36)=1 + +C...Initialize multiple interactions. + CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM) + IF(MINT(51).NE.0) RETURN + +C...Decide whether quarks in hard scattering were valence or sea + PT2HD=VINT(54) + DO 170 JS=1,2 + MINT(30)=JS + CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM) + IF(MINT(51).NE.0) RETURN + 170 CONTINUE + +C...Set lower cutoff for PT2 iteration and colour interference PT2 scale + VINT(18)=0D0 + PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2) + IF (MSTP(70).EQ.2) THEN +C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18)) + VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2 + ELSEIF (MSTP(70).EQ.3) THEN +C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73) + ALPHA0 = MAX(1D-6,PARP(73)) + Q20 = ALAM3**2/PARP(64) + IF (MSTP(64).EQ.3) Q20 = Q20 * 1.661**2 + VINT(18) = Q20 * (EXP(12*PARU(1)/27D0/ALPHA0)-1D0) + ENDIF +C...Also store PT2MIN in VINT(17). + 180 VINT(17)=PT2MIN + +C...Set FS masses zero now. + VINT(63)=0D0 + VINT(64)=0D0 + +C...Initialize IS showers with VINT(56) as max scale. + PT2ISR=VINT(56) + PT20=PT2MIN + IF (MSTP(70).EQ.0) THEN + PT20=MAX(PT2MIN,PARP(62)**2) + ELSEIF (MSTP(70).EQ.1) THEN + PT20=MAX(PT2MIN,(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2) + ENDIF + CALL PYPTIS(-1,PT2ISR,PT20,PT2DUM,IFAIL) + IF(MINT(51).NE.0) RETURN + + RETURN + +C---------------------------------------------------------------------- +C...MODE= 1: Evolve event from PTMAX to PTMIN. + ELSEIF (MODE.EQ.1) THEN + +C...Skip if no phase space. + 190 IF (PT2MAX.LE.PT2MIN) GOTO 330 + +C...Starting pT2 max scale (to be udpated successively). + PT2CMX=PT2MAX + +C...Evolve two sides of the event to find which branches at highest pT. + 200 JSMX=-1 + MIMX=0 + PT2MX=0D0 + +C...Loop over current shower initiators. + IF (MSTP(61).GE.1) THEN + DO 230 MI=1,MINT(31) + IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230 + ISUB=96 + IF (MI.EQ.1) ISUB=ISUBHD + MINT(1)=ISUB + MINT(36)=MI +C...Set up shat, initiator x values, and x remaining in BR. + VINT(44)=SHAT(MI) + VINT(141)=XMI(1,MI) + VINT(142)=XMI(2,MI) + VINT(143)=1D0 + VINT(144)=1D0 + DO 210 JI=1,MINT(31) + IF (JI.EQ.MINT(36)) GOTO 210 + VINT(143)=VINT(143)-XMI(1,JI) + VINT(144)=VINT(144)-XMI(2,JI) + 210 CONTINUE +C...Loop over sides. +C...Generate trial branchings for this interaction. The hardest +C...branching so far is automatically updated if necessary in /PYISMX/. + DO 220 JS=1,2 + MINT(30)=JS + PT20=PT2MIN + IF (MSTP(70).EQ.0) THEN + PT20=MAX(PT2MIN,PARP(62)**2) + ELSEIF (MSTP(70).EQ.1) THEN + PT20=MAX(PT2MIN, + & (PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2) + ENDIF + CALL PYPTIS(0,PT2CMX,PT20,PT2NEW,IFAIL) + IF (MINT(51).NE.0) RETURN + 220 CONTINUE + 230 CONTINUE + ENDIF + +C...Generate trial additional interaction. + MINT(36)=MINT(31)+1 + 240 IF (MOD(MSTP(81),10).GE.1) THEN + MINT(1)=96 +C...Set up X remaining in BR. + VINT(143)=1D0 + VINT(144)=1D0 + DO 250 JI=1,MINT(31) + VINT(143)=VINT(143)-XMI(1,JI) + VINT(144)=VINT(144)-XMI(2,JI) + 250 CONTINUE +C...Generate trial interaction + 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL) + IF (MINT(51).EQ.1) RETURN + ENDIF + +C...And the winner is: + IF (PT2MX.LT.PT2MIN) THEN + GOTO 330 + ELSEIF (JSMX.EQ.0) THEN +C...Accept additional interaction (may still fail). + CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL) + IF(MINT(51).NE.0) RETURN + IF (IFAIL.EQ.0) THEN + SHAT(MINT(36))=VINT(44) +C...Decide on flavours (valence/sea/companion). + DO 270 JS=1,2 + MINT(30)=JS + CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL) + IF(MINT(51).NE.0) RETURN + 270 CONTINUE + ENDIF + ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN +C...Reconstruct kinematics of acceptable ISR branching. +C...Set up shat, initiator x values, and x remaining in BR. + MINT(30)=JSMX + MINT(36)=MIMX + VINT(44)=SHAT(MINT(36)) + VINT(141)=XMI(1,MINT(36)) + VINT(142)=XMI(2,MINT(36)) + VINT(143)=1D0 + VINT(144)=1D0 + DO 280 JI=1,MINT(31) + IF (JI.EQ.MINT(36)) GOTO 280 + VINT(143)=VINT(143)-XMI(1,JI) + VINT(144)=VINT(144)-XMI(2,JI) + 280 CONTINUE + PT2NEW=PT2MX + CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL) + IF (MINT(51).EQ.1) RETURN + ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN +C...Bookeep joining. Cannot (yet) be constructed kinematically. + MINT(354)=MINT(354)+1 + VINT(354)=VINT(354)+SQRT(PT2MX) + IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX) + MJOIND(JSMX-2,MJN1MX)=MJN2MX + MJOIND(JSMX-2,MJN2MX)=MJN1MX + ENDIF + +C...Update PT2 iteration scale. + PT2CMX=PT2MX + +C...Loop back to continue evolution. + IF(N.GT.MSTU(4)-MSTU(32)-10) THEN + CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS') + ELSE + IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200 + ENDIF + +C---------------------------------------------------------------------- +C...MODE= 2: (Re-)store user information on hardest interaction etc. + ELSEIF (MODE.EQ.2) THEN + +C...Revert to "ordinary" meanings of some parameters. + 290 DO 310 JS=1,2 + MINT(12+JS)=K(IMI(JS,1,1),2) + VINT(140+JS)=XMI(JS,1) + IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1) + VINT(142+JS)=1D0 + DO 300 MI=1,MINT(31) + VINT(142+JS)=VINT(142+JS)-XMI(JS,MI) + 300 CONTINUE + 310 CONTINUE + +C...Restore saved quantities for hardest interaction. + MINT(1)=ISUBHD + MINT(15)=M15SV + MINT(16)=M16SV + MINT(21)=M21SV + MINT(22)=M22SV + DO 320 J=11,80 + VINT(J)=VINTSV(J) + 320 CONTINUE + + ENDIF + + 330 RETURN + END + +C********************************************************************* + +C...PYSSPA +C...Generates spacelike parton showers. + + SUBROUTINE PYSSPA(IPU1,IPU2) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,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/PYCTAG/NCT,MCT(4000,2) + SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/, + &/PYINT1/,/PYINT2/,/PYINT3/,/PYCTAG/ +C...Local arrays and data. + DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2), + &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25), + &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4), + &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2), + &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2) + DATA IS/2*0/ + +C...Read out basic information; set global Q^2 scale. + IPUS1=IPU1 + IPUS2=IPU2 + ISUB=MINT(1) + Q2MX=VINT(56) + VINT2R=VINT(2)*VINT(143)*VINT(144) + IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX= + &MIN(VINT2R,PARP(67)*VINT(56)) + FCQ2MX=1D0 + +C...Define which processes ME corrections have been implemented for. + MECOR=0 + IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN + IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR. + & ISUB.EQ.144) MECOR=1 + IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2 + IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3 + ENDIF + +C...Initialize QCD evolution and check phase space. + Q2MNC=PARP(62)**2 + Q2MNCS(1)=Q2MNC + Q2MNCS(2)=Q2MNC + IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN + Q0S=PARP(15)**2 + PS=VINT(3)**2 + Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* + & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) + Q2INT=SQRT(Q0S*Q2EFF) + Q2MNCS(1)=MAX(Q2MNC,Q2INT) + ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN + Q2MNCS(1)=MAX(Q2MNC,VINT(283)) + ENDIF + IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN + Q0S=PARP(15)**2 + PS=VINT(4)**2 + Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))* + & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS))) + Q2INT=SQRT(Q0S*Q2EFF) + Q2MNCS(2)=MAX(Q2MNC,Q2INT) + ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN + Q2MNCS(2)=MAX(Q2MNC,VINT(284)) + ENDIF + MCEV=0 + ALAMS=PARU(112) + PARU(112)=PARP(61) + FQ2C=1D0 + TCMX=0D0 + IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN + MCEV=1 + IF(MSTP(64).EQ.1) FQ2C=PARP(63) + IF(MSTP(64).EQ.2) FQ2C=PARP(64) + TCMX=LOG(FQ2C*Q2MX/PARP(61)**2) + IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0) + & MCEV=0 + ENDIF + +C...Initialize QED evolution and check phase space. + MEEV=0 + XEE=1D-10 + SPME=PMAS(11,1)**2 + IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13) + &SPME=PMAS(13,1)**2 + IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15) + &SPME=PMAS(15,1)**2 + Q2MNE=MAX(PARP(68)**2,2D0*SPME) + TEMX=0D0 + FWTE=10D0 + IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN + MEEV=1 + TEMX=LOG(Q2MX/SPME) + IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0 + ENDIF + IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN + MEEV=2 + TEMX=TCMX + FWTE=1D0 + ENDIF + IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN + +C...Loopback point in case of failure to reconstruct kinematics. + NS=N + NPARTS=NPART + LOOP=0 + MNT352=MINT(352) + MNT353=MINT(353) + VNT352=VINT(352) + VNT353=VINT(353) + 100 LOOP=LOOP+1 + IF(LOOP.GT.100) THEN + MINT(51)=1 + RETURN + ENDIF + N=NS + NPART=NPARTS + MINT(352)=MNT352 + MINT(353)=MNT353 + VINT(352)=VNT352 + VINT(353)=VNT353 + +C...Initial values: flavours, momenta, virtualities. + DO 120 JT=1,2 + MORE(JT)=1 + KFBEAM(JT)=MINT(10+JT) + IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22 + KFLS(JT)=MINT(14+JT) + KFLS(JT+2)=KFLS(JT) + XS(JT)=VINT(40+JT) + IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT) + IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT) + ZS(JT)=1D0 + Q2S(JT)=FCQ2MX*Q2MX + DQ2(JT)=0D0 + TEVCSV(JT)=TCMX + ALAM(JT)=PARP(61) + THE2(JT)=1D0 + TEVESV(JT)=TEMX + MCESV(JT)=0 +C...Calculate initial parton distribution weights. + MINT(105)=MINT(102+JT) + MINT(109)=MINT(106+JT) + VINT(120)=VINT(2+JT) + IF(XS(JT).LT.1D0-XEE) THEN + IF(MINT(31).GE.2) MINT(30)=JT + IF(MSTP(57).LE.1) THEN + CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB) + ELSE + CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB) + ENDIF + ENDIF + DO 110 KFL=-25,25 + XFS(JT,KFL)=XFB(KFL) + 110 CONTINUE +C...Special kinematics check for c/b quarks (that g -> c cbar or +C...b bbar kinematically possible). + KFLCB=IABS(KFLS(JT)) + IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN + IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN + MINT(51)=1 + RETURN + ENDIF + ENDIF + 120 CONTINUE + DSH=VINT(44) + IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2) + +C...Find if interference with final state partons. + MFIS=0 + IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67) + IF(MFIS.NE.0) THEN + DO 140 I=1,2 + KCFI(I)=0 + KCA=PYCOMP(IABS(KFLS(I))) + IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I)) + NFIS(I)=0 + IF(KCFI(I).NE.0) THEN + IF(I.EQ.1) IPFS=IPUS1 + IF(I.EQ.2) IPFS=IPUS2 + DO 130 J=1,2 + ICSI=MOD(K(IPFS,3+J),MSTU(5)) + IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND. + & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN + NFIS(I)=NFIS(I)+1 + THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+ + & P(ICSI,2)**2)) + IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I)) + ENDIF + 130 CONTINUE + ENDIF + 140 CONTINUE + IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0 + ENDIF + +C...Pick up leg with highest virtuality. + JTOLD=1 + 150 N=N+1 + JT=1 + IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2 + IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT + IF(MORE(JT).EQ.0) JT=3-JT + JTOLD=JT + KFLB=KFLS(JT) + XB=XS(JT) + DO 160 KFL=-25,25 + XFB(KFL)=XFS(JT,KFL) + 160 CONTINUE + DSHR=2D0*SQRT(DSH) + DSHZ=DSH/ZS(JT) + +C...Check if allowed to branch. + MCEV=0 + IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN + MCEV=1 + XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0)) + IF(XB.GE.1D0-2D0*XEC) MCEV=0 + ENDIF + MEEV=0 + IF(MINT(44+JT).EQ.3) THEN + MEEV=1 + IF(XB.GE.1D0-2D0*XEE) MEEV=0 + IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC) + & MEEV=0 +C***Currently kill QED shower for resolved photoproduction. + IF(MINT(18+JT).EQ.1) MEEV=0 +C***Currently kill shower for W inside electron. + IF(IABS(KFLB).EQ.24) THEN + MCEV=0 + MEEV=0 + ENDIF + ENDIF + IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10) + &MEEV=2 + IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN + Q2B=0D0 + GOTO 260 + ENDIF + +C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f. + Q2B=Q2S(JT) + TEVCB=TEVCSV(JT) + TEVEB=TEVESV(JT) + IF(MSTP(62).LE.1) THEN + IF(ZS(JT).GT.0.99999D0) THEN + Q2B=Q2S(JT) + ELSE + Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)* + & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+ + & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT)))) + ENDIF + IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2) + IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME) + ENDIF + IF(MCEV.EQ.1) THEN + ALSDUM=PYALPS(FQ2C*Q2B) + TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117)) + ALAM(JT)=PARU(117) + B0=(33D0-2D0*MSTU(118))/6D0 + ENDIF + IF(MEEV.EQ.2) TEVEB=TEVCB + TEVCBS=TEVCB + TEVEBS=TEVEB + +C...Select side for interference with final state partons. + IF(MFIS.GE.1.AND.N.LE.NS+2) THEN + IFI=N-NS + ISFI(IFI)=0 + IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN + ISFI(IFI)=1 + ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN + IF(PYR(0).GT.0.5D0) ISFI(IFI)=1 + ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN + ISFI(IFI)=1 + IF(PYR(0).GT.0.5D0) ISFI(IFI)=2 + ENDIF + ENDIF + +C...Calculate preweighting factor for ME-corrected processes. + IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG) + +C...Calculate Altarelli-Parisi weights. + DO 170 KFL=-25,25 + WTAPC(KFL)=0D0 + WTAPE(KFL)=0D0 + WTSF(KFL)=0D0 + 170 CONTINUE +C...q -> q (g or gamma emission), g -> q. + IF(IABS(KFLB).LE.10) THEN + WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC))) + WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC)) + EQ2=1D0/9D0 + IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2 + IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/ + & (XEC*(1D0-XEC))) + IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN + WTAPC(KFLB)=WTFF*WTAPC(KFLB) + WTAPC(21)=WTGF*WTAPC(21) + WTAPE(KFLB)=WTFF*WTAPE(KFLB) + ENDIF +C...f -> f, gamma -> f. + ELSEIF(IABS(KFLB).LE.20) THEN + WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE))) + WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE))) + WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2) + IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE) + IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN + WTAPE(KFLB)=WTFF*WTAPE(KFLB) + WTAPE(22)=WTGF*WTAPE(22) + ENDIF +C...f -> g, g -> g. + ELSEIF(KFLB.EQ.21) THEN + WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB)) + DO 180 KFL=1,MSTP(58) + WTAPC(KFL)=WTAPQ + WTAPC(-KFL)=WTAPQ + 180 CONTINUE + WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC) + IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN + DO 190 KFL=1,MSTP(58) + WTAPC(KFL)=WTFG*WTAPC(KFL) + WTAPC(-KFL)=WTFG*WTAPC(-KFL) + 190 CONTINUE + WTAPC(21)=WTGG*WTAPC(21) + ENDIF +C...f -> gamma, W+, W-. + ELSEIF(KFLB.EQ.22) THEN + WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB + WTAPE(11)=WTAPF + WTAPE(-11)=WTAPF + IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN + WTAPE(11)=WTFG*WTAPE(11) + WTAPE(-11)=WTFG*WTAPE(-11) + ENDIF + ELSEIF(KFLB.EQ.24) THEN + WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/ + & (XEE*(XB+XEE)))/XB + ELSEIF(KFLB.EQ.-24) THEN + WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/ + & (XEE*(XB+XEE)))/XB + ENDIF + +C...Calculate parton distribution weights and sum. + NTRY=0 + 200 NTRY=NTRY+1 + IF(NTRY.GT.500) THEN + MINT(51)=1 + RETURN + ENDIF + WTSUMC=0D0 + WTSUME=0D0 + XFBO=MAX(1D-10,XFB(KFLB)) + DO 210 KFL=-25,25 + WTSF(KFL)=XFB(KFL)/XFBO + WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL) + WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL) + 210 CONTINUE + WTSUMC=MAX(0.0001D0,WTSUMC) + WTSUME=MAX(0.0001D0/FWTE,WTSUME) + +C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2). + NTRY2=0 + 220 NTRY2=NTRY2+1 + IF(NTRY2.GT.500) THEN + MINT(51)=1 + RETURN + ENDIF + IF(MCEV.EQ.1) THEN + IF(MSTP(64).LE.0) THEN + TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC) + ELSEIF(MSTP(64).EQ.1) THEN + TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC)) + ELSE + TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC))) + ENDIF + ENDIF + IF(MEEV.EQ.1) THEN + TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/ + & (PARU(101)*FWTE*WTSUME*TEMX))) + ELSEIF(MEEV.EQ.2) THEN + TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME) + ENDIF + +C...Translate t into Q2 scale; choose between QCD and QED evolution. + 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C + IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB)) + IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C +C...Ensure that Q2 is above threshold for charm/bottom. + KFLCB=IABS(KFLB) + IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND. + &MCEV.EQ.1) THEN + IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN + Q2CB=1.1D0*PMAS(KFLCB,1)**2 + TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2) + FCQ2MX=MIN(2D0,1.05D0*FCQ2MX) + ENDIF + ENDIF + IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND. + &MEEV.EQ.2) THEN + IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0 + ENDIF + MCE=0 + IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN + ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN + IF(Q2CB.GT.Q2MNCS(JT)) MCE=1 + ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN + IF(Q2EB.GT.Q2MNE) MCE=2 + ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN + IF(Q2EB.GT.Q2MNCS(JT)) MCE=2 + ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN + IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1 + IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2 + ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN + MCE=1 + IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2 + IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0 + ELSE + MCE=2 + IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1 + IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0 + ENDIF + +C...Evolution possibly ended. Update t values. + IF(MCE.EQ.0) THEN + Q2B=0D0 + GOTO 260 + ELSEIF(MCE.EQ.1) THEN + Q2B=Q2CB + Q2REF=FQ2C*Q2B + IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME) + IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2) + ELSE + Q2B=Q2EB + Q2REF=Q2B + IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2) + ENDIF + +C...Select flavour for branching parton. + IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC + IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME + KFLA=-25 + 240 KFLA=KFLA+1 + IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA) + IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA) + IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240 + IF(KFLA.EQ.25) THEN + Q2B=0D0 + GOTO 260 + ENDIF + +C...Choose z value and corrective weight. + WTZ=0D0 +C...q -> q + g or q -> q + gamma. + IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN + Z=1D0-((1D0-XB-XEC)/(1D0-XEC))* + & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0) + WTZ=0.5D0*(1D0+Z**2) +C...q -> g + q. + ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN + Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2 + WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z) +C...f -> f + gamma. + ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN + IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN + Z=1D0-((1D0-XB-XEE)/(1D0-XEE))* + & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0) + ELSE + Z=XB+XB*(XEE/(1D0-XEE))* + & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0) + ENDIF + WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB) +C...f -> gamma + f. + ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN + Z=XB+XB*(XEE/(1D0-XEE))* + & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0) + WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z +C...f -> W+- + f. + ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN + Z=XB+XB*(XEE/(1D0-XEE))* + & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0) + WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)* + & (Q2B/(Q2B+PMAS(24,1)**2)) +C...g -> q + qbar. + ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN + Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC)) + WTZ=1D0-2D0*Z*(1D0-Z) +C...g -> g + g. + ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN + Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0)) + WTZ=(1D0-Z*(1D0-Z))**2 +C...gamma -> f + fbar. + ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN + Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE)) + WTZ=1D0-2D0*Z*(1D0-Z) + ENDIF + IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX) + +C...Option with resummation of soft gluon emission as effective z shift. + IF(MCE.EQ.1) THEN + IF(MSTP(65).GE.1) THEN + RSOFT=6D0 + IF(KFLB.NE.21) RSOFT=8D0/3D0 + Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0)) + IF(Z.LE.XB) GOTO 220 + ENDIF + +C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight. + IF(MSTP(64).GE.2) THEN + IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220 + ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z)) + IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220 + IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0 + ENDIF + ENDIF + +C...Remove kinematically impossible branchings. + UHAT=Q2B-DSH*(1D0-Z)/Z + IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220 + +C...Select phi angle of branching at random. + PHIBR=PARU(2)*PYR(0) + +C...Matrix-element corrections for some processes. + IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN + IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN + CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME) + WTZ=WTZ*WTME/WTFF + ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN + CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME) + WTZ=WTZ*WTME/WTGF + ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN + CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME) + WTZ=WTZ*WTME/WTFG + ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN + CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME) + WTZ=WTZ*WTME/WTGG + ENDIF + ENDIF + +C...Impose angular constraint in first branching from interference +C...with final state partons. + IF(MCE.EQ.1) THEN + IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN + THE2D=(4D0*Q2B)/(DSH*(1D0-Z)) + IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN + IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220 + ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN + IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220 + ENDIF + ENDIF + +C...Option with angular ordering requirement. + IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN + THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R) + IF(THE2T.GT.THE2(JT)) GOTO 220 + ENDIF + ENDIF + +C...Weighting with new parton distributions. + MINT(105)=MINT(102+JT) + MINT(109)=MINT(106+JT) + VINT(120)=VINT(2+JT) + IF(MINT(31).GE.2) MINT(30)=JT + IF(MSTP(57).LE.1) THEN + CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN) + ELSE + CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN) + ENDIF + XFBN=XFN(KFLB) + IF(XFBN.LT.1D-20) THEN + IF(KFLA.EQ.KFLB) THEN + TEVCB=TEVCBS + TEVEB=TEVEBS + WTAPC(KFLB)=0D0 + WTAPE(KFLB)=0D0 + GOTO 200 + ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN + TEVCB=0.5D0*(TEVCBS+TEVCB) + GOTO 230 + ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN + TEVEB=0.5D0*(TEVEBS+TEVEB) + GOTO 230 + ELSE + XFBN=1D-10 + XFN(KFLB)=XFBN + ENDIF + ENDIF + DO 250 KFL=-25,25 + XFB(KFL)=XFN(KFL) + 250 CONTINUE + XA=XB/Z + IF(MINT(31).GE.2) MINT(30)=JT + IF(MSTP(57).LE.1) THEN + CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA) + ELSE + CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA) + ENDIF + XFAN=XFA(KFLA) + IF(XFAN.LT.1D-20) GOTO 200 + WTSFA=WTSF(KFLA) + IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200 + +C...Define two hard scatterers in their CM-frame. + 260 IF(N.EQ.NS+2) THEN + DQ2(JT)=Q2B + DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR + DO 280 JR=1,2 + I=NS+JR + IF(JR.EQ.1) IPO=IPUS1 + IF(JR.EQ.2) IPO=IPUS2 + DO 270 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 270 CONTINUE + K(I,1)=14 + K(I,2)=KFLS(JR+2) + K(I,4)=IPO + K(I,5)=IPO + P(I,3)=DPLCM*(-1)**(JR+1) + P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR + P(I,5)=-SQRT(DQ2(JR)) + K(IPO,1)=14 + K(IPO,3)=I + K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I + K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I + MCT(I,1)=MCT(IPO,1) + MCT(I,2)=MCT(IPO,2) + 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 +C...Only do timelike shower here if using PYSHOW + IF (MSTJ(41).NE.11.AND.MSTJ(41).NE.12) THEN + CALL PYSHOW(IT,0,SQRT(Q2TIM)) + ENDIF + 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)) + MCT(N+1,1)=0 + MCT(N+1,2)=0 + +C...Define colour flow of branching. + K(IS(JT),3)=N+1 + K(IT,3)=N+1 + IM1=N+1 + IM2=N+1 +C...f -> f + gamma (Z, W). + IF(IABS(K(IT,2)).GE.22) THEN + K(IT,1)=1 + ID1=IS(JT) + ID2=IS(JT) +C...f -> gamma (Z, W) + f. + ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN + ID1=IT + ID2=IT +C...gamma -> q + qbar, g + g. + ELSEIF(K(N+1,2).EQ.22) THEN + ID1=IS(JT) + ID2=IT + IM1=ID2 + IM2=ID1 +C...q -> q + g. + ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN + ID1=IT + ID2=IS(JT) +C...q -> g + q. + ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN + ID1=IS(JT) + ID2=IT +C...qbar -> qbar + g. + ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN + ID1=IS(JT) + ID2=IT +C...qbar -> g + qbar. + ELSEIF(K(N+1,2).LT.0) THEN + ID1=IT + ID2=IS(JT) +C...g -> g + g; g -> q + qbar. + ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN + ID1=IS(JT) + ID2=IT + ELSE + ID1=IT + ID2=IS(JT) + ENDIF + IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1 + IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2 + K(ID1,4)=K(ID1,4)+MSTU(5)*IM1 + K(ID2,5)=K(ID2,5)+MSTU(5)*IM2 + IF(ID1.NE.ID2) THEN + K(ID1,5)=K(ID1,5)+MSTU(5)*ID2 + K(ID2,4)=K(ID2,4)+MSTU(5)*ID1 + ENDIF + N=N+1 + IF(K(IT,1).EQ.1) THEN + K(IT,4)=0 + K(IT,5)=0 + ENDIF + +C...Boost to new CM-frame. + DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4)) + DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4)) + IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100 + CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ) + IR=N+(JT-1)*(IS(1)-N) + CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT), + & 0D0,0D0,0D0) + +C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR + IF (MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12) THEN + NPART=NPART+1 + IPART(NPART)=IT + PTPART(NPART)=SQRT(PARP(71)*DPT2) + ENDIF + +C...Global statistics. + MINT(352)=MINT(352)+1 + VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2) + IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2) + + ENDIF + +C...Update kinematics variables. + IS(JT)=N + DQ2(JT)=Q2B + IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T + DSH=DSHZ + +C...Save quantities; loop back. + Q2S(JT)=Q2B + DPHI(JT)=PHIBR + MCESV(JT)=MCE + IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR. + &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN + KFLS(JT+2)=KFLS(JT) + KFLS(JT)=KFLA + XS(JT)=XA + ZS(JT)=Z + DO 310 KFL=-25,25 + XFS(JT,KFL)=XFA(KFL) + 310 CONTINUE + TEVCSV(JT)=TEVCB + TEVESV(JT)=TEVEB + ELSE + MORE(JT)=0 + IF(JT.EQ.1) IPU1=N + IF(JT.EQ.2) IPU2=N + ENDIF + IF(N.GT.MSTU(4)-MSTU(32)-10) THEN + CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS') + IF(MSTU(21).GE.1) N=NS + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150 + +C...Boost hard scattering partons to frame of shower initiators. + DO 320 J=1,3 + ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4)) + 320 CONTINUE + K(N+2,1)=1 + DO 330 J=1,5 + P(N+2,J)=P(NS+1,J) + 330 CONTINUE + CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5)) + ROBO(2)=PYANGL(P(N+2,1),P(N+2,2)) + ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2)) + IMIN=MINT(83)+5 + IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2) + CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0) + CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5)) + +C...Store user information. Reset Lambda value. + IF(MINT(31).LE.1) THEN + K(IPU1,3)=MINT(83)+3 + K(IPU2,3)=MINT(83)+4 + ELSE + K(IPU1,3)=MINT(83)+1 + K(IPU2,3)=MINT(83)+2 + ENDIF + DO 340 JT=1,2 + MINT(12+JT)=KFLS(JT) + VINT(140+JT)=XS(JT) + IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT) + IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT) + 340 CONTINUE + PARU(112)=ALAMS + + RETURN + END + +C********************************************************************* + +C...PYPTIS +C...Generates pT-ordered spacelike initial-state parton showers and +C...trial joinings. +C...MODE=-1: Initialize ISR from scratch, starting from the hardest +C... interaction initiators at PT2NOW. +C...MODE= 0: Generate a trial branching on interaction MINT(36), side +C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2. +C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2 +C... is below PT2CUT. +C... (Also generate test joinings if MSTP(96)=1.) +C...MODE= 1: Accept stored shower branching. Update event record etc. +C...PT2NOW : Starting (max) PT2 scale for evolution. +C...PT2CUT : Lower limit for evolution. +C...PT2 : Result of evolution. Generated PT2 for trial emission. +C...IFAIL : Status return code. IFAIL=0 when all is well. + + SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement for maximum size of showers. + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), + & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), + & XMI(2,240),PT2MI(240),IMISEP(0:240) + COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240), + & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX + COMMON/PYCTAG/NCT,MCT(4000,2) + COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240) + SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/, + & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/ +C...Local variables + DIMENSION ZSAV(2,240),PT2SAV(2,240), + & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25), + & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240), + & WTAPJ(240),WTPDFJ(240),X1(240),Y(240) + SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW, + & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI +C...For check on excessive weights. + CHARACTER CHWT*12 + +C...Only give errors for very large weights, otherwise just warnings + DATA WTEMAX /1.5D0/ +C...Only give errors for large pT, otherwise just warnings + DATA PTEMAX /5D0/ + + IFAIL=-1 + +C---------------------------------------------------------------------- +C...MODE=-1: Initialize initial state showers from scratch, i.e. +C...starting from the hardest interaction initiators. + IF (MODE.EQ.-1) THEN +C...Set hard scattering SHAT. + SHTNOW(1)=VINT(44) +C...Mass thresholds and Lambda for QCD evolution. + AEM2PI=PARU(101)/PARU(2) + RMB=PMAS(5,1) + RMC=PMAS(4,1) + ALAM4=PARP(61) + IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0) + IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0) + ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0) + ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0) +C...Optionally use Lambda_MC = Lambda_CMW + IF (MSTP(64).EQ.3) THEN + ALAM5 = ALAM5 * 1.569 + ALAM4 = ALAM4 * 1.618 + ALAM3 = ALAM3 * 1.661 + ENDIF + RMB2=RMB**2 + RMC2=RMC**2 +C...Massive quark forced creation threshold (in M**2). + TMIN=1.01D0 +C...Set upper limit for X (ensures some X left for beam remnant). + XMXC=1D0-2D0*PARP(111)/VINT(1) + + IF (MSTP(61).GE.1) THEN +C...Initial values: flavours, momenta, virtualities. + DO 100 JS=1,2 + NISGEN(JS,1)=0 + +C...Special kinematics check for c/b quarks (that g -> c cbar or +C...b bbar kinematically possible). + KFLB=K(IMI(JS,1,1),2) + KFLCB=IABS(KFLB) + IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN +C...Check PT2MAX > mQ^2 + IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN + CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '// + & 'No Q creation possible.') + MINT(51)=1 + RETURN + ELSE +C...Check for physical z values (m == MQ / sqrt(s)) +C...For creation diagram, x < z < (1-m)/(1+m(1-m)) + FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1)) + ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ)) + IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN + CALL PYERRM(9,'(PYPTIS:) No physical z value for '// + & 'Q creation.') + MINT(51)=1 + RETURN + ENDIF + ENDIF + ENDIF + 100 CONTINUE + ENDIF + + MINT(354)=0 +C...Zero joining array + DO 110 MJ=1,240 + MJOIND(1,MJ)=0 + MJOIND(2,MJ)=0 + 110 CONTINUE + +C---------------------------------------------------------------------- +C...MODE= 0: Generate a trial branching on interaction MINT(36) side +C...MINT(30). Store if emission PT2 scale is largest so far. +C...Also generate test joinings if MSTP(96)=1. + ELSEIF(MODE.EQ.0) THEN + IFAIL=-1 + MECOR=0 + ISUB=MINT(1) + JS=MINT(30) +C...No shower for structureless beam + IF (MINT(44+JS).EQ.1) RETURN + MI=MINT(36) + SHAT=VINT(44) +C...Absolute shower max scale = VINT(56) + IF (MSTP(67).NE.0) THEN + PT2 = MIN(PT2NOW,VINT(56)) + ELSE +C...For MSTP(67)=0, adjust starting scale by PARP(67) + PT2=MIN(PT2NOW,PARP(67)*VINT(56)) + ENDIF + IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT +C...Define for which processes ME corrections have been implemented. + IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN + IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ + & .142.OR.ISUB.EQ.144) MECOR=1 + IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2 + IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3 +C...Calculate preweighting factor for ME-corrected processes. + IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG) + ENDIF +C...Basic info on daughter for which to find mother. + KFLB=K(IMI(JS,MI,1),2) + KFLBA=IABS(KFLB) +C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for +C...second companion. + KSVCB=MAX(-1,IMI(JS,MI,2)) +C...Treat "first" companion of a pair like an ordinary sea quark +C...(except that creation diagram is not allowed) + IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1 +C...X (rescaled to [0,1]) + XB=XMI(JS,MI)/VINT(142+JS) +C...Massive quarks (use physical masses.) + RMQ2=0D0 + MQMASS=0 + IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN + RMQ2=RMC2 + IF (KFLBA.EQ.5) RMQ2=RMB2 +C...Special threshold treatment for non-photon beams + IF (KFBEAM(JS).NE.22) MQMASS=KFLBA +C...Check that not below mass threshold. + IF(MQMASS.GT.0.AND.PT2.LT.TMIN*RMQ2) THEN + CALL PYERRM(9,'(PYPTIS:) PT2 < 1.01 * MQ**2. '// + & 'No Q creation possible.') + MINT(51)=1 +C...Special return code if failing before any evolution at all: bad event + IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2 + RETURN + ENDIF + + ENDIF + +C...Flags for parton distribution calls. + MINT(105)=MINT(102+JS) + MINT(109)=MINT(106+JS) + VINT(120)=VINT(2+JS) + +C...Calculate initial parton distribution weights. + IF(XB.GE.XMXC) THEN + RETURN + ELSEIF(MQMASS.EQ.0) THEN + CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB) + ELSE +C...Initialize massive quark PT2 dependent pdf underestimate. + PT20=PT2 + CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB) +C.!.Tentative treatment of massive valence quarks. + XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB)) + XG0=XFB(21) + TPM0=LOG(PT20/RMQ2) + WPDF0=TPM0*XG0/XQ0 + ENDIF + IF (KFLBA.LE.6) THEN +C...For quarks, only include respective sea, val, or cmp part. + IF (KSVCB.LE.0) THEN + XFB(KFLB)=XPSVC(KFLB,KSVCB) + ELSE +C...Find companion's companion + MISEA=0 + 120 MISEA=MISEA+1 + IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120 + XS=XMI(JS,MISEA) + XREM=VINT(142+JS) + YS=XS/(XREM+XS) +C...Momentum fraction of the companion quark. +C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS). + YB=XB*(1D0-YS) + XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87)) + ENDIF + ENDIF + +C...Determine overestimated z range: switch at c and b masses. + 130 IF (PT2.GT.TMIN*RMB2) THEN + IZRG=3 + PT2MNE=MAX(TMIN*RMB2,PT2CUT) + B0=23D0/6D0 + ALAM2=ALAM5**2 + ELSEIF(PT2.GT.TMIN*RMC2) THEN + IZRG=2 + PT2MNE=MAX(TMIN*RMC2,PT2CUT) + B0=25D0/6D0 + ALAM2=ALAM4**2 + ELSE + IZRG=1 + PT2MNE=PT2CUT + B0=27D0/6D0 + ALAM2=ALAM3**2 + ENDIF +C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64)) + ALAM2=ALAM2/PARP(64) +C...Overestimated ZMAX: + IF (MQMASS.EQ.0) THEN +C...Massless + ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI) + & /PT2MNE)-1D0) + ELSE +C...Massive (limit for bremsstrahlung diagram > creation) + FMQ=SQRT(RMQ2/SHTNOW(MI)) + ZMAX=1D0/(1D0+FMQ) + ENDIF + ZMIN=XB/XMXC + +C...If kinematically impossible then do not evolve. + IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN + +C...Reset Altarelli-Parisi and PDF weights. + DO 140 KFL=-5,5 + WTAP(KFL)=0D0 + WTPDF(KFL)=0D0 + 140 CONTINUE + WTAP(21)=0D0 + WTPDF(21)=0D0 +C...Zero joining weights and compute X(partner) and X(mother) values. + NJN=0 + IF (MSTP(96).NE.0) THEN + DO 150 MJ=1,MINT(31) + WTAPJ(MJ)=0D0 + WTPDFJ(MJ)=0D0 + X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ)) + Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ) + & +XMI(JS,MI)) + 150 CONTINUE + ENDIF + +C...Approximate Altarelli-Parisi weights (integrated AP dz). +C...q -> q, g -> q or q -> q + gamma (already set which). + IF(KFLBA.LE.5) THEN +C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps. + IF (KSVCB.LT.0) THEN + WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX)) + ELSE + RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN)) + RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX)) + WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN) + ENDIF + WTAP(21)=0.5D0*(ZMAX-ZMIN) + WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX)) + IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE + IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN + WTAP(KFLB)=WTFF*WTAP(KFLB) + WTAP(21)=WTGF*WTAP(21) + WTAPE=WTFF*WTAPE + ENDIF + IF(MSTP(61).EQ.1) WTAPE=0D0 + IF (KSVCB.GE.1) THEN +C...Kill normal creation but add joining diagrams for cmp quark. + WTAP(21)=0D0 + IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN + CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'// + & " quark here. Not handled yet, giving up!") + PT2=0D0 + MINT(51)=1 + RETURN + ENDIF +C...Check for possible joinings + IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN +C...Find companion's companion. + MJ=0 + 160 MJ=MJ+1 + IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160 + IF (MJOIND(JS,MJ).EQ.0) THEN + Y(MI)=YB+YS + Z=YB/Y(MI) + WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2) + IF (WTAPJ(MJ).GT.1D-6) THEN + NJN=1 + ELSE + WTAPJ(MJ)=0D0 + ENDIF + ENDIF +C...Add trial gluon joinings. + DO 170 MJ=1,MINT(31) + KFLC=K(IMI(JS,MJ,1),2) + IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170 + Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ)) + WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2) + IF (WTAPJ(MJ).GT.1D-6) THEN + NJN=NJN+1 + ELSE + WTAPJ(MJ)=0D0 + ENDIF + 170 CONTINUE + ENDIF + ELSEIF (IMI(JS,MI,2).GE.0) THEN +C...Kill creation diagram for val quarks and sea quarks with companions. + WTAP(21)=0D0 + ELSEIF (MQMASS.EQ.0) THEN +C...Extra safety factor for massless sea quark creation. + WTAP(21)=WTAP(21)*1.25D0 + ENDIF + +C... q -> g, g -> g. + ELSEIF(KFLB.EQ.21) THEN +C...Here we decide later whether a quark picked up is valence or +C...sea, so we maintain the extra factor sqrt(z) since we deal +C...with the *sum* of sea and valence in this context. + WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX)) +C...new: do not allow backwards evol to pick up heavy flavour. + DO 180 KFL=1,MIN(3,MSTP(58)) + WTAP(KFL)=WTAPQ + WTAP(-KFL)=WTAPQ + 180 CONTINUE + WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX))) + IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN + WTAPQ=WTFG*WTAPQ + WTAP(21)=WTGG*WTAP(21) + ENDIF +C...Check for possible joinings (companions handled separately above) + IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0) + & THEN + DO 190 MJ=1,MINT(31) + IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190 + KSVCC=IMI(JS,MJ,2) + IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1 + IF (KSVCC.GE.1) GOTO 190 + KFLC=K(IMI(JS,MJ,1),2) +C...Only try g -> g + g once. + IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190 + Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ)) + IF (KFLC.EQ.21) THEN + WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2) + ELSE + WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2) + ENDIF + IF (WTAPJ(MJ).GT.1D-6) THEN + NJN=NJN+1 + ELSE + WTAPJ(MJ)=0D0 + ENDIF + 190 CONTINUE + ENDIF + ENDIF + +C...Initialize massive quark evolution + IF (MQMASS.NE.0) THEN + RML=(RMQ2+VINT(18))/ALAM2 + TML=LOG(RML) + TPL=LOG((PT2+VINT(18))/ALAM2) + TPM=LOG((PT2+VINT(18))/RMQ2) + WN=WTAP(21)*WPDF0/B0 + ENDIF + + +C...Loopback point for iteration + NTRY=0 + NTHRES=0 + 200 NTRY=NTRY+1 + IF(NTRY.GT.500) THEN + CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.') + MINT(51)=1 + RETURN + ENDIF + +C... Calculate PDF weights and sum for evolution rate. + WTSUM=0D0 + XFBO=MAX(1D-10,XFB(KFLB)) + DO 210 KFL=-5,5 + WTPDF(KFL)=XFB(KFL)/XFBO + WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL) + 210 CONTINUE +C...Only add gluon mother diagram for massless KFLB. + IF(MQMASS.EQ.0) THEN + WTPDF(21)=XFB(21)/XFBO + WTSUM=WTSUM+WTAP(21)*WTPDF(21) + ENDIF + WTSUM=MAX(0.0001D0,WTSUM) + WTSUMS=WTSUM +C...Add joining diagrams where applicable. + WTJOIN=0D0 + IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN + DO 220 MJ=1,MINT(31) + IF (WTAPJ(MJ).LT.1D-3) GOTO 220 + WTPDFJ(MJ)=1D0/XFBO +C...x and x*pdf (+ sea/val) for parton C. + KFLC=K(IMI(JS,MJ,1),2) + KFLCA=IABS(KFLC) + KSVCC=MAX(-1,IMI(JS,MJ,2)) + IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1 + MINT(30)=JS + MINT(36)=MJ + CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ) + MINT(36)=MI + IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN + XFJ(KFLC)=XPSVC(KFLC,KSVCC) + ELSEIF (KSVCC.GE.1) THEN + print*, 'error! parton C is companion!' + ENDIF + WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC) +C...x and x*pdf (+ sea/val) for parton A. + KFLA=21 + KSVCA=0 + IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN + KFLA=KFLB + KSVCA=KSVCB + ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN + KFLA=KFLC + KSVCA=KSVCC + ENDIF + MINT(30)=JS + IF (KSVCA.LE.0) THEN +C...Consider C the "evolved" parton if B is gluon. Val/sea +C...counting will then be done correctly in PYPDFU. + IF (KFLBA.EQ.21) MINT(36)=MJ + CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ) + MINT(36)=MI + IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA) + ELSE +C...If parton A is companion, use Y(MI) and YS in call to PYFCMP. + XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87)) + ENDIF + WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ) + WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ) + 220 CONTINUE + ENDIF + +C...Pick normal pT2 (in overestimated z range). + 230 PT2OLD=PT2 + WTSUM=WTSUMS + PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18) + KFLC=21 + +C...Evolve q -> q gamma separately, pick it if larger pT. + IF(KFLBA.LE.5.AND.MSTP(61).GE.2) THEN + PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18) + IF(PT2QED.GT.PT2) THEN + PT2=PT2QED + KFLC=22 + KFLA=KFLB + ENDIF + ENDIF + +C... Evolve massive quark creation separately. + MCRQQ=0 + IF (MQMASS.NE.0) THEN + PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM))) + & -VINT(18) +C...If massive quark also on opposite side, ensure sufficient remaining +C...phase space also for creation of that quark + TMINQQ = TMIN + KFLOPP = K(IMI(3-JS,MI,1),2) + IF (ABS(KFLOPP).EQ.4.OR.ABS(KFLOPP).EQ.5) TMINQQ = 1.05 +C...Ensure mininimum PT2CR and force creation near threshold. + IF (PT2CR.LT.TMINQQ*RMQ2) THEN + NTHRES=NTHRES+1 + IF (NTHRES.GT.50) THEN + CALL PYERRM(9,'(PYPTIS:) no phase space left for '// + & 'massive quark creation. Gave up trying.') + MINT(51)=1 +C...Special return code if failing before any evolution at all: bad event + IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2 + RETURN + ENDIF + PT2=0D0 + PT2CR=TMINQQ*RMQ2 +C...Signal that massive quark creation is being forced + MCRQQ=2 + ENDIF +C... Select largest PT2 (brems or creation): + IF (PT2CR.GT.PT2) THEN + MCRQQ=MAX(MCRQQ,1) + WTSUM=0D0 + PT2=PT2CR + KFLA=21 + ELSE + MCRQQ=0 + KFLA=KFLB + ENDIF +C... Compute logarithms for this PT2 + TPL=LOG((PT2+VINT(18))/ALAM2) + TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18))) + WTCRQQ=TPM/LOG(PT2/RMQ2) + ENDIF + +C...Evolve joining separately + MJOIN=0 + IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN + PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN)) + & -VINT(18) + IF (PT2JN.GE.PT2) THEN + MJOIN=1 + PT2=PT2JN + ENDIF + ENDIF + +C...Loopback if crossed c/b mass thresholds. + IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN + PT2=RMB2 + GOTO 130 + ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN + PT2=RMC2 + GOTO 130 + ENDIF + +C...Speed up shower. Skip if higher-PT acceptable branching +C...already found somewhere else. +C...Also finish if below lower cutoff. + + IF ((PT2-PT2MX).LT.-0.001.OR.PT2.LT.PT2CUT) RETURN + +C...Select parton A flavour (massive Q handled above.) + IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN + WTRAN=PYR(0)*WTSUM + KFLA=-6 + 240 KFLA=KFLA+1 + WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA) + IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240 + IF(KFLA.EQ.6) KFLA=21 + ELSEIF (MJOIN.EQ.1) THEN +C...Tentative joining accept/reject. + WTRAN=PYR(0)*WTJOIN + MJ=0 + 250 MJ=MJ+1 + WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ) + IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250 + IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN + CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'// + & ' Rejected.') + GOTO 230 + ENDIF +C...x*pdf (+ sea/val) at new pT2 for parton B. + IF (KSVCB.LE.0) THEN + MINT(30)=JS + CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB) + IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB) + ELSE +C...Companion distributions do not evolve. + XFB(KFLB)=XFBO + ENDIF + WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB) + KFLC=K(IMI(JS,MJ,1),2) + KFLCA=IABS(KFLC) + KSVCC=MAX(-1,IMI(JS,MJ,2)) + IF (KSVCB.GE.1) KSVCC=-1 +C...x*pdf (+ sea/val) at new pT2 for parton C. + MINT(30)=JS + MINT(36)=MJ + CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ) + MINT(36)=MI + IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC) + WTVETO=WTVETO/XFJ(KFLC) +C...x and x*pdf (+ sea/val) at new pT2 for parton A. + KFLA=21 + KSVCA=0 + IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN + KFLA=KFLB + KSVCA=KSVCB + ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN + KFLA=KFLC + KSVCA=KSVCC + ENDIF + IF (KSVCA.LE.0) THEN + MINT(30)=JS + IF (KFLB.EQ.21) MINT(36)=MJ + CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ) + MINT(36)=MI + IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA) + ELSE + XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87)) + ENDIF + WTVETO=WTVETO*XFJ(KFLA) +C...Monte Carlo veto. + IF (WTVETO.LT.PYR(0)) GOTO 200 +C...If accept, save PT2 of this joining. + IF (PT2.GT.PT2MX) THEN + PT2MX=PT2 + JSMX=2+JS + MJN1MX=MJ + MJN2MX=MI + WTAPJ(MJ)=0D0 + NJN=0 + ENDIF +C...Exit and continue evolution. + GOTO 390 + ENDIF + KFLAA=IABS(KFLA) + +C...Choose z value (still in overestimated range) and corrective weight. +C...Unphysical z will be rejected below when Q2 has is computed. + WTZ=0D0 + +C...Note: ME and MQ>0 give corrections to overall weights, not shapes. +C...q -> q + g or q -> q + gamma (already set which). + IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN + IF (KSVCB.LT.0) THEN + Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0) + ELSE + ZFAC=RMIN*(RMAX/RMIN)**PYR(0) + Z=((1-ZFAC)/(1+ZFAC))**2 + ENDIF + WTZ=0.5D0*(1D0+Z**2) +C...Massive weight correction. + IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2 +C...Valence quark weight correction (extra sqrt) + IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z) + +C...q -> g + q. +C...NB: MQ>0 not yet implemented. Forced absent above. + ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN + KFLC=KFLA + Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2 + WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z) + +C...g -> q + qbar. + ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN + KFLC=-KFLB + Z=ZMIN+PYR(0)*(ZMAX-ZMIN) + WTZ=Z**2+(1D0-Z)**2 +C...Massive correction + IF (MQMASS.NE.0) THEN + WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2 +C...Extra safety margin for light sea quark creation + ELSEIF (KSVCB.LT.0) THEN + WTZ=WTZ/1.25D0 + ENDIF + +C...g -> g + g. + ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN + KFLC=21 + Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/ + & (ZMAX*(1D0-ZMIN)))**PYR(0)) + WTZ=(1D0-Z*(1D0-Z))**2 + ENDIF + +C...Derive Q2 from pT2. + Q2B=PT2/(1D0-Z) + IF (KFLBA.GE.4) Q2B=Q2B-RMQ2 + +C...Loopback if outside allowed z range for given pT2. + RM2C=PYMASS(KFLC)**2 + PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI) + IF (PT2ADJ.LT.1D-6) GOTO 230 + +C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62) +C...No modification for very first emission if using ME correction + MSTP67 = MSTP(67) + IF (MECOR.GE.1.AND.NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) THEN + MSTP67 = 0 + ENDIF + +C...For 1st branching, limit phase space by s-hat with color-partner + IF (MSTP67.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN + MSIDE=1 + IDIP=IMI(JS,MI,1) +C...Use anticolor tag for antiquark, or for gluon half the time + IF ((KFLB.LT.0.AND.KFLBA.LT.10).OR.( + & KFLB.EQ.21.AND.PYR(0).GT.0.5)) MSIDE=2 +C...Tag + MCTAG=MCT(IDIP,MSIDE) +C...Default is to set up phase space using the opposite incoming parton + JDIP=IMI(3-JS,MI,1) + NDIP=0 +C...Alternatively, look for final-state color partner (pick first if several) + DO 260 IFS=1,NPART + IF (MCT(IPART(IFS),MSIDE).EQ.MCTAG.AND.NDIP.EQ.0) THEN + JDIP=IPART(IFS) + NDIP=NDIP+1 + ENDIF + 260 CONTINUE +C...Compute momentum transfer: sdip = -t = - (p1 - p2)^2 +C...(also works for annihilation since incoming massless, so shat = -(p1 - p2)^2) + SDIP=ABS(((P(IDIP,4)-P(JDIP,4))**2-(P(IDIP,3)-P(JDIP,3))**2 + & -(P(IDIP,2)-P(JDIP,2))**2-(P(IDIP,1)-P(JDIP,1))**2)) + IF (MSTP67.EQ.1) THEN +C...1 Option to completely kill radiation above s_dip * PARP(67) + IF (4D0*PT2.GT.PARP(67)*SDIP) GOTO 230 + ELSE IF (MSTP67.EQ.2) THEN +C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67) +C... (-> improved power showers?) + IF (4D0*PT2*PYR(0).GT.PARP(67)*SDIP) GOTO 230 + ENDIF + +C...For subsequent branchings, loopback if nonordered in angle/rapidity + ELSE IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN + IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI)) + & GOTO 230 + ENDIF + +C...Select phi angle of branching at random. + PHI=PARU(2)*PYR(0) + +C...Matrix-element corrections for some processes. + IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN + IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN + CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME) + WTZ=WTZ*WTME/WTFF + ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN + CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME) + WTZ=WTZ*WTME/WTGF + ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN + CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME) + WTZ=WTZ*WTME/WTFG + ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN + CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME) + WTZ=WTZ*WTME/WTGG + ENDIF + ENDIF + +C...Parton distributions at new pT2 but old x. + MINT(30)=JS + CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN) +C...Treat val and cmp separately + IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB) + IF (KSVCB.GE.1) + & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87)) + XFBN=XFN(KFLB) + IF(XFBN.LT.1D-20) THEN + IF(KFLA.EQ.KFLB) THEN + WTAP(KFLB)=0D0 + GOTO 200 + ELSE + XFBN=1D-10 + XFN(KFLB)=XFBN + ENDIF + ENDIF + DO 270 KFL=-5,5 + XFB(KFL)=XFN(KFL) + 270 CONTINUE + XFB(21)=XFN(21) + +C...Parton distributions at new pT2 and new x. + XA=XB/Z + MINT(30)=JS + CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA) + IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN +C...q -> q + g: only consider respective sea, val, or cmp content. + IF (KSVCB.LE.0) THEN + XFA(KFLA)=XPSVC(KFLA,KSVCB) + ELSE + YA=XA*(1D0-YS) + XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87)) + ENDIF + ENDIF + XFAN=XFA(KFLA) + IF(XFAN.LT.1D-20) THEN + GOTO 200 + ENDIF + +C...If weighting fails continue evolution. + WTTOT=0D0 + IF (MCRQQ.EQ.0) THEN + WTPDFA=1D0/WTPDF(KFLA) + WTTOT=WTZ*XFAN/XFBN*WTPDFA + ELSEIF(MCRQQ.EQ.1) THEN + WTPDFA=TPM/WPDF0 + WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA + XBEST=TPM/TPM0*XQ0 + ELSEIF(MCRQQ.EQ.2) THEN +C...Force massive quark creation. + WTTOT=1D0 + ENDIF + +C...Loop back if trial emission fails. + IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200 + WTACC=((1D0+PT2)/(0.25D0+PT2))**2 + IF(WTTOT.LT.0D0) THEN + WRITE(CHWT,'(1P,E12.4)') WTTOT + CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative') + ELSEIF(WTTOT.GT.WTACC) THEN + WRITE(CHWT,'(1P,E12.4)') WTTOT + IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN +C...Too high weight: write out as error, but do not update error counter + IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1 + CALL PYERRM(19, + & '(PYPTIS:) Weight '//CHWT//' above unity') + IF (PT2.GT.PTEMAX) PTEMAX=PT2 + IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT + ELSE + CALL PYERRM(9, + & '(PYPTIS:) Weight '//CHWT//' above unity') + ENDIF +C...Useful for debugging but commented out for distribution: +C print*, 'JS, MI',JS, MI +C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ +C print*, 'A -> B C',KFLA, KFLB, KFLC +C XFAO=XFBO/WTPDFA +C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN + ENDIF + +C...Special for PT2 = PT2MX (e.g., if two incoming massive quarks +C...simultaneously reached their creation thresholds) + IF (ABS(PT2-PT2MX).LT.0.001) THEN + IF (PYR(0).GT.0.5) PT2=1.0001*PT2MX + ENDIF + +C...Save acceptable branching. + IF(PT2.GT.PT2MX) THEN + MIMX=MINT(36) + JSMX=JS + PT2MX=PT2 + KFLAMX=KFLA + KFLCMX=KFLC + RM2CMX=RM2C + Q2BMX=Q2B + ZMX=Z + PT2AMX=PT2ADJ + PHIMX=PHI + ENDIF + +C---------------------------------------------------------------------- +C...MODE= 1: Accept stored shower branching. Update event record etc. + ELSEIF (MODE.EQ.1) THEN + MI=MIMX + JS=JSMX + SHAT=SHTNOW(MI) + SIDE=3D0-2D0*JS +C...Shift down rest of event record to make room for insertion. + IT=IMISEP(MI)+1 + IM=IT+1 + IS=IMI(JS,MI,1) + DO 290 I=N,IT,-1 + IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2 + KT1=K(I,4)/MSTU(5)**2 + KT2=K(I,5)/MSTU(5)**2 + ID1=MOD(K(I,4),MSTU(5)) + ID2=MOD(K(I,5),MSTU(5)) + IM1=MOD(K(I,4)/MSTU(5),MSTU(5)) + IM2=MOD(K(I,5)/MSTU(5),MSTU(5)) + IF (ID1.GE.IT) ID1=ID1+2 + IF (ID2.GE.IT) ID2=ID2+2 + IF (IM1.GE.IT) IM1=IM1+2 + IF (IM2.GE.IT) IM2=IM2+2 + K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1 + K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2 + DO 280 IX=1,5 + K(I+2,IX)=K(I,IX) + P(I+2,IX)=P(I,IX) + V(I+2,IX)=V(I,IX) + 280 CONTINUE + MCT(I+2,1)=MCT(I,1) + MCT(I+2,2)=MCT(I,2) + 290 CONTINUE + N=N+2 +C...Also update shifted-down pointers in IMI, IMISEP, and IPART. + DO 300 JI=1,MINT(31) + IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2 + IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2 + IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2 + IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2 + IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2 +C...Also update companion pointers to the present mother. + IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM + 300 CONTINUE + DO 310 IFS=1,NPART + IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2 + 310 CONTINUE +C...Zero entries dedicated for new timelike and mother partons. + DO 330 I=IT,IT+1 + DO 320 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 320 CONTINUE + MCT(I,1)=0 + MCT(I,2)=0 + 330 CONTINUE + +C...Define timelike and new mother partons. History. + K(IT,1)=3 + K(IT,2)=KFLCMX + K(IM,1)=14 + K(IM,2)=KFLAMX + K(IS,3)=IM + K(IT,3)=IM +C...Set mother origin = side. + K(IM,3)=MINT(83)+JS+2 + IF(MI.GE.2) K(IM,3)=MINT(83)+JS + +C...Define colour flow of branching. + IM1=IM + IM2=IM +C...q -> q + gamma. + IF(K(IT,2).EQ.22) THEN + K(IT,1)=1 + ID1=IS + ID2=IS +C...q -> q + g. + ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN + ID1=IT + ID2=IS +C...q -> g + q. + ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN + ID1=IS + ID2=IT +C...qbar -> qbar + g. + ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN + ID1=IS + ID2=IT +C...qbar -> g + qbar. + ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN + ID1=IT + ID2=IS +C...g -> g + g; g -> q + qbar.. + ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN + ID1=IS + ID2=IT + ELSE + ID1=IT + ID2=IS + ENDIF + IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1 + IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2 + K(ID1,4)=K(ID1,4)+MSTU(5)*IM1 + K(ID2,5)=K(ID2,5)+MSTU(5)*IM2 + IF(ID1.NE.ID2) THEN + K(ID1,5)=K(ID1,5)+MSTU(5)*ID2 + K(ID2,4)=K(ID2,4)+MSTU(5)*ID1 + ENDIF + IF(K(IT,1).EQ.1) THEN + K(IT,4)=0 + K(IT,5)=0 + ENDIF +C...Update IMI and colour tag arrays. + IMI(JS,MI,1)=IM + DO 340 MC=1,2 + MCT(IT,MC)=0 + MCT(IM,MC)=0 + 340 CONTINUE + DO 350 JCS=4,5 + KCS=JCS +C...If mother flag not yet set for spacelike parton, trace it. + IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM) + IF(MINT(51).NE.0) RETURN + 350 CONTINUE + DO 360 JCS=4,5 + KCS=JCS +C...If mother flag not yet set for timelike parton, trace it. + IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM) + IF(MINT(51).NE.0) RETURN + 360 CONTINUE + +C...Boost recoiling parton to compensate for Q2 scale. + BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/ + & (1D0+(1D0+Q2BMX/SHAT)**2) + IR=IMI(3-JS,MI,1) + CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ) + +C...Define system to be rotated and boosted +C...(not including the 2 just added partons) +C...(but including the docu lines for first interaction) + IMIN=IMISEP(MI-1)+1 + IF (MI.EQ.1) IMIN=MINT(83)+5 + IMAX=IMISEP(MI)-2 + +C...Rotate back system in phi to compensate for subsequent rotation. + CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0) + +C...Define kinematics of new partons in old frame. + IMAX=IMISEP(MI) + P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX)) + P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT + & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE + P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2) + P(IT,1)=P(IM,1) + P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE + P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX) + P(IT,5)=SQRT(RM2CMX) + +C...Update internal line, now spacelike + P(IS,1)=P(IM,1)-P(IT,1) + P(IS,2)=P(IM,2)-P(IT,2) + P(IS,3)=P(IM,3)-P(IT,3) + P(IS,4)=P(IM,4)-P(IT,4) + P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2 +C...Represent spacelike virtualities as -sqrt(abs(Q2)) . + IF (P(IS,5).LT.0D0) THEN + P(IS,5)=-SQRT(ABS(P(IS,5))) + ELSE + P(IS,5)=SQRT(P(IS,5)) + ENDIF + +C...Boost entire system and rotate to new frame. +C...(including docu lines) + BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4)) + BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4)) + IF(BETAX**2+BETAZ**2.GE.1D0) THEN + CALL PYERRM(1,'(PYPTIS:) boost bigger than unity') + MINT(51)=1 + IFAIL=-1 + RETURN + ENDIF + CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ) + I1=IMI(1,MI,1) + THETA=PYANGL(P(I1,3),P(I1,1)) + CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0) + +C...Global statistics. + MINT(352)=MINT(352)+1 + VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2) + IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2) + +C...Add parton with relevant pT scale for timelike shower. + IF (K(IT,2).NE.22) THEN + NPART=NPART+1 + IPART(NPART)=IT + PTPART(NPART)=SQRT(PT2AMX) + ENDIF + +C...Update saved variables. + SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX + NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1 + XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX + PT2SAV(JSMX,MIMX)=PT2MX + ZSAV(JS,MIMX)=ZMX + + KSA=IABS(K(IS,2)) + KMA=IABS(K(IM,2)) + IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN +C...Gluon reconstructs to quark. +C...Decide whether newly created quark is valence or sea: + MINT(30)=JS + CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL) + IF(MINT(51).NE.0) RETURN + ENDIF + IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN +C...Quark reconstructs to gluon. +C...Now some guy may have lost his companion. Check. + ICMP=IMI(JS,MI,2) + IF (ICMP.GT.0) THEN + CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated' + & //' away. Cannot handle that yet. Giving up.') + MINT(51)=1 + RETURN + ELSEIF(ICMP.LT.0) THEN +C...A sea quark with companion still in BR was reconstructed to a gluon. +C...Companion should now be removed from the beam remnant. +C...(Momentum integral is automatically updated in next call to PYPDFU.) + ICMP=-ICMP + IFL=-K(IS,2) + DO 380 JCMP=ICMP,NVC(JS,IFL)-1 + XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1) + DO 370 JI=1,MINT(31) + KMI=-IMI(JS,JI,2) + JFL=-K(IMI(JS,JI,1),2) + IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI + & ,2)+1 + 370 CONTINUE + 380 CONTINUE + NVC(JS,IFL)=NVC(JS,IFL)-1 + ENDIF +C...Set gluon IMI(JS,MI,2) = 0. + IMI(JS,MI,2)=0 + ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN +C...Quark reconstructing to quark. If sea with companion still in BR +C...then update associated x value. +C...(Momentum integral is automatically updated in next call to PYPDFU.) + IF (IMI(JS,MI,2).LT.0) THEN + ICMP=-IMI(JS,MI,2) + IFL=-K(IS,2) + XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX) + ENDIF + ENDIF + + ENDIF + +C...If reached this point, normal exit. + 390 IFAIL=0 + + RETURN + END + +C********************************************************************* + +C...PYMEMX +C...Generates maximum ME weight in some initial-state showers. +C...Inparameter MECOR: kind of hard scattering process +C...Outparameter WTFF: maximum weight for fermion -> fermion +C... WTGF: maximum weight for gluon/photon -> fermion +C... WTFG: maximum weight for fermion -> gluon/photon +C... WTGG: maximum weight for gluon -> gluon + + SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2) + ENDIF + +C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0). + ELSEIF(MECOR.EQ.2) THEN + IF(IFLCB.EQ.3) THEN + WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2) + ELSEIF(IFLCB.EQ.4) THEN + WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2 + ENDIF + +C...Matrix-element corrections for q + qbar -> Higgs (h0) + ELSEIF(MECOR.EQ.3) THEN + IF(IFLCB.EQ.2) THEN + WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/ + 1 (SH**2+2D0*SQM*(SQM-SH)) + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYPTMI +C...Handles the generation of additional interactions in the new +C...multiple interactions framework. +C...MODE=-1 : Initalize MI from scratch. +C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve +C... Sudakov for PT2, abort if below PT2CUT. +C...MODE= 1 : Accept interaction at PT2NOW and store variables. +C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW +C...PT2NOW : Starting (max) PT2 scale for evolution. +C...PT2CUT : Lower limit for evolution. +C...PT2 : Result of evolution. Generated PT2 for trial interaction. +C...IFAIL : Status return code. +C... = 0: All is well. +C... < 0: Phase space exhausted, generation to be terminated. +C... > 0: Additional interaction vetoed, but continue evolution. + + SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL) +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement for maximum size of showers. + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), + & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), + & XMI(2,240),PT2MI(240),IMISEP(0:240) + COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240), + & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX + COMMON/PYCTAG/NCT,MCT(4000,2) +C...Local arrays and saved variables. + DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25) + + SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/, + & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/, + & /PYISMX/,/PYCTAG/ + SAVE NCHN,XT2FAC,SIGS + + IFAIL=0 +C...Set MI subprocess = QCD 2 -> 2. + ISUB=96 + +C---------------------------------------------------------------------- +C...MODE=-1: Initialize from scratch + IF (MODE.EQ.-1) THEN +C...Initialize PT2 array. + PT2MI(1)=VINT(54) +C...Initialize list of incoming beams and partons from two sides. + DO 110 JS=1,2 + DO 100 MI=1,240 + IMI(JS,MI,1)=0 + IMI(JS,MI,2)=0 + 100 CONTINUE + NMI(JS)=1 + IMI(JS,1,1)=MINT(84)+JS + IMI(JS,1,2)=0 + XMI(JS,1)=VINT(40+JS) +C...Rescale x values to fractions of photon energy. + IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS) +C...Hard reset: hard interaction initiators motherless by definition. + K(MINT(84)+JS,3)=2+JS + K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5)) + K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5)) + 110 CONTINUE + IMISEP(0)=MINT(84) + IMISEP(1)=N + IF (MOD(MSTP(81),10).GE.1) THEN + IF(MSTP(82).LE.1) THEN + SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0 + & ,5)) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT* + & VINT(317)/(VINT(318)*VINT(320)) + XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149)) + ELSE + XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/ + & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149)) + ENDIF + ENDIF +C...Zero entries relating to scatterings beyond the first. + DO 120 MI=2,240 + IMI(1,MI,1)=0 + IMI(2,MI,1)=0 + IMI(1,MI,2)=0 + IMI(2,MI,2)=0 + IMISEP(MI)=IMISEP(1) + PT2MI(MI)=0D0 + XMI(1,MI)=0D0 + XMI(2,MI)=0D0 + 120 CONTINUE +C...Initialize factors for PDF reshaping. + DO 140 JS=1,2 + KFBEAM(JS)=MINT(10+JS) + IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22 + KFABM=IABS(KFBEAM(JS)) + KFSBM=ISIGN(1,KFBEAM(JS)) + +C...Zero flavour content of incoming beam particle. + KFIVAL(JS,1)=0 + KFIVAL(JS,2)=0 + KFIVAL(JS,3)=0 +C... Flavour content of baryon. + IF(KFABM.GT.1000) THEN + KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10) + KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10) + KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10) +C... Flavour content of pi+-, K+-. + ELSEIF(KFABM.EQ.211) THEN + KFIVAL(JS,1)=KFSBM*2 + KFIVAL(JS,2)=-KFSBM + ELSEIF(KFABM.EQ.321) THEN + KFIVAL(JS,1)=-KFSBM*3 + KFIVAL(JS,2)=KFSBM*2 +C... Flavour content of pi0, gamma, K0S, K0L not defined yet. + ENDIF + +C...Zero initial valence and companion content. + DO 130 IFL=-6,6 + NVC(JS,IFL)=0 + 130 CONTINUE + 140 CONTINUE +C...Set up colour line tags starting from hard interaction initiators. + NCT=0 +C...Reset colour tag array and colour processing flags. + DO 150 I=IMISEP(0)+1,N + MCT(I,1)=0 + MCT(I,2)=0 + K(I,4)=MOD(K(I,4),MSTU(5)**2) + K(I,5)=MOD(K(I,5),MSTU(5)**2) + 150 CONTINUE +C... Consider each side in turn. + DO 170 JS=1,2 + I1=IMI(JS,1,1) + I2=IMI(3-JS,1,1) + DO 160 JCS=4,5 + IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2))) + & GOTO 160 + IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160 + KCS=JCS + CALL PYCTTR(I1,KCS,I2) + IF(MINT(51).NE.0) RETURN + 160 CONTINUE + 170 CONTINUE + +C...Range checking for companion quark pdf large-x param. + IF (MSTP(87).LT.0) THEN + CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'// + & ' MSTP(87)=0') + MSTP(87)=0 + ELSEIF (MSTP(87).GT.4) THEN + CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'// + & ' MSTP(87)=4') + MSTP(87)=4 + ENDIF + +C---------------------------------------------------------------------- +C...MODE=0: Generate trial interaction. Return codes: +C...IFAIL < 0: Phase space exhausted, generation to be terminated. +C...IFAIL = 0: Additional interaction generated at PT2. +C...IFAIL > 0: Additional interaction vetoed, but continue evolution. + ELSEIF (MODE.EQ.0) THEN +C...Abolute MI max scale = VINT(62) + XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2) + 180 IF(MSTP(82).LE.1) THEN + XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) + IF(XT2.LT.VINT(149)) IFAIL=-2 + ELSE + IF(XT2.LE.0.01001D0*VINT(149)) THEN + IFAIL=-3 + ELSE + XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))* + & LOG(PYR(0)))-VINT(149) + ENDIF + ENDIF +C...Also exit if below lower limit or if higher trial branching +C...already found. + PT2=0.25D0*VINT(2)*XT2 + IF (PT2.LE.PT2CUT) IFAIL=-4 + IF (PT2.LE.PT2MX) IFAIL=-5 + IF (IFAIL.NE.0) THEN + PT2=0D0 + RETURN + ENDIF + IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2) + VINT(25)=4D0*PT2/VINT(2) + XT2=VINT(25) + +C...Choose tau and y*. Calculate cos(theta-hat). + IF(PYR(0).LE.COEF(ISUB,1)) THEN + TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) + TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) + ELSE + TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) + ENDIF + VINT(21)=TAU +C...New: require shat > 1. + IF(TAU*VINT(2).LT.1D0) GOTO 180 + CALL PYKLIM(2) + RYST=PYR(0) + MYST=1 + IF(RYST.GT.COEF(ISUB,8)) MYST=2 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 + CALL PYKMAP(2,MYST,PYR(0)) + VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) + +C...Check that x not used up. Accept or reject kinematical variables. + X1M=SQRT(TAU)*EXP(VINT(22)) + X2M=SQRT(TAU)*EXP(-VINT(22)) + IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180 + VINT(71)=0.5D0*VINT(1)*SQRT(XT2) + NCHN=0 + CALL PYSIGH(NCHN,SIGS) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320) + IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180 + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320) + +C...Save if highest PT so far. + IF (PT2.GT.PT2MX) THEN + JSMX=0 + MIMX=MINT(31)+1 + PT2MX=PT2 + ENDIF + +C---------------------------------------------------------------------- +C...MODE=1: Generate and save accepted scattering. + ELSEIF (MODE.EQ.1) THEN + PT2=PT2NOW +C...Reset K, P, V, and MCT vectors. + DO 200 I=N+1,N+4 + DO 190 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 190 CONTINUE + MCT(I,1)=0 + MCT(I,2)=0 + 200 CONTINUE + + NTRY=0 +C...Choose flavour of reacting partons (and subprocess). + 210 NTRY=NTRY+1 + IF (NTRY.GT.50) THEN + CALL PYERRM(9,'(PYPTMI:) Unable to generate additional ' + & //'interaction. Giving up!') + MINT(51)=1 + RETURN + ENDIF + RSIGS=SIGS*PYR(0) + DO 220 ICHN=1,NCHN + KFL1=ISIG(ICHN,1) + KFL2=ISIG(ICHN,2) + ICONMI=ISIG(ICHN,3) + RSIGS=RSIGS-SIGH(ICHN) + IF(RSIGS.LE.0D0) GOTO 230 + 220 CONTINUE + +C...Reassign to appropriate process codes. + 230 ISUBMI=ICONMI/10 + ICONMI=MOD(ICONMI,10) + +C...Choose new quark flavour for annihilation graphs + IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN + SH=VINT(21)*VINT(2) + CALL PYWIDT(21,SH,WDTP,WDTE) + 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0) + DO 250 I=1,MDCY(21,3) + KFLF=KFDP(I+MDCY(21,2)-1,1) + RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4)) + IF(RKFL.LE.0D0) GOTO 260 + 250 CONTINUE + 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN + IF(KFLF.GE.4) GOTO 240 + ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN + KFLF=4 + ICONMI=ICONMI-2 + ELSEIF(ISUBMI.EQ.53) THEN + KFLF=5 + ICONMI=ICONMI-4 + ENDIF + ENDIF + +C...Final state flavours and colour flow: default values + JS=1 + KFL3=KFL1 + KFL4=KFL2 + KCC=20 + KCS=ISIGN(1,KFL1) + + IF(ISUBMI.EQ.11) THEN +C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2 + KCC=ICONMI + IF(KFL1*KFL2.LT.0) KCC=KCC+2 + + ELSEIF(ISUBMI.EQ.12) THEN +C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2 + KFL3=ISIGN(KFLF,KFL1) + KFL4=-KFL3 + KCC=4 + + ELSEIF(ISUBMI.EQ.13) THEN +C...f + fbar -> g + g; th arbitrary + KFL3=21 + KFL4=21 + KCC=ICONMI+4 + + ELSEIF(ISUBMI.EQ.28) THEN +C...f + g -> f + g; th = (p(f)-p(f))**2 + IF(KFL1.EQ.21) JS=2 + KCC=ICONMI+6 + IF(KFL1.EQ.21) KCC=KCC+2 + IF(KFL1.NE.21) KCS=ISIGN(1,KFL1) + IF(KFL2.NE.21) KCS=ISIGN(1,KFL2) + + ELSEIF(ISUBMI.EQ.53) THEN +C...g + g -> f + fbar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + KFL3=ISIGN(KFLF,KCS) + KFL4=-KFL3 + KCC=ICONMI+10 + + ELSEIF(ISUBMI.EQ.68) THEN +C...g + g -> g + g; th arbitrary + KCC=ICONMI+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + ENDIF + +C...Check that massive sea quarks have non-zero phase space for g -> Q Q + IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5 + & .OR.IABS(KFL4).EQ.5) THEN + RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2 + IF (PT2.LE.1.05*RMMAX2) THEN + IF (NTRY.EQ.2) CALL PYERRM(9,'(PYPTMI:) Heavy quarks' + & //' too close to threshold (2nd try).') + GOTO 210 + ENDIF + ENDIF + +C...Store flavours of scattering. + MINT(13)=KFL1 + MINT(14)=KFL2 + MINT(15)=KFL1 + MINT(16)=KFL2 + MINT(21)=KFL3 + MINT(22)=KFL4 + +C...Set flavours and mothers of scattering partons. + K(N+1,1)=14 + K(N+2,1)=14 + K(N+3,1)=3 + K(N+4,1)=3 + K(N+1,2)=KFL1 + K(N+2,2)=KFL2 + K(N+3,2)=KFL3 + K(N+4,2)=KFL4 + K(N+1,3)=MINT(83)+1 + K(N+2,3)=MINT(83)+2 + K(N+3,3)=N+1 + K(N+4,3)=N+2 + +C...Store colour connection indices. + DO 270 J=1,2 + JC=J + IF(KCS.EQ.-1) JC=3-J + IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC) + IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC) + IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC)) + IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC)) + 270 CONTINUE + +C...Store incoming and outgoing partons in their CM-frame. + SHR=SQRT(VINT(21))*VINT(1) + P(N+1,3)=0.5D0*SHR + P(N+1,4)=0.5D0*SHR + P(N+2,3)=-0.5D0*SHR + P(N+2,4)=0.5D0*SHR + P(N+3,5)=PYMASS(K(N+3,2)) + P(N+4,5)=PYMASS(K(N+4,2)) + IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN + IFAIL=1 + RETURN + ENDIF + P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR) + P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2)) + P(N+4,4)=SHR-P(N+3,4) + P(N+4,3)=-P(N+3,3) + +C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4) + PHI=PARU(2)*PYR(0) + CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0) + +C...Global statistics. + MINT(351)=MINT(351)+1 + VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2) + IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2) + +C...Keep track of loose colour ends and information on scattering. + MINT(31)=MINT(31)+1 + MINT(36)=MINT(31) + PT2MI(MINT(36))=PT2 + IMISEP(MINT(31))=N+4 + DO 280 JS=1,2 + IMI(JS,MINT(31),1)=N+JS + IMI(JS,MINT(31),2)=0 + XMI(JS,MINT(31))=VINT(40+JS) + NMI(JS)=NMI(JS)+1 +C...Update cumulative counters + VINT(142+JS)=VINT(142+JS)-VINT(40+JS) + VINT(150+JS)=VINT(150+JS)+VINT(40+JS) + 280 CONTINUE + +C...Add to list of final state partons + IPART(NPART+1)=N+3 + IPART(NPART+2)=N+4 + PTPART(NPART+1)=SQRT(PT2) + PTPART(NPART+2)=SQRT(PT2) + NPART=NPART+2 + +C...Initialize ISR + NISGEN(1,MINT(31))=0 + NISGEN(2,MINT(31))=0 + +C...Update ER + N=N+4 + IF(N.GT.MSTU(4)-MSTU(32)-10) THEN + CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS') + MINT(51)=1 + RETURN + ENDIF + +C...Finally, assign colour tags to new partons + DO 300 JS=1,2 + I1=IMI(JS,MINT(31),1) + I2=IMI(3-JS,MINT(31),1) + DO 290 JCS=4,5 + IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2))) + & GOTO 290 + IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290 + KCS=JCS + CALL PYCTTR(I1,KCS,I2) + IF(MINT(51).NE.0) RETURN + 290 CONTINUE + 300 CONTINUE + +C---------------------------------------------------------------------- +C...MODE=2: Decide whether quarks in last scattering were valence, +C...companion, or sea. + ELSEIF (MODE.EQ.2) THEN + JS=MINT(30) + MI=MINT(36) + PT2=PT2NOW + KFSBM=ISIGN(1,MINT(10+JS)) + IFL=K(IMI(JS,MI,1),2) + IMI(JS,MI,2)=0 + IF (IABS(IFL).GE.6) THEN + IF (IABS(IFL).EQ.6) THEN + CALL PYERRM(29,'(PYPTMI:) top in initial state!') + ENDIF + RETURN + ENDIF +C...Get PDFs at X(rescaled) and PT2 of the current initiator. +C...(Do not include the parton itself in the X rescaling.) + X=XMI(JS,MI) + XRSC=X/(VINT(142+JS)+X) +C...Note: XPSVC = x*pdf. + MINT(30)=JS + CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ) + SEA=XPSVC(IFL,-1) + VAL=XPSVC(IFL,0) +C...Ensure that pdfs are positive definite + IF (SEA.LT.0D0) THEN + CALL PYERRM(9,'(PYPTMI:) Sea distribution negative.') + SEA=MAX(0D0,SEA) + ELSEIF (VAL.LT.0D0) THEN + CALL PYERRM(9,'(PYPTMI:) Val distribution negative.') + VAL=MAX(0D0,VAL) + ENDIF + CMP=0D0 + DO 310 IVC=1,NVC(JS,IFL) + CMP=CMP+XPSVC(IFL,IVC) + 310 CONTINUE + + NTRY=0 +C...Decide (Extra factor x cancels in the dvision). + 320 RVCS=PYR(0)*(SEA+VAL+CMP) + IVNOW=1 + NTRY=NTRY+1 + 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN +C...Safety check that valence present; pi0/gamma/K0S/K0L special cases. + IVNOW=0 + IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,1).EQ.0) THEN + IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1 + IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1 + IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND. + & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1 + ELSE +C...Count down valence remaining. Do not count current scattering. + DO 340 I1=1,NMI(JS) + IF (I1.EQ.MINT(36)) GOTO 340 + IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0) + & IVNOW=IVNOW-1 + 340 CONTINUE + ENDIF + IF(IVNOW.EQ.0) GOTO 330 +C...Mark valence. + IMI(JS,MI,2)=0 +C...Sets valence content of gamma, pi0, K0S, K0L if not done. + IF(KFIVAL(JS,1).EQ.0) THEN + IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN + KFIVAL(JS,1)=IFL + KFIVAL(JS,2)=-IFL + ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN + KFIVAL(JS,1)=IFL + IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL) + IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL) + ENDIF + ENDIF + + ELSEIF (RVCS.LE.VAL+SEA) THEN +C...If sea, add opposite sign companion parton. Store X and I. + NVC(JS,-IFL)=NVC(JS,-IFL)+1 + XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI) +C...Set pointer to companion + IMI(JS,MI,2)=-NVC(JS,-IFL) + + ELSE +C...If companion, check whether we've got any in the books + IF (NVC(JS,IFL).EQ.0) THEN + CMP=0D0 +C...Only report error first time for this event + IF (NTRY.EQ.1) + & CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!') +C...Try a few times + IF (NTRY.LE.10) THEN + GOTO 320 +C... But if it stil fails, abort this event + ELSE + MINT(51)=1 + RETURN + ENDIF + ENDIF +C...If several possibilities, decide which one + CMPSUM=VAL+SEA + ISEL=0 + 350 ISEL=ISEL+1 + CMPSUM=CMPSUM+XPSVC(IFL,ISEL) + IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350 +C...Find original sea (anti-)quark. Do not consider current scattering. + IASSOC=0 + DO 360 I1=1,NMI(JS) + IF (I1.EQ.MINT(36)) GOTO 360 + IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360 + IF (-IMI(JS,I1,2).EQ.ISEL) THEN + IMI(JS,MI,2)=IMI(JS,I1,1) + IMI(JS,I1,2)=IMI(JS,MI,1) + ENDIF + 360 CONTINUE +C...Mark companion "out-kicked". + XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL) + ENDIF + + ENDIF + RETURN + END + +C********************************************************************* + +C...PYFCMP: Auxiliary to PYPDFU and PYPTIS. +C...Giving the x*f pdf of a companion quark, with its partner at XS, +C...using an approximate gluon density like (1-X)^NPOW/X. The value +C...corresponds to an unrescaled range between 0 and 1-X. + + FUNCTION PYFCMP(XC,XS,NPOW) + IMPLICIT NONE + DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC + INTEGER NPOW + + PYFCMP=0D0 +C...Parent gluon momentum fraction + Y=XC+XS + IF (Y.GE.1D0) RETURN +C...Common factor (includes factor XC, since PYFCMP=x*f) + FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4) +C...Store normalized companion x*f distribution. + IF (NPOW.LE.0) THEN + PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS))) + ELSEIF (NPOW.EQ.1) THEN + PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS)) + ELSEIF (NPOW.EQ.2) THEN + PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS)) + & +3D0*XS*(1D0+XS)*LOG(XS))) + ELSEIF (NPOW.EQ.3) THEN + PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3 + & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS))) + ELSEIF (NPOW.GE.4) THEN + PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+ + & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS))) + ENDIF + RETURN + END + +C********************************************************************* + +C...PYPCMP: Auxiliary to PYPDFU. +C...Giving the momentum integral of a companion quark, with its +C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x. +C...The value corresponds to an unrescaled range between 0 and 1-XS. + + FUNCTION PYPCMP(XS,NPOW) + IMPLICIT NONE + DOUBLE PRECISION XS, PYPCMP + INTEGER NPOW + IF (XS.GE.1D0.OR.XS.LE.0D0) THEN + PYPCMP=0D0 + ELSEIF (NPOW.LE.0) THEN + PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS)) + PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS))) + ELSEIF (NPOW.EQ.1) THEN + PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2)) + & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS)) + ELSEIF (NPOW.EQ.2) THEN + PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS)) + & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2)) + PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS)) + & -3D0*XS*LOG(XS)*(1+XS))) + ELSEIF (NPOW.EQ.3) THEN + PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS)) + & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS)))) + PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3 + & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS))) + ELSE + PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS) + & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS))) + PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS)) + & -6D0*XS*LOG(XS)*(1D0+XS))) + ENDIF + RETURN + END + +C********************************************************************* + +C...PYUPRE +C...Rearranges contents of the HEPEUP commonblock so that +C...mothers precede daughters and daughters of a decay are +C...listed consecutively. + + SUBROUTINE PYUPRE + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...User process event common block. + INTEGER MAXNUP + PARAMETER (MAXNUP=500) + INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP + DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP + COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), + &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), + &VTIMUP(MAXNUP),SPINUP(MAXNUP) + SAVE /HEPEUP/ + +C...Local arrays. + DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP), + &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP), + &VTIUPT(MAXNUP),SPIUPT(MAXNUP) + +C...Check whether a rearrangement is required. + NEED=0 + DO 100 IUP=1,NUP + IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1 + 100 CONTINUE + DO 110 IUP=2,NUP + IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1 + 110 CONTINUE + + IF(NEED.NE.0) THEN +C...Find the new order that particles should have. + NEWPOS(0)=0 + NNEW=0 + INEW=-1 + 120 INEW=INEW+1 + DO 130 IUP=1,NUP + IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN + NNEW=NNEW+1 + NEWPOS(NNEW)=IUP + ENDIF + 130 CONTINUE + IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120 + IF(NNEW.NE.NUP) THEN + CALL PYERRM(2, + & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP') + RETURN + ENDIF + +C...Copy old info into temporary storage. + DO 150 I=1,NUP + IDUPT(I)=IDUP(I) + ISTUPT(I)=ISTUP(I) + MOTUPT(1,I)=MOTHUP(1,I) + MOTUPT(2,I)=MOTHUP(2,I) + ICOUPT(1,I)=ICOLUP(1,I) + ICOUPT(2,I)=ICOLUP(2,I) + DO 140 J=1,5 + PUPT(J,I)=PUP(J,I) + 140 CONTINUE + VTIUPT(I)=VTIMUP(I) + SPIUPT(I)=SPINUP(I) + 150 CONTINUE + +C...Copy info back into HEPEUP in right order. + DO 180 I=1,NUP + IOLD=NEWPOS(I) + IDUP(I)=IDUPT(IOLD) + ISTUP(I)=ISTUPT(IOLD) + MOTHUP(1,I)=0 + MOTHUP(2,I)=0 + DO 160 IMOT=1,I-1 + IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT + IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT + 160 CONTINUE + IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN + MOTHSW=MOTHUP(1,I) + MOTHUP(1,I)=MOTHUP(2,I) + MOTHUP(2,I)=MOTHSW + ENDIF + ICOLUP(1,I)=ICOUPT(1,IOLD) + ICOLUP(2,I)=ICOUPT(2,IOLD) + DO 170 J=1,5 + PUP(J,I)=PUPT(J,IOLD) + 170 CONTINUE + VTIMUP(I)=VTIUPT(IOLD) + SPINUP(I)=SPIUPT(IOLD) + 180 CONTINUE + ENDIF + +c...If incoming particles are massive recalculate to put them massless. + IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN + PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2)) + PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2)) + PUP(4,1)=0.5D0*PPLUS + PUP(3,1)=PUP(4,1) + PUP(5,1)=0D0 + PUP(4,2)=0.5D0*PMINUS + PUP(3,2)=-PUP(4,2) + PUP(5,2)=0D0 + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYADSH +C...Administers the generation of successive final-state showers +C...in external processes. + + SUBROUTINE PYADSH(NFIN) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement for maximum size of showers. + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYCTAG/NCT,MCT(4000,2) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/ +C...Local array. + DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3) + +C...Set primary vertex. + DO 100 J=1,5 + V(MINT(83)+5,J)=0D0 + V(MINT(83)+6,J)=0D0 + V(MINT(84)+1,J)=0D0 + V(MINT(84)+2,J)=0D0 + 100 CONTINUE + +C...Isolate systems of particles with the same mother. + NSYS=0 + IMS=-1 + DO 140 I=MINT(84)+3,NFIN + IM=K(I,3) + IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3) + IF(IM.NE.IMS) THEN + NSYS=NSYS+1 + IBEG(NSYS)=I + IMS=IM + ENDIF + +C...Set production vertices. + IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2)) + & THEN + DO 110 J=1,4 + V(I,J)=0D0 + 110 CONTINUE + ELSE + DO 120 J=1,4 + V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5) + 120 CONTINUE + ENDIF + IF(MSTP(125).GE.1) THEN + IDOC=I-MSTP(126)+4 + DO 130 J=1,5 + V(IDOC,J)=V(I,J) + 130 CONTINUE + ENDIF + 140 CONTINUE + +C...End loop over systems. Return if no showers to be performed. + IBEG(NSYS+1)=NFIN+1 + IF(MSTP(71).LE.0) RETURN + +C...Loop through systems of particles; check that sensible size. + DO 270 ISYS=1,NSYS + NSIZ=IBEG(ISYS+1)-IBEG(ISYS) + IF(MINT(35).LE.2) THEN + IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN + GOTO 270 + ELSEIF(NSIZ.LE.1) THEN + CALL PYERRM(2,'(PYADSH:) only one particle in system') + GOTO 270 + ELSEIF(NSIZ.GT.80) THEN + CALL PYERRM(2,'(PYADSH:) more than 80 particles in system') + GOTO 270 + ENDIF + ENDIF + +C...Save status codes and daughters of showering particles; reset them. + DO 150 J=1,4 + PSUM(J)=0D0 + 150 CONTINUE + DO 170 II=1,NSIZ + I=IBEG(ISYS)-1+II + KSAV(II,1)=K(I,1) + IF(K(I,1).GT.10) THEN + K(I,1)=1 + IF(KSAV(II,1).EQ.14) K(I,1)=3 + ENDIF + IF(KSAV(II,1).LE.10) THEN + ELSEIF(K(I,1).EQ.1) THEN + KSAV(II,4)=K(I,4) + KSAV(II,5)=K(I,5) + K(I,4)=0 + K(I,5)=0 + ELSE + KSAV(II,4)=MOD(K(I,4),MSTU(5)) + KSAV(II,5)=MOD(K(I,5),MSTU(5)) + K(I,4)=K(I,4)-KSAV(II,4) + K(I,5)=K(I,5)-KSAV(II,5) + ENDIF + DO 160 J=1,4 + PSUM(J)=PSUM(J)+P(I,J) + 160 CONTINUE + 170 CONTINUE + +C...Perform shower. + QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2- + & PSUM(3)**2)) + IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55)) + NSAV=N + IF(MINT(35).LE.2) THEN + IF(NSIZ.EQ.2) THEN + CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX) + ELSE + CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX) + ENDIF + +C...For external processes, first call, also ISR partons radiate. +C...Can use existing PYPART list, removing partons that radiate later. + ELSEIF(ISYS.EQ.1) THEN + NPARTN=0 + DO 175 II=1,NPART + IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN + NPARTN=NPARTN+1 + IPART(NPARTN)=IPART(II) + PTPART(NPARTN)=PTPART(II) + ENDIF + 175 CONTINUE + NPART=NPARTN + CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN) + ELSE +C...For subsequent calls use the systems excluded above. + NPART=NSIZ + NPARTD=0 + DO 180 II=1,NSIZ + I=IBEG(ISYS)-1+II + IPART(II)=I + PTPART(II)=0.5D0*QMAX + 180 CONTINUE + CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN) + ENDIF + +C...Look up showered copies of original showering particles. + DO 260 II=1,NSIZ + I=IBEG(ISYS)-1+II + IMV=I +C...Particles without daughters need not be studied. + IF(KSAV(II,1).LE.10) GOTO 260 + IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN + ELSEIF(K(I,1).EQ.11) THEN + 190 IMV=MOD(K(IMV,4),MSTU(5)) + IF(K(IMV,1).EQ.11) GOTO 190 + ELSE + KDA1=MOD(K(I,4),MSTU(5)) + IF(KDA1.GT.0) THEN + IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5) + ENDIF + KDA2=MOD(K(I,5),MSTU(5)) + IF(KDA2.GT.0) THEN + IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5) + ENDIF + DO 200 I3=I+1,N + IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2)) + & THEN + IMV=I3 + KDA1=MOD(K(I3,4),MSTU(5)) + IF(KDA1.GT.0) THEN + IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5) + ENDIF + KDA2=MOD(K(I3,5),MSTU(5)) + IF(KDA2.GT.0) THEN + IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5) + ENDIF + ENDIF + 200 CONTINUE + ENDIF + +C...Restore daughter info of original partons to showered copies. + IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1) + IF(KSAV(II,1).LE.10) THEN + ELSEIF(K(I,1).EQ.1) THEN + K(IMV,4)=KSAV(II,4) + K(IMV,5)=KSAV(II,5) + ELSE + K(IMV,4)=K(IMV,4)+KSAV(II,4) + K(IMV,5)=K(IMV,5)+KSAV(II,5) + ENDIF + +C...Reset mother info of existing daughters to showered copies. + DO 210 I3=IBEG(ISYS+1),NFIN + IF(K(I3,3).EQ.I) K(I3,3)=IMV + IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN + IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I) + IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I) + ENDIF + 210 CONTINUE + +C...Boost all original daughters to new frame of showered copy. +C...Also update their colour tags. + IF(IMV.NE.I) THEN + DO 220 J=1,3 + BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4)) + 220 CONTINUE + FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2) + DO 230 J=1,3 + BETA(J)=FAC*BETA(J) + 230 CONTINUE + DO 250 I3=IBEG(ISYS+1),NFIN + IMO=I3 + 240 IMO=K(IMO,3) + IF(MSTP(128).LE.0) THEN + IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240 + IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3))) + & THEN + CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3)) + IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1) + IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2) + ENDIF + ELSE + IF(IMO.EQ.IMV) THEN + CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3)) + IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1) + IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2) + ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN + GOTO 240 + ENDIF + ENDIF + 250 CONTINUE + ENDIF + 260 CONTINUE + +C...End of loop over showering systems + 270 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYVETO +C...Interface to UPVETO, which allows user to veto event generation +C...on the parton level, after parton showers but before multiple +C...interactions, beam remnants and hadronization is added. + + SUBROUTINE PYVETO(IVETO) + +C...All real arithmetic in double precision. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) +C...Three Pythia functions return integers, so need declaring. + INTEGER PYK,PYCHGE,PYCOMP + +C...PYTHIA commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYJETS/,/PYPARS/,/PYINT1/ +C...HEPEVT commonblock. + PARAMETER (NMXHEP=4000) + COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), + &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) + DOUBLE PRECISION PHEP,VHEP + SAVE /HEPEVT/ +C...Local array. + DIMENSION IRESO(100) + +C...Define longitudinal boost from initiator rest frame to cm frame. + GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142)) + GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142)) + +C...Presentation is different if using pT-ordered shower + IF(MINT(35).EQ.3) THEN + GAMMA=1D0 + GABEZ=0D0 + ENDIF + +C... Reset counters. + NEVHEP=0 + NHEP=0 + NRESO=0 + +C...Oth pass: identify beam and incoming partons + DO 140 I=MINT(83)+1,MINT(83)+6 + ISTORE=0 + IF(K(I,2).EQ.94) THEN + + ELSE + NRESO=NRESO+1 + IRESO(NRESO)=I + IMOTH=K(I,3) + ENDIF + 140 CONTINUE + +C...First pass: identify final locations of resonances +C...and of their daughters before showering. + DO 150 I=MINT(84)+3,N + ISTORE=0 + IMOTH=0 + +C...Skip shower CM frame documentation lines. + IF(K(I,2).EQ.94) THEN + +C... Store a new intermediate product, when mother in documentation. + ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND. + & K(I,3).LE.MINT(84)) THEN + ISTORE=1 + NHEP=NHEP+1 + II=NHEP + NRESO=NRESO+1 + IRESO(NRESO)=I + IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6)) + +C... Store a new intermediate product, when mother in main section. + ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND. + & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN + ISTORE=1 + NHEP=NHEP+1 + II=NHEP + NRESO=NRESO+1 + IRESO(NRESO)=I + IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6)) + ENDIF + + IF(ISTORE.EQ.1) THEN +C...Copy parton info, boosting momenta along z axis to cm frame. + ISTHEP(II)=2 + IDHEP(II)=K(I,2) + PHEP(1,II)=P(I,1) + PHEP(2,II)=P(I,2) + PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4) + PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3) + PHEP(5,II)=P(I,5) +C...Store one mother. Rest of history and vertex info zeroed. + JMOHEP(1,II)=IMOTH + JMOHEP(2,II)=0 + JDAHEP(1,II)=0 + JDAHEP(2,II)=0 + VHEP(1,II)=0D0 + VHEP(2,II)=0D0 + VHEP(3,II)=0D0 + VHEP(4,II)=0D0 + ENDIF + 150 CONTINUE + +C...Second pass: identify current set of "final" partons. + DO 200 I=MINT(84)+3,N + ISTORE=0 + IMOTH=0 + +C...Store a final parton. + IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN + ISTORE=1 + NHEP=NHEP+1 + II=NHEP +C..Trace it back through shower, to check if from documented particle. + IHIST=I + ISAVE=IHIST + 160 CONTINUE + IF(IHIST.GT.MINT(84)) THEN + IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST) + DO 170 IRI=1,NRESO + IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI + 170 CONTINUE + ISAVE=IHIST + IHIST=K(IHIST,3) + IF(IMOTH.EQ.0) GOTO 160 + IMOTH=MAX(0,IMOTH-6) + ELSEIF(IHIST.LE.4) THEN + IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN + ISTORE=0 + NHEP=NHEP-1 + ELSE + IMOTH=0 + ENDIF + ENDIF + ENDIF + + IF(ISTORE.EQ.1) THEN +C...Copy parton info, boosting momenta along z axis to cm frame. + ISTHEP(II)=1 + IDHEP(II)=K(I,2) + PHEP(1,II)=P(I,1) + PHEP(2,II)=P(I,2) + PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4) + PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3) + PHEP(5,II)=P(I,5) +C...Store one mother. Rest of history and vertex info zeroed. + JMOHEP(1,II)=IMOTH + JMOHEP(2,II)=0 + JDAHEP(1,II)=0 + JDAHEP(2,II)=0 + VHEP(1,II)=0D0 + VHEP(2,II)=0D0 + VHEP(3,II)=0D0 + VHEP(4,II)=0D0 + ENDIF + 200 CONTINUE +C...Call user-written routine to decide whether to keep events. + CALL UPVETO(IVETO) + RETURN + END +C********************************************************************* + +C...PYRESD +C...Allows resonances to decay (including parton showers for hadronic +C...channels). + + SUBROUTINE PYRESD(IRES) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Parameter statement for maximum size of showers. + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYCTAG/NCT,MCT(4000,2) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYPUED/IUED(0:99),RUED(0:99) + SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/, + &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYPUED/ +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(4),ILIN(6), + &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3), + &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),VDCY(4), + &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(4),ITRI(4),IOCT(4),KCQ4(3), + &KFL4(3) + COMPLEX FGK,HA(6,6),HC(6,6) + REAL TIR,UIR + CHARACTER CODE*9,MASS*9 +C...Local arrays. + DIMENSION PV(10,5),RORD(10),UE(3),BE(3),WTCOR(10) + 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) + +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 + IIN1=MINT(84)+1 + IIN2=MINT(84)+2 +C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons +C...(101,102) are off shell and can have inconsistent momenta, resulting +C...in boosts larger than unity. However, the corresponding docu partons +C...(5,6) are kept on shell, and have consistent momenta that can be used +C...to derive this boost instead. Ultimately, should change the way the new +C...shower stores intermediate partons, but just using partons (5,6) for now +C...does define the boost and furnishes a quick and much needed solution. + IF (MINT(35).EQ.3) THEN + IIN1=MINT(83)+5 + IIN2=MINT(83)+6 + ENDIF + ETOTIN=P(IIN1,4)+P(IIN2,4) + BEXIN=(P(IIN1,1)+P(IIN2,1))/ETOTIN + BEYIN=(P(IIN1,2)+P(IIN2,2))/ETOTIN + BEZIN=(P(IIN1,3)+P(IIN2,3))/ETOTIN + CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN) + PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2)) + CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0) + THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1)) + CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0) + ENDIF + +C...Reset original resonance configuration. + DO 100 JT=1,8 + IREF(1,JT)=0 + 100 CONTINUE + +C...Define initial one, two or three objects for subprocess. + IHDEC=0 + IF(IRES.EQ.0) THEN + ISUB=MINT(1) + IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN + IREF(1,1)=MINT(84)+2+ISET(ISUB) + IREF(1,4)=MINT(83)+6+ISET(ISUB) + JTMAX=1 + ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN + IREF(1,1)=MINT(84)+1+ISET(ISUB) + IREF(1,2)=MINT(84)+2+ISET(ISUB) + IREF(1,4)=MINT(83)+5+ISET(ISUB) + IREF(1,5)=MINT(83)+6+ISET(ISUB) + JTMAX=2 + ELSEIF(ISET(ISUB).EQ.5) THEN + IREF(1,1)=MINT(84)+3 + IREF(1,2)=MINT(84)+4 + IREF(1,3)=MINT(84)+5 + IREF(1,4)=MINT(83)+7 + IREF(1,5)=MINT(83)+8 + IREF(1,6)=MINT(83)+9 + JTMAX=3 + ENDIF + +C...Define original resonance for odd cases. + ELSE + ISUB=0 + IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36) + & IHDEC=1 + IF(IHDEC.EQ.1) ISUB=3 + IREF(1,1)=IRES + IREF(1,4)=K(IRES,3) + IRESTM=IRES + IF(IREF(1,4).GT.MINT(84)) THEN + 110 ITMPMO=IREF(1,4) + IF(K(ITMPMO,2).EQ.94) THEN + IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1) + IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3) + ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN + IRESTM=ITMPMO +C...Explicitly check that reference particle exists, otherwise stop recursion + IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN + IREF(1,4)=K(ITMPMO,3) + GOTO 110 + ENDIF + ENDIF + ENDIF + IF(IREF(1,4).GT.MINT(84)) THEN + EMATCH=1D10 + IREF14=IREF(1,4) + DO 120 II=MINT(83)+7,MINT(83)+MINT(4) + IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT. + & EMATCH) THEN + IREF(1,4)=II + EMATCH=ABS(P(II,4)-P(IREF14,4)) + ENDIF + 120 CONTINUE + ENDIF + JTMAX=1 + ENDIF + +C...Check if initial resonance has been moved (in resonance + jet). + DO 140 JT=1,3 + IF(IREF(1,JT).GT.0) THEN + IF(K(IREF(1,JT),1).GT.10) THEN + KFA=IABS(K(IREF(1,JT),2)) + IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN + KDA1=MOD(K(IREF(1,JT),4),MSTU(5)) + KDA2=MOD(K(IREF(1,JT),5),MSTU(5)) + IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN + IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5) + ENDIF + IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN + IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5) + ENDIF + DO 130 I=IREF(1,JT)+1,N + IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR. + & I.EQ.KDA2)) THEN + IREF(1,JT)=I + KDA1=MOD(K(IREF(1,JT),4),MSTU(5)) + KDA2=MOD(K(IREF(1,JT),5),MSTU(5)) + IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN + IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5) + ENDIF + IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN + IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5) + ENDIF + ENDIF + 130 CONTINUE + ELSE + KDA=MOD(K(IREF(1,JT),4),MSTU(5)) + IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA + ENDIF + ENDIF + ENDIF + 140 CONTINUE + +C...Set decay vertex for initial resonances + DO 160 JT=1,JTMAX + DO 150 I=1,4 + V(IREF(1,JT),I)=0D0 + 150 CONTINUE + 160 CONTINUE + +C...Loop over decay history. + NP=1 + IP=0 + 170 IP=IP+1 + NINH=0 + JTMAX=2 + IF(IREF(IP,2).EQ.0) JTMAX=1 + IF(IREF(IP,3).NE.0) JTMAX=3 + IT4=0 + NSAV=N + +C...Check for Higgs which appears as decay product of user-process. + IF(ISUB.EQ.0) THEN + IHDEC=0 + IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7) + & .EQ.36) IHDEC=1 + IF(IHDEC.EQ.1) ISUB=3 + ENDIF + +C...Start treatment of one, two or three resonances in parallel. + 180 N=NSAV + DO 340 JT=1,JTMAX + ID=IREF(IP,JT) + KDCY(JT)=0 + KFL1(JT)=0 + KFL2(JT)=0 + KFL3(JT)=0 + KFL4(JT)=0 + KEQL(JT)=0 + NSD(JT)=ID + ITJUNC(JT)=0 + +C...Check whether particle can/is allowed to decay. + IF(ID.EQ.0) GOTO 330 + KFA=IABS(K(ID,2)) + KCA=PYCOMP(KFA) + IF(MWID(KCA).EQ.0) GOTO 330 + IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330 + IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR. + & KFA.EQ.18) IT4=IT4+1 + K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5)) + K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5)) + +C...Choose lifetime and determine decay vertex. + IF(K(ID,1).EQ.5) THEN + V(ID,5)=0D0 + ELSEIF(K(ID,1).NE.4) THEN + V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0)) + ENDIF + DO 190 J=1,4 + VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5) + 190 CONTINUE + +C...Determine whether decay allowed or not. + MOUT=0 + IF(MSTJ(22).EQ.2) THEN + IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1 + ELSEIF(MSTJ(22).EQ.3) THEN + IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1 + ELSEIF(MSTJ(22).EQ.4) THEN + IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1 + IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1 + ENDIF + IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN + K(ID,1)=4 + GOTO 330 + ENDIF + +C...Info for selection of decay channel: sign, pairings. + IF(KCHG(KCA,3).EQ.0) THEN + IPM=2 + ELSE + IPM=(5-ISIGN(1,K(ID,2)))/2 + ENDIF + KFB=0 + IF(JTMAX.EQ.2) THEN + KFB=IABS(K(IREF(IP,3-JT),2)) + ELSEIF(JTMAX.EQ.3) THEN + JT2=JT+1-3*(JT/3) + KFB=IABS(K(IREF(IP,JT2),2)) + IF(KFB.NE.KFA) THEN + JT2=JT+2-3*((JT+1)/3) + KFB=IABS(K(IREF(IP,JT2),2)) + ENDIF + ENDIF + +C...Select decay channel. + IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR. + & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1 + CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE) + WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4) + IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5) + IF(WDTE0S.LE.0D0) GOTO 330 + RKFL=WDTE0S*PYR(0) + IDL=0 + 200 IDL=IDL+1 + IDC=IDL+MDCY(KCA,2)-1 + RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4)) + IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5) + IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200 + + NPROD=0 +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)) + NPROD=NPROD+1 + 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 + NPROD=NPROD+1 + KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2)) + KCQ3(JT)=0 + KFL4(JT)=KFDP(IDC,4)*ISIGN(1,K(ID,2)) + KCQ4(JT)=0 + IF(KFL3(JT).NE.0) THEN + KFC3A=PYCOMP(IABS(KFL3(JT))) + IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT)) + KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT)) + IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2 + NPROD=NPROD+1 + IF(KFL4(JT).NE.0) THEN + KFC4A=PYCOMP(IABS(KFL4(JT))) + IF(KCHG(KFC4A,3).EQ.0) KFL4(JT)=IABS(KFL4(JT)) + KCQ4(JT)=KCHG(KFC4A,2)*ISIGN(1,KFL4(JT)) + IF(KCQ4(JT).EQ.-2) KCQ4(JT)=2 + NPROD=NPROD+1 + ENDIF + 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 + + PXSUM=0D0 +C...Select masses; to begin with assume resonances narrow. + DO 220 I=1,4 + P(N+I,5)=0D0 + PMMN(I)=0D0 + IF(I.EQ.1) THEN + KFLW=IABS(KFL1(JT)) + KCW=KFC1A + ELSEIF(I.EQ.2) THEN + KFLW=IABS(KFL2(JT)) + KCW=KFC2A + ELSEIF(I.EQ.3) THEN + IF(KFL3(JT).EQ.0) GOTO 220 + KFLW=IABS(KFL3(JT)) + KCW=KFC3A + ELSEIF(I.EQ.4) THEN + IF(KFL4(JT).EQ.0) GOTO 220 + KFLW=IABS(KFL4(JT)) + KCW=KFC4A + ENDIF + P(N+I,5)=PMAS(KCW,1) + PXSUM=PXSUM+P(N+I,5) +CMRENNA++ +C...This prevents SUSY/t particles from becoming too light. + IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN + PMMN(I)=PMAS(KCW,1) + DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1 + IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN + PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+ + & PMAS(PYCOMP(KFDP(IDC,2)),1) + IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+ + & PMAS(PYCOMP(KFDP(IDC,3)),1) + IF(KFDP(IDC,4).NE.0) PMSUM=PMSUM+ + & PMAS(PYCOMP(KFDP(IDC,4)),1) + PMMN(I)=MIN(PMMN(I),PMSUM) + ENDIF + 210 CONTINUE +C MRENNA-- + ELSEIF(KFLW.EQ.6) THEN + PMMN(I)=PMAS(24,1)+PMAS(5,1) + ENDIF +C...UED: select a graviton mass from continuous distribution +C...(stored in PMAS(39,1) so no value returned) + IF (IUED(1).EQ.1.AND.IUED(2).EQ.1.AND.KFLW.EQ.39) + & CALL PYGRAM(1) + 220 CONTINUE + +C...Check which two out of three are widest. + IWID1=1 + IWID2=2 + PWID1=PMAS(KFC1A,2) + PWID2=PMAS(KFC2A,2) + KFLW1=IABS(KFL1(JT)) + KFLW2=IABS(KFL2(JT)) + IF(KFL3(JT).NE.0) THEN + PWID3=PMAS(KFC3A,2) + IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN + IWID1=3 + PWID1=PWID3 + KFLW1=IABS(KFL3(JT)) + ELSEIF(PWID3.GT.PWID2) THEN + IWID2=3 + PWID2=PWID3 + KFLW2=IABS(KFL3(JT)) + ENDIF + ENDIF + IF(KFL4(JT).NE.0) THEN + PWID4=PMAS(KFC4A,2) + IF(PWID4.GT.PWID1.AND.PWID2.GE.PWID1) THEN + IWID1=4 + PWID1=PWID4 + KFLW1=IABS(KFL4(JT)) + ELSEIF(PWID4.GT.PWID2) THEN + IWID2=4 + PWID2=PWID4 + KFLW2=IABS(KFL4(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(PXSUM.GT.P(ID,5)) THEN + CALL PYERRM(13,'(PYRESD:) daughter masses too large') + MINT(51)=1 + GOTO 720 + ELSEIF(PXSUM+PARJ(64).GT.P(ID,5)) THEN + CALL PYERRM(3,'(PYRESD:) masses+PARJ(64) too large') + MINT(51)=1 + GOTO 720 + ENDIF + +C...For three wide resonances select narrower of three +C...according to BW decoupled from rest. + ELSE + PMTOT=P(ID,5) + IF(KFL3(JT).NE.0) THEN + IWID3=6-IWID1-IWID2 + KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))- + & KFLW1-KFLW2 + LOOP=0 + 230 LOOP=LOOP+1 + P(N+IWID3,5)=PYMASS(KFLW3) + IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230 + PMTOT=PMTOT-P(N+IWID3,5) + ENDIF +C...Select other two correlated within remaining phase space. + IF(IP.EQ.1) THEN + CKIN45=CKIN(45) + CKIN47=CKIN(47) + CKIN(45)=MAX(PMMN(IWID1),CKIN(45)) + CKIN(47)=MAX(PMMN(IWID2),CKIN(47)) + CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5), + & P(N+IWID2,5)) + CKIN(45)=CKIN45 + CKIN(47)=CKIN47 + ELSE + CKIN(49)=PMMN(IWID1) + CKIN(50)=PMMN(IWID2) + CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5), + & P(N+IWID2,5)) + CKIN(49)=0D0 + CKIN(50)=0D0 + ENDIF + IF(MINT(51).EQ.1) GOTO 720 + ENDIF + +C...Begin fill decay products, with colour flow for coloured objects. + MSTU10=MSTU(10) + MSTU(10)=1 + MSTU(19)=1 + + +C...Three-body decays + IF(KFL3(JT).NE.0.OR.KFL4(JT).NE.0) THEN + DO 250 I=N+1,N+NPROD + DO 240 J=1,5 + K(I,J)=0 + V(I,J)=0D0 + 240 CONTINUE + MCT(I,1)=0 + MCT(I,2)=0 + 250 CONTINUE + K(N+1,1)=1 + K(N+1,2)=KFL1(JT) + K(N+2,1)=1 + K(N+2,2)=KFL2(JT) + K(N+3,1)=1 + K(N+3,2)=KFL3(JT) + IF(KFL4(JT).NE.0) THEN + K(N+4,1)=1 + K(N+4,2)=KFL4(JT) + ENDIF + IDIN=ID + +C...Generate kinematics (default is flat) + IF(KFL4(JT).EQ.0) THEN + CALL PYTBDY(IDIN) + ELSE + PS=P(N+1,5)+P(N+2,5)+P(N+3,5)+P(N+4,5) + ND=4 + PV(1,1)=0D0 + PV(1,2)=0D0 + PV(1,3)=0D0 + PV(1,4)=P(IDIN,5) + PV(1,5)=P(IDIN,5) +C...Calculate maximum weight ND-particle decay. + PV(ND,5)=P(N+ND,5) + WTMAX=1D0/WTCOR(ND-2) + PMAX=PV(1,5)-PS+P(N+ND,5) + PMIN=0D0 + DO 381 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)) + 381 CONTINUE + +C...M-generator gives weight. If rejected, try again. + + 411 RORD(1)=1D0 + DO 441 IL1=2,ND-1 + RSAV=PYR(0) + DO 421 IL2=IL1-1,1,-1 + IF(RSAV.LE.RORD(IL2)) GOTO 431 + RORD(IL2+1)=RORD(IL2) + 421 CONTINUE + 431 RORD(IL2+1)=RSAV + 441 CONTINUE + RORD(ND)=0D0 + WT=1D0 + DO 451 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)) + 451 CONTINUE + IF(WT.LT.PYR(0)*WTMAX) GOTO 411 + +C...Perform two-particle decays in respective CM frame. + DO 481 IL=1,ND-1 + PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5)) + UE(3)=2D0*PYR(0)-1D0 + PHIX=PARU(2)*PYR(0) + UE(1)=SQRT(1D0-UE(3)**2)*COS(PHIX) + UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHIX) + DO 471 J=1,3 + P(N+IL,J)=PA*UE(J) + PV(IL+1,J)=-PA*UE(J) + 471 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) + 481 CONTINUE + +C...Lorentz transform decay products to lab frame. + DO 491 J=1,4 + P(N+ND,J)=PV(ND,J) + 491 CONTINUE + DO 531 IL=ND-1,1,-1 + DO 501 J=1,3 + BE(J)=PV(IL,J)/PV(IL,4) + 501 CONTINUE + GA=PV(IL,4)/PV(IL,5) + DO 521 I=N+IL,N+ND + BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3) + DO 511 J=1,3 + P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J) + 511 CONTINUE + P(I,4)=GA*(P(I,4)+BEP) + 521 CONTINUE + 531 CONTINUE + + ENDIF + +C...Set generic colour flows whenever unambiguous, +C...(independently of the order of the decay products) +C...Sum up total colour content + NANT=0 + NTRI=0 + NOCT=0 + KCQ(0)=KCQM(JT) + KCQ(1)=KCQ1(JT) + KCQ(2)=KCQ2(JT) + KCQ(3)=KCQ3(JT) + KCQ(4)=KCQ4(JT) + DO 255 J=0,NPROD + IF (KCQ(J).EQ.-1) THEN + NANT=NANT+1 + IANT(NANT)=N+J + ELSEIF (KCQ(J).EQ.1) THEN + NTRI=NTRI+1 + ITRI(NTRI)=N+J + ELSEIF (KCQ(J).EQ.2) THEN + NOCT=NOCT+1 + IOCT(NOCT)=N+J + ENDIF + 255 CONTINUE + +C...Set color flow for generic 1 -> N processes (N arbitrary) + IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN +C...All singlets: do nothing + + ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN +C...Two octets, zero triplets, n singlets: + IF (KCQ(0).EQ.2) THEN +C...8 -> 8 + n(1) + K(ID,4)=K(ID,4)+IOCT(2) + K(ID,5)=K(ID,5)+IOCT(2) + K(IOCT(2),1)=3 + K(IOCT(2),4)=MSTU(5)*ID + K(IOCT(2),5)=MSTU(5)*ID + MCT(IOCT(2),1)=MCT(ID,1) + MCT(IOCT(2),2)=MCT(ID,2) + ELSE +C...1 -> 8 + 8 + n(1) + K(IOCT(1),1)=3 + K(IOCT(1),4)=MSTU(5)*IOCT(2) + K(IOCT(1),5)=MSTU(5)*IOCT(2) + K(IOCT(2),1)=3 + K(IOCT(2),4)=MSTU(5)*IOCT(1) + K(IOCT(2),5)=MSTU(5)*IOCT(1) + NCT=NCT+1 + MCT(IOCT(1),1)=NCT + MCT(IOCT(2),2)=NCT + NCT=NCT+1 + MCT(IOCT(2),1)=NCT + MCT(IOCT(1),2)=NCT + ENDIF + + ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN +C...Two triplets, zero octets, n singlets. + IF (KCQ(0).EQ.1) THEN +C...3 -> 3 + n(1) + K(ID,4)=K(ID,4)+ITRI(2) + K(ITRI(2),1)=3 + K(ITRI(2),4)=MSTU(5)*ID + MCT(ITRI(2),1)=MCT(ID,1) + ELSEIF (KCQ(0).EQ.-1) THEN +C...3bar -> 3bar + n(1) + K(ID,5)=K(ID,5)+IANT(2) + K(IANT(2),1)=3 + K(IANT(2),5)=MSTU(5)*ID + MCT(IANT(2),2)=MCT(ID,2) + ELSE +C...1 -> 3 + 3bar + n(1) + K(ITRI(1),1)=3 + K(ITRI(1),4)=MSTU(5)*IANT(1) + K(IANT(1),1)=3 + K(IANT(1),5)=MSTU(5)*ITRI(1) + NCT=NCT+1 + MCT(ITRI(1),1)=NCT + MCT(IANT(1),2)=NCT + ENDIF + + ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN +C...Two triplets, one octet, n singlets. + IF (KCQ(0).EQ.2) THEN +C...8 -> 3 + 3bar + n(1) + K(ID,4)=K(ID,4)+ITRI(1) + K(ID,5)=K(ID,5)+IANT(1) + K(ITRI(1),1)=3 + K(ITRI(1),4)=MSTU(5)*ID + K(IANT(1),1)=3 + K(IANT(1),5)=MSTU(5)*ID + MCT(ITRI(1),1)=MCT(ID,1) + MCT(IANT(1),2)=MCT(ID,2) + ELSEIF (KCQ(0).EQ.1) THEN +C...3 -> 8 + 3 + n(1) + K(ID,4)=K(ID,4)+IOCT(1) + K(IOCT(1),1)=3 + K(IOCT(1),4)=MSTU(5)*ID + K(IOCT(1),5)=MSTU(5)*ITRI(2) + K(ITRI(2),1)=3 + K(ITRI(2),4)=MSTU(5)*IOCT(1) + MCT(IOCT(1),1)=MCT(ID,1) + NCT=NCT+1 + MCT(IOCT(1),2)=NCT + MCT(ITRI(2),1)=NCT + ELSEIF (KCQ(0).EQ.-1) THEN +C...3bar -> 8 + 3bar + n(1) + K(ID,5)=K(ID,5)+IOCT(1) + K(IOCT(1),1)=3 + K(IOCT(1),5)=MSTU(5)*ID + K(IOCT(1),4)=MSTU(5)*IANT(2) + K(IANT(2),1)=3 + K(IANT(2),5)=MSTU(5)*IOCT(1) + MCT(IOCT(1),2)=MCT(ID,2) + NCT=NCT+1 + MCT(IOCT(1),1)=NCT + MCT(IANT(2),2)=NCT + ELSE +C...1 -> 3 + 3bar + 8 + n(1) + K(ITRI(1),1)=3 + K(ITRI(1),4)=MSTU(5)*IOCT(1) + K(IOCT(1),1)=3 + K(IOCT(1),5)=MSTU(5)*ITRI(1) + K(IOCT(1),4)=MSTU(5)*IANT(1) + K(IANT(1),1)=3 + K(IANT(1),5)=MSTU(5)*IOCT(1) + NCT=NCT+1 + MCT(ITRI(1),1)=NCT + MCT(IOCT(1),2)=NCT + NCT=NCT+1 + MCT(IOCT(1),1)=NCT + MCT(IANT(1),2)=NCT + ENDIF + ELSEIF(NTRI+NANT.EQ.4) THEN +C... + IF (KCQ(0).EQ.1) THEN +C...3 -> 3 + n(1) -> 3 + 3bar + K(ID,4)=K(ID,4)+ITRI(2) + K(ITRI(2),1)=3 + K(ITRI(2),4)=MSTU(5)*ID + MCT(ITRI(2),1)=MCT(ID,1) + K(ITRI(3),1)=3 + K(ITRI(3),4)=MSTU(5)*IANT(1) + K(IANT(1),1)=3 + K(IANT(1),5)=MSTU(5)*ITRI(3) + NCT=NCT+1 + MCT(ITRI(3),1)=NCT + MCT(IANT(1),2)=NCT + ELSEIF (KCQ(0).EQ.-1) THEN +C...3bar -> 3bar + n(1) -> 3 + 3bar + K(ID,5)=K(ID,5)+IANT(2) + K(IANT(2),1)=3 + K(IANT(2),5)=MSTU(5)*ID + MCT(IANT(2),2)=MCT(ID,2) + K(ITRI(1),1)=3 + K(ITRI(1),4)=MSTU(5)*IANT(3) + K(IANT(3),1)=3 + K(IANT(3),5)=MSTU(5)*ITRI(1) + NCT=NCT+1 + MCT(ITRI(1),1)=NCT + MCT(IANT(3),2)=NCT + ENDIF + ELSEIF(KFL4(JT).NE.0) THEN + CALL PYERRM(21,'(PYRESD:) unknown 4-bdy decay') +CPS-- End of generic cases +C...(could three octets also be handled?) +C...(could (some of) the RPV cases be made generic as well?) + +C...Special cases (= old treatment) +C...Set colour flow for t -> W + b + Z. + ELSEIF(KFA.EQ.6) THEN + K(N+2,1)=3 + ISID=4 + IF(KCQM(JT).EQ.-1) ISID=5 + IDAU=N+2 + K(ID,ISID)=K(ID,ISID)+IDAU + K(IDAU,ISID)=MSTU(5)*ID + +C...Set colour flow in three-body decays - programmed as special cases. + + ELSEIF(KFC2A.LE.6) THEN + K(N+2,1)=3 + K(N+3,1)=3 + ISID=4 + IF(KFL2(JT).LT.0) ISID=5 + K(N+2,ISID)=MSTU(5)*(N+3) + K(N+3,9-ISID)=MSTU(5)*(N+2) +C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA) + ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10 + & .AND.KFL3(JT).NE.0) THEN + KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT)) +C...3-body decays of squarks to colour singlets plus one quark + IF (KQSUMA.EQ.1) THEN +C...Find quark + IQ=0 + IF (KCQ1(JT).NE.0) IQ=1 + IF (KCQ2(JT).NE.0) IQ=2 + IF (KCQ3(JT).NE.0) IQ=3 + ISID=4 + IF (K(N+IQ,2).LT.0) ISID=5 + K(N+IQ,1)=3 + K(ID,ISID)=K(ID,ISID)+(N+IQ) + K(N+IQ,ISID)=MSTU(5)*ID + ENDIF +C...PS-- + ELSEIF(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) + ELSEIF(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 +CMRENNA-- + + ELSEIF(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 + + NSAV=N + +C...Set colour flow in three-body decays with baryon number violation. +C...Neutralino and chargino decays first. + KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT) + IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN + ITJUNC(JT)=(1+(1-KCQ1(JT))/2) + K(N+4,4)=ITJUNC(JT)*MSTU(5) +C...Insert junction to keep track of colours. + IF(KCQ1(JT).NE.0) K(N+1,1)=3 + IF(KCQ2(JT).NE.0) K(N+2,1)=3 + IF(KCQ3(JT).NE.0) K(N+3,1)=3 +C...Set special junction codes: + K(N+4,1)=42 + K(N+4,2)=88 + +C...Order decay products by invariant mass. (will be used in PYSTRF). + PM12=P(N+1,4)*P(N+2,4)-P(N+1,1)*P(N+2,1)-P(N+1,2)*P(N+2,2)- + & P(N+1,3)*P(N+2,3) + PM13=P(N+1,4)*P(N+3,4)-P(N+1,1)*P(N+3,1)-P(N+1,2)*P(N+3,2)- + & P(N+1,3)*P(N+3,3) + PM23=P(N+2,4)*P(N+3,4)-P(N+2,1)*P(N+3,1)-P(N+2,2)*P(N+3,2)- + & P(N+2,3)*P(N+3,3) + IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN + K(N+4,4)=N+3+K(N+4,4) + K(N+4,5)=N+1+MSTU(5)*(N+2) + ELSEIF(PM13.LT.PM23) THEN + K(N+4,4)=N+2+K(N+4,4) + K(N+4,5)=N+1+MSTU(5)*(N+3) + ELSE + K(N+4,4)=N+1+K(N+4,4) + K(N+4,5)=N+2+MSTU(5)*(N+3) + ENDIF + DO 260 J=1,5 + P(N+4,J)=0D0 + V(N+4,J)=0D0 + 260 CONTINUE +C...Connect daughters to junction. + DO 270 II=N+1,N+3 + K(II,4)=0 + K(II,5)=0 + K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4) + 270 CONTINUE +C...Particle counter should be stepped up one extra for junction. + N=N+1 + +C...Gluino decays. + ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN + ITJUNC(JT)=(5+(1-KCQ1(JT))/2) + K(N+4,4)=ITJUNC(JT)*MSTU(5) +C...Insert junction to keep track of colours. + IF(KCQ1(JT).NE.0) K(N+1,1)=3 + IF(KCQ2(JT).NE.0) K(N+2,1)=3 + IF(KCQ3(JT).NE.0) K(N+3,1)=3 + K(N+4,1)=42 + K(N+4,2)=88 + DO 280 J=1,5 + P(N+4,J)=0D0 + V(N+4,J)=0D0 + 280 CONTINUE + CTMSUM=0D0 + DO 290 II=N+1,N+3 + K(II,4)=0 + K(II,5)=0 +C...Start by connecting all daughters to junction. + K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4) +C...Only consider colour topologies with off shell resonances. + RMQ1=PMAS(PYCOMP(K(II,2)),1) + RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1) + RMGLU=PMAS(PYCOMP(KSUSY1+21),1) + IF (RMGLU-RMQ1.LT.RMRES) THEN +C...Calculate propagators for each colour topology. + RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1) + & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3)) + CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2 + ELSE + CTM2(II-N)=0D0 + ENDIF + CTMSUM=CTMSUM+CTM2(II-N) + 290 CONTINUE + CTMSUM=PYR(0)*CTMSUM +C...Select colour topology J, with most off shell least likely. + J=0 + 300 J=J+1 + CTMSUM=CTMSUM-CTM2(J) + IF (CTMSUM.GT.0D0) GOTO 300 +C...The lucky winner gets its colour (anti-colour) directly from gluino. + K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID + K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5) +C...The other gluino colour is connected to junction + K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))* + & MSTU(5) + K(N+4,4)=K(N+4,4)+ID +C...Lastly, connect junction to remaining daughters. + K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3)) +C...Particle counter should be stepped up one extra for junction. + N=N+1 + ENDIF + +C...Update particle counter. + N=N+NPROD + +C...2) Everything else two-body decay. + ELSE + CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5)) + MCT(N-1,1)=0 + MCT(N-1,2)=0 + MCT(N,1)=0 + MCT(N,2)=0 +C...First set colour flow as if mother colour singlet. + IF(KCQ1(JT).NE.0) THEN + K(N-1,1)=3 + IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N + IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N + ENDIF + IF(KCQ2(JT).NE.0) THEN + K(N,1)=3 + IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1) + IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1) + ENDIF +C...Then redirect colour flow if mother (anti)triplet. + IF(KCQM(JT).EQ.0) THEN + ELSEIF(KCQM(JT).NE.2) THEN + ISID=4 + IF(KCQM(JT).EQ.-1) ISID=5 + IDAU=N-1 + IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N + K(ID,ISID)=K(ID,ISID)+IDAU + K(IDAU,ISID)=MSTU(5)*ID +C...Then redirect colour flow if mother octet. + ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN + IDAU=N-1 + IF(KCQ1(JT).EQ.0) IDAU=N + K(ID,4)=K(ID,4)+IDAU + K(ID,5)=K(ID,5)+IDAU + K(IDAU,4)=MSTU(5)*ID + K(IDAU,5)=MSTU(5)*ID + ELSE + ISID=4 + IF(KCQ1(JT).EQ.-1) ISID=5 + IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0)) + K(ID,ISID)=K(ID,ISID)+(N-1) + K(ID,9-ISID)=K(ID,9-ISID)+N + K(N-1,ISID)=MSTU(5)*ID + K(N,9-ISID)=MSTU(5)*ID + ENDIF + +C...Insert junction + IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN + N=N+1 +C...~q* mother: type 3 junction. ~q mother: type 4. + ITJUNC(JT)=(7+KCQM(JT))/2 +C...Specify junction KF and set colour flow from junction + K(N,1)=42 + K(N,2)=88 + K(N,3)=ID +C...Junction type encoded together with mother: + K(N,4)=ID+ITJUNC(JT)*MSTU(5) + K(N,5)=N-1+MSTU(5)*(N-2) +C...Zero P and V for junction (V filled later) + DO 310 J=1,5 + P(N,J)=0D0 + V(N,J)=0D0 + 310 CONTINUE +C...Set colour flow from mother to junction + K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5)) +C...Set colour flow from daughters to junction + DO 320 II=N-2,N-1 + K(II,4) = 0 + K(II,5) = 0 +C...(Anti-)colour mother is junction. + K(II,1+ITJUNC(JT)) = MSTU(5)*N + 320 CONTINUE + ENDIF + ENDIF + +C...End loop over resonances for daughter flavour and mass selection. + MSTU(10)=MSTU10 + 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0)) + & NINH=NINH+1 + IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND. + & KFL1(JT).EQ.0) THEN + WRITE(CODE,'(I9)') K(ID,2) + WRITE(MASS,'(F9.3)') P(ID,5) + CALL PYERRM(3,'(PYRESD:) Failed to decay particle'// + & CODE//' with mass'//MASS) + MINT(51)=1 + GOTO 720 + ENDIF + 340 CONTINUE + +C...Check for allowed combinations. Skip if no decays. + IF(JTMAX.EQ.1) THEN + IF(KDCY(1).EQ.0) GOTO 710 + ELSEIF(JTMAX.EQ.2) THEN + IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710 + IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180 + IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180 + ELSEIF(JTMAX.EQ.3) THEN + IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710 + IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180 + IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180 + IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180 + IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180 + IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180 + IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180 + ENDIF + +C...Special case: matrix element option for Z0 decay to quarks. + IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND. + &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN + +C...Check consistency of MSTJ options set. + IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN + CALL PYERRM(6, + & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1') + MSTJ(110)=1 + ENDIF + IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN + CALL PYERRM(6, + & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0') + + MSTJ(111)=0 + ENDIF + +C...Select alpha_strong behaviour. + MST111=MSTU(111) + PAR112=PARU(112) + MSTU(111)=MSTJ(108) + IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1)) + & MSTU(111)=1 + PARU(112)=PARJ(121) + IF(MSTU(111).EQ.2) PARU(112)=PARJ(122) + +C...Find axial fraction in total cross section for scalar gluon model. + PARJ(171)=0D0 + IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR. + & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN + POLL=1D0-PARJ(131)*PARJ(132) + SFF=1D0/(16D0*XW*XW1) + SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+ + & (PARJ(123)*PARJ(124))**2) + SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2) + VE=4D0*XW-1D0 + HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131)) + HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE* + & (PARJ(132)-PARJ(131))) + KFLC=IABS(KFL1(1)) + PMQ=PYMASS(KFLC) + QF=KCHG(KFLC,1)/3D0 + VQ=1D0 + IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0, + & 1D0-(2D0*PMQ/P(ID,5))**2)) + VF=SIGN(1D0,QF)-4D0*QF*XW + RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+ + & VF**2*HF1W)+VQ**3*HF1W + IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV) + ENDIF + +C...Choice of jet configuration. + CALL PYXJET(P(ID,5),NJET,CUT) + KFLC=IABS(KFL1(1)) + KFLN=21 + IF(NJET.EQ.4) THEN + CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14) + ELSEIF(NJET.EQ.3) THEN + CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3) + ELSE + MSTJ(120)=1 + ENDIF + +C...Fill jet configuration; return if incorrect kinematics. + NC=N-2 + IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN + CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5)) + ELSEIF(NJET.EQ.2) THEN + CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5)) + ELSEIF(NJET.EQ.3) THEN + CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3) + ELSEIF(KFLN.EQ.21) THEN + CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4, + & X12,X14) + ELSE + CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4, + & X12,X14) + ENDIF + IF(MSTU(24).NE.0) THEN + MINT(51)=1 + MSTU(111)=MST111 + PARU(112)=PAR112 + GOTO 720 + ENDIF + +C...Angular orientation according to matrix element. + IF(MSTJ(106).EQ.1) THEN + CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ) + IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ + CTHE(1)=COS(THEZ) + CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0) + CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0) + ENDIF + +C...Boost partons to Z0 rest frame. + CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4), + & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4)) + +C...Mark decayed resonance and add documentation lines, + K(ID,1)=K(ID,1)+10 + IDOC=MINT(83)+MINT(4) + DO 360 I=NC+1,N + I1=MINT(83)+MINT(4)+1 + K(I,3)=I1 + IF(MSTP(128).GE.1) K(I,3)=ID + IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN + MINT(4)=MINT(4)+1 + K(I1,1)=21 + K(I1,2)=K(I,2) + K(I1,3)=IREF(IP,4) + DO 350 J=1,5 + P(I1,J)=P(I,J) + 350 CONTINUE + ENDIF + 360 CONTINUE + +C...Generate parton shower. + IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN + CALL PYSHOW(N-1,N,P(ID,5)) + ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN + NPART=2 + IPART(1)=N-1 + IPART(2)=N + PTPART(1)=0.5D0*P(ID,5) + PTPART(2)=PTPART(1) + NCT=NCT+1 + IF(K(N-1,2).GT.0) THEN + MCT(N-1,1)=NCT + MCT(N,2)=NCT + ELSE + MCT(N-1,2)=NCT + MCT(N,1)=NCT + ENDIF + CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN) + ENDIF + +C... End special case for Z0: skip ahead. + MSTU(111)=MST111 + PARU(112)=PAR112 + GOTO 700 + ENDIF + +C...Order incoming partons and outgoing resonances. + IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND. + &NINH.EQ.0) THEN + ILIN(1)=MINT(84)+1 + IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2 + IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22) + & ILIN(1)=2*MINT(84)+3-ILIN(1) + ILIN(2)=2*MINT(84)+3-ILIN(1) + IMIN=1 + IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7) + & .EQ.36) IMIN=3 + IMAX=2 + IORD=1 + IF(K(IREF(IP,1),2).EQ.23) IORD=2 + IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2 + IAKIPD=IABS(K(IREF(IP,IORD),2)) + IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD + IF(KDCY(IORD).EQ.0) IORD=3-IORD + +C...Order decay products of resonances. + DO 370 JT=IORD,3-IORD,3-2*IORD + IF(KDCY(JT).EQ.0) THEN + ILIN(IMAX+1)=NSD(JT) + IMAX=IMAX+1 + ELSEIF(K(NSD(JT)+1,2).GT.0) THEN + ILIN(IMAX+1)=N+2*JT-1 + ILIN(IMAX+2)=N+2*JT + IMAX=IMAX+2 + K(N+2*JT-1,2)=K(NSD(JT)+1,2) + K(N+2*JT,2)=K(NSD(JT)+2,2) + ELSE + ILIN(IMAX+1)=N+2*JT + + ILIN(IMAX+2)=N+2*JT-1 + IMAX=IMAX+2 + K(N+2*JT-1,2)=K(NSD(JT)+1,2) + K(N+2*JT,2)=K(NSD(JT)+2,2) + ENDIF + 370 CONTINUE + +C...Find charge, isospin, left- and righthanded couplings. + DO 390 I=IMIN,IMAX + DO 380 J=1,4 + COUP(I,J)=0D0 + 380 CONTINUE + KFA=IABS(K(ILIN(I),2)) + IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390 + COUP(I,1)=KCHG(KFA,1)/3D0 + COUP(I,2)=(-1)**MOD(KFA,2) + COUP(I,4)=-2D0*COUP(I,1)*XWV + COUP(I,3)=COUP(I,2)+COUP(I,4) + 390 CONTINUE + +C...Full propagator dependence and flavour correlations for 2 gamma*/Z. + IF(ISUB.EQ.22) THEN + DO 420 I=3,5,2 + I1=IORD + IF(I.EQ.5) I1=3-IORD + DO 410 J1=1,2 + DO 400 J2=1,2 + CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/ + & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)* + & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)* + & COUP(I,J2+2)**2 + 400 CONTINUE + 410 CONTINUE + 420 CONTINUE + COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+ + & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)) + COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))* + & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2)) + + IF(COWT12.LT.PYR(0)*COMX12) GOTO 180 + ENDIF + ENDIF + +C...Select angular orientation type - Z'/W' only. + MZPWP=0 + IF(ISUB.EQ.141) THEN + IF(PYR(0).LT.PARU(130)) MZPWP=1 + IF(IP.EQ.2) THEN + IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2 + IAKIR=IABS(K(IREF(2,2),2)) + IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2 + IF(IAKIR.LE.20) MZPWP=2 + ENDIF + IF(IP.GE.3) MZPWP=2 + ELSEIF(ISUB.EQ.142) THEN + IF(PYR(0).LT.PARU(136)) MZPWP=1 + IF(IP.EQ.2) THEN + IAKIR=IABS(K(IREF(2,2),2)) + IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2 + IF(IAKIR.LE.20) MZPWP=2 + ENDIF + IF(IP.GE.3) MZPWP=2 + ENDIF + +C...Select random angles (begin of weighting procedure). + 430 DO 440 JT=1,JTMAX + IF(KDCY(JT).EQ.0) GOTO 440 + IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN + CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0) + IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33) + PHI(JT)=VINT(24) + ELSE + CTHE(JT)=2D0*PYR(0)-1D0 + PHI(JT)=PARU(2)*PYR(0) + ENDIF + 440 CONTINUE + + IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN +C...Construct massless four-vectors. + DO 460 I=N+1,N+4 + K(I,1)=1 + DO 450 J=1,5 + P(I,J)=0D0 + V(I,J)=0D0 + 450 CONTINUE + 460 CONTINUE + DO 470 JT=1,JTMAX + IF(KDCY(JT).EQ.0) GOTO 470 + ID=IREF(IP,JT) + P(N+2*JT-1,3)=0.5D0*P(ID,5) + P(N+2*JT-1,4)=0.5D0*P(ID,5) + P(N+2*JT,3)=-0.5D0*P(ID,5) + P(N+2*JT,4)=0.5D0*P(ID,5) + CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT), + & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4)) + 470 CONTINUE + +C...Store incoming and outgoing momenta, with random rotation to +C...avoid accidental zeroes in HA expressions. + IF(ISUB.NE.0) THEN + DO 490 I=IMIN,IMAX + K(N+4+I,1)=1 + P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+ + & P(ILIN(I),3)**2+P(ILIN(I),5)**2) + P(N+4+I,5)=P(ILIN(I),5) + DO 480 J=1,3 + P(N+4+I,J)=P(ILIN(I),J) + 480 CONTINUE + 490 CONTINUE + 500 THERR=ACOS(2D0*PYR(0)-1D0) + PHIRR=PARU(2)*PYR(0) + CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0) + DO 520 I=IMIN,IMAX + IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+ + & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500 + DO 510 J=1,4 + PK(I,J)=P(N+4+I,J) + 510 CONTINUE + 520 CONTINUE + ENDIF + +C...Calculate internal products. + IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR. + & ISUB.EQ.142) THEN + DO 540 I1=IMIN,IMAX-1 + DO 530 I2=I1+1,IMAX + HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+ + & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))* + & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))- + & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/ + & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))* + & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2))) + HC(I1,I2)=CONJG(HA(I1,I2)) + IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2) + IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2) + HA(I2,I1)=-HA(I1,I2) + HC(I2,I1)=-HC(I1,I2) + 530 CONTINUE + 540 CONTINUE + ENDIF + +C...Calculate four-products. + IF(ISUB.NE.0) THEN + DO 560 I=1,2 + DO 550 J=1,4 + PK(I,J)=-PK(I,J) + 550 CONTINUE + 560 CONTINUE + DO 580 I1=IMIN,IMAX-1 + DO 570 I2=I1+1,IMAX + PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)- + & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3)) + PKK(I2,I1)=PKK(I1,I2) + 570 CONTINUE + 580 CONTINUE + ENDIF + ENDIF + + KFAGM=IABS(IREF(IP,7)) + IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN +C...Isotropic decay selected by user. + WT=1D0 + WTMAX=1D0 + + ELSEIF(JTMAX.EQ.3) THEN +C...Isotropic decay when three mother particles. + WT=1D0 + WTMAX=1D0 + + ELSEIF(IT4.GE.1) THEN +C... Isotropic decay t -> b + W etc for 4th generation q and l. + WT=1D0 + WTMAX=1D0 + + ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR. + & IREF(IP,7).EQ.36) THEN +C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons. +C...CP-odd case added by Kari Ertresvag Myklevoll. +C...Now also with mixed Higgs CP-states + ETA=PARP(25) + IF(IP.EQ.1) WTMAX=SH**2 + IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4 + KFA=IABS(K(IREF(IP,1),2)) + KFT=IABS(K(IREF(IP,2),2)) + + IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND. + & MSTP(25).GE.3) THEN +C...For mixed CP states need epsilon product. + P10=PK(3,4) + P20=PK(4,4) + P30=PK(5,4) + P40=PK(6,4) + P11=PK(3,1) + P21=PK(4,1) + P31=PK(5,1) + P41=PK(6,1) + P12=PK(3,2) + P22=PK(4,2) + P32=PK(5,2) + P42=PK(6,2) + P13=PK(3,3) + P23=PK(4,3) + P33=PK(5,3) + P43=PK(6,3) + EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22* + & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11* + & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+ + & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30* + & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20* + & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13* + & P22*P30*P41+P13*P22*P31*P40 +C...For mixed CP states need gauge boson masses. + XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2- + & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2)) + XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2- + & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2)) + XMV=PMAS(KFA,1) + ENDIF + +C...Z decay + IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN + KFLF1A=IABS(KFL1(1)) + EF1=KCHG(KFLF1A,1)/3D0 + AF1=SIGN(1D0,EF1+0.1D0) + VF1=AF1-4D0*EF1*XWV + KFLF2A=IABS(KFL1(2)) + EF2=KCHG(KFLF2A,1)/3D0 + AF2=SIGN(1D0,EF2+0.1D0) + VF2=AF2-4D0*EF2*XWV + VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2)) + IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1) + & THEN +C...CP-even decay + WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+ + & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5) + ELSEIF(MSTP(25).LE.2) THEN +C...CP-odd decay + WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2 + & -2*PKK(3,4)*PKK(5,6) + & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/ + & (PKK(3,4)*PKK(5,6)) + & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))* + & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS) + ELSE +C...Mixed CP states. + WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6) + & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5)) + & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6)) + & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5))) + & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2 + & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2 + & +PKK(3,4)*PKK(5,6) + & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2) + & +VA12AS*PKK(3,4)*PKK(5,6) + & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6)) + & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6)))) + & /(1D0 +2D0*ETA*XMA*XMB/XMV**2 + & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS)) + ENDIF + +C...W decay + ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN + IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1) + & THEN +C...CP-even decay + WT=16D0*PKK(3,5)*PKK(4,6) + ELSEIF(MSTP(25).LE.2) THEN +C...CP-odd decay + WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2 + & -2*PKK(3,4)*PKK(5,6) + & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/ + & (PKK(3,4)*PKK(5,6)) + & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))* + & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6))) + ELSE +C...Mixed CP states. + WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6) + & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6)) + & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2 + & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2 + & +PKK(3,4)*PKK(5,6) + & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2) + & +PKK(3,4)*PKK(5,6) + & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6)) + & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6)))) + & /(1D0 +2D0*ETA*XMA*XMB/XMV**2 + & +(2D0*ETA*XMA*XMB/XMV**2)**2) + ENDIF + +C...No angular correlations in other Higgs decays. + ELSE + WT=WTMAX + ENDIF + + ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR. + & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24) + & THEN +C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons. + I1=IREF(IP,8) + IF(MOD(KFAGM,2).EQ.0) THEN + I2=N+1 + I3=N+2 + ELSE + I2=N+2 + I3=N+1 + ENDIF + I4=IREF(IP,2) + WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)- + & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)- + & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3)) + WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0 + + ELSEIF(ISUB.EQ.1) THEN +C...Angular weight for gamma*/Z0 -> 2 quarks/leptons. + EI=KCHG(IABS(MINT(15)),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + EF=KCHG(IABS(KFL1(1)),1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + + VF=AF-4D0*EF*XWV + RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH) + WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+ + & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2) + WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+ + & (VI**2+AI**2)*VINT(114)*VF**2) + WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+ + & 4D0*VI*AI*VINT(114)*VF*AF) + WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+ + & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)) + WTMAX=2D0*(WT1+ABS(WT3)) + + ELSEIF(ISUB.EQ.2) THEN +C...Angular weight for W+/- -> 2 quarks/leptons. + RM3=PMAS(IABS(KFL1(1)),1)**2/SH + RM4=PMAS(IABS(KFL2(1)),1)**2/SH + BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) + WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2 + WTMAX=4D0 + + ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN +C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) -> +C...-> gluon/gamma + 2 quarks/leptons. + CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ + & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+ + & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2 + CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ + & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+ + & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2 + CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ + & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+ + & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2 + CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ + & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+ + & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2 + WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+ + & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2) + WTMAX=(CLILF+CLIRF+CRILF+CRIRF)* + & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2) + + ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN +C...Angular weight for f + fbar' -> gluon/gamma + W+/- -> +C...-> gluon/gamma + 2 quarks/leptons. + WT=PKK(1,3)**2+PKK(2,4)**2 + WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2 + + ELSEIF(ISUB.EQ.22) THEN +C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons. + S34=P(IREF(IP,IORD),5)**2 + S56=P(IREF(IP,3-IORD),5)**2 + TI=PKK(1,3)+PKK(1,4)+S34 + UI=PKK(1,5)+PKK(1,6)+S56 + TIR=REAL(TI) + UIR=REAL(UI) + FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2 + FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2 + FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2 + FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2 + FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2 + FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2 + FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2 + FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2 + + WT= + & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+ + & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+ + & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+ + & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264 + WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+ + & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56* + & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+ + & 1D0/UI**2)) + + ELSEIF(ISUB.EQ.23) THEN +C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons. + D34=P(IREF(IP,IORD),5)**2 + D56=P(IREF(IP,3-IORD),5)**2 + DT=PKK(1,3)+PKK(1,4)+D34 + DU=PKK(1,5)+PKK(1,6)+D56 + FACBW=1D0/((SH-SQMW)**2+GMMW**2) + CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW + CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW + FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+ + + & REAL(CBWZ)*FGK(1,2,5,6,3,4)) + FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+ + & REAL(CBWZ)*FGK(1,2,6,5,3,4)) + WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2 + WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2* + & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU)) + + ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN +C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0 +C...(or H0, or A0). + WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)* + & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)* + & COUP(3,3))**2)*PKK(1,4)*PKK(2,3) + WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)* + & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4)) + + ELSEIF(ISUB.EQ.25) THEN +C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons. + POLR=(1D0+PARJ(132))*(1D0-PARJ(131)) + POLL=(1D0-PARJ(132))*(1D0+PARJ(131)) + D34=P(IREF(IP,IORD),5)**2 + D56=P(IREF(IP,3-IORD),5)**2 + DT=PKK(1,3)+PKK(1,4)+D34 + DU=PKK(1,5)+PKK(1,6)+D56 + FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2) + CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH + CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT + CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU + CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH + FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)- + & REAL(CBWW)*FGK(1,2,5,6,3,4)) + FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6)) + IF(MSTP(50).LE.0) THEN + WT=FGK135**2+(CCWW*FGK253)**2 + WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)- + & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)- + & DJGK(DT,DU))) + ELSE + WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2 + WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+ + & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+ + & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))) + ENDIF + + ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN +C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0 +C...(or H0, or A0). + WT=PKK(1,3)*PKK(2,4) + WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4)) + + ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN +C...Angular weight for f + g/gamma -> f + (gamma*/Z0) +C...-> f + 2 quarks/leptons. + CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ + & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+ + & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2 + CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ + & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+ + & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2 + CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ + & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+ + & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2 + CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+ + & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+ + & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2 + IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+ + & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2) + IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+ + & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2) + WTMAX=(CLILF+CLIRF+CRILF+CRIRF)* + & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2) + + ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN +C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions. + IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2 + IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2 + WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2 + + ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR. + & ISUB.EQ.77) THEN +C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W). + WT=16D0*PKK(3,5)*PKK(4,6) + WTMAX=SH**2 + + ELSEIF(ISUB.EQ.110) THEN +C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic. + WT=1D0 + WTMAX=1D0 + + ELSEIF(ISUB.EQ.141) THEN +C...Special case: if only branching ratios known then isotropic decay. + IF(MWID(32).EQ.2) THEN + WT=1D0 + WTMAX=1D0 + ELSEIF(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 +C...Special case: if only branching ratios known then isotropic decay. + IF(MWID(34).EQ.2) THEN + WT=1D0 + WTMAX=1D0 + ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN +C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons. + KFAI=IABS(MINT(15)) + KFAIC=1 + IF(KFAI.GT.10) KFAIC=2 + VI=PARU(129+2*KFAIC) + AI=PARU(130+2*KFAIC) + KFAF=IABS(KFL1(1)) + KFAFC=1 + IF(KFAF.GT.10) KFAFC=2 + VF=PARU(129+2*KFAFC) + AF=PARU(130+2*KFAFC) + ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2)) + WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2 + WTMAX=2D0+ABS(ASYM) + ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN +C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0. + RM1=P(NSD(1)+1,5)**2/SH + RM2=P(NSD(1)+2,5)**2/SH + CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)* + & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2) + CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+ + & (RM2-RM1)**2) + WT=CFLAT+CCOS2*CTHE(1)**2 + WTMAX=CFLAT+MAX(0D0,CCOS2) + ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN +C...Angular weight for f + fbar -> W'+/- -> W+/- + h0. + RM1=P(NSD(1)+1,5)**2/SH + RM2=P(NSD(1)+2,5)**2/SH + FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2) + WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1) + WTMAX=1D0+FLAM2/(8D0*RM1) + ELSEIF(MZPWP.EQ.0) THEN +C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons +C...(W/Z like if intermediate W). + D34=P(IREF(IP,IORD),5)**2 + D56=P(IREF(IP,3-IORD),5)**2 + DT=PKK(1,3)+PKK(1,4)+D34 + DU=PKK(1,5)+PKK(1,6)+D56 + FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4)) + FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4)) + WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2 + WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)* + & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)) + ELSEIF(MZPWP.EQ.1) THEN +C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons +C...(W/Z approximately longitudinal, like if intermediate H). + WT=16D0*PKK(3,5)*PKK(4,6) + WTMAX=SH**2 + ELSE +C...Angular weight for f + fbar -> W' -> W + h0 -> whatever, +C...t + bbar -> t + W + bbar. + WT=1D0 + WTMAX=1D0 + ENDIF + + ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164) + & THEN +C...Isotropic decay of leptoquarks (assumed spin 0). + WT=1D0 + WTMAX=1D0 + + ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN +C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-). + SIDE=1D0 + IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0 + IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN + WT=1D0+SIDE*CTHE(1) + WTMAX=2D0 + ELSEIF(IP.EQ.1) THEN + + RM1=P(NSD(1)+1,5)**2/SH + WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1) + WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1) + ELSE +C...W/Z decay assumed isotropic, since not known. + WT=1D0 + WTMAX=1D0 + ENDIF + + ELSEIF(ISUB.EQ.149) THEN +C...Isotropic decay of techni-eta. + WT=1D0 + WTMAX=1D0 + + ELSEIF(ISUB.EQ.191) THEN + IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN +C...Angular weight for f + fbar -> rho_tc0 -> W+ W-, +C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-. + WT=1D0-CTHE(1)**2 + WTMAX=1D0 + ELSEIF(IP.EQ.1) THEN +C...Angular weight for f + fbar -> rho_tc0 -> f fbar. + CTHESG=CTHE(1)*ISIGN(1,MINT(15)) + XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW)) + BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) + BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) + KFAI=IABS(MINT(15)) + EI=KCHG(KFAI,1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=0.5D0*(VI+AI) + VARI=0.5D0*(VI-AI) + ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2 + ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2 + KFAF=IABS(KFL1(1)) + EF=KCHG(KFAF,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + VALF=0.5D0*(VF+AF) + VARF=0.5D0*(VF-AF) + ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2 + ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2 + ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF + AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF + WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2 + WTMAX=4D0*MAX(ASAME,AFLIP) + ELSE +C...Isotropic decay of W/pi_tc produced in rho_tc decay. + WT=1D0 + WTMAX=1D0 + ENDIF + + ELSEIF(ISUB.EQ.192) THEN + IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN +C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0, +C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0. + WT=1D0-CTHE(1)**2 + WTMAX=1D0 + ELSEIF(IP.EQ.1) THEN +C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'. + CTHESG=CTHE(1)*ISIGN(1,MINT(15)) + WT=(1D0+CTHESG)**2 + WTMAX=4D0 + ELSE +C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay. + WT=1D0 + WTMAX=1D0 + ENDIF + + ELSEIF(ISUB.EQ.193) THEN + IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN +C...Angular weight for f + fbar -> omega_tc0 -> +C...gamma pi_tc0 or Z0 pi_tc0. + WT=1D0+CTHE(1)**2 + WTMAX=2D0 + ELSEIF(IP.EQ.1) THEN +C...Angular weight for f + fbar -> omega_tc0 -> f fbar. + CTHESG=CTHE(1)*ISIGN(1,MINT(15)) + BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) + BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) + KFAI=IABS(MINT(15)) + EI=KCHG(KFAI,1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=0.5D0*(VI+AI) + VARI=0.5D0*(VI-AI) + BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2 + BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2 + KFAF=IABS(KFL1(1)) + EF=KCHG(KFAF,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + VALF=0.5D0*(VF+AF) + VARF=0.5D0*(VF-AF) + BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2 + BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2 + BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF + BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF + WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2 + WTMAX=4D0*MAX(BSAME,BFLIP) + ELSE +C...Isotropic decay of Z/pi_tc produced in omega_tc decay. + WT=1D0 + WTMAX=1D0 + ENDIF + + ELSEIF(ISUB.EQ.353) THEN +C...Angular weight for Z_R0 -> 2 quarks/leptons. + EI=KCHG(IABS(MINT(15)),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + EF=KCHG(PYCOMP(KFL1(1)),1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH) + WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2) + WT2=RMF*(VI**2+AI**2)*VF**2 + WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF + WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+ + & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)) + WTMAX=2D0*(WT1+ABS(WT3)) + + ELSEIF(ISUB.EQ.354) THEN +C...Angular weight for W_R+/- -> 2 quarks/leptons. + RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH + RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH + BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) + WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2 + WTMAX=4D0 + + ELSEIF(ISUB.EQ.391) THEN +C...Angular weight for f + fbar -> G* -> f + fbar + IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN + WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4 + WTMAX=2D0 +C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g +C...implemented by M.-C. Lemaire + ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR. + & IABS(KFL1(1)).EQ.22)) THEN + WT=1D0-CTHE(1)**4 + WTMAX=1D0 +C...Other G* decays not yet implemented angular distributions. + ELSE + WT=1D0 + WTMAX=1D0 + ENDIF + + ELSEIF(ISUB.EQ.392) THEN +C...Angular weight for g + g -> G* -> f + fbar + IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN + WT=1D0-CTHE(1)**4 + WTMAX=1D0 +C...Angular weight for g + g -> G* -> gamma +gamma or g + g +C...implemented by M.-C. Lemaire + ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR. + & IABS(KFL1(1)).EQ.22)) THEN + WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4 + WTMAX=8D0 +C...Other G* decays not yet implemented angular distributions. + ELSE + WT=1D0 + WTMAX=1D0 + ENDIF + +C...Obtain correct angular distribution by rejection techniques. + ELSE + WT=1D0 + WTMAX=1D0 + ENDIF + IF(WT.LT.PYR(0)*WTMAX) GOTO 430 + +C...Construct massive four-vectors using angles chosen. + 590 DO 690 JT=1,JTMAX + IF(KDCY(JT).EQ.0) GOTO 690 + ID=IREF(IP,JT) + DO 600 J=1,5 + DPMO(J)=P(ID,J) + 600 CONTINUE + DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2) +CMRENNA++ + NPROD=2 + IF(KFL3(JT).NE.0) NPROD=3 + IF(KFL4(JT).NE.0) NPROD=4 + CALL PYROBO(NSD(JT)+1,NSD(JT)+NPROD,ACOS(CTHE(JT)),PHI(JT), + & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4)) + N0=NSD(JT)+NPROD + + DO 610 J=1,4 + VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5) + 610 CONTINUE +C...Fill in position of decay vertex. + DO 630 I=NSD(JT)+1,N0 + DO 620 J=1,4 + V(I,J)=VDCY(J) + 620 CONTINUE + V(I,5)=0D0 + + 630 CONTINUE +CMRENNA-- + +C...Mark decayed resonances; trace history. + K(ID,1)=K(ID,1)+10 + KFA=IABS(K(ID,2)) + KCA=PYCOMP(KFA) + IF(KCQM(JT).NE.0) THEN +C...Do not kill colour flow through coloured resonance! + ELSE + K(ID,4)=NSD(JT)+1 + K(ID,5)=NSD(JT)+NPROD + IF(ITJUNC(JT).NE.0) K(ID,5)=K(ID,5)+1 +C...If 3-body or 2-body with junction: +c IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3 +C...If 3-body with junction: +c IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4 + ENDIF + +C...Add documentation lines. + ISUBRG=MAX(1,MIN(500,MINT(1))) + IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN + IDOC=MINT(83)+MINT(4) +CMRENNA+++ + IHI=NSD(JT)+NPROD +c IF(KFL3(JT).NE.0) IHI=IHI+1 + DO 650 I=NSD(JT)+1,IHI +CMRENNA--- + I1=MINT(83)+MINT(4)+1 + K(I,3)=I1 + IF(MSTP(128).GE.1) K(I,3)=ID + IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN + MINT(4)=MINT(4)+1 + K(I1,1)=21 + K(I1,2)=K(I,2) + K(I1,3)=IREF(IP,JT+3) + DO 640 J=1,5 + P(I1,J)=P(I,J) + 640 CONTINUE + ENDIF + 650 CONTINUE + ELSE + K(NSD(JT)+1,3)=ID + K(NSD(JT)+2,3)=ID +C...If 3-body or 2-body with junction: + IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID +C...If 3-body with junction: + IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID +C...If 4-body or 3-body with junction: + IF(KFL4(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID +C...If 4-body with junction: + IF(KFL4(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+5,3)=ID + ENDIF + +C...Do showering of two or three objects. + NSHBEF=N + IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN + IF(KFL3(JT).EQ.0) THEN + CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5)) + ELSE + CALL PYSHOW(NSD(JT)+1,-NPROD,P(ID,5)) + ENDIF + +c...For pT-ordered shower need set up first, especially colour tags. +C...(Need to set up colour tags even if MSTP(71) = 0) + ELSEIF(MINT(35).GE.2) THEN + NPART=NPROD +c IF(KFL3(JT).NE.0) NPART=3 + IPART(1)=NSD(JT)+1 + IPART(2)=NSD(JT)+2 + IPART(3)=NSD(JT)+3 + IPART(4)=NSD(JT)+4 + PTPART(1)=0.5D0*P(ID,5) + PTPART(2)=PTPART(1) + PTPART(3)=PTPART(1) + PTPART(4)=PTPART(1) + IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN + MOTHER=K(NSD(JT)+1,4)/MSTU(5) + IF(MOTHER.LE.NSD(JT)) THEN + MCT(NSD(JT)+1,1)=MCT(MOTHER,1) + ELSE + NCT=NCT+1 + MCT(NSD(JT)+1,1)=NCT + MCT(MOTHER,2)=NCT + ENDIF + ENDIF + IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN + MOTHER=K(NSD(JT)+1,5)/MSTU(5) + IF(MOTHER.LE.NSD(JT)) THEN + MCT(NSD(JT)+1,2)=MCT(MOTHER,2) + ELSE + NCT=NCT+1 + MCT(NSD(JT)+1,2)=NCT + MCT(MOTHER,1)=NCT + ENDIF + ENDIF + IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR. + & KCQ2(JT).EQ.2)) THEN + MOTHER=K(NSD(JT)+2,4)/MSTU(5) + IF(MOTHER.LE.NSD(JT)) THEN + MCT(NSD(JT)+2,1)=MCT(MOTHER,1) + ELSE + NCT=NCT+1 + MCT(NSD(JT)+2,1)=NCT + MCT(MOTHER,2)=NCT + ENDIF + ENDIF + IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR. + & KCQ2(JT).EQ.2)) THEN + MOTHER=K(NSD(JT)+2,5)/MSTU(5) + IF(MOTHER.LE.NSD(JT)) THEN + MCT(NSD(JT)+2,2)=MCT(MOTHER,2) + ELSE + NCT=NCT+1 + MCT(NSD(JT)+2,2)=NCT + MCT(MOTHER,1)=NCT + ENDIF + ENDIF + IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND. + & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN + MOTHER=K(NSD(JT)+3,4)/MSTU(5) + MCT(NSD(JT)+3,1)=MCT(MOTHER,1) + ENDIF + IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND. + & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN + MOTHER=K(NSD(JT)+3,5)/MSTU(5) + MCT(NSD(JT)+2,2)=MCT(MOTHER,2) + ENDIF + IF(NPART.EQ.4.AND.MCT(NSD(JT)+4,1).EQ.0.AND. + & (KCQ4(JT).EQ.1.OR. KCQ4(JT).EQ.2)) THEN + MOTHER=K(NSD(JT)+4,4)/MSTU(5) + MCT(NSD(JT)+4,1)=MCT(MOTHER,1) + ENDIF + IF(NPART.EQ.4.AND.MCT(NSD(JT)+4,2).EQ.0.AND. + & (KCQ4(JT).EQ.-1.OR.KCQ4(JT).EQ.2)) THEN + MOTHER=K(NSD(JT)+4,5)/MSTU(5) + MCT(NSD(JT)+4,2)=MCT(MOTHER,2) + ENDIF + + IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN) + ENDIF + NSHAFT=N + IF(JT.EQ.1) NAFT1=N + +C...Check if decay products moved by shower. + NSD1=NSD(JT)+1 + NSD2=NSD(JT)+2 + NSD3=NSD(JT)+3 + NSD4=NSD(JT)+4 +C...4-body decays will only work if one of the products is "inert" + IF(NSHAFT.GT.NSHBEF) THEN + IF(K(NSD1,1).GT.10) THEN + DO 660 I=NSHBEF+1,NSHAFT + IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I + 660 CONTINUE + ENDIF + IF(K(NSD2,1).GT.10) THEN + DO 670 I=NSHBEF+1,NSHAFT + IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND. + & I.NE.NSD1) NSD2=I + 670 CONTINUE + ENDIF + IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN + DO 680 I=NSHBEF+1,NSHAFT + IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND. + & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I + 680 CONTINUE + ENDIF + IF(KFL4(JT).NE.0.AND.K(NSD4,1).GT.10) THEN + DO 685 I=NSHBEF+1,NSHAFT + IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD4,2).AND. + & I.NE.NSD1.AND.I.NE.NSD2.AND.I.NE.NSD3) NSD4=I + 685 CONTINUE + ENDIF + ENDIF + +C...Store decay products for further treatment. + IF(KFL4(JT).EQ.0) THEN + 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) + ELSE + NSDA=NSD1 + NSDB=NSD2 + NSDC=NSD3 + NP=NP+1 + IREF(NP,4)=IDOC+1 + IREF(NP,5)=IDOC+2 + IREF(NP,6)=IDOC+3 + IF(K(NSD1,1).EQ.1) THEN + NSDA=NSD4 + IREF(NP,4)=IDOC+4 + ELSEIF(K(NSD2,1).EQ.1) THEN + NSDB=NSD4 + IREF(NP,5)=IDOC+4 + ELSEIF(K(NSD3,1).EQ.1) THEN + NSDC=NSD4 + IREF(NP,6)=IDOC+4 + ENDIF + IREF(NP,1)=NSDA + IREF(NP,2)=NSDB + IREF(NP,3)=NSDC + IREF(NP,7)=K(IREF(IP,JT),2) + IREF(NP,8)=IREF(IP,JT) + ENDIF + 690 CONTINUE + + +C...Fill information for 2 -> 1 -> 2. + 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN + MINT(7)=MINT(83)+6+2*ISET(ISUB) + MINT(8)=MINT(83)+7+2*ISET(ISUB) + MINT(25)=KFL1(1) + MINT(26)=KFL2(1) + VINT(23)=CTHE(1) + RM3=P(N-1,5)**2/SH + RM4=P(N,5)**2/SH + BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) + VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1)) + VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1)) + VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2) + VINT(47)=SQRT(VINT(48)) + ENDIF + +C...Possibility of colour rearrangement in W+W- events. + IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN + IAKF1=IABS(KFL1(1)) + IAKF2=IABS(KFL1(2)) + IAKF3=IABS(KFL2(1)) + IAKF4=IABS(KFL2(2)) + IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND. + & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL + & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1) + IF(MINT(51).NE.0) RETURN + ENDIF + +C...Loop back if needed. + 710 IF(IP.LT.NP) GOTO 170 + +C...Boost back to standard frame. + 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN, + &BEZIN) + + + RETURN + END + +C********************************************************************* + +C...PYMULT +C...Initializes treatment of multiple interactions, selects kinematics +C...of hardest interaction if low-pT physics included in run, and +C...generates all non-hardest interactions. + + SUBROUTINE PYMULT(MMUL) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/ +C...Local arrays and saved variables. + DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80) + SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C, + &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP, + &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147 + +C...Initialization of multiple interaction treatment. + IF(MMUL.EQ.1) THEN + IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82) + ISUB=96 + MINT(1)=96 + VINT(63)=0D0 + VINT(64)=0D0 + VINT(143)=1D0 + VINT(144)=1D0 + +C...Loop over phase space points: xT2 choice in 20 bins. + 100 SIGSUM=0D0 + DO 120 IXT2=1,20 + NMUL(IXT2)=MSTP(83) + SIGM(IXT2)=0D0 + DO 110 ITRY=1,MSTP(83) + RSCA=0.05D0*((21-IXT2)-PYR(0)) + XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149) + XT2=MAX(0.01D0*VINT(149),XT2) + VINT(25)=XT2 + +C...Choose tau and y*. Calculate cos(theta-hat). + IF(PYR(0).LE.COEF(ISUB,1)) THEN + TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) + TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) + ELSE + TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) + ENDIF + VINT(21)=TAU + CALL PYKLIM(2) + RYST=PYR(0) + MYST=1 + IF(RYST.GT.COEF(ISUB,8)) MYST=2 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 + CALL PYKMAP(2,MYST,PYR(0)) + VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) + +C...Calculate differential cross-section. + VINT(71)=0.5D0*VINT(1)*SQRT(XT2) + CALL PYSIGH(NCHN,SIGS) + SIGM(IXT2)=SIGM(IXT2)+SIGS + 110 CONTINUE + SIGSUM=SIGSUM+SIGM(IXT2) + 120 CONTINUE + SIGSUM=SIGSUM/(20D0*MSTP(83)) + +C...Reject result if sigma(parton-parton) is smaller than hadronic one. + IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN + IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) + & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM + PARP(82)=0.9D0*PARP(82) + VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/ + & VINT(2) + GOTO 100 + ENDIF + IF(MSTP(122).GE.1) WRITE(MSTU(11),5200) + & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM + +C...Start iteration to find k factor. + YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5)) + P83A=(1D0-PARP(83))**2 + P83B=2D0*PARP(83)*(1D0-PARP(83)) + P83C=PARP(83)**2 + CQ2I=1D0/PARP(84)**2 + CQ2R=2D0/(1D0+PARP(84)**2) + SO=0.5D0 + XI=0D0 + YI=0D0 + XF=0D0 + YF=0D0 + XK=0.5D0 + IIT=0 + 130 IF(IIT.EQ.0) THEN + XK=2D0*XK + ELSEIF(IIT.EQ.1) THEN + XK=0.5D0*XK + ELSE + XK=XI+(YKE-YI)*(XF-XI)/(YF-YI) + ENDIF + +C...Evaluate overlap integrals. Find where to divide the b range. + IF(MSTP(82).EQ.2) THEN + SP=0.5D0*PARU(1)*(1D0-EXP(-XK)) + SOP=SP/PARU(1) + ELSE + IF(MSTP(82).EQ.3) THEN + DELTAB=0.02D0 + ELSEIF(MSTP(82).EQ.4) THEN + DELTAB=MIN(0.01D0,0.05D0*PARP(84)) + ELSE + POWIP=MAX(0.4D0,PARP(83)) + RPWIP=2D0/POWIP-1D0 + DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP)) + SO=0D0 + ENDIF + SP=0D0 + SOP=0D0 + BSP=0D0 + SOHIGH=0D0 + IBDIV=0 + B=-0.5D0*DELTAB + 140 B=B+DELTAB + IF(MSTP(82).EQ.3) THEN + OV=EXP(-B**2)/PARU(2) + ELSEIF(MSTP(82).EQ.4) THEN + OV=(P83A*EXP(-MIN(50D0,B**2))+ + & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+ + & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2) + ELSE + OV=EXP(-B**POWIP)/PARU(2) + SO=SO+PARU(2)*B*DELTAB*OV + ENDIF + IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV + PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV)) + SP=SP+PARU(2)*B*DELTAB*PACC + SOP=SOP+PARU(2)*B*DELTAB*OV*PACC + BSP=BSP+B*PARU(2)*B*DELTAB*PACC + IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN + IBDIV=1 + BDIV=B+0.5D0*DELTAB + ENDIF + IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140 + ENDIF + YK=PARU(1)*XK*SO/SP + +C...Continue iteration until convergence. + IF(YK.LT.YKE) THEN + XI=XK + YI=YK + IF(IIT.EQ.1) IIT=2 + ELSE + XF=XK + YF=YK + IF(IIT.EQ.0) IIT=1 + ENDIF + IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130 + +C...Store some results for subsequent use. + BAVG=BSP/SP + VINT(145)=SIGSUM + VINT(146)=SOP/SO + VINT(147)=SOP/SP + VNT145=VINT(145) + VNT146=VINT(146) + VNT147=VINT(147) +C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr. + PIK=(VNT146/VNT147)*YKE + +C...Find relative weight for low and high impact parameter. + PLOWB=PARU(1)*BDIV**2 + IF(MSTP(82).EQ.3) THEN + PHIGHB=PIK*0.5*EXP(-BDIV**2) + ELSEIF(MSTP(82).EQ.4) THEN + S4A=P83A*EXP(-BDIV**2) + S4B=P83B*EXP(-BDIV**2*CQ2R) + S4C=P83C*EXP(-BDIV**2*CQ2I) + PHIGHB=PIK*0.5*(S4A+S4B+S4C) + ELSEIF(PARP(83).GE.1.999D0) THEN + PHIGHB=PIK*SOHIGH + B2RPDV=BDIV**POWIP + ELSE + PHIGHB=PIK*SOHIGH + B2RPDV=BDIV**POWIP + B2RPMX=MAX(2D0*RPWIP,B2RPDV) + ENDIF + PALLB=PLOWB+PHIGHB + +C...Initialize iteration in xT2 for hardest interaction. + ELSEIF(MMUL.EQ.2) THEN + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + IF(MSTP(82).LE.0) THEN + ELSEIF(MSTP(82).EQ.1) THEN + XT2=1D0 + SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5)) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT* + & VINT(317)/(VINT(318)*VINT(320)) + XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149)) + ELSEIF(MSTP(82).EQ.2) THEN + XT2=1D0 + XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))* + & VINT(149)*(1D0+VINT(149)) + ELSE + XC2=4D0*CKIN(3)**2/VINT(2) + IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0 + ENDIF + +C...Select impact parameter for hardest interaction. + IF(MSTP(82).LE.2) RETURN + 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN +C...Treatment in low b region. + MINT(39)=1 + B=BDIV*SQRT(PYR(0)) + IF(MSTP(82).EQ.3) THEN + OV=EXP(-B**2)/PARU(2) + ELSEIF(MSTP(82).EQ.4) THEN + OV=(P83A*EXP(-MIN(50D0,B**2))+ + & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+ + & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2) + ELSE + OV=EXP(-B**POWIP)/PARU(2) + ENDIF + VINT(148)=OV/VNT147 + PACC=1D0-EXP(-MIN(50D0,PIK*OV)) + XT2=1D0 + XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))* + & VINT(149)*(1D0+VINT(149)) + ELSE +C...Treatment in high b region. + MINT(39)=2 + IF(MSTP(82).EQ.3) THEN + B=SQRT(BDIV**2-LOG(PYR(0))) + OV=EXP(-B**2)/PARU(2) + ELSEIF(MSTP(82).EQ.4) THEN + S4RNDM=PYR(0)*(S4A+S4B+S4C) + IF(S4RNDM.LT.S4A) THEN + B=SQRT(BDIV**2-LOG(PYR(0))) + ELSEIF(S4RNDM.LT.S4A+S4B) THEN + B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R) + ELSE + B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I) + ENDIF + OV=(P83A*EXP(-MIN(50D0,B**2))+ + & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+ + & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2) + ELSEIF(PARP(83).GE.1.999D0) THEN + 144 B2RPW=B2RPDV-LOG(PYR(0)) + ACCIP=(B2RPW/B2RPDV)**RPWIP + IF(ACCIP.LT.PYR(0)) GOTO 144 + OV=EXP(-B2RPW)/PARU(2) + B=B2RPW**(1D0/POWIP) + ELSE + 146 B2RPW=B2RPDV-2D0*LOG(PYR(0)) + ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX)) + IF(ACCIP.LT.PYR(0)) GOTO 146 + OV=EXP(-B2RPW)/PARU(2) + B=B2RPW**(1D0/POWIP) + ENDIF + VINT(148)=OV/VNT147 + PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV) + ENDIF + IF(PACC.LT.PYR(0)) GOTO 142 + VINT(139)=B/BAVG + + ELSEIF(MMUL.EQ.3) THEN +C...Low-pT or multiple interactions (first semihard interaction): +C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm) +C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....). + ISUB=MINT(1) + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + IF(MSTP(82).LE.0) THEN + XT2=0D0 + ELSEIF(MSTP(82).EQ.1) THEN + XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) +C...Use with "Sudakov" for low b values when impact parameter dependence. + ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN + IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+ + & VINT(149)))).GT.PYR(0)) XT2=1D0 + IF(XT2.GE.1D0) THEN + XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0- + & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))- + & VINT(149) + ELSE + XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)* + & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))- + & VINT(149) + ENDIF + XT2=MAX(0.01D0*VINT(149),XT2) +C...Use without "Sudakov" for high b values when impact parameter dep. + ELSE + XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)- + & PYR(0)*(1D0-XC2))-VINT(149) + XT2=MAX(0.01D0*VINT(149),XT2) + ENDIF + VINT(25)=XT2 + +C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed. + IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN + IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143) + IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143) + ISUB=95 + MINT(1)=ISUB + VINT(21)=0.01D0*VINT(149) + VINT(22)=0D0 + VINT(23)=0D0 + VINT(25)=0.01D0*VINT(149) + + ELSE +C...Multiple interactions (first semihard interaction). +C...Choose tau and y*. Calculate cos(theta-hat). + IF(PYR(0).LE.COEF(ISUB,1)) THEN + TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) + TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) + ELSE + TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) + ENDIF + VINT(21)=TAU + CALL PYKLIM(2) + RYST=PYR(0) + MYST=1 + IF(RYST.GT.COEF(ISUB,8)) MYST=2 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 + CALL PYKMAP(2,MYST,PYR(0)) + VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) + ENDIF + VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25)) + +C...Store results of cross-section calculation. + ELSEIF(MMUL.EQ.4) THEN + ISUB=MINT(1) + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + XTS=VINT(25) + IF(ISET(ISUB).EQ.1) XTS=VINT(21) + IF(ISET(ISUB).EQ.2) + & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2) + IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26) + RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/ + & (XTS+VINT(149)))) + IRBIN=INT(1D0+20D0*RBIN) + IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN + NMUL(IRBIN)=NMUL(IRBIN)+1 + SIGM(IRBIN)=SIGM(IRBIN)+VINT(153) + ENDIF + +C...Choose impact parameter if not already done. + ELSEIF(MMUL.EQ.5) THEN + ISUB=MINT(1) + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + 150 IF(MINT(39).GT.0) THEN + ELSEIF(MSTP(82).EQ.3) THEN + EXPB2=PYR(0) + B2=-LOG(PYR(0)) + VINT(148)=EXPB2/(PARU(2)*VNT147) + VINT(139)=SQRT(B2)/BAVG + ELSEIF(MSTP(82).EQ.4) THEN + RTYPE=PYR(0) + IF(RTYPE.LT.P83A) THEN + B2=-LOG(PYR(0)) + ELSEIF(RTYPE.LT.P83A+P83B) THEN + B2=-LOG(PYR(0))/CQ2R + ELSE + B2=-LOG(PYR(0))/CQ2I + ENDIF + VINT(148)=(P83A*EXP(-MIN(50D0,B2))+ + & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+ + & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147) + VINT(139)=SQRT(B2)/BAVG + ELSEIF(PARP(83).GE.1.999D0) THEN + POWIP=MAX(2D0,PARP(83)) + RPWIP=2D0/POWIP-1D0 + PROB1=POWIP/(2D0*EXP(-1D0)+POWIP) + 160 IF(PYR(0).LT.PROB1) THEN + B2RPW=PYR(0)**(0.5D0*POWIP) + ACCIP=EXP(-B2RPW) + ELSE + B2RPW=1D0-LOG(PYR(0)) + ACCIP=B2RPW**RPWIP + ENDIF + IF(ACCIP.LT.PYR(0)) GOTO 160 + VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147) + VINT(139)=B2RPW**(1D0/POWIP)/BAVG + ELSE + POWIP=MAX(0.4D0,PARP(83)) + RPWIP=2D0/POWIP-1D0 + PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP)) + 170 IF(PYR(0).LT.PROB1) THEN + B2RPW=2D0*RPWIP*PYR(0) + ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW) + ELSE + B2RPW=2D0*(RPWIP-LOG(PYR(0))) + ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW) + ENDIF + IF(ACCIP.LT .PYR(0)) GOTO 170 + VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147) + VINT(139)=B2RPW**(1D0/POWIP)/BAVG + ENDIF + +C...Multiple interactions (variable impact parameter) : reject with +C...probability exp(-overlap*cross-section above pT/normalization). +C...Does not apply to low-b region, where "Sudakov" already included. + VINT(150)=1D0 + IF(MINT(39).NE.1) THEN + RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN) + SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN) + DO 180 IBIN=IRBIN+1,20 + RNCOR=RNCOR+NMUL(IBIN) + SIGCOR=SIGCOR+SIGM(IBIN) + 180 CONTINUE + SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149)) + IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289) + VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)* + & SIGABV/MAX(1D-10,SIGT(0,0,5)))) + ENDIF + IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND. + & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53 + & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN + IF(VINT(150).LT.PYR(0)) GOTO 150 + VINT(150)=1D0 + ENDIF + +C...Generate additional multiple semihard interactions. + ELSEIF(MMUL.EQ.6) THEN + ISUBSV=MINT(1) + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + DO 190 J=11,80 + VINTSV(J)=VINT(J) + 190 CONTINUE + ISUB=96 + MINT(1)=96 + VINT(151)=0D0 + VINT(152)=0D0 + +C...Reconstruct strings in hard scattering. + NMAX=MINT(84)+4 + IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2 + IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3) + NSTR=0 + DO 210 I=MINT(84)+1,NMAX + KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2)) + IF(KCS.EQ.0) GOTO 210 + DO 200 J=1,4 + IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200 + IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200 + IF(J.LE.2) THEN + IST=MOD(K(I,J+3)/MSTU(5),MSTU(5)) + ELSE + IST=MOD(K(I,J+1),MSTU(5)) + ENDIF + IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200 + IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200 + NSTR=NSTR+1 + IF(J.EQ.1.OR.J.EQ.4) THEN + KSTR(NSTR,1)=I + KSTR(NSTR,2)=IST + ELSE + KSTR(NSTR,1)=IST + KSTR(NSTR,2)=I + ENDIF + 200 CONTINUE + 210 CONTINUE + +C...Set up starting values for iteration in xT2. + XT2=4D0*VINT(62)/VINT(2) + IF(MSTP(82).LE.1) THEN + SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5)) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT* + & VINT(317)/(VINT(318)*VINT(320)) + XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149)) + ELSE + XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/ + & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149)) + ENDIF + VINT(63)=0D0 + VINT(64)=0D0 + VINT(143)=1D0-VINT(141) + VINT(144)=1D0-VINT(142) + +C...Iterate downwards in xT2. + 220 IF(MSTP(82).LE.1) THEN + XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) + IF(XT2.LT.VINT(149)) GOTO 270 + ELSE + IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270 + XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))* + & LOG(PYR(0)))-VINT(149) + IF(XT2.LE.0D0) GOTO 270 + XT2=MAX(0.01D0*VINT(149),XT2) + ENDIF + VINT(25)=XT2 + +C...Choose tau and y*. Calculate cos(theta-hat). + IF(PYR(0).LE.COEF(ISUB,1)) THEN + TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) + TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) + ELSE + TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) + ENDIF + VINT(21)=TAU + CALL PYKLIM(2) + RYST=PYR(0) + MYST=1 + IF(RYST.GT.COEF(ISUB,8)) MYST=2 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 + CALL PYKMAP(2,MYST,PYR(0)) + VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) + +C...Check that x not used up. Accept or reject kinematical variables. + X1M=SQRT(TAU)*EXP(VINT(22)) + X2M=SQRT(TAU)*EXP(-VINT(22)) + IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220 + VINT(71)=0.5D0*VINT(1)*SQRT(XT2) + CALL PYSIGH(NCHN,SIGS) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320) + IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220 + +C...Reset K, P and V vectors. Select some variables. + DO 240 I=N+1,N+2 + DO 230 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 230 CONTINUE + 240 CONTINUE + RFLAV=PYR(0) + PT=0.5D0*VINT(1)*SQRT(XT2) + PHI=PARU(2)*PYR(0) + CTH=VINT(23) + +C...Add first parton to event record. + K(N+1,1)=3 + K(N+1,2)=21 + IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)= + & 1+INT((2D0+PARJ(2))*PYR(0)) + P(N+1,1)=PT*COS(PHI) + P(N+1,2)=PT*SIN(PHI) + P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH)) + P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH)) + P(N+1,5)=0D0 + +C...Add second parton to event record. + K(N+2,1)=3 + K(N+2,2)=21 + IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2) + P(N+2,1)=-P(N+1,1) + P(N+2,2)=-P(N+1,2) + P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH)) + P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH)) + P(N+2,5)=0D0 + + IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN +C....Choose relevant string pieces to place gluons on. + DO 260 I=N+1,N+2 + DMIN=1D8 + DO 250 ISTR=1,NSTR + I1=KSTR(ISTR,1) + I2=KSTR(ISTR,2) + DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)- + & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)- + & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)- + & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3)) + IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN + DMIN=DIST + IST1=I1 + IST2=I2 + ISTM=ISTR + ENDIF + 250 CONTINUE + +C....Colour flow adjustments, new string pieces. + IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+ + & MOD(K(IST1,4),MSTU(5)) + IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)= + & MSTU(5)*(K(IST1,5)/MSTU(5))+I + K(I,5)=MSTU(5)*IST1 + K(I,4)=MSTU(5)*IST2 + IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+ + & MOD(K(IST2,5),MSTU(5)) + IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)= + & MSTU(5)*(K(IST2,4)/MSTU(5))+I + KSTR(ISTM,2)=I + KSTR(NSTR+1,1)=I + KSTR(NSTR+1,2)=IST2 + NSTR=NSTR+1 + 260 CONTINUE + +C...String drawing and colour flow for gluon loop. + ELSEIF(K(N+1,2).EQ.21) THEN + K(N+1,4)=MSTU(5)*(N+2) + K(N+1,5)=MSTU(5)*(N+2) + K(N+2,4)=MSTU(5)*(N+1) + K(N+2,5)=MSTU(5)*(N+1) + KSTR(NSTR+1,1)=N+1 + KSTR(NSTR+1,2)=N+2 + KSTR(NSTR+2,1)=N+2 + KSTR(NSTR+2,2)=N+1 + NSTR=NSTR+2 + +C...String drawing and colour flow for qqbar pair. + ELSE + K(N+1,4)=MSTU(5)*(N+2) + K(N+2,5)=MSTU(5)*(N+1) + KSTR(NSTR+1,1)=N+1 + KSTR(NSTR+1,2)=N+2 + NSTR=NSTR+1 + ENDIF + +C...Global statistics. + MINT(351)=MINT(351)+1 + VINT(351)=VINT(351)+PT + IF (MINT(351).EQ.1) VINT(356)=PT + +C...Update remaining energy; iterate. + N=N+2 + IF(N.GT.MSTU(4)-MSTU(32)-10) THEN + CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS') + MINT(51)=1 + RETURN + ENDIF + MINT(31)=MINT(31)+1 + VINT(151)=VINT(151)+VINT(41) + VINT(152)=VINT(152)+VINT(42) + VINT(143)=VINT(143)-VINT(41) + VINT(144)=VINT(144)-VINT(42) +C...Allow FSR for UE (always handle with old showers) + IF(MSTP(152).EQ.1) THEN + M41SAV=MSTJ(41) + IF (MSTJ(41).EQ.10) MSTJ(41)=2 + MSTJ(41)=MOD(MSTJ(41),10) + CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT) + MSTJ(41)=M41SAV + ENDIF + IF(MINT(31).LT.240) GOTO 220 + 270 CONTINUE + MINT(1)=ISUBSV + DO 280 J=11,80 + VINT(J)=VINTSV(J) + 280 CONTINUE + ENDIF + +C...Format statements for printout. + 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter', + &'actions for MSTP(82) =',I2,' ******') + 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P, + &D9.2,' mb: rejected') + 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P, + &D9.2,' mb: accepted') + + RETURN + END + +C********************************************************************* + +C...PYREMN +C...Adds on target remnants (one or two from each side) and +C...includes primordial kT for hadron beams. + + SUBROUTINE PYREMN(IPU1,IPU2) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ +C...Local arrays. + DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5), + &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4) + +C...Find event type and remaining energy. + ISUB=MINT(1) + NS=N + IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN + VINT(143)=1D0-VINT(141) + VINT(144)=1D0-VINT(142) + ENDIF + +C...Define initial partons. + NTRY=0 + 100 NTRY=NTRY+1 + DO 130 JT=1,2 + I=MINT(83)+JT+2 + IF(JT.EQ.1) IPU=IPU1 + IF(JT.EQ.2) IPU=IPU2 + K(I,1)=21 + K(I,2)=K(IPU,2) + K(I,3)=I-2 + PMS(JT)=0D0 + VINT(156+JT)=0D0 + VINT(158+JT)=0D0 + IF(MINT(47).EQ.1) THEN + DO 110 J=1,5 + P(I,J)=P(I-2,J) + 110 CONTINUE + ELSEIF(ISUB.EQ.95) THEN + K(I,2)=21 + ELSE + P(I,5)=P(IPU,5) + +C...No primordial kT, or chosen according to truncated Gaussian or +C...exponential, or (for photon) predetermined or power law. + 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN + IF(MSTP(91).LE.0) THEN + PT=0D0 + ELSEIF(MSTP(91).EQ.1) THEN + PT=PARP(91)*SQRT(-LOG(PYR(0))) + ELSE + RPT1=PYR(0) + RPT2=PYR(0) + PT=-PARP(92)*LOG(RPT1*RPT2) + ENDIF + IF(PT.GT.PARP(93)) GOTO 120 + ELSEIF(MINT(106+JT).EQ.3) THEN + PTA=SQRT(VINT(282+JT)) + PTB=0D0 + IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN + PTB=PARP(99)*SQRT(-LOG(PYR(0))) + ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN + RPT1=PYR(0) + RPT2=PYR(0) + PTB=-PARP(99)*LOG(RPT1*RPT2) + ENDIF + IF(PTB.GT.PARP(100)) GOTO 120 + PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0))) + PT=PT*0.8D0**MINT(57) + IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10) + ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN + IF(MSTP(93).LE.0) THEN + PT=0D0 + ELSEIF(MSTP(93).EQ.1) THEN + PT=PARP(99)*SQRT(-LOG(PYR(0))) + ELSEIF(MSTP(93).EQ.2) THEN + RPT1=PYR(0) + RPT2=PYR(0) + PT=-PARP(99)*LOG(RPT1*RPT2) + ELSEIF(MSTP(93).EQ.3) THEN + HA=PARP(99)**2 + HB=PARP(100)**2 + PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA)) + ELSE + HA=PARP(99)**2 + HB=PARP(100)**2 + IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2) + PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA)) + ENDIF + IF(PT.GT.PARP(100)) GOTO 120 + ELSE + PT=0D0 + ENDIF + VINT(156+JT)=PT + PHI=PARU(2)*PYR(0) + P(I,1)=PT*COS(PHI) + P(I,2)=PT*SIN(PHI) + PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2 + ENDIF + 130 CONTINUE + IF(MINT(47).EQ.1) RETURN + +C...Kinematics construction for initial partons. + I1=MINT(83)+3 + I2=MINT(83)+4 + IF(ISUB.EQ.95) THEN + SHS=0D0 + SHR=0D0 + ELSE + SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+ + & (P(I1,2)+P(I2,2))**2 + SHR=SQRT(MAX(0D0,SHS)) + IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100 + P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR) + P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1))) + P(I2,4)=SHR-P(I1,4) + P(I2,3)=-P(I1,3) + +C...Transform partons to overall CM-frame. + ROBO(3)=(P(I1,1)+P(I2,1))/SHR + ROBO(4)=(P(I1,2)+P(I2,2))/SHR + CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0) + ROBO(2)=PYANGL(P(I1,1),P(I1,2)) + CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0) + ROBO(1)=PYANGL(P(I1,3),P(I1,1)) + CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0) + CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0) + CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0) + ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142)) + CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5)) + ENDIF + +C...Optionally fix up x and Q2 definitions for leptoproduction. + IDISXQ=0 + IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND. + &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1 + IF(IDISXQ.EQ.1) THEN + +C...Find where incoming and outgoing leptons/partons are sitting. + LESD=1 + IF(MINT(42).EQ.1) LESD=2 + LPIN=MINT(83)+3-LESD + LEIN=MINT(84)+LESD + LQIN=MINT(84)+3-LESD + LEOUT=MINT(84)+2+LESD + LQOUT=MINT(84)+5-LESD + IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3) + IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3) + LSCMS=0 + DO 140 I=MINT(84)+5,N + IF(K(I,2).EQ.94) THEN + LSCMS=I + LEOUT=I+LESD + LQOUT=I+3-LESD + ENDIF + 140 CONTINUE + LQBG=IPU1 + IF(LESD.EQ.1) LQBG=IPU2 + +C...Calculate actual and wanted momentum transfer. + XNOM=VINT(43-LESD) + Q2NOM=-VINT(45) + HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)- + & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))* + & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4)) + HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK))) + FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2)) + P(N+1,1)=FAC*P(LEOUT,1) + P(N+1,2)=FAC*P(LEOUT,2) + P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)- + & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1) + P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+ + & P(N+1,3)**2) + DO 150 J=1,4 + QOLD(J)=P(LEIN,J)-P(LEOUT,J) + QNEW(J)=P(LEIN,J)-P(N+1,J) + 150 CONTINUE + +C...Boost outgoing electron and daughters. + IF(LSCMS.EQ.0) THEN + DO 160 J=1,4 + P(LEOUT,J)=P(N+1,J) + 160 CONTINUE + ELSE + DO 170 J=1,3 + P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4)) + 170 CONTINUE + PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2) + DO 180 J=1,3 + DBE(J)=PINV*P(N+2,J) + 180 CONTINUE + DO 200 I=LSCMS+1,N + IORIG=I + 190 IORIG=K(IORIG,3) + IF(IORIG.GT.LEOUT) GOTO 190 + IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT) + & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3)) + 200 CONTINUE + ENDIF + +C...Copy shower initiator and all outgoing partons. + NCOP=N+1 + K(NCOP,3)=LQBG + DO 210 J=1,5 + P(NCOP,J)=P(LQBG,J) + 210 CONTINUE + DO 240 I=MINT(84)+1,N + ICOP=0 + IF(K(I,1).GT.10) GOTO 240 + IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN + ICOP=I + ELSE + IORIG=I + 220 IORIG=K(IORIG,3) + IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN + ICOP=IORIG + ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN + GOTO 220 + ENDIF + ENDIF + IF(ICOP.NE.0) THEN + NCOP=NCOP+1 + K(NCOP,3)=I + DO 230 J=1,5 + P(NCOP,J)=P(I,J) + 230 CONTINUE + ENDIF + 240 CONTINUE + +C...Calculate relative rescaling factors. + SLC=3-2*LESD + PLCSUM=0D0 + DO 250 I=N+2,NCOP + PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3)) + 250 CONTINUE + DO 260 I=N+2,NCOP + V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM + 260 CONTINUE + +C...Transfer extra three-momentum of current. + DO 280 I=N+2,NCOP + DO 270 J=1,3 + P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J)) + 270 CONTINUE + P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + 280 CONTINUE + +C...Iterate change of initiator momentum to get energy right. + ITER=0 + 290 ITER=ITER+1 + PEEX=-P(N+1,4)-QNEW(4) + PEMV=-P(N+1,3)/P(N+1,4) + DO 300 I=N+2,NCOP + PEEX=PEEX+P(I,4) + PEMV=PEMV+V(I,1)*P(I,3)/P(I,4) + 300 CONTINUE + IF(ABS(PEMV).LT.1D-10) THEN + MINT(51)=1 + MINT(57)=MINT(57)+1 + RETURN + ENDIF + PZCH=-PEEX/PEMV + P(N+1,3)=P(N+1,3)+PZCH + P(N+1,4)=SQRT(P(N+1,5)**2+P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2) + DO 310 I=N+2,NCOP + P(I,3)=P(I,3)+V(I,1)*PZCH + P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + 310 CONTINUE + IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290 + +C...Modify momenta in event record. + HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/ + & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2) + IF(ABS(HBE).GE.1D0) THEN + MINT(51)=1 + MINT(57)=MINT(57)+1 + RETURN + ENDIF + I=MINT(83)+5-LESD + CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE) + DO 330 I=N+1,NCOP + ICOP=K(I,3) + DO 320 J=1,4 + P(ICOP,J)=P(I,J) + 320 CONTINUE + 330 CONTINUE + ENDIF + +C...Check minimum invariant mass of remnant system(s). + PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152)) + PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152)) + PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2) + PMIN(0)=SQRT(PMS(0)) + DO 340 JT=1,2 + PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT) + PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1) + PMIN(JT)=0D0 + IF(MINT(44+JT).EQ.1) GOTO 340 + MINT(105)=MINT(102+JT) + MINT(109)=MINT(106+JT) + CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT)) + IF(MINT(51).NE.0) THEN + MINT(57)=MINT(57)+1 + RETURN + ENDIF + IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT)) + IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT)) + IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111) + PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+ + & P(MINT(83)+JT+2,2)**2) + 340 CONTINUE + IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND. + &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT. + &PSYS(2,4))) THEN + MINT(51)=1 + MINT(57)=MINT(57)+1 + RETURN + ENDIF + +C...Loop over two remnants; skip if none there. + I=NS + DO 410 JT=1,2 + ISN(JT)=0 + IF(MINT(44+JT).EQ.1) GOTO 410 + IF(JT.EQ.1) IPU=IPU1 + IF(JT.EQ.2) IPU=IPU2 + +C...Store first remnant parton. + I=I+1 + IS(JT)=I + ISN(JT)=1 + DO 350 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 350 CONTINUE + K(I,1)=1 + K(I,2)=KFLSP(JT) + K(I,3)=MINT(83)+JT + P(I,5)=PYMASS(K(I,2)) + +C...First parton colour connections and kinematics. + KCOL=KCHG(PYCOMP(KFLSP(JT)),2) + IF(KCOL.EQ.2) THEN + K(I,1)=3 + K(I,4)=MSTU(5)*IPU+IPU + K(I,5)=MSTU(5)*IPU+IPU + K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I + K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I + ELSEIF(KCOL.NE.0) THEN + K(I,1)=3 + KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2 + K(I,KFLS+3)=IPU + K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I + ENDIF + IF(KFLCH(JT).EQ.0) THEN + P(I,1)=-P(MINT(83)+JT+2,1) + P(I,2)=-P(MINT(83)+JT+2,2) + PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2 + PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1) + P(I,3)=PSYS(JT,3) + P(I,4)=PSYS(JT,4) + +C...When extra remnant parton or hadron: store extra remnant. + ELSE + I=I+1 + ISN(JT)=2 + DO 360 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 360 CONTINUE + K(I,1)=1 + K(I,2)=KFLCH(JT) + K(I,3)=MINT(83)+JT + P(I,5)=PYMASS(K(I,2)) + +C...Find parton colour connections of extra remnant. + KCOL=KCHG(PYCOMP(KFLCH(JT)),2) + IF(KCOL.EQ.2) THEN + K(I,1)=3 + K(I,4)=MSTU(5)*IPU+IPU + K(I,5)=MSTU(5)*IPU+IPU + K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I + K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I + ELSEIF(KCOL.NE.0) THEN + K(I,1)=3 + KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2 + K(I,KFLS+3)=IPU + K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I + ENDIF + +C...Relative transverse momentum when two remnants. + LOOP=0 + 370 LOOP=LOOP+1 + CALL PYPTDI(1,P(I-1,1),P(I-1,2)) + IF(IABS(MINT(10+JT)).LT.20) THEN + P(I-1,1)=0D0 + P(I-1,2)=0D0 + ELSE + P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1) + P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2) + ENDIF + PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2 + P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1) + P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2) + PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2 + +C...Meson or baryon; photon as meson. For splitup below. + IMB=1 + IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2 + +C***Relative distribution for electron into two electrons. Temporary! + IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT)) + & THEN + CHI(JT)=PYR(0) + +C...Relative distribution of electron energy into electron plus parton. + ELSEIF(IABS(MINT(10+JT)).LT.20) THEN + XHRD=VINT(140+JT) + XE=VINT(154+JT) + CHI(JT)=(XE-XHRD)/(1D0-XHRD) + +C...Relative distribution of energy for particle into two jets. + ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN + CHIK=PARP(92+2*IMB) + IF(MSTP(92).LE.1) THEN + IF(IMB.EQ.1) CHI(JT)=PYR(0) + IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0)) + ELSEIF(MSTP(92).EQ.2) THEN + CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK)) + ELSEIF(MSTP(92).EQ.3) THEN + CUT=2D0*0.3D0/VINT(1) + 380 CHI(JT)=PYR(0)**2 + IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0* + & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380 + ELSEIF(MSTP(92).EQ.4) THEN + CUT=2D0*0.3D0/VINT(1) + CUTR=(1D0+SQRT(1D0+CUT**2))/CUT + 390 CHIR=CUT*CUTR**PYR(0) + CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR) + IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390 + ELSE + CUT=2D0*0.3D0/VINT(1) + CUTA=CUT**(1D0-PARP(98)) + CUTB=(1D0+CUT)**(1D0-PARP(98)) + 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98))) + IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))** + & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400 + ENDIF + +C...Relative distribution of energy for particle into jet plus particle. + ELSE + IF(MSTP(94).LE.1) THEN + IF(IMB.EQ.1) CHI(JT)=PYR(0) + IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0)) + IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT) + ELSEIF(MSTP(94).EQ.2) THEN + CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB))) + IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT) + ELSEIF(MSTP(94).EQ.3) THEN + CALL PYZDIS(1,0,PMS(JT+4),ZZ) + CHI(JT)=ZZ + ELSE + CALL PYZDIS(1000,0,PMS(JT+4),ZZ) + CHI(JT)=ZZ + ENDIF + ENDIF + +C...Construct total transverse mass; reject if too large. + CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT))) + PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT)) + IF(PMS(JT).GT.PSYS(JT,4)**2) THEN + IF(LOOP.LT.100) THEN + GOTO 370 + ELSE + MINT(51)=1 + MINT(57)=MINT(57)+1 + RETURN + ENDIF + ENDIF + PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1) + VINT(158+JT)=CHI(JT) + +C...Subdivide longitudinal momentum according to value selected above. + PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3))) + P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1) + P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1) + P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4) + P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3) + ENDIF + 410 CONTINUE + N=I + +C...Check if longitudinal boosts needed - if so pick two systems. + PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+ + &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3)) + IF(PDEV.LE.1D-6*VINT(1)) RETURN + IF(ISN(1).EQ.0) THEN + IR=0 + IL=2 + ELSEIF(ISN(2).EQ.0) THEN + IR=1 + IL=0 + ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN + IR=1 + IL=2 + ELSEIF(VINT(143).GT.0.2D0) THEN + IR=1 + IL=0 + ELSEIF(VINT(144).GT.0.2D0) THEN + IR=0 + IL=2 + ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN + IR=1 + IL=0 + ELSE + IR=0 + IL=2 + ENDIF + IG=3-IR-IL + +C...E+-pL wanted for system to be modified. + IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN + PPB=VINT(1) + PNB=VINT(1) + ELSE + PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3)) + PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3)) + ENDIF + +C...To keep x and Q2 in leptoproduction: do not count scattered lepton. + IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN + PPB=PPB-(PSYS(0,4)+PSYS(0,3)) + PNB=PNB-(PSYS(0,4)-PSYS(0,3)) + DO 420 J=1,4 + PSYS(0,J)=0D0 + 420 CONTINUE + DO 450 I=MINT(84)+1,NS + IF(K(I,1).GT.10) GOTO 450 + INCL=0 + IORIG=I + 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1 + IORIG=K(IORIG,3) + IF(IORIG.GT.LPIN) GOTO 430 + IF(INCL.EQ.0) GOTO 450 + DO 440 J=1,4 + PSYS(0,J)=PSYS(0,J)+P(I,J) + 440 CONTINUE + 450 CONTINUE + PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2) + PPB=PPB+(PSYS(0,4)+PSYS(0,3)) + PNB=PNB+(PSYS(0,4)-PSYS(0,3)) + ENDIF + +C...Construct longitudinal boosts. + DPMTB=PPB*PNB + DPMTR=PMS(IR) + DPMTL=PMS(IL) + DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL)) + IF(DSQLAM.LE.1D-6*DPMTB) THEN + MINT(51)=1 + MINT(57)=MINT(57)+1 + RETURN + ENDIF + DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4)) + DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/ + &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB) + DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/ + &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB) + DBER=(DRKR**2-1D0)/(DRKR**2+1D0) + DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0) + +C...Perform longitudinal boosts. + IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN + P(IS(1),3)=0D0 + P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2) + ELSEIF(IR.EQ.1) THEN + CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER) + ELSEIF(IDISXQ.EQ.1) THEN + DO 470 I=I1,NS + INCL=0 + IORIG=I + 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1 + IORIG=K(IORIG,3) + IF(IORIG.GT.LPIN) GOTO 460 + IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER) + 470 CONTINUE + ELSE + CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER) + ENDIF + IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN + P(IS(2),3)=0D0 + P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2) + ELSEIF(IL.EQ.2) THEN + CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL) + ELSEIF(IDISXQ.EQ.1) THEN + DO 490 I=I1,NS + INCL=0 + IORIG=I + 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1 + IORIG=K(IORIG,3) + IF(IORIG.GT.LPIN) GOTO 480 + IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL) + 490 CONTINUE + ELSE + CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL) + ENDIF + +C...Final check that energy-momentum conservation worked. + PESUM=0D0 + PZSUM=0D0 + DO 500 I=MINT(84)+1,N + IF(K(I,1).GT.10) GOTO 500 + PESUM=PESUM+P(I,4) + PZSUM=PZSUM+P(I,3) + 500 CONTINUE + PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM) + IF(PDEV.GT.1D-4*VINT(1)) THEN + MINT(51)=1 + MINT(57)=MINT(57)+1 + RETURN + ENDIF + +C...Calculate rotation and boost from overall CM frame to +C...hadronic CM frame in leptoproduction. + MINT(91)=0 + IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN + MINT(91)=1 + LESD=1 + IF(MINT(42).EQ.1) LESD=2 + LPIN=MINT(83)+3-LESD + +C...Sum upp momenta of everything not lepton or photon to define boost. + DO 510 J=1,4 + PSUM(J)=0D0 + 510 CONTINUE + DO 530 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530 + IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530 + IF(K(I,2).EQ.22) GOTO 530 + DO 520 J=1,4 + PSUM(J)=PSUM(J)+P(I,J) + 520 CONTINUE + 530 CONTINUE + VINT(223)=-PSUM(1)/PSUM(4) + VINT(224)=-PSUM(2)/PSUM(4) + VINT(225)=-PSUM(3)/PSUM(4) + +C...Boost incoming hadron to hadronic CM frame to determine rotations. + K(N+1,1)=1 + DO 540 J=1,5 + P(N+1,J)=P(LPIN,J) + V(N+1,J)=V(LPIN,J) + 540 CONTINUE + CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225)) + VINT(222)=-PYANGL(P(N+1,1),P(N+1,2)) + CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0) + IF(LESD.EQ.2) THEN + VINT(221)=-PYANGL(P(N+1,3),P(N+1,1)) + ELSE + VINT(221)=PYANGL(-P(N+1,3),P(N+1,1)) + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYMIGN +C...Initializes treatment of new multiple interactions scenario, +C...selects kinematics of hardest interaction if low-pT physics +C...included in run, and generates all non-hardest interactions. + + SUBROUTINE PYMIGN(MMUL) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + EXTERNAL PYALPS + DOUBLE PRECISION PYALPS +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), + & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), + & XMI(2,240),PT2MI(240),IMISEP(0:240) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/, + &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/ +C...Local arrays and saved variables. + DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80), + &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5) + SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C, + &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP, + &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147 + +C...Initialization of multiple interaction treatment. + IF(MMUL.EQ.1) THEN + IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82) + ISUB=96 + MINT(1)=96 + VINT(63)=0D0 + VINT(64)=0D0 + VINT(143)=1D0 + VINT(144)=1D0 + +C...Loop over phase space points: xT2 choice in 20 bins. + 100 SIGSUM=0D0 + DO 120 IXT2=1,20 + NMUL(IXT2)=MSTP(83) + SIGM(IXT2)=0D0 + DO 110 ITRY=1,MSTP(83) + RSCA=0.05D0*((21-IXT2)-PYR(0)) + XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149) + XT2=MAX(0.01D0*VINT(149),XT2) + VINT(25)=XT2 + +C...Choose tau and y*. Calculate cos(theta-hat). + IF(PYR(0).LE.COEF(ISUB,1)) THEN + TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) + TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) + ELSE + TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) + ENDIF + VINT(21)=TAU + CALL PYKLIM(2) + RYST=PYR(0) + MYST=1 + IF(RYST.GT.COEF(ISUB,8)) MYST=2 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 + CALL PYKMAP(2,MYST,PYR(0)) + VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) + +C...Calculate differential cross-section. + VINT(71)=0.5D0*VINT(1)*SQRT(XT2) + CALL PYSIGH(NCHN,SIGS) + SIGM(IXT2)=SIGM(IXT2)+SIGS + 110 CONTINUE + SIGSUM=SIGSUM+SIGM(IXT2) + 120 CONTINUE + SIGSUM=SIGSUM/(20D0*MSTP(83)) + +C...Reject result if sigma(parton-parton) is smaller than hadronic one. + IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN + IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) + & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM + PARP(82)=0.9D0*PARP(82) + VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/ + & VINT(2) + GOTO 100 + ENDIF + IF(MSTP(122).GE.1) WRITE(MSTU(11),5200) + & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM + +C...Start iteration to find k factor. + YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5)) + P83A=(1D0-PARP(83))**2 + P83B=2D0*PARP(83)*(1D0-PARP(83)) + P83C=PARP(83)**2 + CQ2I=1D0/PARP(84)**2 + CQ2R=2D0/(1D0+PARP(84)**2) + SO=0.5D0 + XI=0D0 + YI=0D0 + XF=0D0 + YF=0D0 + XK=0.5D0 + IIT=0 + 130 IF(IIT.EQ.0) THEN + XK=2D0*XK + ELSEIF(IIT.EQ.1) THEN + XK=0.5D0*XK + ELSE + XK=XI+(YKE-YI)*(XF-XI)/(YF-YI) + ENDIF + +C...Evaluate overlap integrals. Find where to divide the b range. + IF(MSTP(82).EQ.2) THEN + SP=0.5D0*PARU(1)*(1D0-EXP(-XK)) + SOP=SP/PARU(1) + ELSE + IF(MSTP(82).EQ.3) THEN + DELTAB=0.02D0 + ELSEIF(MSTP(82).EQ.4) THEN + DELTAB=MIN(0.01D0,0.05D0*PARP(84)) + ELSE + POWIP=MAX(0.4D0,PARP(83)) + RPWIP=2D0/POWIP-1D0 + DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP)) + SO=0D0 + ENDIF + SP=0D0 + SOP=0D0 + BSP=0D0 + SOHIGH=0D0 + IBDIV=0 + B=-0.5D0*DELTAB + 140 B=B+DELTAB + IF(MSTP(82).EQ.3) THEN + OV=EXP(-B**2)/PARU(2) + ELSEIF(MSTP(82).EQ.4) THEN + OV=(P83A*EXP(-MIN(50D0,B**2))+ + & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+ + & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2) + ELSE + OV=EXP(-B**POWIP)/PARU(2) + SO=SO+PARU(2)*B*DELTAB*OV + ENDIF + IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV + PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV)) + SP=SP+PARU(2)*B*DELTAB*PACC + SOP=SOP+PARU(2)*B*DELTAB*OV*PACC + BSP=BSP+B*PARU(2)*B*DELTAB*PACC + IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN + IBDIV=1 + BDIV=B+0.5D0*DELTAB + ENDIF + IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140 + ENDIF + YK=PARU(1)*XK*SO/SP + +C...Continue iteration until convergence. + IF(YK.LT.YKE) THEN + XI=XK + YI=YK + IF(IIT.EQ.1) IIT=2 + ELSE + XF=XK + YF=YK + IF(IIT.EQ.0) IIT=1 + ENDIF + IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130 + +C...Store some results for subsequent use. + BAVG=BSP/SP + VINT(145)=SIGSUM + VINT(146)=SOP/SO + VINT(147)=SOP/SP + VNT145=VINT(145) + VNT146=VINT(146) + VNT147=VINT(147) +C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr. + PIK=(VNT146/VNT147)*YKE + +C...Find relative weight for low and high impact parameter.. + PLOWB=PARU(1)*BDIV**2 + IF(MSTP(82).EQ.3) THEN + PHIGHB=PIK*0.5*EXP(-BDIV**2) + ELSEIF(MSTP(82).EQ.4) THEN + S4A=P83A*EXP(-BDIV**2) + S4B=P83B*EXP(-BDIV**2*CQ2R) + S4C=P83C*EXP(-BDIV**2*CQ2I) + PHIGHB=PIK*0.5*(S4A+S4B+S4C) + ELSEIF(PARP(83).GE.1.999D0) THEN + PHIGHB=PIK*SOHIGH + B2RPDV=BDIV**POWIP + ELSE + PHIGHB=PIK*SOHIGH + B2RPDV=BDIV**POWIP + B2RPMX=MAX(2D0*RPWIP,B2RPDV) + ENDIF + PALLB=PLOWB+PHIGHB + +C...Initialize iteration in xT2 for hardest interaction. + ELSEIF(MMUL.EQ.2) THEN + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + IF(MSTP(82).LE.0) THEN + ELSEIF(MSTP(82).EQ.1) THEN + XT2=1D0 + SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5)) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT* + & VINT(317)/(VINT(318)*VINT(320)) + XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149)) + ELSEIF(MSTP(82).EQ.2) THEN + XT2=1D0 + XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))* + & VINT(149)*(1D0+VINT(149)) + ELSE + XC2=4D0*CKIN(3)**2/VINT(2) + IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0 + ENDIF + +C...Select impact parameter for hardest interaction. + IF(MSTP(82).LE.2) RETURN + 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN +C...Treatment in low b region. + MINT(39)=1 + B=BDIV*SQRT(PYR(0)) + IF(MSTP(82).EQ.3) THEN + OV=EXP(-B**2)/PARU(2) + ELSEIF(MSTP(82).EQ.4) THEN + OV=(P83A*EXP(-MIN(50D0,B**2))+ + & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+ + & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2) + ELSE + OV=EXP(-B**POWIP)/PARU(2) + ENDIF + VINT(148)=OV/VNT147 + PACC=1D0-EXP(-MIN(50D0,PIK*OV)) + XT2=1D0 + XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))* + & VINT(149)*(1D0+VINT(149)) + ELSE +C...Treatment in high b region. + MINT(39)=2 + IF(MSTP(82).EQ.3) THEN + B=SQRT(BDIV**2-LOG(PYR(0))) + OV=EXP(-B**2)/PARU(2) + ELSEIF(MSTP(82).EQ.4) THEN + S4RNDM=PYR(0)*(S4A+S4B+S4C) + IF(S4RNDM.LT.S4A) THEN + B=SQRT(BDIV**2-LOG(PYR(0))) + ELSEIF(S4RNDM.LT.S4A+S4B) THEN + B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R) + ELSE + B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I) + ENDIF + OV=(P83A*EXP(-MIN(50D0,B**2))+ + & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+ + & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2) + ELSEIF(PARP(83).GE.1.999D0) THEN + 144 B2RPW=B2RPDV-LOG(PYR(0)) + ACCIP=(B2RPW/B2RPDV)**RPWIP + IF(ACCIP.LT.PYR(0)) GOTO 144 + OV=EXP(-B2RPW)/PARU(2) + B=B2RPW**(1D0/POWIP) + ELSE + 146 B2RPW=B2RPDV-2D0*LOG(PYR(0)) + ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX)) + IF(ACCIP.LT.PYR(0)) GOTO 146 + OV=EXP(-B2RPW)/PARU(2) + B=B2RPW**(1D0/POWIP) + ENDIF + VINT(148)=OV/VNT147 + PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV) + ENDIF + IF(PACC.LT.PYR(0)) GOTO 142 + VINT(139)=B/BAVG + + ELSEIF(MMUL.EQ.3) THEN +C...Low-pT or multiple interactions (first semihard interaction): +C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm) +C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....). + ISUB=MINT(1) + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + IF(MSTP(82).LE.0) THEN + XT2=0D0 + ELSEIF(MSTP(82).EQ.1) THEN + XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) +C...Use with "Sudakov" for low b values when impact parameter dependence. + ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN + IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+ + & VINT(149)))).GT.PYR(0)) XT2=1D0 + IF(XT2.GE.1D0) THEN + XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0- + & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))- + & VINT(149) + ELSE + XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)* + & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))- + & VINT(149) + ENDIF + XT2=MAX(0.01D0*VINT(149),XT2) +C...Use without "Sudakov" for high b values when impact parameter dep. + ELSE + XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)- + & PYR(0)*(1D0-XC2))-VINT(149) + XT2=MAX(0.01D0*VINT(149),XT2) + ENDIF + VINT(25)=XT2 + +C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed. + IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN + IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143) + IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143) + ISUB=95 + MINT(1)=ISUB + VINT(21)=1D-12*VINT(149) + VINT(22)=0D0 + VINT(23)=0D0 + VINT(25)=1D-12*VINT(149) + + ELSE +C...Multiple interactions (first semihard interaction). +C...Choose tau and y*. Calculate cos(theta-hat). + IF(PYR(0).LE.COEF(ISUB,1)) THEN + TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) + TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) + ELSE + TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) + ENDIF + VINT(21)=TAU + CALL PYKLIM(2) + RYST=PYR(0) + MYST=1 + IF(RYST.GT.COEF(ISUB,8)) MYST=2 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 + CALL PYKMAP(2,MYST,PYR(0)) + VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) + ENDIF + VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25)) + +C...Store results of cross-section calculation. + ELSEIF(MMUL.EQ.4) THEN + ISUB=MINT(1) + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + XTS=VINT(25) + IF(ISET(ISUB).EQ.1) XTS=VINT(21) + IF(ISET(ISUB).EQ.2) + & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2) + IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26) + RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/ + & (XTS+VINT(149)))) + IRBIN=INT(1D0+20D0*RBIN) + IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN + NMUL(IRBIN)=NMUL(IRBIN)+1 + SIGM(IRBIN)=SIGM(IRBIN)+VINT(153) + ENDIF + +C...Choose impact parameter if not already done. + ELSEIF(MMUL.EQ.5) THEN + ISUB=MINT(1) + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + 150 IF(MINT(39).GT.0) THEN + ELSEIF(MSTP(82).EQ.3) THEN + EXPB2=PYR(0) + B2=-LOG(PYR(0)) + VINT(148)=EXPB2/(PARU(2)*VNT147) + VINT(139)=SQRT(B2)/BAVG + ELSEIF(MSTP(82).EQ.4) THEN + RTYPE=PYR(0) + IF(RTYPE.LT.P83A) THEN + B2=-LOG(PYR(0)) + ELSEIF(RTYPE.LT.P83A+P83B) THEN + B2=-LOG(PYR(0))/CQ2R + ELSE + B2=-LOG(PYR(0))/CQ2I + ENDIF + VINT(148)=(P83A*EXP(-MIN(50D0,B2))+ + & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+ + & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147) + VINT(139)=SQRT(B2)/BAVG + ELSEIF(PARP(83).GE.1.999D0) THEN + POWIP=MAX(2D0,PARP(83)) + RPWIP=2D0/POWIP-1D0 + PROB1=POWIP/(2D0*EXP(-1D0)+POWIP) + 160 IF(PYR(0).LT.PROB1) THEN + B2RPW=PYR(0)**(0.5D0*POWIP) + ACCIP=EXP(-B2RPW) + ELSE + B2RPW=1D0-LOG(PYR(0)) + ACCIP=B2RPW**RPWIP + ENDIF + IF(ACCIP.LT.PYR(0)) GOTO 160 + VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147) + VINT(139)=B2RPW**(1D0/POWIP)/BAVG + ELSE + POWIP=MAX(0.4D0,PARP(83)) + RPWIP=2D0/POWIP-1D0 + PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP)) + 170 IF(PYR(0).LT.PROB1) THEN + B2RPW=2D0*RPWIP*PYR(0) + ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW) + ELSE + B2RPW=2D0*(RPWIP-LOG(PYR(0))) + ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW) + ENDIF + IF(ACCIP.LT .PYR(0)) GOTO 170 + VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147) + VINT(139)=B2RPW**(1D0/POWIP)/BAVG + ENDIF + +C...Multiple interactions (variable impact parameter) : reject with +C...probability exp(-overlap*cross-section above pT/normalization). +C...Does not apply to low-b region, where "Sudakov" already included. + VINT(150)=1D0 + IF(MINT(39).NE.1) THEN + RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN) + SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN) + DO 180 IBIN=IRBIN+1,20 + RNCOR=RNCOR+NMUL(IBIN) + SIGCOR=SIGCOR+SIGM(IBIN) + 180 CONTINUE + SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149)) + IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289) + VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)* + & SIGABV/MAX(1D-10,SIGT(0,0,5)))) + ENDIF + IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND. + & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53 + & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN + IF(VINT(150).LT.PYR(0)) GOTO 150 + VINT(150)=1D0 + ENDIF + +C...Generate additional multiple semihard interactions. + ELSEIF(MMUL.EQ.6) THEN + +C...Save data for hardest initeraction, to be restored. + ISUBSV=MINT(1) + VINT(145)=VNT145 + VINT(146)=VNT146 + VINT(147)=VNT147 + M13SV=MINT(13) + M14SV=MINT(14) + M15SV=MINT(15) + M16SV=MINT(16) + M21SV=MINT(21) + M22SV=MINT(22) + DO 190 J=11,80 + VINTSV(J)=VINT(J) + 190 CONTINUE + V141SV=VINT(141) + V142SV=VINT(142) + +C...Store data on hardest interaction. + XMI(1,1)=VINT(141) + XMI(2,1)=VINT(142) + PT2MI(1)=VINT(54) + IMISEP(0)=MINT(84) + IMISEP(1)=N + +C...Change process to generate; sum of x values so far. + ISUB=96 + MINT(1)=96 + VINT(143)=1D0-VINT(141) + VINT(144)=1D0-VINT(142) + VINT(151)=0D0 + VINT(152)=0D0 + +C...Initialize factors for PDF reshaping. + DO 230 JS=1,2 + KFBEAM=MINT(10+JS) + KFABM=IABS(KFBEAM) + KFSBM=ISIGN(1,KFBEAM) + +C...Zero flavour content of incoming beam particle. + KFIVAL(JS,1)=0 + KFIVAL(JS,2)=0 + KFIVAL(JS,3)=0 +C...Flavour content of baryon. + IF(KFABM.GT.1000) THEN + KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10) + KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10) + KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10) +C...Flavour content of pi+-, K+-. + ELSEIF(KFABM.EQ.211) THEN + KFIVAL(JS,1)=KFSBM*2 + KFIVAL(JS,2)=-KFSBM + ELSEIF(KFABM.EQ.321) THEN + KFIVAL(JS,1)=-KFSBM*3 + KFIVAL(JS,2)=KFSBM*2 +C...Flavour content of pi0, gamma, K0S, K0L not defined yet. + ENDIF + +C...Zero initial valence and companion content. + DO 200 IFL=-6,6 + NVC(JS,IFL)=0 + 200 CONTINUE + +C...Initiate listing of all incoming partons from two sides. + NMI(JS)=0 + DO 210 I=MINT(84)+1,N + IF(K(I,3).EQ.MINT(83)+2+JS) THEN + IMI(JS,1,1)=I + IMI(JS,1,2)=0 + ENDIF + 210 CONTINUE + +C...Decide whether quarks in hard scattering were valence or sea. + IFL=K(IMI(JS,1,1),2) + IF (IABS(IFL).GT.6) GOTO 230 + +C...Get PDFs at X and Q2 of the parton shower initiator for the +C...hard scattering. + X=VINT(140+JS) + IF(MSTP(61).GE.1) THEN + Q2=PARP(62)**2 + ELSE + Q2=VINT(54) + ENDIF +C...Note: XPSVC = x*pdf. + MINT(30)=JS + CALL PYPDFU(KFBEAM,X,Q2,XPQ) + SEA=XPSVC(IFL,-1) + VAL=XPSVC(IFL,0) + +C...Decide (Extra factor x cancels in the division). + RVCS=PYR(0)*(SEA+VAL) + IVNOW=1 + 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN +C...Safety check that valence present; pi0/gamma/K0S/K0L special cases. + IVNOW=0 + IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,1).EQ.0) THEN + IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1 + IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1 + IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND. + & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1 + ENDIF + IF(IVNOW.EQ.0) GOTO 220 +C...Mark valence. + IMI(JS,1,2)=0 +C...Sets valence content of gamma, pi0, K0S, K0L if not done. + IF(KFIVAL(JS,1).EQ.0) THEN + IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN + KFIVAL(JS,1)=IFL + KFIVAL(JS,2)=-IFL + ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN + KFIVAL(JS,1)=IFL + IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL) + IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL) + ENDIF + ENDIF + +C...If sea, add opposite sign companion parton. Store X and I. + ELSE + NVC(JS,-IFL)=NVC(JS,-IFL)+1 + XASSOC(JS,-IFL,NVC(JS,-IFL))=X +C...Set pointer to companion + IMI(JS,1,2)=-NVC(JS,-IFL) + ENDIF + 230 CONTINUE + +C...Update counter number of multiple interactions. + NMI(1)=1 + NMI(2)=1 + +C...Set up starting values for iteration in xT2. + IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND. + & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND. + & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND. + & ISUBSV.NE.96)) THEN + XT2=(1D0-VINT(141))*(1D0-VINT(142)) + ELSE + XT2=VINT(25) + IF(ISET(ISUBSV).EQ.1) XT2=VINT(21) + IF(ISET(ISUBSV).EQ.2) + & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2) + IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26) + ENDIF + IF(MSTP(82).LE.1) THEN + SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5)) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT* + & VINT(317)/(VINT(318)*VINT(320)) + XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149)) + ELSE + XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/ + & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149)) + ENDIF + VINT(63)=0D0 + VINT(64)=0D0 + +C...Iterate downwards in xT2. + 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN + XT2=0D0 + GOTO 440 + ELSEIF(MSTP(82).LE.1) THEN + XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0))) + IF(XT2.LT.VINT(149)) GOTO 440 + ELSE + IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440 + XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))* + & LOG(PYR(0)))-VINT(149) + IF(XT2.LE.0D0) GOTO 440 + XT2=MAX(0.01D0*VINT(149),XT2) + ENDIF + VINT(25)=XT2 + +C...Choose tau and y*. Calculate cos(theta-hat). + IF(PYR(0).LE.COEF(ISUB,1)) THEN + TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0) + TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT) + ELSE + TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2) + ENDIF + VINT(21)=TAU +C...New: require shat > 1. + IF(TAU*VINT(2).LT.1D0) GOTO 240 + CALL PYKLIM(2) + RYST=PYR(0) + MYST=1 + IF(RYST.GT.COEF(ISUB,8)) MYST=2 + IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3 + CALL PYKMAP(2,MYST,PYR(0)) + VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0)) + +C...Check that x not used up. Accept or reject kinematical variables. + X1M=SQRT(TAU)*EXP(VINT(22)) + X2M=SQRT(TAU)*EXP(-VINT(22)) + IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240 + VINT(71)=0.5D0*VINT(1)*SQRT(XT2) + CALL PYSIGH(NCHN,SIGS) + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320) + IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240 + IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320) + +C...Reset K, P and V vectors. + DO 260 I=N+1,N+4 + DO 250 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 250 CONTINUE + 260 CONTINUE + PT=0.5D0*VINT(1)*SQRT(XT2) + +C...Choose flavour of reacting partons (and subprocess). + RSIGS=SIGS*PYR(0) + DO 270 ICHN=1,NCHN + KFL1=ISIG(ICHN,1) + KFL2=ISIG(ICHN,2) + ICONMI=ISIG(ICHN,3) + RSIGS=RSIGS-SIGH(ICHN) + IF(RSIGS.LE.0D0) GOTO 280 + 270 CONTINUE + +C...Reassign to appropriate process codes. + 280 ISUBMI=ICONMI/10 + ICONMI=MOD(ICONMI,10) + +C...Choose new quark flavour for annihilation graphs + IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN + SH=TAU*VINT(2) + CALL PYWIDT(21,SH,WDTP,WDTE) + 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0) + DO 300 I=1,MDCY(21,3) + KFLF=KFDP(I+MDCY(21,2)-1,1) + RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4)) + IF(RKFL.LE.0D0) GOTO 310 + 300 CONTINUE + 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN + IF(KFLF.GE.4) GOTO 290 + ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN + KFLF=4 + ICONMI=ICONMI-2 + ELSEIF(ISUBMI.EQ.53) THEN + KFLF=5 + ICONMI=ICONMI-4 + ENDIF + ENDIF + +C...Final state flavours and colour flow: default values + JS=1 + KFL3=KFL1 + KFL4=KFL2 + KCC=20 + KCS=ISIGN(1,KFL1) + + IF(ISUBMI.EQ.11) THEN +C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2 + KCC=ICONMI + IF(KFL1*KFL2.LT.0) KCC=KCC+2 + + ELSEIF(ISUBMI.EQ.12) THEN +C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2 + KFL3=ISIGN(KFLF,KFL1) + KFL4=-KFL3 + KCC=4 + + ELSEIF(ISUBMI.EQ.13) THEN +C...f + fbar -> g + g; th arbitrary + KFL3=21 + KFL4=21 + KCC=ICONMI+4 + + ELSEIF(ISUBMI.EQ.28) THEN +C...f + g -> f + g; th = (p(f)-p(f))**2 + IF(KFL1.EQ.21) JS=2 + KCC=ICONMI+6 + IF(KFL1.EQ.21) KCC=KCC+2 + IF(KFL1.NE.21) KCS=ISIGN(1,KFL1) + IF(KFL2.NE.21) KCS=ISIGN(1,KFL2) + + ELSEIF(ISUBMI.EQ.53) THEN +C...g + g -> f + fbar; th arbitrary + KCS=(-1)**INT(1.5D0+PYR(0)) + KFL3=ISIGN(KFLF,KCS) + KFL4=-KFL3 + KCC=ICONMI+10 + + ELSEIF(ISUBMI.EQ.68) THEN +C...g + g -> g + g; th arbitrary + KCC=ICONMI+12 + KCS=(-1)**INT(1.5D0+PYR(0)) + ENDIF + +C...Store flavours of scattering. + MINT(13)=KFL1 + MINT(14)=KFL2 + MINT(15)=KFL1 + MINT(16)=KFL2 + MINT(21)=KFL3 + MINT(22)=KFL4 + +C...Set flavours and mothers of scattering partons. + K(N+1,1)=14 + K(N+2,1)=14 + K(N+3,1)=3 + K(N+4,1)=3 + K(N+1,2)=KFL1 + K(N+2,2)=KFL2 + K(N+3,2)=KFL3 + K(N+4,2)=KFL4 + K(N+1,3)=MINT(83)+1 + K(N+2,3)=MINT(83)+2 + K(N+3,3)=N+1 + K(N+4,3)=N+2 + +C...Store colour connection indices. + DO 320 J=1,2 + JC=J + IF(KCS.EQ.-1) JC=3-J + IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC) + IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC) + IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC)) + IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC)) + 320 CONTINUE + +C...Store incoming and outgoing partons in their CM-frame. + SHR=SQRT(TAU)*VINT(1) + P(N+1,3)=0.5D0*SHR + P(N+1,4)=0.5D0*SHR + P(N+2,3)=-0.5D0*SHR + P(N+2,4)=0.5D0*SHR + P(N+3,5)=PYMASS(K(N+3,2)) + P(N+4,5)=PYMASS(K(N+4,2)) + IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240 + P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR) + P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2)) + P(N+4,4)=SHR-P(N+3,4) + P(N+4,3)=-P(N+3,3) + +C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4) + PHI=PARU(2)*PYR(0) + CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0) + +C...Set up default values before showers. + MINT(31)=MINT(31)+1 + IPU1=N+1 + IPU2=N+2 + IPU3=N+3 + IPU4=N+4 + VINT(141)=VINT(41) + VINT(142)=VINT(42) + N=N+4 + +C...Showering of initial state partons (optional). +C...Note: no showering of final state partons here; it comes later. + IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN + MINT(51)=0 + ALAMSV=PARJ(81) + PARJ(81)=PARP(72) + NSAV=N + DO 340 I=1,4 + DO 330 J=1,5 + KSAV(I,J)=K(N-4+I,J) + PSAV(I,J)=P(N-4+I,J) + 330 CONTINUE + 340 CONTINUE + CALL PYSSPA(IPU1,IPU2) + PARJ(81)=ALAMSV +C...If shower failed then restore to situation before shower. + IF(MINT(51).GE.1) THEN + N=NSAV + DO 360 I=1,4 + DO 350 J=1,5 + K(N-4+I,J)=KSAV(I,J) + P(N-4+I,J)=PSAV(I,J) + 350 CONTINUE + 360 CONTINUE + IPU1=N-3 + IPU2=N-2 + VINT(141)=VINT(41) + VINT(142)=VINT(42) + ENDIF + ENDIF + +C...Keep track of loose colour ends and information on scattering. + 370 IMI(1,MINT(31),1)=IPU1 + IMI(2,MINT(31),1)=IPU2 + IMI(1,MINT(31),2)=0 + IMI(2,MINT(31),2)=0 + XMI(1,MINT(31))=VINT(141) + XMI(2,MINT(31))=VINT(142) + PT2MI(MINT(31))=VINT(54) + IMISEP(MINT(31))=N + +C...Decide whether quarks in last scattering were valence, companion or +C...sea. + DO 430 JS=1,2 + KFBEAM=MINT(10+JS) + KFSBM=ISIGN(1,MINT(10+JS)) + IFL=K(IMI(JS,MINT(31),1),2) + IMI(JS,MINT(31),2)=0 + IF (IABS(IFL).GT.6) GOTO 430 + +C...Get PDFs at X and Q2 of the parton shower initiator for the +C...last scattering. At this point VINT(143:144) do not yet +C...include the scattered x values VINT(141:142). + X=VINT(140+JS)/VINT(142+JS) + IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN + Q2=PARP(62)**2 + ELSE + Q2=VINT(54) + ENDIF +C...Note: XPSVC = x*pdf. + MINT(30)=JS + CALL PYPDFU(KFBEAM,X,Q2,XPQ) + SEA=XPSVC(IFL,-1) + VAL=XPSVC(IFL,0) + CMP=0D0 + DO 380 IVC=1,NVC(JS,IFL) + CMP=CMP+XPSVC(IFL,IVC) + 380 CONTINUE + +C...Decide (Extra factor x cancels in the dvision). + RVCS=PYR(0)*(SEA+VAL+CMP) + IVNOW=1 + 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN +C...Safety check that valence present; pi0/gamma/K0S/K0L special cases. + IVNOW=0 + IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1 + IF(KFIVAL(JS,1).EQ.0) THEN + IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1 + IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1 + IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND. + & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1 + ELSE + DO 400 I1=1,NMI(JS) + IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0) + & IVNOW=IVNOW-1 + 400 CONTINUE + ENDIF + IF(IVNOW.EQ.0) GOTO 390 +C...Mark valence. + IMI(JS,MINT(31),2)=0 +C...Sets valence content of gamma, pi0, K0S, K0L if not done. + IF(KFIVAL(JS,1).EQ.0) THEN + IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN + KFIVAL(JS,1)=IFL + KFIVAL(JS,2)=-IFL + ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN + KFIVAL(JS,1)=IFL + IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL) + IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL) + ENDIF + ENDIF + + ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN +C...If sea, add opposite sign companion parton. Store X and I. + NVC(JS,-IFL)=NVC(JS,-IFL)+1 + XASSOC(JS,-IFL,NVC(JS,-IFL))=X +C...Set pointer to companion + IMI(JS,MINT(31),2)=-NVC(JS,-IFL) + ELSE +C...If companion, decide which one. + CMPSUM=VAL+SEA + ISEL=0 + 410 ISEL=ISEL+1 + CMPSUM=CMPSUM+XPSVC(IFL,ISEL) + IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410 +C...Find original sea (anti-)quark: + IASSOC=0 + DO 420 I1=1,NMI(JS) + IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420 + IF (-IMI(JS,I1,2).EQ.ISEL) THEN + IMI(JS,MINT(31),2)=IMI(JS,I1,1) + IMI(JS,I1,2)=IMI(JS,MINT(31),1) + ENDIF + 420 CONTINUE +C...Change X to what associated companion had, so that the correct +C...amount of momentum can be subtracted from the companion sum below. + X=XASSOC(JS,IFL,ISEL) +C...Mark companion read. + XASSOC(JS,IFL,ISEL)=0D0 + ENDIF + 430 CONTINUE + +C...Global statistics. + MINT(351)=MINT(351)+1 + VINT(351)=VINT(351)+PT + IF (MINT(351).EQ.1) VINT(356)=PT + +C...Update remaining energy and other counters. + IF(N.GT.MSTU(4)-MSTU(32)-10) THEN + CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS') + MINT(51)=1 + RETURN + ENDIF + NMI(1)=NMI(1)+1 + NMI(2)=NMI(2)+1 + VINT(151)=VINT(151)+VINT(41) + VINT(152)=VINT(152)+VINT(42) + VINT(143)=VINT(143)-VINT(141) + VINT(144)=VINT(144)-VINT(142) + +C...Iterate, with more interactions allowed. + IF(MINT(31).LT.240) GOTO 240 + 440 CONTINUE + +C...Restore saved quantities for hardest interaction. + MINT(1)=ISUBSV + MINT(13)=M13SV + MINT(14)=M14SV + MINT(15)=M15SV + MINT(16)=M16SV + MINT(21)=M21SV + MINT(22)=M22SV + DO 450 J=11,80 + VINT(J)=VINTSV(J) + 450 CONTINUE + VINT(141)=V141SV + VINT(142)=V142SV + + ENDIF + +C...Format statements for printout. + 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter', + &'actions for MSTP(82) =',I2,' ******') + 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P, + &D9.2,' mb: rejected') + 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P, + &D9.2,' mb: accepted') + + RETURN + END + +C********************************************************************* + +C...PYMIHK +C...Finds left-behind remnant flavour content and hooks up +C...the colour flow between the hard scattering and remnants + + SUBROUTINE PYMIHK + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...The event record + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) +C...Parameters + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) +C...The common block of dangling ends + COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), + & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), + & XMI(2,240),PT2MI(240),IMISEP(0:240) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/ +C...Local variables + PARAMETER (NERSIZ=4000) + COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2) + & ,MACCPT + COMMON /PYCTAG/NCT,MCT(NERSIZ,2) + SAVE /PYCBLS/,/PYCTAG/ + DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2) + & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240) + DATA NERRPR/0/ + SAVE NERRPR + FOUR(I,J)=P(I,4)*P(J,4)-P(I,3)*P(J,3)-P(I,2)*P(J,2)-P(I,1)*P(J,1) + +C...Set up error checkers + IBOOST=0 + +C...Initialize colour arrays: MCO (Original) and MCT (New) + DO 110 I=MINT(84)+1,NERSIZ + DO 100 JC=1,2 + MCT(I,JC)=0 + MCO(I,JC)=0 + 100 CONTINUE +C...Also zero colour tracing information, if existed. + IF (I.LE.N) THEN + K(I,4)=MOD(K(I,4),MSTU(5)**2) + K(I,5)=MOD(K(I,5),MSTU(5)**2) + ENDIF + 110 CONTINUE + +C...Initialize colour tag collapse arrays: +C...JCCO (Original) and JCCN (New). + DO 130 MG=MINT(84)+1,NERSIZ + DO 120 JC=1,2 + JCCO(MG,JC)=0 + JCCN(MG,JC)=0 + 120 CONTINUE + 130 CONTINUE + +C...Zero gluon insertion array + DO 150 IM=1,1000 + DO 140 J=1,3 + INSR(IM,J)=0 + 140 CONTINUE + 150 CONTINUE + +C...Compute hard scattering system rapidities + IF (MSTP(89).EQ.1) THEN + DO 160 IM=1,240 + IF (IM.LE.MINT(31)) THEN + YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM)) + ELSE +C...Set (unsigned) rapidity = 100 for beam remnant systems. + YMI(IM)=100D0 + ENDIF + 160 CONTINUE + ENDIF + +C...Treat each side separately + DO 290 JS=1,2 + +C...Initialize side. + NG(JS)=0 + JV=0 + KFS=ISIGN(1,MINT(10+JS)) + +C...Set valence content of pi0, gamma, K0S, K0L if not yet done. + IF(KFIVAL(JS,1).EQ.0) THEN + IF(MINT(10+JS).EQ.111) THEN + KFIVAL(JS,1)=INT(1.5D0+PYR(0)) + KFIVAL(JS,2)=-KFIVAL(JS,1) + ELSEIF(MINT(10+JS).EQ.22) THEN + PYRKF=PYR(0) + KFIVAL(JS,1)=1 + IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2 + IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3 + IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4 + KFIVAL(JS,2)=-KFIVAL(JS,1) + ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN + IF(PYR(0).GT.0.5D0) THEN + KFIVAL(JS,1)=1 + KFIVAL(JS,2)=-3 + ELSE + KFIVAL(JS,1)=3 + KFIVAL(JS,2)=-1 + ENDIF + ENDIF + ENDIF + +C...Initialize beam remnant sea and valence content flavour by flavour. + NVSUM(JS)=0 + NBRTOT(JS)=0 + DO 210 JFA=1,6 +C...Count up original number of JFA valence quarks and antiquarks. + NVALQ=0 + NVALQB=0 + NSEA=0 + DO 170 J=1,3 + IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1 + IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1 + 170 CONTINUE + NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB +C...Subtract kicked out valence and determine sea from flavour cons. + DO 180 IM=1,NMI(JS) + IFL = K(IMI(JS,IM,1),2) + IFA = IABS(IFL) + IFS = ISIGN(1,IFL) + IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN +C...Subtract K.O. valence quark from remainder. + NVALQ=NVALQ-1 + JV=NVSUM(JS)-NVALQ-NVALQB + IV(JS,JV)=IMI(JS,IM,1) + ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN +C...Subtract K.O. valence antiquark from remainder. + NVALQB=NVALQB-1 + JV=NVSUM(JS)-NVALQ-NVALQB + IV(JS,JV)=IMI(JS,IM,1) + ELSEIF (IFA.EQ.JFA) THEN +C...Outside sea without companion: add opposite sea flavour inside. + IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS + ENDIF + 180 CONTINUE +C...Check if space left in PYJETS for additional BR flavours + NFLSUM=IABS(NSEA)+NVALQ+NVALQB + NBRTOT(JS)=NBRTOT(JS)+NFLSUM + IF (N+NFLSUM+1.GT.MSTU(4)) THEN + CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS') + MINT(51)=1 + RETURN + ENDIF +C...Add required val+sea content to beam remnant. + IF (NFLSUM.GT.0) THEN + DO 200 IA=1,NFLSUM +C...Insert beam remnant quark as p.t. symbolic parton in ER. + N=N+1 + DO 190 IX=1,5 + K(N,IX)=0 + P(N,IX)=0D0 + V(N,IX)=0D0 + 190 CONTINUE + K(N,1)=3 + K(N,2)=ISIGN(JFA,NSEA) + IF (IA.LE.NVALQ) K(N,2)=JFA + IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA + K(N,3)=MINT(83)+JS +C...Also update NMI, IMI, and IV arrays. + NMI(JS)=NMI(JS)+1 + IMI(JS,NMI(JS),1)=N + IMI(JS,NMI(JS),2)=-1 + IF (IA.LE.NVALQ+NVALQB) THEN + IMI(JS,NMI(JS),2)=0 + JV=JV+1 + IV(JS,JV)=IMI(JS,NMI(JS),1) + ENDIF + 200 CONTINUE + ENDIF + 210 CONTINUE + + IM=0 + 220 IM=IM+1 + IF (IM.LE.NMI(JS)) THEN + IF (K(IMI(JS,IM,1),2).EQ.21) THEN + NG(JS)=NG(JS)+1 +C...Add fictitious parent gluons for companion pairs. + ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN +C...Randomly assign companions to sea quarks which have none. + IF (IMI(JS,IM,2).LT.0) THEN + IMC=PYR(0)*NMI(JS) + 230 IMC=MOD(IMC,NMI(JS))+1 + IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230 + IF (IMI(JS,IMC,2).GE.0) GOTO 230 + IMI(JS, IM,2) = IMI(JS,IMC,1) + IMI(JS,IMC,2) = IMI(JS, IM,1) + ENDIF +C...Add fictitious parent gluon + N=N+1 + DO 240 IX=1,5 + K(N,IX)=0 + P(N,IX)=0D0 + V(N,IX)=0D0 + 240 CONTINUE + K(N,1)=14 + K(N,2)=21 + K(N,3)=MINT(83)+JS +C...Set gluon (anti-)colour daughter pointers + K(N,4)=IMI(JS, IM,1) + K(N,5)=IMI(JS, IM,2) +C...Set quark (anti-)colour parent pointers + K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N + K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N +C...Add gluon to IMI + NMI(JS)=NMI(JS)+1 + IMI(JS,NMI(JS),1)=N + IMI(JS,NMI(JS),2)=0 + ENDIF + GOTO 220 + ENDIF + +C...If incoming (anti-)baryon, insert inside (anti-)junction. +C...Set up initial v-v-j-v configuration. Otherwise set up +C...mesonic v-vbar configuration + IF (IABS(MINT(10+JS)).GT.1000) THEN +C...Determine junction type (1: B=1 2: B=-1) + ITJUNC(JS) = (3-KFS)/2 +C...Insert junction. + N=N+1 + DO 250 IX=1,5 + K(N,IX)=0 + P(N,IX)=0D0 + V(N,IX)=0D0 + 250 CONTINUE +C...Set special junction codes: + K(N,1)=42 + K(N,2)=88 +C...Set parent to side. + K(N,3)=MINT(83)+JS + K(N,4)=ITJUNC(JS)*MSTU(5) + K(N,5)=0 +C...Connect valence quarks to junction. + MOUT(JS)=0 + MANTI=ITJUNC(JS)-1 +C...Set (anti)colour mother = junction. + DO 260 JV=1,3 + K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5)) + & +MSTU(5)*N +C...Keep track of partons adjacent to junction: + JST(JS,JV)=IV(JS,JV) + 260 CONTINUE + ELSE +C...Mesons: set up initial q-qbar topology + ITJUNC(JS)=0 + IF (K(IV(JS,1),2).GT.0) THEN + IQ=IV(JS,1) + IQBAR=IV(JS,2) + ELSE + IQ=IV(JS,2) + IQBAR=IV(JS,1) + ENDIF + IV(JS,3)=0 + JST(JS,1)=IQ + JST(JS,2)=IQBAR + JST(JS,3)=0 + K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR + K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ +C...Special for mesons. Insert gluon if BR empty. + IF (NBRTOT(JS).EQ.0) THEN + N=N+1 + DO 270 IX=1,5 + K(N,IX)=0 + P(N,IX)=0D0 + V(N,IX)=0D0 + 270 CONTINUE + K(N,1)=3 + K(N,2)=21 + K(N,3)=MINT(83)+JS + K(N,4)=0 + K(N,5)=0 + NBRTOT(JS)=1 + NG(JS)=NG(JS)+1 +C...Add gluon to IMI + NMI(JS)=NMI(JS)+1 + IMI(JS,NMI(JS),1)=N + IMI(JS,NMI(JS),2)=0 + ENDIF + MOUT(JS)=0 + ENDIF + +C...Count up number of valence quarks outside BR. + DO 280 JV=1,3 + IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0) + & MOUT(JS)=MOUT(JS)+1 + 280 CONTINUE + + 290 CONTINUE + +C...Now both sides have been prepared in an initial vvjv (baryonic) or +C...v(g)vbar (mesonic) configuration. + +C...Create colour line tags starting from initiators. + NCT=0 + DO 320 IM=1,MINT(31) +C...Consider each side in turn. + DO 310 JS=1,2 + I1=IMI(JS,IM,1) + I2=IMI(3-JS,IM,1) + DO 300 JCS=4,5 + IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2))) + & GOTO 300 + IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300 + + KCS=JCS + CALL PYCTTR(I1,KCS,I2) + IF(MINT(51).NE.0) RETURN + + 300 CONTINUE + 310 CONTINUE + 320 CONTINUE + + DO 340 JS=1,2 +C...Create colour tags for beam remnant partons. + DO 330 IM=MINT(31)+1,NMI(JS) + IP=IMI(JS,IM,1) + IF (K(IP,2).NE.21) THEN + JC=(3-ISIGN(1,K(IP,2)))/2 + IF (MCT(IP,JC).EQ.0) THEN + NCT=NCT+1 + MCT(IP,JC)=NCT + ENDIF + ELSE +C...Gluons + ICD=K(IP,4) + IAD=K(IP,5) + IF (ICD.NE.0) THEN +C...Fictituous gluons just inherit from their quark daughters. + ICC=MCT(ICD,1) + IAC=MCT(IAD,2) + ELSE +C...Real beam remnant gluons get their own colours + ICC=NCT+1 + IAC=NCT+2 + NCT=NCT+2 + ENDIF + MCT(IP,1)=ICC + MCT(IP,2)=IAC + ENDIF + 330 CONTINUE + 340 CONTINUE + +C...Create colour tags for colour lines which are detached from the +C...initial state. + + DO 360 MQGST=1,2 + DO 350 I=MINT(84)+1,N + +C...Look for coloured string endpoint, or (later) leftover gluon. + IF (K(I,1).NE.3) GOTO 350 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 350 + KQ=KCHG(KC,2) + IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350 + +C...Pick up loose string end with no previous tag. + KCS=4 + IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5 + IF(MCT(I,KCS-3).NE.0) GOTO 350 + + CALL PYCTTR(I,KCS,I) + IF(MINT(51).NE.0) RETURN + + 350 CONTINUE + 360 CONTINUE + +C...Store original colour tags + DO 370 I=MINT(84)+1,N + MCO(I,1)=MCT(I,1) + MCO(I,2)=MCT(I,2) + 370 CONTINUE + +C...Iteratively add gluons to already existing string pieces, enforcing +C...various possible orderings, and rejecting insertions that would give +C...rise to singlet gluons. +C... normalization. + RM0=1.5D0 + MRETRY=0 + PARP80=PARP(80) + +C...Set up simplified kinematics. +C...Boost hard interaction systems. + IBOOST=IBOOST+1 + DO 380 IM=1,MINT(31) + BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM)) + CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA) + 380 CONTINUE +C...Assign preliminary beam remnant momenta. + DO 390 I=MINT(53)+1,N + JS=K(I,3) + P(I,1)=0D0 + P(I,2)=0D0 + IF (K(I,2).NE.88) THEN + P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31)) + P(I,3)=P(I,4) + IF (JS.EQ.2) P(I,3)=-P(I,3) + ELSE +C...Junctions are wildcards for the present. + P(I,4)=0D0 + P(I,3)=0D0 + ENDIF + 390 CONTINUE + +C...Reset colour processing information. + 400 DO 410 I=MINT(84)+1,N + K(I,4)=MOD(K(I,4),MSTU(5)**2) + K(I,5)=MOD(K(I,5),MSTU(5)**2) + 410 CONTINUE + + NCC=0 + DO 430 JS=1,2 +C...If meson, without gluon in BR, collapse q-qbar colour tags: + IF (ITJUNC(JS).EQ.0) THEN + JC1=MCT(JST(JS,1),1) + JC2=MCT(JST(JS,2),2) + NCC=NCC+1 + JCCO(NCC,1)=MAX(JC1,JC2) + JCCO(NCC,2)=MIN(JC1,JC2) +C...Collapse colour tags in event record + DO 420 I=MINT(84)+1,N + IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2) + IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2) + 420 CONTINUE + ENDIF + 430 CONTINUE + + 440 JS=1 + IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2 + IF (NG(JS).GT.0) THEN + NOPT=0 + RLOPT=1D9 +C...Start at random gluon (optimizes speed for random attachments) + NMGL=0 + IMGL=PYR(0)*NMI(JS)+1 + 450 IMGL=MOD(IMGL,NMI(JS))+1 + NMGL=NMGL+1 +C...Only loop through NMI once (with upper limit to save time) + IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN + IGL = IMI(JS,IMGL,1) +C...If not gluon or if already connected, try next. + IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0 + & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450 +C...Now loop through all possible insertions of this gluon. + NMP1=0 + IMP1=PYR(0)*NMI(JS)+1 + 460 IMP1=MOD(IMP1,NMI(JS))+1 + NMP1=NMP1+1 + IF (IMP1.EQ.IMGL) GOTO 460 +C...Only loop through NMI once (with upper limit to save time). + IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN + IP1 = IMI(JS,IMP1,1) +C...Try both colour mother and colour anti-mother. +C...Randomly select which one to try first. + NANTI=0 + MANTI=PYR(0)*2 + 470 MANTI=MOD(MANTI+1,2) + NANTI=NANTI+1 + IF (NANTI.LE.2) THEN + IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5)) +C...Reject if no appropriate mother (or if mother is fictitious +C...parent gluon.) + IF (IP2.LE.0) GOTO 470 + IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470 +C...Also reject if this link has already been tried. + IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470 + IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470 +C...Set flag to indicate that this link has now been tried for this +C...gluon. IP2 may be junction, which has several mothers. + K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2 + IF (K(IP2,2).NE.88) THEN + K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2 + ENDIF + +C...JCG1: Original colour tag of gluon on IP1 side +C...JCG2: Original colour tag of gluon on IP2 side +C...JCP1: Original colour tag of IP1 on gluon side +C...JCP2: Original colour tag of IP2 on gluon side. + JCG1=MCO(IGL,2-MANTI) + JCG2=MCO(IGL,1+MANTI) + JCP1=MCO(IP1,1+MANTI) + JCP2=MCO(IP2,2-MANTI) + + CALL PYMIHG(JCP1,JCG1,JCP2,JCG2) +C...Reject gluon attachments that give rise to singlet gluons. + IF (MACCPT.EQ.0) GOTO 470 + +C...Update colours + JCG1=MCT(IGL,2-MANTI) + JCG2=MCT(IGL,1+MANTI) + JCP1=MCT(IP1,1+MANTI) + JCP2=MCT(IP2,2-MANTI) + +C...Select whether to accept this insertion + IF (MSTP(89).EQ.0) THEN +C...Random insertions: no measure. + RL=1D0 +C...For random ordering, we want to suppress beam remnant breakups +C...already at this point. + IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53) + & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN + NMP1=0 + NMGL=0 + GOTO 470 + ENDIF + ELSEIF (MSTP(89).EQ.1) THEN +C...Rapidity ordering: +C...YGL = Rapidity of gluon. + YGL=YMI(IMGL) +C...If fictitious gluon + IF (YGL.EQ.100D0) THEN + YGL=(3-2*JS)*100D0 + IDA1=MOD(K(IGL,4),MSTU(5)) + IDA2=MOD(K(IGL,5),MSTU(5)) + DO 480 IMT=1,NMI(JS) +C...Select (arbitrarily) the most central daughter. + IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2) + & THEN + IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT) + ENDIF + 480 CONTINUE + ENDIF +C...YP1 = Rapidity IP1 + YP1=YMI(IMP1) +C...If fictitious gluon + IF (YP1.EQ.100D0) THEN + YP1=(3-2*JS)*YP1 + IDA1=MOD(K(IP1,4),MSTU(5)) + IDA2=MOD(K(IP1,5),MSTU(5)) + DO 490 IMT=1,NMI(JS) +C...Select (arbitrarily) the most central daughter. + IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2) + & THEN + IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT) + ENDIF + 490 CONTINUE + ENDIF +C...YP2 = Rapidity of mother system + IF (K(IP2,2).NE.88) THEN + DO 500 IMT=1,NMI(JS) + IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT) + 500 CONTINUE +C...If fictitious gluon + IF (YP2.EQ.100D0) THEN + YP2=(3-2*JS)*YP2 + IDA1=MOD(K(IP2,4),MSTU(5)) + IDA2=MOD(K(IP2,5),MSTU(5)) + DO 510 IMT=1,NMI(JS) +C...Select (arbitrarily) the most central daughter. + IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2 + & ) THEN + IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT) + ENDIF + 510 CONTINUE + ENDIF +C...Assign (arbitrarily) 100D0 to junction also + ELSE + YP2=(3-2*JS)*100D0 + ENDIF + RL=ABS(YGL-YP1)+ABS(YGL-YP2) + ELSEIF (MSTP(89).EQ.2) THEN +C...Lambda ordering: +C...Compute lambda measure for this insertion. + RL=1D0 + DO 520 IST=1,6 + ISTR(IST)=0 + 520 CONTINUE +C...If IP2 is junction, not caught below. + IF (JCP2.EQ.0) THEN + ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5)) +C...Anti-junction is colour endpoint et vv., always on JCG2. + ISTR(5-ITJU)=IP2 + ENDIF + DO 530 I=MINT(84)+1,N + IF (K(I,1).LT.10) THEN +C...The new string pieces + IF (MCT(I,1).EQ.JCG1) ISTR(1)=I + IF (MCT(I,2).EQ.JCG1) ISTR(2)=I + IF (MCT(I,1).EQ.JCG2) ISTR(3)=I + IF (MCT(I,2).EQ.JCG2) ISTR(4)=I + ENDIF + 530 CONTINUE +C...Also identify junctions as string endpoints. + DO 540 I=MINT(84)+1,N + ICMO=MOD(K(I,4)/MSTU(5),MSTU(5)) + IAMO=MOD(K(I,5)/MSTU(5),MSTU(5)) +C...Find partons adjacent to junctions. + IF (ICMO.GT.0.AND.ICMO.LE.N) THEN + IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2) + & .EQ.0) ISTR(2) = ICMO + IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4) + & .EQ.0) ISTR(4) = ICMO + ENDIF + IF (IAMO.GT.0.AND.IAMO.LE.N) THEN + IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1) + & .EQ.0) ISTR(1) = IAMO + IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3) + & .EQ.0) ISTR(3) = IAMO + ENDIF + 540 CONTINUE +C...The old string piece + ISTR(5)=ISTR(1+2*MANTI) + ISTR(6)=ISTR(4-2*MANTI) + IF (ISTR(1).EQ.0.OR.ISTR(2).EQ.0.OR.ISTR(3).EQ.0.OR. + & ISTR(4).EQ.0.OR.ISTR(5).EQ.0.OR.ISTR(6).EQ.0) THEN +C...If one or more of the colour tags for this connection is/are still +C...dangling, skip this attempt for the time being. + RL=1D6 + ELSE + RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3) + & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6))) + RL=LOG(RL) + ENDIF + ENDIF +C...Allow some breadth to speed things up. + IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN + NOPT=NOPT+1 + ELSEIF (RL.GT.RLOPT) THEN + GOTO 470 + ELSE + NOPT=1 + RLOPT=RL + ENDIF +C...INSR(NOPT,1)=Gluon colour mother +C...INSR(NOPT,2)=Gluon +C...INSR(NOPT,3)=Gluon anticolour mother + IF (NOPT.GT.1000) GOTO 470 + INSR(NOPT,1+2*MANTI)=IP2 + INSR(NOPT,2)=IGL + INSR(NOPT,3-2*MANTI)=IP1 + IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470 + ENDIF + IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460 + ENDIF +C...Reset link test information. + DO 550 I=MINT(84)+1,N + K(I,4)=MOD(K(I,4),MSTU(5)**2) + K(I,5)=MOD(K(I,5),MSTU(5)**2) + 550 CONTINUE + IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450 + ENDIF +C...Now we have a list of best gluon insertions, none of which cause +C...singlets to arise. If list is empty, try again a few times. Note: +C...this should never happen if we have a meson with a gluon inserted +C...in the beam remnant, since that breaks up the colour line. + IF (NOPT.EQ.0) THEN +C...Abandon BR-g-BR suppression for retries. This is not serious, it +C...just means we happened to start with trying a bad sequence. + PARP80=1D0 + IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND + & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN + MRETRY=MRETRY+1 + DO 590 JS=1,2 + IF (ITJUNC(JS).NE.0) THEN + JST(JS,1)=IV(JS,1) + JST(JS,2)=IV(JS,2) + JST(JS,3)=IV(JS,3) +C...Reset valence quark parent pointers + DO 560 I=MINT(53)+1,N + IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I + 560 CONTINUE + MANTI=ITJUNC(JS)-1 +C...Set (anti)colour mother = junction. + DO 570 JV=1,3 + K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5)) + & +MSTU(5)*IJU + 570 CONTINUE + ELSE +C...Same for mesons. JST unchanged, so needn't be restored. + IQ=JST(JS,1) + IQBAR=JST(JS,2) + K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR + K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ + ENDIF +C...Also reset gluon parent pointers. + NG(JS)=0 + DO 580 IM=1,NMI(JS) + I=IMI(JS,IM,1) + IF (K(I,2).EQ.21) THEN + K(I,4)=MOD(K(I,4),MSTU(5)) + K(I,5)=MOD(K(I,5),MSTU(5)) + NG(JS)=NG(JS)+1 + ENDIF + 580 CONTINUE + 590 CONTINUE +C...Reset colour tags + DO 600 I=MINT(84)+1,N + MCT(I,1)=MCO(I,1) + MCT(I,2)=MCO(I,2) + 600 CONTINUE + GOTO 400 + ELSE + IF(NERRPR.LT.5) THEN + NERRPR=NERRPR+1 + CALL PYLIST(4) + CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!') + WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS) + ENDIF +C...Kill event and start another. + MINT(51)=1 + RETURN + ENDIF + ELSE +C...Select between insertions, suppressing insertions wholly in the BR. + IIN=PYR(0)*NOPT+1 + 610 IIN=MOD(IIN,NOPT)+1 + IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53) + & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610 + ENDIF + +C...Now we know which gluon to insert where. Colour tags in JCCO and +C...colour connection information should be updated, NG(JS) should be +C...counted down, and a new loop performed if there are still gluons +C...left on any side. + ICM=INSR(IIN,1) + IACM=INSR(IIN,3) + IGL=INSR(IIN,2) +C...JCG : Original gluon colour tag +C...JCAG: Original gluon anticolour tag. +C...JCM : Original anticolour tag of gluon colour mother +C...JACM: Original colour tag of gluon anticolour mother + JCG=MCO(IGL,1) + JCM=MCO(ICM,2) + JACG=MCO(IGL,2) + JACM=MCO(IACM,1) + + CALL PYMIHG(JACM,JACG,JCM,JCG) + IF (MACCPT.EQ.0) THEN + IF(NERRPR.LT.5) THEN + NERRPR=NERRPR+1 + CALL PYLIST(4) + CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!') + WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM + ENDIF +C...Kill event and start another. + MINT(51)=1 + RETURN + ELSE +C...If everything went fine, store new JCCN in JCCO. + NCC=NCC+1 + DO 620 ICC=1,NCC + JCCO(ICC,1)=JCCN(ICC,1) + JCCO(ICC,2)=JCCN(ICC,2) + 620 CONTINUE + ENDIF + +C...One gluon attached is counted as equivalent to one end outside. + MOUT(JS)=1 +C...Set IGL colour mother = ICM. + K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM +C...Set ICM anticolour mother = IGL colour. + IF (K(ICM,2).NE.88) THEN + K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL + ELSE +C...If ICM is junction, just update JST array for now. + DO 630 MSJ=1,3 + IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL + 630 CONTINUE + ENDIF +C...Set IGL anticolour mother = IACM. + K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM +C...Set IACM anticolour mother = IGL anticolour. + IF (K(IACM,2).NE.88) THEN + K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL + ELSE +C...If IACM is junction, just update JST array for now. + DO 640 MSJ=1,3 + IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL + 640 CONTINUE + ENDIF +C...Count down # unconnected gluons. + NG(JS)=NG(JS)-1 + ENDIF + IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440 + + DO 840 JS=1,2 +C...Collapse fictitious gluons. + DO 670 IGL=MINT(53)+1,N + IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND. + & K(IGL,1).EQ.14) THEN + ICM=K(IGL,4)/MSTU(5) + IAM=K(IGL,5)/MSTU(5) + ICD=MOD(K(IGL,4),MSTU(5)) + IAD=MOD(K(IGL,5),MSTU(5)) +C...Set gluon daughters pointing to gluon mothers + K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM + K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM +C...Set gluon mothers pointing to gluon daughters. + IF (K(ICM,2).NE.88) THEN + K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD + ELSE +C...Special case: mother=junction. Just update JST array for now. + DO 650 MSJ=1,3 + IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD + 650 CONTINUE + ENDIF + IF (K(IAM,2).NE.88) THEN + K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD + ELSE + DO 660 MSJ=1,3 + IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD + 660 CONTINUE + ENDIF + ENDIF + 670 CONTINUE + +C...Erase collapsed gluons from NMI and IMI (but keep them in ER) + IM=NMI(JS)+1 + 680 IM=IM-1 + IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680 + IF (IM.GT.MINT(31)) THEN + NMI(JS)=NMI(JS)-1 + DO 690 IMR=IM,NMI(JS) + IMI(JS,IMR,1)=IMI(JS,IMR+1,1) + IMI(JS,IMR,2)=IMI(JS,IMR+1,2) + 690 CONTINUE + GOTO 680 + ENDIF + +C...Finally, connect junction. + IF (ITJUNC(JS).NE.0) THEN + DO 700 I=MINT(53)+1,N + IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I + 700 CONTINUE +C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR. + NBRJQ =0 + NBRVQ =0 + DO 720 MSJ=1,3 + IDQ(MSJ)=0 +C...Find jq with no glue inbetween inside beam remnant. + IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5) + & THEN + NBRJQ=NBRJQ+1 +C...Set IDQ = -I if q non-valence and = +I if q valence. + IDQ(NBRJQ)=-JST(JS,MSJ) + DO 710 JV=1,3 + IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN + IDQ(NBRJQ)=JST(JS,MSJ) + NBRVQ=NBRVQ+1 + ENDIF + 710 CONTINUE + ENDIF + I12=MOD(MSJ+1,2) + I45=5 + IF (MSJ.EQ.3) I45=4 + K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ) + 720 CONTINUE + +C...Check if diquark can be formed. + IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88) + & .GE.1)) THEN +C...If there is less than 2 valence quarks connected to junction +C...and MSTP(88)>1, use random non-valence quarks to fill up. + IF (NBRVQ.LE.1) THEN + NDIQ=NBRVQ + 730 JFLIP=NBRJQ*PYR(0)+1 + IF (IDQ(JFLIP).LT.0) THEN + IDQ(JFLIP)=-IDQ(JFLIP) + NDIQ=NDIQ+1 + ENDIF + IF (NDIQ.LE.1) GOTO 730 + ENDIF +C...Place selected quarks first in IDQ, ordered in flavour. + DO 740 JDQ=1,3 + IF (IDQ(JDQ).LE.0) THEN + ITEMP1 = IDQ(JDQ) + IDQ(JDQ)= IDQ(3) + IDQ(3) = -ITEMP1 + IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN + ITEMP1 = IDQ(1) + IDQ(1) = IDQ(2) + IDQ(2) = ITEMP1 + ENDIF + ENDIF + 740 CONTINUE +C...Choose diquark spin. + IF (NBRVQ.EQ.2) THEN +C...If the selected quarks are both valence, we may use SU(6) rules +C...to figure out which spin the diquark has, by a subdivision of the +C...original beam hadron into the selected diquark system plus a kicked +C...out quark, IKO. + JKO=6 + DO 760 JDQ=1,2 + DO 750 JV=1,3 + IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV + 750 CONTINUE + 760 CONTINUE + IKO=IV(JS,JKO) + CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ) + ELSE +C...If one or more of the selected quarks are not valence, we cannot use +C...SU(6) subdivisions of the original beam hadron. Instead, with the +C...flavours of the diquark already selected, we assume for now +C...50:50 spin-1:spin-0 (where spin-0 possible). + KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2) + IS=3 + IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND. + & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1 + KFDQ=KFDQ+ISIGN(IS,KFDQ) + ENDIF + +C...Collapse diquark-j-quark system to baryon, if allowed and possible. +C...Note: third quark can per definition not also be valence, +C...therefore we can only do this if we are allowed to use sea quarks. + 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN + NTRY=0 + 780 NTRY=NTRY+1 + CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR) + IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN + GOTO 780 + ELSEIF(NTRY.GT.100) THEN +C...If no baryon can be found, give up and form diquark. + IDQ(3)=0 + GOTO 770 + ELSE +C...Replace junction by baryon. + K(IJU,1)=1 + K(IJU,2)=KFBAR + K(IJU,3)=MINT(83)+JS + K(IJU,4)=0 + K(IJU,5)=0 + P(IJU,5)=PYMASS(KFBAR) + DO 790 MSJ=1,3 +C...Prepare removal of participating quarks from ER. + K(JST(JS,MSJ),1)=-1 + 790 CONTINUE + ENDIF + ELSE +C...If collapse to baryon not possible or not allowed, replace junction +C...by diquark. This way, collapsed gluons that were pointing at the +C...junction will now point (correctly) at diquark. + MANTI=ITJUNC(JS)-1 + K(IJU,1)=3 + K(IJU,2)=KFDQ + K(IJU,3)=MINT(83)+JS + K(IJU,4)=0 + K(IJU,5)=0 + DO 800 MSJ=1,3 + IP=JST(JS,MSJ) + IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN + K(IJU,4+MANTI)=0 + K(IJU,5-MANTI)=IP*MSTU(5) + K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+ + & MSTU(5)*IJU + MCT(IJU,2-MANTI)=MCT(IP,1+MANTI) + ELSE +C...Prepare removal of participating quarks from ER. + K(IP,1)=-1 + ENDIF + 800 CONTINUE + ENDIF + +C...Update so ER pointers to collapsed quarks +C...now go to collapsed object. + DO 820 I=MINT(84)+1,N + IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND + & .K(I,1).GT.0) THEN + DO 810 ISID=4,5 + IMO=K(I,ISID)/MSTU(5) + IDA=MOD(K(I,ISID),MSTU(5)) + IF (IMO.GT.0) THEN + IF (K(IMO,1).EQ.-1) IMO=IJU + ENDIF + IF (IDA.GT.0) THEN + IF (K(IDA,1).EQ.-1) IDA=IJU + ENDIF + K(I,ISID)=IDA+MSTU(5)*IMO + 810 CONTINUE + ENDIF + 820 CONTINUE + ENDIF + ENDIF + +C...Finally, if beam remnant is empty, insert a gluon in beam remnant. +C...(this only happens for baryons, where we want to force the gluon +C...to sit next to the junction. Mesons handled above.) + IF (NBRTOT(JS).EQ.0) THEN + N=N+1 + DO 830 IX=1,5 + K(N,IX)=0 + P(N,IX)=0D0 + V(N,IX)=0D0 + 830 CONTINUE + IGL=N + K(IGL,1)=3 + K(IGL,2)=21 + K(IGL,3)=MINT(83)+JS + IF (ITJUNC(JS).NE.0) THEN +C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons) + JLEG=PYR(0)*NVSUM(JS)+1 + I1=JST(JS,JLEG) + JST(JS,JLEG)=IGL + JCT=MCT(I1,ITJUNC(JS)) + MCT(IGL,3-ITJUNC(JS))=JCT + NCT=NCT+1 + MCT(IGL,ITJUNC(JS))=NCT + MANTI=ITJUNC(JS)-1 + ELSE +C...Meson. Should not happen. + CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant') + IF(NERRPR.LT.5) THEN + WRITE(MSTU(11),*) 'This should not have been possible!' + CALL PYLIST(4) + NERRPR=NERRPR+1 + ENDIF + MINT(51)=1 + RETURN + ENDIF + I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5)) + K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL + K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1 + K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2 + IF (K(I2,2).NE.88) THEN + K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL + ELSE + IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN + K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL + ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN + K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL + ELSE + K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL + ENDIF + ENDIF + ENDIF + 840 CONTINUE + +C...Remove collapsed quarks and junctions from ER and update IMI. + CALL PYEDIT(11) + +C...Also update beam remnant part of IMI. + NMI(1)=MINT(31) + NMI(2)=MINT(31) + DO 850 I=MINT(53)+1,N + IF (K(I,1).LE.0) GOTO 850 +C...Restore BR quark/diquark/baryon pointers in IMI. + IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN + JS=K(I,3)-MINT(83) + NMI(JS)=NMI(JS)+1 + IMI(JS,NMI(JS),1)=I + IMI(JS,NMI(JS),2)=0 + ENDIF + 850 CONTINUE + +C...Restore companion information from collapsed gluons. + DO 870 I=MINT(53)+1,N + IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN + JS=K(I,3)-MINT(83) + JCD=MOD(K(I,4),MSTU(5)) + JAD=MOD(K(I,5),MSTU(5)) + DO 860 IM=1,NMI(JS) + IF (IMI(JS,IM,1).EQ.JCD) IMC=IM + IF (IMI(JS,IM,1).EQ.JAD) IMA=IM + 860 CONTINUE + IMI(JS,IMC,2)=IMI(JS,IMA,1) + IMI(JS,IMA,2)=IMI(JS,IMC,1) + ENDIF + 870 CONTINUE + +C...Renumber colour lines (since some have disappeared) + JCT=0 + JCD=0 + 880 JCT=JCT+1 + MFOUND=0 + I=MINT(84) + 890 I=I+1 + IF (I.EQ.N+1) THEN + IF (MFOUND.EQ.0) JCD=JCD+1 + ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN + MCT(I,1)=JCT-JCD + MFOUND=1 + ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN + MCT(I,2)=JCT-JCD + MFOUND=1 + ENDIF + IF (I.LE.N) GOTO 890 + IF (JCT.LT.NCT) GOTO 880 + NCT=JCT-JCD + +C...Reset hard interaction subsystems to their CM frames. + IF (IBOOST.EQ.1) THEN + DO 900 IM=1,MINT(31) + BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM)) + CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA) + 900 CONTINUE +C...Zero beam remnant longitudinal momenta and energies + DO 910 I=MINT(53)+1,N + P(I,3)=0D0 + P(I,4)=0D0 + 910 CONTINUE + ELSE + CALL PYERRM(9 + & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.') +C...Kill event and start another. + MINT(51)=1 + RETURN + ENDIF + + 9999 RETURN + END +C********************************************************************* + +C...PYCTTR +C...Adapted from PYPREP. +C...Assigns LHA1 colour tags to coloured partons based on +C...K(I,4) and K(I,5) colour connection record. +C...KCS negative signifies that a previous tracing should be continued. +C...(in case the tag to be continued is empty, the routine exits) +C...Starts at I and ends at I or IEND. +C...Special considerations for systems with junctions. +C...Special: if IEND=-1, means trace this parton to its color partner, +C... then exit. If no partner found, exit with 0. + + SUBROUTINE PYCTTR(I,KCS,IEND) +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYINT1/MINT(400),VINT(400) +C...The common block of colour tags. + COMMON/PYCTAG/NCT,MCT(4000,2) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/ + DATA NERRPR/0/ + SAVE NERRPR + +C...Skip if parton not existing or does not have KCS + IF (K(I,1).LE.0) GOTO 120 + KC=PYCOMP(K(I,2)) + IF (KC.EQ.0) GOTO 120 + KQ=KCHG(KC,2) + IF (KQ.EQ.0) GOTO 120 + IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2))) + & GOTO 120 + + IF (KCS.GT.0) THEN + NCT=NCT+1 +C...Set colour tag of first parton. + MCT(I,KCS-3)=NCT + NCS=NCT + ELSE + KCS=-KCS + NCS=MCT(I,KCS-3) + IF (NCS.EQ.0) GOTO 120 + ENDIF + + IA=I + NSTP=0 + 100 NSTP=NSTP+1 + IF(NSTP.GT.4*N) THEN + CALL PYERRM(14,'(PYCTTR:) caught in infinite loop') + GOTO 120 + ENDIF + +C...Finished if reached final-state triplet. + IF(K(IA,1).EQ.3) THEN + IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120 + ENDIF + +C...Also finished if reached junction. + IF(K(IA,1).EQ.42) THEN + GOTO 120 + ENDIF + +C...GOTO next parton in colour space. + 110 IB=IA +C...If IB's KCS daughter not traced and exists, goto KCS daughter. + IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5)) + & .NE.0) THEN + IA=MOD(K(IB,KCS),MSTU(5)) + K(IB,KCS)=K(IB,KCS)+MSTU(5)**2 + MREV=0 + ELSE +C...If KCS mother traced or KCS mother nonexistent, switch colour. + IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5), + & MSTU(5)).EQ.0) THEN + KCS=9-KCS + NCT=NCT+1 + NCS=NCT +C...Assign new colour tag on other side of old parton. + MCT(IB,KCS-3)=NCT + ENDIF +C...Goto (new) KCS mother, set mother traced tag + IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5)) + K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2 + MREV=1 + ENDIF + IF(IA.LE.0.OR.IA.GT.N) THEN + IF (IEND.EQ.-1) THEN + IEND=0 + GOTO 120 + ENDIF + CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed') + IF(NERRPR.LT.5) THEN + write(*,*) 'began at ',I + write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS, + & ' NCS=',NCS,' MREV=',MREV + CALL PYLIST(4) + NERRPR=NERRPR+1 + ENDIF + MINT(51)=1 + RETURN + ENDIF + IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5), + & MSTU(5)).EQ.IB) THEN + IF(MREV.EQ.1) KCS=9-KCS + IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS +C...Set KSC mother traced tag for IA + K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2 + ELSE + IF(MREV.EQ.0) KCS=9-KCS + IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS +C...Set KCS daughter traced tag for IA + K(IA,KCS)=K(IA,KCS)+MSTU(5)**2 + ENDIF +C...Assign new colour tag + MCT(IA,KCS-3)=NCS +C...Finish if IEND=-1 and found final-state color partner + IF (IEND.EQ.-1.AND.K(IA,1).LT.10) THEN + IEND=IA + GOTO 120 + ENDIF + IF (IA.NE.I.AND.IA.NE.IEND) GOTO 100 + + 120 RETURN + END + +********************************************************************* + +C...PYMIHG +C...Collapse JCP1 and connecting tags to JCG1. +C...Collapse JCP2 and connecting tags to JCG2. + + SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2) +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...The event record + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) +C...Parameters + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYJETS/,/PYINT1/ +C...Local variables + COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT + COMMON /PYCTAG/NCT,MCT(4000,2) + SAVE /PYCBLS/,/PYCTAG/ + +C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags +C...in temporary tag collapse array JCCN. Only break up one connection. + MACCPT=1 + MCLPS=0 + DO 100 ICC=1,NCC + JCCN(ICC,1)=JCCO(ICC,1) + JCCN(ICC,2)=JCCO(ICC,2) +C...If there was a mother, it was previously connected to JCP1. +C...Should be changed to JCP2. + IF (MCLPS.EQ.0) THEN + IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1 + & ,JCP2)) THEN + JCCN(ICC,1)=MAX(JCG2,JCP2) + JCCN(ICC,2)=MIN(JCG2,JCP2) + MCLPS=1 + ENDIF + ENDIF + 100 CONTINUE +C...Also collapse colours on JCP1 side of JCG1 + IF (JCP1.NE.0) THEN + JCCN(NCC+1,1)=MAX(JCP1,JCG1) + JCCN(NCC+1,2)=MIN(JCP1,JCG1) + ELSE + JCCN(NCC+1,1)=MAX(JCP2,JCG2) + JCCN(NCC+1,2)=MIN(JCP2,JCG2) + ENDIF + +C...Initialize event record colour tag array MCT array to MCO. + DO 110 I=MINT(84)+1,N + MCT(I,1)=MCO(I,1) + MCT(I,2)=MCO(I,2) + 110 CONTINUE + +C...Collapse tags: +C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1 +C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2 +C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1 +C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2 + DO 160 IS=1,4 +C...Skip if junction. + IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160 +C...Define starting point in tag space. +C...JCA = previous tag +C...JCO = present tag +C...JCN = new tag + IF (MOD(IS,2).EQ.1) THEN + JCO=JCP1 + JCN=JCG1 + JCALL=JCG1 + ELSEIF (MOD(IS,2).EQ.0) THEN + JCO=JCP2 + JCN=JCG2 + JCALL=JCG2 + ENDIF + ITRACE=0 + 120 ITRACE=ITRACE+1 + IF (ITRACE.GT.1000) THEN +C...NB: Proper error message should be defined here. + CALL PYERRM(14 + & ,'(PYMIHG:) Inf loop when collapsing colours.') + MINT(57)=MINT(57)+1 + MINT(51)=1 + RETURN + ENDIF +C...Collapse all JCN tags to JCALL + DO 130 I=MINT(84)+1,N + IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL + IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL + 130 CONTINUE +C...IS = 1,2: first step forward. IS = 3,4: first step backward. + IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN + JCA=JCN + JCN=JCO + ELSE + JCA=JCO + JCO=JCN + ENDIF +C...If possible, step from JCO to new tag JCN not equal to JCA. + DO 140 ICC=1,NCC+1 + IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN= + & JCCN(ICC,2) + IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN= + & JCCN(ICC,1) + 140 CONTINUE +C...Iterate if new colour was arrived at, but don't go in circles. + IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120 +C...Change all JCN tags in MCO to JCALL in MCT. + DO 150 I=MINT(84)+1,N + IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL + IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL +C...If gluon and colour tag = anticolour tag (and not = 0) try again. + IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1) + & .NE.0) MACCPT=0 + 150 CONTINUE + 160 CONTINUE + + DO 200 JCL=NCT,1,-1 + JCA=0 + JCN=JCL + 170 JCO=JCN + DO 180 ICC=1,NCC+1 + IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN + & =JCCN(ICC,2) + IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN + & =JCCN(ICC,1) + 180 CONTINUE +C...Overpaint all JCN with JCL + IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN + DO 190 I=MINT(84)+1,N + IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL + IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL +C...If gluon and colour tag = anticolour tag (and not = 0) try again. + IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1) + & .NE.0) MACCPT=0 + 190 CONTINUE + JCA=JCO + GOTO 170 + ENDIF + 200 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYMIRM +C...Picks primordial kT and shares longitudinal momentum among +C...beam remnants. + + SUBROUTINE PYMIRM + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...The event record + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) +C...Parameters + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) +C...The common block of colour tags. + COMMON/PYCTAG/NCT,MCT(4000,2) +C...The common block of dangling ends + COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), + & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), + & XMI(2,240),PT2MI(240),IMISEP(0:240) + SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/ +C...Local variables + DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2) +C...W(I,J)| J=0 | 1 | 2 | +C... I=0 | Wrem**2 | W+ | W- | +C... 1 | W1**2 | W1+ | W1- | +C... 2 | W2**2 | W2+ | W2- | +C...4-product + FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) +C...Tentative parametrization of as a function of Q. + SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q)) +C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q)) +C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q)) + GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93)) +C...Lambda kinematic function. + FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A) + +C...Beginning and end of beam remnant partons + NOUT=MINT(53) + ISUB=MINT(1) + +C...Loopback point if kinematic choices gives impossible configuration. + NTRY=0 + 100 NTRY=NTRY+1 + +C...Assign kT values on each side separately. + DO 180 JS=1,2 + +C...First zero all kT on this side. Skip if no kT to generate. + DO 110 IM=1,NMI(JS) + P(IMI(JS,IM,1),1)=0D0 + P(IMI(JS,IM,1),2)=0D0 + 110 CONTINUE + IF(MSTP(91).LE.0) GOTO 180 + +C...Now assign kT to each (non-collapsed) parton in IMI. + DO 170 IM=1,NMI(JS) + I=IMI(JS,IM,1) +C...Select kT according to truncated gaussian or 1/kt6 tails. +C...For first interaction, either use rms width = PARP(91) or fitted. + IF (IM.EQ.1) THEN + SIGMA=PARP(91) + IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN + Q=SQRT(PT2MI(IM)) + SIGMA=SIGPT(Q) + ENDIF + ELSE +C...For subsequent interactions and BR partons use fragmentation width. + SIGMA=PARJ(21) + ENDIF + PHI=PARU(2)*PYR(0) + PT=0D0 + IF(NTRY.LE.100) THEN + 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN + PT=GETPT(Q,SIGMA) + PTX=PT*COS(PHI) + PTY=PT*SIN(PHI) + ELSEIF (MSTP(91).EQ.2) THEN + CALL PYERRM(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '// + & 'available, using MSTP(91)=1.') + CALL PYGIVE('MSTP(91)=1') + GOTO 111 + ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN +C...Use distribution with kt**6 tails, rms width = PARP(91). + EPS=SQRT(3D0/2D0)*SIGMA +C...Generate PTX and PTY separately, each propto 1/KT**6 + DO 119 IXY=1,2 +C...Decide which interval to try + 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6) + IF (PYR(0).LT.P12) THEN +C...Use flat approx with accept/reject up to EPS. + PT=PYR(0)*EPS + WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3 + IF (PYR(0).GT.WT) GOTO 112 + ELSE +C...Above EPS, use 1/kt**6 approx with accept/reject. + PT=EPS/(PYR(0)**(1D0/5D0)) + WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3 + IF (PYR(0).GT.WT) GOTO 112 + ENDIF + MSIGN=1 + IF (PYR(0).GT.0.5D0) MSIGN=-1 + IF (IXY.EQ.1) PTX=MSIGN*PT + IF (IXY.EQ.2) PTY=MSIGN*PT + 119 CONTINUE + ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN + PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0)) + PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0)) + ENDIF +C...Adjust final PT. Impose upper cutoff, or zero for soft evts. + PT=SQRT(PTX**2+PTY**2) + WT=1D0 + IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT) + IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0 + PTX=PTX*WT + PTY=PTY*WT + PT=SQRT(PTX**2+PTY**2) + ENDIF + + P(I,1)=P(I,1)+PTX + P(I,2)=P(I,2)+PTY + +C...Compensation kicks, with varying degree of local anticorrelations. + MCORR=MSTP(90) + IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN + PTCX=-PTX/(NMI(JS)-1) + PTCY=-PTY/(NMI(JS)-1) + IF(ISUB.EQ.95) THEN + PTCX=-PTX/(NMI(JS)-2) + PTCY=-PTY/(NMI(JS)-2) + ENDIF + DO 120 IMC=1,NMI(JS) + IF (IMC.EQ.IM) GOTO 120 + IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120 + P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX + P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY + 120 CONTINUE + ELSEIF (MCORR.GE.1) THEN + DO 140 MSID=4,5 + NNXT(MSID-3)=0 +C...Count up # of neighbours on either side + IMO=I + 130 IMO=K(IMO,MSID)/MSTU(5) + IF (IMO.EQ.0) GOTO 140 + NNXT(MSID-3)=NNXT(MSID-3)+1 +C...Stop at quarks and junctions + IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130 + 140 CONTINUE +C...How should compensation be shared when unequal numbers on the +C...two sides? 50/50 regardless? N1:N2? Assume latter for now. + NSUM=NNXT(1)+NNXT(2) + T1=0 + DO 160 MSID=4,5 +C...Total momentum to be compensated on this side + IF (NNXT(MSID-3).EQ.0) GOTO 160 + PTCX=-(NNXT(MSID-3)*PTX)/NSUM + PTCY=-(NNXT(MSID-3)*PTY)/NSUM +C...RS: compensation supression factor as we go out from parton I. +C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff, +C...since (for now) MSTP(90) provides enough variability. + RS=0.5D0 + FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3))) + IMO=I + 150 IDA=IMO + IMO=K(IMO,MSID)/MSTU(5) + IF (IMO.EQ.0) GOTO 160 + FAC=FAC*RS + IF (K(IMO,2).NE.88) THEN + P(IMO,1)=P(IMO,1)+FAC*PTCX + P(IMO,2)=P(IMO,2)+FAC*PTCY + IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150 +C...If we reach junction, divide out the kT that would have been +C...assigned to the junction on each of its other legs. + ELSE + L1=MOD(K(IMO,4),MSTU(5)) + L2=K(IMO,5)/MSTU(5) + L3=MOD(K(IMO,5),MSTU(5)) + P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX + P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY + P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX + P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY + P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX + P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY + P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX + P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY + ENDIF + + 160 CONTINUE + ENDIF + 170 CONTINUE +C...End assignment of kT values to initiators and remnants. + 180 CONTINUE + +C...Check kinematics constraints for non-BR partons. + DO 190 IM=1,MINT(31) + SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2) + PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2) + PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2) + PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1) + & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2) + IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN + IF(NTRY.GE.100) THEN +C...Kill this event and start another. + CALL PYERRM(1, + & '(PYMIRM:) No consistent (x,kT) sets found') + MINT(51)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + 190 CONTINUE + +C...Calculate W+ and W- available for combined remnant system. + W(0,1)=VINT(1) + W(0,2)=VINT(1) + DO 200 IM=1,MINT(31) + PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2 + & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2 + ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2 + W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST) + W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST) + 200 CONTINUE +C...Also store Wrem**2 = W+ * W- + W(0,0)=W(0,1)*W(0,2) + + IF ((W(0,0).LT.0D0.OR.W(0,1)+W(0,2).LT.0D0).AND.NTRY.LE.100) THEN + IF(NTRY.GE.100) THEN +C...Kill this event and start another. + CALL PYERRM(1, + & '(PYMIRM:) Negative beam remnant mass squared unavoidable') + MINT(51)=1 + RETURN + ENDIF + GOTO 100 + ENDIF + +C...Assign unscaled x values to partons/hadrons in each of the +C...beam remnants and calculate unscaled W+ and W- from them. + NTRYX=0 + 210 NTRYX=NTRYX+1 + DO 280 JS=1,2 + W(JS,1)=0D0 + W(JS,2)=0D0 + DO 270 IM=MINT(31)+1,NMI(JS) + I=IMI(JS,IM,1) + KF=K(I,2) + KFA=IABS(KF) + ICOMP=IMI(JS,IM,2) + +C...Skip collapsed gluons and junctions. Reset. + IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270 + IF (KFA.EQ.88) GOTO 270 + X=0D0 + IVALQ(1)=0 + IVALQ(2)=0 + ICOMQ(1)=0 + ICOMQ(2)=0 + +C...If gluon then only beam remnant, so takes all. + IF(KFA.EQ.21) THEN + X=1D0 +C...If valence quark then use parametrized valence distribution. + ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN + IVALQ(1)=KF +C...If companion quark then derive from companion x. + ELSEIF(KFA.LE.6) THEN + ICOMQ(1)=ICOMP +C...If valence diquark then use two parametrized valence distributions. + ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND. + & ICOMP.EQ.0) THEN + IVALQ(1)=ISIGN(KFA/1000,KF) + IVALQ(2)=ISIGN(MOD(KFA/100,10),KF) +C...If valence+sea diquark then combine valence + companion choices. + ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND. + & ICOMP.LT.MSTU(5)) THEN + IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN + IVALQ(1)=ISIGN(MOD(KFA/100,10),KF) + ELSE + IVALQ(1)=ISIGN(KFA/1000,KF) + ENDIF + ICOMQ(1)=ICOMP +C...Extra code: workaround for diquark made out of two sea +C...quarks, but where not (yet) ICOMP > MSTU(5). + DO 220 IM1=1,MINT(31) + IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN + ICOMQ(2)=IMI(JS,IM1,1) + IVALQ(1)=0 + ENDIF + 220 CONTINUE +C...If sea diquark then sum of two derived from companion x. + ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN + ICOMQ(1)=MOD(ICOMP,MSTU(5)) + ICOMQ(2)=ICOMP/MSTU(5) +C...If meson or baryon then use fragmentation function. +C...Somewhat arbitrary split into old and new flavour, but OK normally. + ELSE + KFL3=MOD(KFA/10,10) + IF(MOD(KFA/1000,10).EQ.0) THEN + KFL1=MOD(KFA/100,10) + ELSE + KFL1=MOD(KFA,10000)-10*KFL3-1 + IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND. + & MOD(KFA,10).EQ.2) KFL1=KFL1+2 + ENDIF + PR=P(I,5)**2+P(I,1)**2+P(I,2)**2 + CALL PYZDIS(KFL1,KFL3,PR,X) + ENDIF + + DO 260 IQ=1,2 +C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x), +C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson. +C...In other baryons combine u and d from proton appropriately. + IF(IVALQ(IQ).NE.0) THEN + NVAL=0 + IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1 + IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1 + IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1 +C...Meson. + IF(KFIVAL(JS,3).EQ.0) THEN + MDU=0 +C...Baryon with three identical quarks: mix u and d forms. + ELSEIF(NVAL.EQ.3) THEN + MDU=INT(PYR(0)+5D0/3D0) +C...Baryon, one of two identical quarks: u form. + ELSEIF(NVAL.EQ.2) THEN + MDU=2 +C...Baryon with two identical quarks, but not the one picked: d form. + ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ. + & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN + MDU=1 +C...Baryon with three nonidentical quarks: mix u and d forms. + ELSE + MDU=INT(PYR(0)+5D0/3D0) + ENDIF + XPOW=0.8D0 + IF(MDU.EQ.1) XPOW=3.5D0 + IF(MDU.EQ.2) XPOW=2D0 + 230 XX=PYR(0)**2 + IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230 + X=X+XX + ENDIF + +C...Calculation of x of companion quark. + IF(ICOMQ(IQ).NE.0) THEN + XCOMP=1D-4 + DO 240 IM1=1,MINT(31) + IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1) + 240 CONTINUE + NPOW=MAX(0,MIN(4,MSTP(87))) + 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0) + CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW* + & (XCOMP**2+XX**2)/(XCOMP+XX)**2 + IF(CORR.LT.PYR(0)) GOTO 250 + X=X+XX + ENDIF + 260 CONTINUE + +C...Optionally enchance x of composite systems (e.g. diquarks) + IF (KFA.GT.100) X=PARP(79)*X + +C...Store x. Also calculate light cone energies of each system. + XMI(JS,IM)=X + W(JS,JS)=W(JS,JS)+X + W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X + 270 CONTINUE + W(JS,JS)=W(JS,JS)*W(0,JS) + W(JS,3-JS)=W(JS,3-JS)/W(0,JS) + W(JS,0)=W(JS,1)*W(JS,2) + 280 CONTINUE + +C...Check W1 W2 < Wrem (can be done before rescaling, since W +C...insensitive to global rescalings of the BR x values). + IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100) + & THEN + GOTO 210 + ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN + GOTO 100 + ELSEIF (NTRYX.GT.100) THEN + CALL PYERRM(1,'(PYMIRM:) No consistent (x,kT) sets found') + MINT(57)=MINT(57)+1 + MINT(51)=1 + RETURN + ENDIF + +C...Compute x rescaling factors + COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0))) + R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2)) + R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1)) + + IF (R1.LT.0.OR.R2.LT.0) THEN + CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !') + MINT(57)=MINT(57)+1 + MINT(51)=1 + ENDIF + +C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent). + W(1,1)=W(1,1)*R1 + W(1,2)=W(1,2)/R1 + W(2,1)=W(2,1)/R2 + W(2,2)=W(2,2)*R2 + +C...Rescale BR x values. + DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2)) + XMI(1,IM)=XMI(1,IM)*R1 + XMI(2,IM)=XMI(2,IM)*R2 + 290 CONTINUE + +C...Now we have a consistent set of x and kT values. +C...First set up the initiators and their daughters correctly. + DO 300 IM=1,MINT(31) + I1=IMI(1,IM,1) + I2=IMI(2,IM,1) + ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+ + & (P(I1,2)+P(I2,2))**2 + PT12=P(I1,1)**2+P(I1,2)**2 + PT22=P(I2,1)**2+P(I2,2)**2 +C...p_z + P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST)) + P(I2,3)=-P(I1,3) +C...Energies (masses should be zero at this stage) + P(I1,4)=SQRT(PT12+P(I1,3)**2) + P(I2,4)=SQRT(PT22+P(I2,3)**2) + +C...Transverse 12 system initiator velocity: + VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST) + VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST) +C...Boost to overall initiator system rest frame + CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0) + CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0) + +C...Compute phi,theta coordinates of I1 and rotate z axis. + PHI=PYANGL(P(I1,1),P(I1,2)) + THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2)) + IMIN=IMISEP(IM-1)+1 +C...(include documentation lines if MI = 1) + IF (IM.EQ.1) IMIN=MINT(83)+5 + IMAX=IMISEP(IM) +C...Rotate entire system in phi + CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0) +C...Only rotate 12 system in theta + CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0) + CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0) + +C...Now boost entire system back to LAB + VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM)) + CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0) + CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3)) + + 300 CONTINUE + + +C...For the beam remnant partons/hadrons, we only need to set pz and E. + DO 320 JS=1,2 + DO 310 IM=MINT(31)+1,NMI(JS) + I=IMI(JS,IM,1) +C...Skip collapsed gluons and junctions. + IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310 + IF (KFA.EQ.88) GOTO 310 + RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2 + P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS))) + P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS))) + IF (JS.EQ.2) P(I,3)=-P(I,3) + 310 CONTINUE + 320 CONTINUE + + +C...Documentation lines + DO 340 JS=1,2 + IN=MINT(83)+JS+2 + IO=IMI(JS,1,1) + K(IN,1)=21 + K(IN,2)=K(IO,2) + K(IN,3)=MINT(83)+JS + K(IN,4)=0 + K(IN,5)=0 + DO 330 J=1,5 + P(IN,J)=P(IO,J) + V(IN,J)=V(IO,J) + 330 CONTINUE + MCT(IN,1)=MCT(IO,1) + MCT(IN,2)=MCT(IO,2) + 340 CONTINUE + +C...Final state colour reconnections. + IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380 + +C...Number of colour tags for which a recoupling will be tried. + NTOT=NCT +C...Number of recouplings to try + MINT(34)=0 + NRECP=0 + NITER=0 + 350 NRECP=MINT(34) + NITER=NITER+1 + IITER=0 + 360 IITER=IITER+1 + IF (IITER.LE.PARP(78)*NTOT) THEN +C...Select two colour tags at random +C...NB: jj strings do not have colour tags assigned to them, +C...thus they are as yet not affected by anything done here. + JCT=PYR(0)*NCT+1 + KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1 + IJ1=0 + IJ2=0 + IK1=0 + IK2=0 +C...Find final state partons with this (anti)colour + DO 370 I=MINT(84)+1,N + IF (K(I,1).EQ.3) THEN + IF (MCT(I,1).EQ.JCT) IJ1=I + IF (MCT(I,2).EQ.JCT) IJ2=I + IF (MCT(I,1).EQ.KCT) IK1=I + IF (MCT(I,2).EQ.KCT) IK2=I + ENDIF + 370 CONTINUE +C...Only consider recouplings not involving junctions for now. + IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360 + + RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2) + RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2) + IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN + MCT(IJ2,2)=KCT + MCT(IK2,2)=JCT +C...Count up number of reconnections + MINT(34)=MINT(34)+1 + ENDIF + IF (MINT(34).LE.1000) THEN + GOTO 360 + ELSE + CALL PYERRM(4,'(PYMIRM:) caught in infinite loop') + GOTO 380 + ENDIF + ENDIF + IF (NRECP.LT.MINT(34)) GOTO 350 + +C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS). + 380 MINT(33)=1 + + RETURN + END + +C********************************************************************* + +C...PYFSCR +C...Performs colour annealing. +C...MSTP(95) : CR Type +C... = 1 : old cut-and-paste reconnections, handled in PYMIHK +C... = 2 : Type I(no gg loops); hadron-hadron only +C... = 3 : Type I(no gg loops); all beams +C... = 4 : Type II(gg loops) ; hadron-hadron only +C... = 5 : Type II(gg loops) ; all beams +C... = 6 : Type S ; hadron-hadron only +C... = 7 : Type S ; all beams +C... = 8 : Type P ; hadron-hadron only +C... = 9 : Type P ; all beams +C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120. +C...Type S is driven by starting only from free triplets, not octets. +C...Type P is also driven by free triplets, but the reconnect probability +C...is computed from the string density per unit rapidity, where the axis +C...with respect to which the rapidity is computed is the Thrust axis of the +C...event. +C...A string piece remains unchanged with probability +C... PKEEP = (1-PARP(78))**N +C...This scaling corresponds to each string piece having to go through +C...N other ones, each with probability PARP(78) for reconnection. +C...For types I, II, and S, N is chosen simply as the number of multiple +C...interactions, for a rough scaling with the general level of activity. +C...For type P, N is chosen to be the number of string pieces in a given +C...interval of rapidity (minus one, since the string doesn't reconnect +C...with itself), and the reconnect probability is interpreted as the +C...probability per unit rapidity. +C...It also also possible to apply a dampening factor to the CR strength, +C...using PARP(77), which will cause reconnections among high-pT string +C...pieces to be suppressed. + + SUBROUTINE PYFSCR(IP) +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYINT1/MINT(400),VINT(400) +C...The common block of colour tags. + COMMON/PYCTAG/NCT,MCT(4000,2) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/, + &/PYPARS/ +C...MCN: Temporary storage of new colour tags + INTEGER MCN(4000,2) +C...Arrays for storing color strings + PARAMETER (NBINY=100) + INTEGER ICR(4000),MSCR(4000) + INTEGER IOPT(4000), NSTRY(NBINY) + DOUBLE PRECISION RLOPTC(4000) + +C...Function to give four-product. + FOUR(I,J)=P(I,4)*P(J,4) + & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) + +C...Check valid range of MSTP(95), local copy + IF (MSTP(95).LE.1.OR.MSTP(95).GE.10) RETURN + MSTP95=MOD(MSTP(95),10) +C...Set whether CR allowed inside resonance systems or not +C...(not implemented yet) +C MRESCR=1 +C IF (MSTP(95).GE.10) MRESCR=0 + +C...Check whether colour tags already defined + IF (MINT(33).EQ.0) THEN +C...Erase any existing colour tags for this event + DO 100 I=1,N + MCT(I,1)=0 + MCT(I,2)=0 + 100 CONTINUE +C...Create colour tags for this event + DO 120 I=1,N + IF (K(I,1).EQ.3) THEN + DO 110 KCS=4,5 + KCSIN=KCS + IF (MCT(I,KCSIN-3).EQ.0) THEN + CALL PYCTTR(I,KCSIN,I) + ENDIF + 110 CONTINUE + ENDIF + 120 CONTINUE +C...Instruct PYPREP to use colour tags + MINT(33)=1 + ENDIF + +C...For MSTP(95) even, only apply to hadron-hadron + KA1=IABS(MINT(11)) + KA2=IABS(MINT(12)) + IF (MOD(MSTP(95),2).EQ.0.AND.(KA1.LT.100.OR.KA2.LT.100)) GOTO 9999 + +C...Initialize new tag array (but do not delete old yet) + LCT=NCT + DO 130 I=MAX(1,IP),N + MCN(I,1)=0 + MCN(I,2)=0 + 130 CONTINUE + +C...For Paquis type, determine thrust axis (default along Z axis) + TX=0D0 + TY=0D0 + TZ=1D0 + IF (MSTP95.GE.8) THEN + CALL PYTHRU(THRDUM,OBLDUM) + TX = P(N+1,1) + TY = P(N+1,2) + TZ = P(N+1,3) + ENDIF + +C...For each final-state dipole, check whether string should be +C...preserved. + NCR=0 + IA=0 + IC=0 + RAPMAX=0.0 + + ICTMIN=NCT + DO 150 ICT=1,NCT + IA=0 + IC=0 + DO 140 I=MAX(1,IP),N + IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I + IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I + 140 CONTINUE + IF (IC.NE.0.AND.IA.NE.0) THEN +C...Save smallest NCT value so far + ICTMIN = MIN(ICTMIN,ICT) +C...For Paquis algorithm, just store all string pieces for now + IF (MSTP95.GE.8) THEN +C... Add coloured parton + NCR=NCR+1 + ICR(NCR)=IC + MSCR(NCR)=1 + IOPT(NCR)=0 +C... Store rapidity (along Thrust axis) in RLOPT for the time being +C... Add pion mass headroom to energy for this calculation + EET = P(IC,4)*SQRT(1D0+(0.135D0/P(IC,4))**2) + PZT = P(IC,1)*TX+P(IC,2)*TY+P(IC,3)*TZ + RLOPTC(NCR)=LOG((EET+PZT)/(EET-PZT)) +C... Add anti-coloured parton + NCR = NCR+1 + ICR(NCR) = IA + MSCR(NCR) = 2 + IOPT(NCR) = 0 +C... Store rapidity (along Thrust axis) in RLOPT for the time being + EET = P(IA,4)*SQRT(1D0+(0.135D0/P(IA,4))**2) + PZT = P(IA,1)*TX+P(IA,2)*TY+P(IA,3)*TZ + RLOPTC(NCR)=LOG((EET+PZT)/(EET-PZT)) +C... Keep track of largest endpoint "rapidity" + RAPMAX = MAX(RAPMAX,ABS(RLOPTC(NCR))) + RAPMAX = MAX(RAPMAX,ABS(RLOPTC(NCR-1))) + ELSE + CRMODF=1D0 +C... Opt: suppress breakup of high-boost string pieces (i.e., let them escape) +C... (so far ignores the possibility that the whole "muck" may be moving.) + IF (PARP(77).GT.0D0) THEN + PT2STR=(P(IA,1)+P(IC,1))**2+(P(IA,2)+P(IC,2))**2 +C... For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2 + IF (KA1.LT.100.AND.KA2.LT.100) THEN + P2STR = PT2STR + (P(IA,3)+P(IC,3))**2 + ELSE + P2STR = 3D0/2D0 * PT2STR + ENDIF + RM2STR=(P(IA,4)+P(IC,4))**2-(P(IA,3)+P(IC,3))**2-PT2STR + RM2STR=MAX(RM2STR,PMAS(PYCOMP(111),1)**2) +C... Estimate number of particles ~ log(M2), cut off at 1. + RLOGM2=MAX(1D0,LOG(RM2STR)) + P2AVG=P2STR/RLOGM2 +C... Supress reconnection probability by 1/(1+P77*P2AVG) + CRMODF=1D0/(1D0+PARP(77)**2*P2AVG) + ENDIF + PKEEP=(1D0-PARP(78)*CRMODF)**MINT(31) + IF (PYR(0).LE.PKEEP) THEN + LCT=LCT+1 + MCN(IC,1)=LCT + MCN(IA,2)=LCT + ELSE +C... Add coloured parton + NCR=NCR+1 + ICR(NCR)=IC + MSCR(NCR)=1 + IOPT(NCR)=0 + RLOPTC(NCR)=1D19 +C... Add anti-coloured parton + NCR=NCR+1 + ICR(NCR)=IA + MSCR(NCR)=2 + IOPT(NCR)=0 + RLOPTC(NCR)=1D19 + ENDIF + ENDIF + ENDIF + 150 CONTINUE + +C...PAQUIS TYPE + IF (MSTP95.GE.8) THEN +C... For Paquis type, make "histogram" of string densities along thrust axis + RAPMIN = -RAPMAX + DRAP = 2*RAPMAX/(1D0*NBINY) +C... Explicitly zero histogram bin content + DO 147 IBINY=1,NBINY + NSTRY(IBINY)=0 + 147 CONTINUE + DO 152 ISTR=1,NCR-1,2 + IC = ICR(ISTR) + IA = ICR(ISTR+1) + Y1 = MIN(RLOPTC(ISTR),RLOPTC(ISTR+1)) + Y2 = MAX(RLOPTC(ISTR),RLOPTC(ISTR+1)) + DO 153 IBINY=1,NBINY + YBINLO = RAPMIN + (IBINY-1)*DRAP +C... If bin inside string piece, add 1 in this bin +C... (Strictly speaking: if it starts before midpoint and ends after midpoint) + IF (Y1.LE.YBINLO+0.5*DRAP.AND.Y2.GE.YBINLO+0.5*DRAP) + & NSTRY(IBINY) = NSTRY(IBINY) + 1 + 153 CONTINUE + 152 CONTINUE +C... Loop over pieces to find individual reconnect probability + DO 167 IS=1,NCR-1,2 + DNSUM = 0D0 + DNAVG = 0D0 +C...Beginning at Y = RAPMIN = -RAPMAX, ending at Y = RAPMAX + RBINLO = (MIN(RLOPTC(IS),RLOPTC(IS+1))-RAPMIN)/DRAP + 0.5 + RBINHI = (MAX(RLOPTC(IS),RLOPTC(IS+1))-RAPMIN)/DRAP + 0.5 +C...Make sure integer bin numbers lie inside proper range + IBINLO = MAX(1,MIN(NBINY,NINT(RBINLO))) + IBINHI = MAX(1,MIN(NBINY,NINT(RBINHI))) +C...Size of rapidity bins (is < DRAP if piece smaller than one bin) +C...(also smaller than DRAP if a one-unit wide piece is stretched +C... over 2 bins, thus making the computation more accurate) + DRAPAV = (RBINHI-RBINLO)/(IBINHI-IBINLO+1)*DRAP +C... Decide whether to suppress reconnections in high-pT string pieces + CRMODF = 1D0 + IF (PARP(77).GT.0D0) THEN +C... Total string piece energy, momentum squared, and components + EES = P(ICR(IS),4) + P(ICR(IS+1),4) + PPS2 = (P(ICR(IS),1)+ P(ICR(IS+1),1))**2 + & + (P(ICR(IS),2)+ P(ICR(IS+1),2))**2 + & + (P(ICR(IS),3)+ P(ICR(IS+1),3))**2 + PZTS = P(ICR(IS),1)*TX+P(ICR(IS),2)*TY+P(ICR(IS),3)*TZ + & + P(ICR(IS+1),1)*TX+P(ICR(IS+1),2)*TY+P(ICR(IS+1),3)*TZ + PTTS = SQRT(PPS2 - PZTS**2) +C... Mass of string piece in units of mpi (at least 1) + RMPI2 = 0.135D0 + RM2STR = MAX(RMPI2,EES**2 - PPS2) +C... Estimate number of pions ~ log(M2) (at least 1) + RNPI = LOG(RM2STR/RMPI2)+1D0 + PT2AVG = (PTTS / RNPI)**2 +C... Supress reconnection probability by 1/(1+P77*P2AVG) + CRMODF=1D0/(1D0+PARP(77)**2*PT2AVG) + ENDIF + PKEEP = 1.0 + DO 178 IBINY=IBINLO,IBINHI +C DNSUM = DNSUM + 1D0 + DNOVL = MAX(0,NSTRY(IBINY)-1) + PKEEP = PKEEP * (1D0-CRMODF*PARP(78))**(DRAPAV*DNOVL) +C DNAVG = DNAVG + MAX(1,NSTRY(IBINY)) + 178 CONTINUE +C DNAVG = DNAVG / DNSUM +C... If keeping string piece, save + IF (PYR(0).LE.PKEEP) THEN + LCT = LCT+1 + MCN(ICR(IS),1)=LCT + MCN(ICR(IS+1),2)=LCT + ENDIF + 167 CONTINUE + ENDIF + +C...Skip if there is only one possibility + IF (NCR.LE.2) THEN + GOTO 9999 + ENDIF + +C...Reorder, so ordered in I (in order to correspond to old algorithm) + NLOOP=0 + 151 NLOOP=NLOOP+1 + MORD=1 + DO 155 IC1=1,NCR-1 + I1=ICR(IC1) + I2=ICR(IC1+1) + IF (I1.GT.I2) THEN + IT=I1 + MST=MSCR(IC1) + ICR(IC1)=I2 + MSCR(IC1)=MSCR(IC1+1) + ICR(IC1+1)=IT + MSCR(IC1+1)=MST + MORD=0 + ENDIF + 155 CONTINUE +C...Max do 1000 reordering loops + IF (MORD.EQ.0.AND.NLOOP.LE.1000) GOTO 151 + +C...PS: 03 May 2010 +C...For Seattle and Paquis types, check if there is a dangling tag +C...Needed for special case when entire reconnected state was one or +C...more gluon loops in original topology in which case these CR +C...algorithms need to be told they shouldn't look for a dangling tag. + M3FREE=0 + IF (MSTP95.GE.6.AND.MSTP95.LE.9) THEN + DO 157 IC1=1,NCR + I1=ICR(IC1) +C...Color charge + MCI=KCHG(PYCOMP(K(I1,2)),2)*ISIGN(1,K(I1,2)) + IF (MCI.EQ.1.AND.MCN(I1,1).EQ.0) M3FREE=1 + IF (MCI.EQ.-1.AND.MCN(I1,2).EQ.0) M3FREE=1 + IF (MCI.EQ.2) THEN + IF (MCN(I1,1).NE.0.AND.MCN(I1,2).EQ.0) M3FREE=1 + IF (MCN(I1,2).NE.0.AND.MCN(I1,1).EQ.0) M3FREE=1 + ENDIF + 157 CONTINUE + ENDIF + +C...Loop over CR partons +C...(Ignore junctions for now.) + NLOOP=0 + 160 NLOOP=NLOOP+1 + RLMAX=0D0 + ICRMAX=0 +C...Loop over coloured partons + DO 230 IC1=1,NCR +C...Retrieve parton Event Record index and Colour Side + I=ICR(IC1) + MSI=MSCR(IC1) +C...Skip already connected partons + IF (MCN(I,MSI).NE.0) GOTO 230 +C...Shorthand for colour charge + MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2)) +C...For Seattle algorithm, only start from partons with one dangling +C...colour tag (unless there aren't any, cf. M3FREE above.) + IF (MSTP(95).GE.6.AND.MSTP(95).LE.9) THEN + IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0 + & .AND.M3FREE.EQ.1) THEN + GOTO 230 + ENDIF + ENDIF +C...Retrieve saved optimal partner + IO=IOPT(IC1) + IF (IO.NE.0) THEN +C...Reject saved optimal partner if latter is now connected +C...(Also reject if using model S1, since saved partner may +C...now give rise to gg loop.) + IF (MCN(IO,3-MSI).NE.0.OR.MSTP(95).LE.3) THEN + IOPT(IC1)=0 + RLOPTC(IC1)=1D19 + ENDIF + ENDIF + RLOPT=RLOPTC(IC1) +C...Search for new optimal partner if necessary + IF (IOPT(IC1).EQ.0) THEN + MBROPT=0 + MGGOPT=0 + RLOPT=1D19 +C...Loop over partons you can connect to + DO 210 IC2=1,NCR + J=ICR(IC2) + MSJ=MSCR(IC2) +C...Skip if already connected + IF (MCN(J,MSJ).NE.0) GOTO 210 +C...Skip if this not colour-anticolour pair + IF (MSI.EQ.MSJ) GOTO 210 +C...And do not let gluons connect to themselves + IF (I.EQ.J) GOTO 210 +C...Suppress direct connections between partons in same Beam Remnant + MBRSTR=0 + IF (K(I,3).LE.2.AND.K(I,3).GE.1.AND.K(I,3).EQ.K(J,3)) + & MBRSTR=1 +C...Shorthand for colour charge + MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2)) +C...Check for gluon loops + MGGSTR=0 + IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN + IF (MCN(I,2).EQ.MCN(J,1).AND.MSTP(95).LE.3.AND. + & MCN(I,2).NE.0) MGGSTR=1 + ENDIF +C...Save connection with smallest lambda measure + RL=FOUR(I,J) +C...If best so far was a BR string and this is not, also save. +C...If best so far was a gg string and this is not, also save. +C...NB: this is not fool-proof. If the algorithm finds a BR or gg +C...string with a small Lambda measure as the last step, this connection +C...will be saved regardless of whether other possibilities existed. +C...I.e., there should really be a check whether another possibility has +C...already been found, but since these models are now actively in use +C...and uncertainties are anyway large, the algorithm is left as it is. +C...(correction --> Pythia 8 ?) + IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0) + & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0) + & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN +C...Paquis type: fix problem above + MPAQ = 0 + IF (MSTP95.GE.8.AND.RLOPT.LE.1D18) THEN + IF (MBRSTR.EQ.1.AND.MBROPT.EQ.0) MPAQ=1 + IF (MGGSTR.EQ.1.AND.MGGOPT.EQ.0) MPAQ=1 + ENDIF + IF (MPAQ.EQ.0) THEN + RLOPT=RL + RLOPTC(IC1)=RLOPT + IOPT(IC1)=J + MBROPT=MBRSTR + MGGOPT=MGGSTR + ENDIF + ENDIF + 210 CONTINUE + ENDIF + IF (IOPT(IC1).NE.0) THEN +C...Save pair with largest RLOPT so far + IF (RLOPT.GE.RLMAX) THEN + ICRMAX=IC1 + RLMAX=RLOPT + ENDIF + ENDIF + 230 CONTINUE +C...Save and iterate + ICMAX=0 + IF (ICRMAX.GT.0) THEN + LCT=LCT+1 + ILMAX=ICR(ICRMAX) + JLMAX=IOPT(ICRMAX) + ICMAX=MSCR(ICRMAX) + JCMAX=3-ICMAX + MCN(ILMAX,ICMAX)=LCT + MCN(JLMAX,JCMAX)=LCT + IF (NLOOP.LE.2*(N-IP)) THEN + GOTO 160 + ELSE + CALL PYERRM(31,' PYFSCR: infinite loop in color annealing') + CALL PYSTOP(11) + ENDIF + ELSE +C...Save and exit. First check for leftover gluon(s) + DO 260 I=MAX(1,IP),N +C...Check colour charge + MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2)) + IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260 + IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN +C...Decide where to put left-over gluon (minimal insertion) + ICMAX=0 + RLMAX=1D19 +C...PS: Bug fix 30 Apr 2010: try all lines, not just reconnected ones + DO 250 KCT=ICTMIN,LCT + IC=0 + IA=0 + DO 240 IT=MAX(1,IP),N + IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240 + IF (MCN(IT,1).EQ.KCT) IC=IT + IF (MCN(IT,2).EQ.KCT) IA=IT + 240 CONTINUE +C...Skip if this color tag no longer present in event record + IF (IC.EQ.0.OR.IA.EQ.0) GOTO 250 + RL=FOUR(IC,I)*FOUR(IA,I) + IF (RL.LT.RLMAX) THEN + RLMAX=RL + ICMAX=IC + IAMAX=IA + ENDIF + 250 CONTINUE + LCT=LCT+1 + MCN(I,1)=MCN(ICMAX,1) + MCN(I,2)=LCT + MCN(ICMAX,1)=LCT + ENDIF + 260 CONTINUE +C...Here we need to loop over entire event. + DO 270 IZ=MAX(1,IP),N +C...Do not erase parton shower colour history + IF (K(IZ,1).NE.3) GOTO 270 +C...Check colour charge + MCI=KCHG(PYCOMP(K(IZ,2)),2)*ISIGN(1,K(IZ,2)) + IF (MCI.EQ.0) GOTO 270 + IF (MCN(IZ,1).NE.0) MCT(IZ,1)=MCN(IZ,1) + IF (MCN(IZ,2).NE.0) MCT(IZ,2)=MCN(IZ,2) + 270 CONTINUE + ENDIF + + 9999 RETURN + END + +C********************************************************************* + +C...PYDIFF +C...Handles diffractive and elastic scattering. + + SUBROUTINE PYDIFF + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/, + &/PYINT5/ + +C...Calculate Monte Carlo estimates of cross-sections. + ISUB=MINT(1) + IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1 + NGEN(0,3)=NGEN(0,3)+1 + XSEC(0,3)=0D0 + DO 100 I=1,500 + IF(I.EQ.96.OR.I.EQ.97) THEN + XSEC(I,3)=0D0 + ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR. + & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN + XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))* + & DBLE(NGEN(96,2))) + ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN + XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))* + & DBLE(NGEN(96,2))) + ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN + XSEC(I,3)=0D0 + ELSEIF(NGEN(I,2).EQ.0) THEN + XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))* + & DBLE(NGEN(0,2))) + ELSE + XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))* + & DBLE(NGEN(I,2))) + ENDIF + XSEC(0,3)=XSEC(0,3)+XSEC(I,3) + 100 CONTINUE + +C...Rescale to known low-pT cross-section for standard QCD processes. + IF(MSUB(95).EQ.1) THEN + XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+ + & XSEC(68,3)+XSEC(95,3) + XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1))) + IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN + FAC=XSECW/XSECH + XSEC(11,3)=FAC*XSEC(11,3) + XSEC(12,3)=FAC*XSEC(12,3) + XSEC(13,3)=FAC*XSEC(13,3) + XSEC(28,3)=FAC*XSEC(28,3) + XSEC(53,3)=FAC*XSEC(53,3) + XSEC(68,3)=FAC*XSEC(68,3) + XSEC(95,3)=FAC*XSEC(95,3) + XSEC(0,3)=XSEC(0,3)-XSECH+XSECW + ENDIF + ENDIF + +C...Save information for gamma-p and gamma-gamma. + IF(MINT(121).GT.1) THEN + IGA=MINT(122) + CALL PYSAVE(2,IGA) + CALL PYSAVE(5,0) + ENDIF + +C...Reset information on hard interaction. + DO 110 J=1,200 + MSTI(J)=0 + PARI(J)=0D0 + 110 CONTINUE + +C...Copy integer valued information from MINT into MSTI. + DO 120 J=1,32 + MSTI(J)=MINT(J) + 120 CONTINUE + IF(MINT(121).GT.1) MSTI(9)=MINT(122) + +C...Store cross-section variables in PARI. + PARI(1)=XSEC(0,3) + PARI(2)=XSEC(0,3)/MINT(5) + PARI(7)=VINT(97) + PARI(9)=VINT(99) + PARI(10)=VINT(100) + VINT(98)=VINT(98)+VINT(100) + IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98) + +C...Store kinematics variables in PARI. + PARI(11)=VINT(1) + PARI(12)=VINT(2) + IF(ISUB.NE.95) THEN + DO 130 J=13,26 + PARI(J)=VINT(30+J) + 130 CONTINUE + PARI(29)=VINT(39) + PARI(30)=VINT(40) + PARI(31)=VINT(141) + PARI(32)=VINT(142) + PARI(33)=VINT(41) + PARI(34)=VINT(42) + PARI(35)=PARI(33)-PARI(34) + PARI(36)=VINT(21) + PARI(37)=VINT(22) + PARI(38)=VINT(26) + PARI(39)=VINT(157) + PARI(40)=VINT(158) + PARI(41)=VINT(23) + PARI(42)=2D0*VINT(47)/VINT(1) + ENDIF + +C...Store information on scattered partons in PARI. + IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN + DO 140 IS=7,8 + I=MINT(IS) + PARI(36+IS)=P(I,3)/VINT(1) + PARI(38+IS)=P(I,4)/VINT(1) + PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2) + PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/ + & SQRT(PR),1D20)),P(I,3)) + PR=MAX(1D-20,P(I,1)**2+P(I,2)**2) + PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/ + & SQRT(PR),1D20)),P(I,3)) + PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2) + PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2)) + PARI(48+IS)=PYANGL(P(I,1),P(I,2)) + 140 CONTINUE + ENDIF + +C...Store sum up transverse and longitudinal momenta. + PARI(65)=2D0*PARI(17) + IF(ISUB.LE.90.OR.ISUB.GE.95) THEN + DO 150 I=MSTP(126)+1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150 + PT=SQRT(P(I,1)**2+P(I,2)**2) + PARI(69)=PARI(69)+PT + IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT + IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT + 150 CONTINUE + PARI(67)=PARI(68) + PARI(71)=VINT(151) + PARI(72)=VINT(152) + PARI(73)=VINT(151) + PARI(74)=VINT(152) + ELSE + PARI(66)=PARI(65) + PARI(69)=PARI(65) + ENDIF + +C...Store various other pieces of information into PARI. + PARI(61)=VINT(148) + PARI(75)=VINT(155) + PARI(76)=VINT(156) + PARI(77)=VINT(159) + PARI(78)=VINT(160) + PARI(81)=VINT(138) + +C...Store information on lepton -> lepton + gamma in PYGAGA. + MSTI(71)=MINT(141) + MSTI(72)=MINT(142) + PARI(101)=VINT(301) + PARI(102)=VINT(302) + DO 160 I=103,114 + PARI(I)=VINT(I+202) + 160 CONTINUE + +C...Set information for PYTABU. + IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN + MSTU(161)=MINT(21) + MSTU(162)=0 + ELSEIF(ISET(ISUB).EQ.5) THEN + MSTU(161)=MINT(23) + MSTU(162)=0 + ELSE + MSTU(161)=MINT(21) + MSTU(162)=MINT(22) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYFRAM +C...Performs transformations between different coordinate frames. + + SUBROUTINE PYFRAM(IFRAME) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYDAT1/,/PYPARS/,/PYINT1/ + +C...Check that transformation can and should be done. + IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND. + &MINT(91).EQ.1)) THEN + IF(IFRAME.EQ.MINT(6)) RETURN + ELSE + WRITE(MSTU(11),5000) IFRAME,MINT(6) + RETURN + ENDIF + + IF(MINT(6).EQ.1) THEN +C...Transform from fixed target or user specified frame to +C...overall CM frame. + CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10)) + CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0) + CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0) + ELSEIF(MINT(6).EQ.3) THEN +C...Transform from hadronic CM frame in DIS to overall CM frame. + CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224), + & -VINT(225)) + ENDIF + + IF(IFRAME.EQ.1) THEN +C...Transform from overall CM frame to fixed target or user specified +C...frame. + CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10)) + ELSEIF(IFRAME.EQ.3) THEN +C...Transform from overall CM frame to hadronic CM frame in DIS. + CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225)) + CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0) + CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0) + ENDIF + +C...Set information about new frame. + MINT(6)=IFRAME + MSTI(6)=IFRAME + + 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X, + &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =', + &1X,I5) + + RETURN + END + +C********************************************************************* + +C...PYWIDT +C...Calculates full and partial widths of resonances. + + SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYPUED/IUED(0:99),RUED(0:99) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/ +C...Local arrays and saved variables. + COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR + DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2), + &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5) +C...UED: equivalences between ordered particles (451->475) +C...and UED particle code (5 000 000 + id) + PARAMETER(KKFLMI=451,KKFLMA=475) + DIMENSION CHIDEL(3), IUEDPR(25) + DIMENSION IUEDEQ(KKFLMA),MUED(2) + COMMON/SW1/SW21,CW21 + DATA (IUEDEQ(I),I=KKFLMI,KKFLMA)/ + & 6100001,6100002,6100003,6100004,6100005,6100006, + & 5100001,5100002,5100003,5100004,5100005,5100006, + & 6100011,6100013,6100015, + & 5100012,5100011,5100014,5100013,5100016,5100015, + & 5100021,5100022,5100023,5100024/ +C...Save local variables + SAVE MOFSV,WIDWSV,WID2SV +C...Initial values + DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/ + DATA CHIDEL/1.1D-03,1.D0,7.4D+2/ + DATA IUEDPR/25*0/ +C...UED: inline functions used in kk width calculus + FKAC1(X,Y)=1.-X**2/Y**2 + FKAC2(X,Y)=2.+X**2/Y**2 + +C...Compressed code and sign; mass. + KFLA=IABS(KFLR) + KFLS=ISIGN(1,KFLR) + KC=PYCOMP(KFLA) + SHR=SQRT(SH) + PMR=PMAS(KC,1) + +C...Reset width information. + DO 110 I=0,MDCY(KC,3) + WDTP(I)=0D0 + DO 100 J=0,5 + WDTE(I,J)=0D0 + 100 CONTINUE + 110 CONTINUE + +C...Allow for fudge factor to rescale resonance width. + FUDGE=1D0 + IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR. + &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN + IF(MSTP(110).EQ.KFLA) THEN + FUDGE=PARP(110) + ELSEIF(MSTP(110).EQ.-1) THEN + IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110) + ELSEIF(MSTP(110).EQ.-2) THEN + FUDGE=PARP(110) + ENDIF + ENDIF + +C...Not to be treated as a resonance: return. + IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND. + &KFLA.NE.22) THEN + WDTP(0)=1D0 + WDTE(0,0)=1D0 + MINT(61)=0 + MINT(62)=0 + MINT(63)=0 + RETURN + +C...Treatment as a resonance based on tabulated branching ratios. + ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN +C...Loop over possible decay channels; skip irrelevant ones. + DO 120 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 120 + +C...Read out decay products and nominal masses. + KFD1=KFDP(IDC,1) + KFC1=PYCOMP(KFD1) +C...Skip dummy modes or unrecognized particles + IF (KFD1.EQ.0.OR.KFC1.EQ.0) GOTO 120 + IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1 + PM1=PMAS(KFC1,1) + KFD2=KFDP(IDC,2) + KFC2=PYCOMP(KFD2) + IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2 + PM2=PMAS(KFC2,1) + KFD3=KFDP(IDC,3) + PM3=0D0 + IF(KFD3.NE.0) THEN + KFC3=PYCOMP(KFD3) + IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3 + PM3=PMAS(KFC3,1) + ENDIF + +C...Naive partial width and alternative threshold factors. + WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR) + IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND. + & PM1+PM2+PM3.GE.SHR) THEN + WDTP(I)=0D0 + ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN + WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2- + & 4D0*PM1**2*PM2**2))/SH + ELSEIF(MDME(IDC,2).EQ.52) THEN + PMA=MAX(PM1,PM2,PM3) + PMC=MIN(PM1,PM2,PM3) + PMB=PM1+PM2+PM3-PMA-PMC + PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC) + PMAN=PMA**2/SH + PMBN=PMB**2/SH + PMCN=PMC**2/SH + PMBCN=PMBC**2/SH + WDTP(I)=WDTP(I)*SQRT(MAX(0D0, + & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)* + & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))* + & ((SHR-PMA)**2-(PMB+PMC)**2)* + & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/ + & ((1D0-PMBCN)*PMBCN*SH) + ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN + WDTP(I)=WDTP(I)*SQRT( + & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/ + & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)) + ELSEIF(MDME(IDC,2).EQ.53) THEN + PMA=MAX(PM1,PM2,PM3) + PMC=MIN(PM1,PM2,PM3) + PMB=PM1+PM2+PM3-PMA-PMC + PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC) + PMAN=PMA**2/SH + PMBN=PMB**2/SH + PMCN=PMC**2/SH + PMBCN=PMBC**2/SH + FACACT=SQRT(MAX(0D0, + & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)* + & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))* + & ((SHR-PMA)**2-(PMB+PMC)**2)* + & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/ + & ((1D0-PMBCN)*PMBCN*SH) + PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC) + PMAN=PMA**2/PMR**2 + PMBN=PMB**2/PMR**2 + PMCN=PMC**2/PMR**2 + PMBCN=PMBC**2/PMR**2 + FACNOM=SQRT(MAX(0D0, + & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)* + & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))* + & ((PMR-PMA)**2-(PMB+PMC)**2)* + & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/ + & ((1D0-PMBCN)*PMBCN*PMR**2) + WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + +C...Calculate secondary width (at most two identical/opposite). + WID2=1D0 + IF(MDME(IDC,1).GT.0) THEN + IF(KFD2.EQ.KFD1) THEN + IF(KCHG(KFC1,3).EQ.0) THEN + WID2=WIDS(KFC1,1) + ELSEIF(KFD1.GT.0) THEN + WID2=WIDS(KFC1,4) + ELSE + WID2=WIDS(KFC1,5) + ENDIF + IF(KFD3.GT.0) THEN + WID2=WID2*WIDS(KFC3,2) + ELSEIF(KFD3.LT.0) THEN + WID2=WID2*WIDS(KFC3,3) + ENDIF + ELSEIF(KFD2.EQ.-KFD1) THEN + WID2=WIDS(KFC1,1) + IF(KFD3.GT.0) THEN + WID2=WID2*WIDS(KFC3,2) + ELSEIF(KFD3.LT.0) THEN + WID2=WID2*WIDS(KFC3,3) + ENDIF + ELSEIF(KFD3.EQ.KFD1) THEN + IF(KCHG(KFC1,3).EQ.0) THEN + WID2=WIDS(KFC1,1) + ELSEIF(KFD1.GT.0) THEN + WID2=WIDS(KFC1,4) + ELSE + WID2=WIDS(KFC1,5) + ENDIF + IF(KFD2.GT.0) THEN + WID2=WID2*WIDS(KFC2,2) + ELSEIF(KFD2.LT.0) THEN + WID2=WID2*WIDS(KFC2,3) + ENDIF + ELSEIF(KFD3.EQ.-KFD1) THEN + WID2=WIDS(KFC1,1) + IF(KFD2.GT.0) THEN + WID2=WID2*WIDS(KFC2,2) + ELSEIF(KFD2.LT.0) THEN + WID2=WID2*WIDS(KFC2,3) + ENDIF + ELSEIF(KFD3.EQ.KFD2) THEN + IF(KCHG(KFC2,3).EQ.0) THEN + WID2=WIDS(KFC2,1) + ELSEIF(KFD2.GT.0) THEN + WID2=WIDS(KFC2,4) + ELSE + WID2=WIDS(KFC2,5) + ENDIF + IF(KFD1.GT.0) THEN + WID2=WID2*WIDS(KFC1,2) + ELSEIF(KFD1.LT.0) THEN + WID2=WID2*WIDS(KFC1,3) + ENDIF + ELSEIF(KFD3.EQ.-KFD2) THEN + WID2=WIDS(KFC2,1) + IF(KFD1.GT.0) THEN + WID2=WID2*WIDS(KFC1,2) + ELSEIF(KFD1.LT.0) THEN + WID2=WID2*WIDS(KFC1,3) + ENDIF + ELSE + IF(KFD1.GT.0) THEN + WID2=WIDS(KFC1,2) + ELSE + WID2=WIDS(KFC1,3) + ENDIF + IF(KFD2.GT.0) THEN + WID2=WID2*WIDS(KFC2,2) + ELSE + WID2=WID2*WIDS(KFC2,3) + ENDIF + IF(KFD3.GT.0) THEN + WID2=WID2*WIDS(KFC3,2) + ELSEIF(KFD3.LT.0) THEN + WID2=WID2*WIDS(KFC3,3) + ENDIF + ENDIF + +C...Store effective widths according to case. + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 120 CONTINUE +C...Return. + MINT(61)=0 + MINT(62)=0 + MINT(63)=0 + RETURN + ENDIF + +C...Here begins detailed dynamical calculation of resonance widths. +C...Shared treatment of Higgs states. + KFHIGG=25 + IHIGG=1 + IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN + KFHIGG=KFLA + IHIGG=KFLA-33 + ENDIF + +C...Common electroweak and strong constants. + XW=PARU(102) + XWV=XW + IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2 + XW1=1D0-XW + AEM=PYALEM(SH) + IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1) + AS=PYALPS(SH) + RADC=1D0+AS/PARU(1) + + IF(KFLA.EQ.6) THEN +C...t quark. + FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR + RADCT=1D0-2.5D0*AS/PARU(1) + DO 140 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 140 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140 + WID2=1D0 + IF(I.GE.4.AND.I.LE.7) THEN +C...t -> W + q; including approximate QCD correction factor. + WDTP(I)=FAC*VCKM(3,I-3)*RADCT* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) + IF(KFLR.GT.0) THEN + WID2=WIDS(24,2) + IF(I.EQ.7) WID2=WID2*WIDS(7,2) + ELSE + WID2=WIDS(24,3) + IF(I.EQ.7) WID2=WID2*WIDS(7,3) + ENDIF + ELSEIF(I.EQ.9) THEN +C...t -> H + b. + RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH + WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+ + & 4D0*SQRT(RM2R*RM2)) + WID2=WIDS(37,2) + IF(KFLR.LT.0) WID2=WIDS(37,3) +CMRENNA++ + ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN +C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4. + BETA=ATAN(RMSS(5)) + SINB=SIN(BETA) + TANW=SQRT(PARU(102)/(1D0-PARU(102))) + ET=KCHG(6,1)/3D0 + T3L=SIGN(0.5D0,ET) + KFC1=PYCOMP(KFDP(IDC,1)) + KFC2=PYCOMP(KFDP(IDC,2)) + PMNCHI=PMAS(KFC1,1) + PMSTOP=PMAS(KFC2,1) + IF(SHR.GT.PMNCHI+PMSTOP) THEN + IZ=I-9 + DO 130 IK=1,4 + ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK)) + 130 CONTINUE + AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB) + AR=-ET*ZMIXC(IZ,1)*TANW + BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR + BR=AL + FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR + FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR + PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)* + & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR) + WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM* + & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+ + & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH + IF(KFLR.GT.0) THEN + WID2=WIDS(KFC1,2)*WIDS(KFC2,2) + ELSE + WID2=WIDS(KFC1,2)*WIDS(KFC2,3) + ENDIF + ENDIF + ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN +C...t -> ~g + ~t + KFC1=PYCOMP(KFDP(IDC,1)) + KFC2=PYCOMP(KFDP(IDC,2)) + PMNCHI=PMAS(KFC1,1) + PMSTOP=PMAS(KFC2,1) + IF(SHR.GT.PMNCHI+PMSTOP) THEN + RL=SFMIX(6,1) + RR=-SFMIX(6,2) + PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)* + & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR) + WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)* + & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH + IF(KFLR.GT.0) THEN + WID2=WIDS(KFC1,2)*WIDS(KFC2,2) + ELSE + WID2=WIDS(KFC1,2)*WIDS(KFC2,3) + ENDIF + ENDIF + ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN +C...t -> ~gravitino + ~t + XMP2=RMSS(29)**2 + KFC1=PYCOMP(KFDP(IDC,1)) + XMGR2=PMAS(KFC1,1)**2 + WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4 + KFC2=PYCOMP(KFDP(IDC,2)) + WID2=WIDS(KFC2,2) + IF(KFLR.LT.0) WID2=WIDS(KFC2,3) +CMRENNA-- + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 140 CONTINUE + + ELSEIF(KFLA.EQ.7) THEN +C...b' quark. + FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR + DO 150 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 150 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150 + WID2=1D0 + IF(I.GE.4.AND.I.LE.7) THEN +C...b' -> W + q. + WDTP(I)=FAC*VCKM(I-3,4)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) + IF(KFLR.GT.0) THEN + WID2=WIDS(24,3) + IF(I.EQ.6) WID2=WID2*WIDS(6,2) + IF(I.EQ.7) WID2=WID2*WIDS(8,2) + ELSE + WID2=WIDS(24,2) + IF(I.EQ.6) WID2=WID2*WIDS(6,3) + IF(I.EQ.7) WID2=WID2*WIDS(8,3) + ENDIF + WID2=WIDS(24,3) + IF(KFLR.LT.0) WID2=WIDS(24,2) + ELSEIF(I.EQ.9.OR.I.EQ.10) THEN +C...b' -> H + q. + WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2) + IF(KFLR.GT.0) THEN + WID2=WIDS(37,3) + IF(I.EQ.10) WID2=WID2*WIDS(6,2) + ELSE + WID2=WIDS(37,2) + IF(I.EQ.10) WID2=WID2*WIDS(6,3) + ENDIF + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 150 CONTINUE + + ELSEIF(KFLA.EQ.8) THEN +C...t' quark. + FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR + DO 160 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 160 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160 + WID2=1D0 + IF(I.GE.4.AND.I.LE.7) THEN +C...t' -> W + q. + WDTP(I)=FAC*VCKM(4,I-3)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) + IF(KFLR.GT.0) THEN + WID2=WIDS(24,2) + IF(I.EQ.7) WID2=WID2*WIDS(7,2) + ELSE + WID2=WIDS(24,3) + IF(I.EQ.7) WID2=WID2*WIDS(7,3) + ENDIF + ELSEIF(I.EQ.9.OR.I.EQ.10) THEN +C...t' -> H + q. + WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2) + IF(KFLR.GT.0) THEN + WID2=WIDS(37,2) + IF(I.EQ.10) WID2=WID2*WIDS(7,2) + ELSE + WID2=WIDS(37,3) + IF(I.EQ.10) WID2=WID2*WIDS(7,3) + ENDIF + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 160 CONTINUE + + ELSEIF(KFLA.EQ.17) THEN +C...tau' lepton. + FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR + DO 170 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 170 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170 + WID2=1D0 + IF(I.EQ.3) THEN +C...tau' -> W + nu'_tau. + WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) + IF(KFLR.GT.0) THEN + WID2=WIDS(24,3) + WID2=WID2*WIDS(18,2) + ELSE + WID2=WIDS(24,2) + WID2=WID2*WIDS(18,3) + ENDIF + ELSEIF(I.EQ.5) THEN +C...tau' -> H + nu'_tau. + WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2) + IF(KFLR.GT.0) THEN + WID2=WIDS(37,3) + WID2=WID2*WIDS(18,2) + ELSE + WID2=WIDS(37,2) + WID2=WID2*WIDS(18,3) + ENDIF + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 170 CONTINUE + + ELSEIF(KFLA.EQ.18) THEN +C...nu'_tau neutrino. + FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR + DO 180 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 180 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180 + WID2=1D0 + IF(I.EQ.2) THEN +C...nu'_tau -> W + tau'. + WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2) + IF(KFLR.GT.0) THEN + WID2=WIDS(24,2) + WID2=WID2*WIDS(17,2) + ELSE + WID2=WIDS(24,3) + WID2=WID2*WIDS(17,3) + ENDIF + ELSEIF(I.EQ.3) THEN +C...nu'_tau -> H + tau'. + WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2) + IF(KFLR.GT.0) THEN + WID2=WIDS(37,2) + WID2=WID2*WIDS(17,2) + ELSE + WID2=WIDS(37,3) + WID2=WID2*WIDS(17,3) + ENDIF + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 180 CONTINUE + + ELSEIF(KFLA.EQ.21) THEN +C...QCD: +C***Note that widths are not given in dimensional quantities here. + DO 190 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 190 + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190 + WID2=1D0 + IF(I.LE.8) THEN +C...QCD -> q + qbar + WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(I.EQ.6) WID2=WIDS(6,1) + IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 190 CONTINUE + + ELSEIF(KFLA.EQ.22) THEN +C...QED photon. +C***Note that widths are not given in dimensional quantities here. + DO 200 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 200 + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200 + WID2=1D0 + IF(I.LE.8) THEN +C...QED -> q + qbar. + EF=KCHG(I,1)/3D0 + FCOF=3D0*RADC + IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0) + WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(I.EQ.6) WID2=WIDS(6,1) + IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) + ELSEIF(I.LE.12) THEN +C...QED -> l+ + l-. + EF=KCHG(9+2*(I-8),1)/3D0 + WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(I.EQ.12) WID2=WIDS(17,1) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 200 CONTINUE + + ELSEIF(KFLA.EQ.23) THEN +C...Z0: + ICASE=1 + XWC=1D0/(16D0*XW*XW1) + FAC=(AEM*XWC/3D0)*SHR + 210 CONTINUE + IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN + VINT(111)=0D0 + VINT(112)=0D0 + VINT(114)=0D0 + ENDIF + IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN + KFI=IABS(MINT(15)) + IF(KFI.GT.20) KFI=IABS(MINT(16)) + EI=KCHG(KFI,1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + SQMZ=PMAS(23,1)**2 + HZ=SHR*WDTP(0) + IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0 + IF(MSTP(43).EQ.3) VINT(112)= + & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2) + IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)= + & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2) + ENDIF + DO 220 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 220 + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220 + WID2=1D0 + IF(I.LE.8) THEN +C...Z0 -> q + qbar + EF=KCHG(I,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + FCOF=3D0*RADC + IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0) + IF(I.EQ.6) WID2=WIDS(6,1) + IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) + ELSEIF(I.LE.16) THEN +C...Z0 -> l+ + l-, nu + nubar + EF=KCHG(I+2,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + FCOF=1D0 + IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1) + ENDIF + BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(ICASE.EQ.1) THEN + WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))* + & BE34 + ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN + WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)* + & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+ + & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34 + ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN + FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34 + FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34 + FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34 + ENDIF + IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I) + IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR. + & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+ + & WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN + IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)= + & VINT(111)+FGGF*WID2 + IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2 + IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)= + & VINT(114)+FZZF*WID2 + ENDIF + ENDIF + 220 CONTINUE + IF(MINT(61).GE.1) ICASE=3-ICASE + IF(ICASE.EQ.2) GOTO 210 + + ELSEIF(KFLA.EQ.24) THEN +C...W+/-: + FAC=(AEM/(24D0*XW))*SHR + DO 230 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 230 + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230 + WID2=1D0 + IF(I.LE.16) THEN +C...W+/- -> q + qbar' + FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1) + IF(KFLR.GT.0) THEN + IF(MOD(I,4).EQ.3) WID2=WIDS(6,2) + IF(MOD(I,4).EQ.0) WID2=WIDS(8,2) + IF(I.GE.13) WID2=WID2*WIDS(7,3) + ELSE + IF(MOD(I,4).EQ.3) WID2=WIDS(6,3) + IF(MOD(I,4).EQ.0) WID2=WIDS(8,3) + IF(I.GE.13) WID2=WID2*WIDS(7,2) + ENDIF + ELSEIF(I.LE.20) THEN +C...W+/- -> l+/- + nu + FCOF=1D0 + IF(KFLR.GT.0) THEN + IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2) + ELSE + IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3) + ENDIF + ENDIF + WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 230 CONTINUE + + ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN +C...h0 (or H0, or A0): + SHFS=SH + FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR + DO 270 I=1,MDCY(KFHIGG,3) + IDC=I+MDCY(KFHIGG,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 270 + KFC1=PYCOMP(KFDP(IDC,1)) + KFC2=PYCOMP(KFDP(IDC,2)) + RM1=PMAS(KFC1,1)**2/SH + RM2=PMAS(KFC2,1)**2/SH + IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0) + & GOTO 270 + WID2=1D0 + + IF(I.LE.8) THEN +C...h0 -> q + qbar + WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)* + & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC +C...A0 behaves like beta, ho and H0 like beta**3. + IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1) + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN + IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2 + IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2 + IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN + WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2 + IF(IHIGG.NE.3) THEN + WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/ + & PARU(151+10*IHIGG))**2 + ENDIF + ENDIF + ENDIF + IF(I.EQ.6) WID2=WIDS(6,1) + IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1) + ELSEIF(I.LE.12) THEN +C...h0 -> l+ + l- + WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS) +C...A0 behaves like beta, ho and H0 like beta**3. + IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1) + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)* + & PARU(153+10*IHIGG)**2 + IF(I.EQ.12) WID2=WIDS(17,1) + + ELSEIF(I.EQ.13) THEN +C...h0 -> g + g; quark loop contribution only + ETARE=0D0 + ETAIM=0D0 + DO 240 J=1,2*MSTP(1) + EPS=(2D0*PMAS(J,1))**2/SH +C...Loop integral; function of eps=4m^2/shat; different for A0. + IF(EPS.LE.1D0) THEN + IF(EPS.GT.1D-4) THEN + ROOT=SQRT(1D0-EPS) + RLN=LOG((1D0+ROOT)/(1D0-ROOT)) + ELSE + RLN=LOG(4D0/EPS-2D0) + ENDIF + PHIRE=-0.25D0*(RLN**2-PARU(1)**2) + PHIIM=0.5D0*PARU(1)*RLN + ELSE + PHIRE=(ASIN(1D0/SQRT(EPS)))**2 + PHIIM=0D0 + ENDIF + IF(IHIGG.LE.2) THEN + ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE) + ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM + ELSE + ETAREJ=-0.5D0*EPS*PHIRE + ETAIMJ=-0.5D0*EPS*PHIIM + ENDIF +C...Couplings (=1 for standard model Higgs). + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN + IF(MOD(J,2).EQ.1) THEN + ETAREJ=ETAREJ*PARU(151+10*IHIGG) + ETAIMJ=ETAIMJ*PARU(151+10*IHIGG) + ELSE + ETAREJ=ETAREJ*PARU(152+10*IHIGG) + ETAIMJ=ETAIMJ*PARU(152+10*IHIGG) + ENDIF + ENDIF + ETARE=ETARE+ETAREJ + ETAIM=ETAIM+ETAIMJ + 240 CONTINUE + ETA2=ETARE**2+ETAIM**2 + WDTP(I)=FAC*(AS/PARU(1))**2*ETA2 + + ELSEIF(I.EQ.14) THEN +C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions + ETARE=0D0 + ETAIM=0D0 + JMAX=3*MSTP(1)+1 + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1 + DO 250 J=1,JMAX + IF(J.LE.2*MSTP(1)) THEN + EJ=KCHG(J,1)/3D0 + EPS=(2D0*PMAS(J,1))**2/SH + ELSEIF(J.LE.3*MSTP(1)) THEN + JL=2*(J-2*MSTP(1))-1 + EJ=KCHG(10+JL,1)/3D0 + EPS=(2D0*PMAS(10+JL,1))**2/SH + ELSEIF(J.EQ.3*MSTP(1)+1) THEN + EPS=(2D0*PMAS(24,1))**2/SH + ELSE + EPS=(2D0*PMAS(37,1))**2/SH + ENDIF +C...Loop integral; function of eps=4m^2/shat. + IF(EPS.LE.1D0) THEN + IF(EPS.GT.1D-4) THEN + ROOT=SQRT(1D0-EPS) + RLN=LOG((1D0+ROOT)/(1D0-ROOT)) + ELSE + RLN=LOG(4D0/EPS-2D0) + ENDIF + PHIRE=-0.25D0*(RLN**2-PARU(1)**2) + PHIIM=0.5D0*PARU(1)*RLN + ELSE + PHIRE=(ASIN(1D0/SQRT(EPS)))**2 + PHIIM=0D0 + ENDIF + IF(J.LE.3*MSTP(1)) THEN +C...Fermion loops: loop integral different for A0; charges. + IF(IHIGG.LE.2) THEN + PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE) + PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM + ELSE + PHIPRE=-0.5D0*EPS*PHIRE + PHIPIM=-0.5D0*EPS*PHIIM + ENDIF + IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN + EJC=3D0*EJ**2 + EJH=PARU(151+10*IHIGG) + ELSEIF(J.LE.2*MSTP(1)) THEN + EJC=3D0*EJ**2 + EJH=PARU(152+10*IHIGG) + ELSE + EJC=EJ**2 + EJH=PARU(153+10*IHIGG) + ENDIF + IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0 + ETAREJ=EJC*EJH*PHIPRE + ETAIMJ=EJC*EJH*PHIPIM + ELSEIF(J.EQ.3*MSTP(1)+1) THEN +C...W loops: loop integral and charges. + ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE) + ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN + ETAREJ=ETAREJ*PARU(155+10*IHIGG) + ETAIMJ=ETAIMJ*PARU(155+10*IHIGG) + ENDIF + ELSE +C...Charged H loops: loop integral and charges. + FACHHH=(PMAS(24,1)/PMAS(37,1))**2* + & PARU(158+10*IHIGG+2*(IHIGG/3)) + ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH + ETAIMJ=-EPS**2*PHIIM*FACHHH + ENDIF + ETARE=ETARE+ETAREJ + ETAIM=ETAIM+ETAIMJ + 250 CONTINUE + ETA2=ETARE**2+ETAIM**2 + WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2 + + ELSEIF(I.EQ.15) THEN +C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions + ETARE=0D0 + ETAIM=0D0 + JMAX=3*MSTP(1)+1 + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1 + DO 260 J=1,JMAX + IF(J.LE.2*MSTP(1)) THEN + EJ=KCHG(J,1)/3D0 + AJ=SIGN(1D0,EJ+0.1D0) + VJ=AJ-4D0*EJ*XWV + EPS=(2D0*PMAS(J,1))**2/SH + EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2 + ELSEIF(J.LE.3*MSTP(1)) THEN + JL=2*(J-2*MSTP(1))-1 + EJ=KCHG(10+JL,1)/3D0 + AJ=SIGN(1D0,EJ+0.1D0) + VJ=AJ-4D0*EJ*XWV + EPS=(2D0*PMAS(10+JL,1))**2/SH + EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2 + ELSE + EPS=(2D0*PMAS(24,1))**2/SH + EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2 + ENDIF +C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2. + IF(EPS.LE.1D0) THEN + ROOT=SQRT(1D0-EPS) + IF(EPS.GT.1D-4) THEN + RLN=LOG((1D0+ROOT)/(1D0-ROOT)) + ELSE + RLN=LOG(4D0/EPS-2D0) + ENDIF + PHIRE=-0.25D0*(RLN**2-PARU(1)**2) + PHIIM=0.5D0*PARU(1)*RLN + PSIRE=0.5D0*ROOT*RLN + PSIIM=-0.5D0*ROOT*PARU(1) + ELSE + PHIRE=(ASIN(1D0/SQRT(EPS)))**2 + PHIIM=0D0 + PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS)) + PSIIM=0D0 + ENDIF + IF(EPSP.LE.1D0) THEN + ROOT=SQRT(1D0-EPSP) + IF(EPSP.GT.1D-4) THEN + RLN=LOG((1D0+ROOT)/(1D0-ROOT)) + ELSE + RLN=LOG(4D0/EPSP-2D0) + ENDIF + PHIREP=-0.25D0*(RLN**2-PARU(1)**2) + PHIIMP=0.5D0*PARU(1)*RLN + PSIREP=0.5D0*ROOT*RLN + PSIIMP=-0.5D0*ROOT*PARU(1) + ELSE + PHIREP=(ASIN(1D0/SQRT(EPSP)))**2 + PHIIMP=0D0 + PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP)) + PSIIMP=0D0 + ENDIF + FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)* + & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP)) + FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)* + & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP)) + F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP) + F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP) + IF(J.LE.3*MSTP(1)) THEN +C...Fermion loops: loop integral different for A0; charges. + IF(IHIGG.EQ.3) FXYRE=0D0 + IF(IHIGG.EQ.3) FXYIM=0D0 + IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN + EJC=-3D0*EJ*VJ + EJH=PARU(151+10*IHIGG) + ELSEIF(J.LE.2*MSTP(1)) THEN + EJC=-3D0*EJ*VJ + EJH=PARU(152+10*IHIGG) + ELSE + EJC=-EJ*VJ + EJH=PARU(153+10*IHIGG) + ENDIF + IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0 + ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE) + ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM) + ELSEIF(J.EQ.3*MSTP(1)+1) THEN +C...W loops: loop integral and charges. + HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS) + ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE) + ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM) + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN + ETAREJ=ETAREJ*PARU(155+10*IHIGG) + ETAIMJ=ETAIMJ*PARU(155+10*IHIGG) + ENDIF + ELSE +C...Charged H loops: loop integral and charges. + FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)* + & PARU(158+10*IHIGG+2*(IHIGG/3)) + ETAREJ=FACHHH*FXYRE + ETAIMJ=FACHHH*FXYIM + ENDIF + ETARE=ETARE+ETAREJ + ETAIM=ETAIM+ETAIMJ + 260 CONTINUE + ETA2=(ETARE**2+ETAIM**2)/(XW*XW1) + WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2 + WID2=WIDS(23,2) + + ELSEIF(I.LE.17) THEN +C...h0 -> Z0 + Z0, W+ + W- + PM1=PMAS(IABS(KFDP(IDC,1)),1) + PG1=PMAS(IABS(KFDP(IDC,1)),2) + IF(MINT(62).GE.1) THEN + IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND. + & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND. + & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN + MOFSV(IHIGG,I-15)=0 + WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0, + & 1D0-4D0*RM1)) + WID2=1D0 + ELSE + MOFSV(IHIGG,I-15)=1 + RMAS=SQRT(MAX(0D0,SH)) + CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW, + & WID2) + WIDWSV(IHIGG,I-15)=WIDW + WID2SV(IHIGG,I-15)=WID2 + ENDIF + ELSE + IF(MOFSV(IHIGG,I-15).EQ.0) THEN + WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0, + & 1D0-4D0*RM1)) + WID2=1D0 + ELSE + WIDW=WIDWSV(IHIGG,I-15) + WID2=WID2SV(IHIGG,I-15) + ENDIF + ENDIF + WDTP(I)=FAC*WIDW/(2D0*(18-I)) + IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)* + & PARU(138+I+10*IHIGG)**2 + WID2=WID2*WIDS(7+I,1) + + ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN +C...H0 -> Z0 + h0, A0-> Z0 + h0 + WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0, + & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + IF(IHIGG.EQ.2) THEN + WDTP(I)=WDTP(I)*PARU(179)**2 + ELSEIF(IHIGG.EQ.3) THEN + WDTP(I)=WDTP(I)*PARU(186)**2 + ENDIF + WID2=WIDS(23,2)*WIDS(25,2) + + ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN +C...H0 -> h0 + h0, A0-> h0 + h0 + WDTP(I)=FAC*0.25D0* + & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(IHIGG.EQ.2) THEN + WDTP(I)=WDTP(I)*PARU(176)**2 + ELSEIF(IHIGG.EQ.3) THEN + WDTP(I)=WDTP(I)*PARU(169)**2 + ENDIF + WID2=WIDS(25,1) + ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN +C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+ + WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0, + & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + & *PARU(195+IHIGG)**2 + IF(I.EQ.20) THEN + WID2=WIDS(24,2)*WIDS(37,3) + ELSEIF(I.EQ.21) THEN + WID2=WIDS(24,3)*WIDS(37,2) + ENDIF + + ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN +C...H0 -> Z0 + A0. + WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0, + & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + 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' + CKMFAC = VCKM((I-1)/4+1,MOD(I-1,4)+1) + FCOF=3D0*CKMFAC*RADC*(PARU(131)**2+PARU(132)**2) + FCOF2=3D0*CKMFAC*RADC*(PARU(131)**2-PARU(132)**2) + 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 + FCOF2=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*0.5*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2) + & *SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + IF (RM1.GT.0D0.AND.RM2.GT.0D0) THEN +C...PS 28/06/2010 +C...Inserted (gV2-gA2)*sqrt(m1*m2) term (FCOF2), following M. Chizhov + WDTP(I)=WDTP(I) + FAC*0.5*6D0*FCOF2*SQRT(RM1*RM2) + & *SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + ENDIF + ELSEIF(I.EQ.21) THEN +C...W'+/- -> W+/- + Z0 + WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2) + IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2) + IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2) + ELSEIF(I.EQ.23) THEN +C...W'+/- -> W+/- + h0 + FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM + IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2) + IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 300 CONTINUE + + ELSEIF(KFLA.EQ.37) THEN +C...H+/-: +C IF(MSTP(49).EQ.0) THEN + SHFS=SH +C ELSE +C SHFS=PMAS(37,1)**2 +C ENDIF + FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR + DO 310 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 310 + KFC1=PYCOMP(KFDP(IDC,1)) + KFC2=PYCOMP(KFDP(IDC,2)) + RM1=PMAS(KFC1,1)**2/SH + RM2=PMAS(KFC2,1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310 + WID2=1D0 + IF(I.LE.4) THEN +C...H+/- -> q + qbar' + RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH + RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH + WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+ + & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS) + IF(KFLR.GT.0) THEN + IF(I.EQ.3) WID2=WIDS(6,2) + IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2) + ELSE + IF(I.EQ.3) WID2=WIDS(6,3) + IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3) + ENDIF + ELSEIF(I.LE.8) THEN +C...H+/- -> l+/- + nu + WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)* + & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0, + & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS) + IF(KFLR.GT.0) THEN + IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2) + ELSE + IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3) + ENDIF + ELSEIF(I.EQ.9) THEN +C...H+/- -> W+/- + h0. + WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0, + & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2) + IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2) + +CMRENNA++ + ELSE +C...Add in SUSY decays (two-body) by rescaling by phase space factor. + RM10=RM1*SH/PMR**2 + RM20=RM2*SH/PMR**2 + WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20) + WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2) + IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN + WFAC=0D0 + ELSE + WFAC=WFAC/WFAC0 + ENDIF + WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC) +CMRENNA-- + KSGN1=2 + IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3 + KSGN2=2 + IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3 + WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 310 CONTINUE + + ELSEIF(KFLA.EQ.41) THEN +C...R: + FAC=(AEM/(12D0*XW))*SHR + DO 320 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 320 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320 + WID2=1D0 + IF(I.LE.6) THEN +C...R -> q + qbar' + FCOF=3D0*RADC + ELSEIF(I.LE.9) THEN +C...R -> l+ + l'- + FCOF=1D0 + ENDIF + WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + IF(KFLR.GT.0) THEN + IF(I.EQ.4) WID2=WIDS(6,3) + IF(I.EQ.5) WID2=WIDS(7,3) + IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3) + IF(I.EQ.9) WID2=WIDS(17,3) + ELSE + IF(I.EQ.4) WID2=WIDS(6,2) + IF(I.EQ.5) WID2=WIDS(7,2) + IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2) + IF(I.EQ.9) WID2=WIDS(17,2) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 320 CONTINUE + + ELSEIF(KFLA.EQ.42) THEN +C...LQ (leptoquark). + FAC=(AEM/4D0)*PARU(151)*SHR + DO 330 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 330 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330 + WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + WID2=1D0 + ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR) + IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2) + IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3) + ILQL=KFDP(IDC,2)*ISIGN(1,KFLR) + IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2) + IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3) + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 330 CONTINUE + +C...UED: kk state width decays : flav: 451 476 + ELSEIF(IUED(1).EQ.1.AND. + & PYCOMP(ABS(KFLA)).GE.KKFLMI.AND. + & PYCOMP(ABS(KFLA)).LE.KKFLMA) THEN + KCLA=PYCOMP(KFLA) +C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W* + RMFLAS=PMAS(KCLA,1) + FACSH=SH/PMAS(KCLA,1)**2 + ALPHEM=PYALEM(RMFLAS**2) + ALPHS=PYALPS(RMFLAS**2) + +C...uedcor parameters (alpha_s is calculated at mkk scale) +C...alpha_em is calculated at z pole ! + ALPHEM=PARU(101) + FACSH=1. + + DO 1070 I=1,MDCY(KCLA,3) + IDC=I+MDCY(KCLA,2)-1 + + IF(MDME(IDC,1).LT.0) GOTO 1070 + KFC1=PYCOMP(ABS(KFDP(IDC,1))) + KFC2=PYCOMP(ABS(KFDP(IDC,2))) + RM1=PMAS(KFC1,1)**2/SH + RM2=PMAS(KFC2,1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) + & GOTO 1070 + WID2=1D0 + +C...N.B. RINV=RUED(1) + RMKK=RUED(1) + RMWKK=PMAS(475,1) + RMZKK=PMAS(474,1) + SW2=PARU(102) + CW2=1.-SW2 + KKCLA=KCLA-KKFLMI+1 + IF(ABS(KFC1).GE.KKFLMI)KKPART=KFC1 + IF(ABS(KFC2).GE.KKFLMI)KKPART=KFC2 + IF(KKCLA.LE.6) THEN +C...q*_S -> q + gamma* (in first time sw21=0) + FAC=0.25*ALPHEM*RMFLAS*0.5*CW21/CW2*KCHG(KCLA,1)**2/9. +C...Eventually change the following by enabling a choice of open or closed. +C...Only the gamma_kk channel is open. + IF(MOD(I,2).EQ.0) + + WDTP(I)=FAC*FKAC2(RMFLAS,RMKK)*FKAC1(RMKK,RMFLAS)**2 + WDTP(I)=FACSH*WDTP(I) + WID2=WIDS(473,2) + ELSEIF(KKCLA.GT.6.AND.KKCLA.LE.12)THEN +C...q*_D -> q + Z*/W* + FAC=0.25*ALPHEM*RMFLAS/(4.*SW2) + GAMMAW=FAC*FKAC2(RMFLAS,RMWKK)*FKAC1(RMWKK,RMFLAS)**2 + IF(I.EQ.1)THEN +C...q*_D -> q + Z* + WDTP(I)=0.5*GAMMAW + WID2=WIDS(474,2) + ELSEIF(I.EQ.2)THEN +C...q*_D -> q + W* + WDTP(I)=GAMMAW + WID2=WIDS(475,2) + ENDIF + WDTP(I)=FACSH*WDTP(I) +C...q*_D -> q + gamma* is closed + ELSEIF(KKCLA.GT.12.AND.KKCLA.LE.21)THEN +C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l) + FAC=ALPHEM/4.*RMFLAS/CW2/8. + RMGAKK=PMAS(473,1) + WDTP(I)=FAC*FKAC2(RMFLAS,RMGAKK)* + + FKAC1(RMGAKK,RMFLAS)**2 + WDTP(I)=FACSH*WDTP(I) + WID2=WIDS(473,2) + ELSEIF(KKCLA.EQ.22)THEN + RMQST=PMAS(KKPART,1) + WID2=WIDS(KKPART,2) +C...g* -> q*_S/q*_D + q + FAC=10.*ALPHS/12.*RMFLAS + WDTP(I)=FAC*FKAC1(RMQST,RMFLAS)**2*FKAC2(RMQST,RMFLAS) + WDTP(I)=FACSH*WDTP(I) + ELSEIF(KKCLA.EQ.23)THEN +C...gamma* decays to graviton + gamma : initial value is used + ICHI=IUED(4)/2 + WDTP(I)=RMFLAS*(RMFLAS/RUED(2))**(IUED(4)+2) + & *CHIDEL(ICHI) + ELSEIF(KKCLA.EQ.24)THEN +C...Z* -> l*_S + l is closed +C... Z* -> l*_D + l + IF(I.LE.3)GOTO 1070 +c... After closing the channels for a Z* decaying into positively charged +C... KK lepton singlets, close the channels for a Z* decaying into negatively +C... charged KK lepton singlets + positively charged SM particles + IF(I.GE.10.AND.I.LE.12)GOTO 1070 + FAC=3./2.*ALPHEM/24./SW2*RMZKK + RMLST=PMAS(KKPART,1) + WDTP(I)=FAC*FKAC1(RMLST,RMZKK)**2*FKAC2(RMLST,RMZKK) + WDTP(I)=FACSH*WDTP(I) + WID2=WIDS(KKPART,2) + ELSEIF(KKCLA.EQ.25)THEN +C...W* -> l*_D lbar + FAC=3.*ALPHEM/12./SW2*RMWKK + RMLST=PMAS(KKPART,1) + WDTP(I)=FAC*FKAC1(RMLST,RMWKK)**2*FKAC2(RMLST,RMWKK) + WDTP(I)=FACSH*WDTP(I) + WID2=WIDS(KKPART,2) + ENDIF + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 1070 CONTINUE + IUEDPR(KKCLA)=1 + + ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN +C...Techni-pi0 and techni-pi0': + FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR + DO 340 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 340 + PM1=PMAS(PYCOMP(KFDP(IDC,1)),1) + PM2=PMAS(PYCOMP(KFDP(IDC,2)),1) + RM1=PM1**2/SH + RM2=PM2**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340 + WID2=1D0 +C...pi_tc -> g + g + IF(I.EQ.8) THEN + FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2 + & /(8D0*PARU(1))*SH*SHR + IF(KFLA.EQ.KTECHN+111) THEN + FACP=FACP*RTCM(9) + ELSE + FACP=FACP*RTCM(10) + ENDIF + WDTP(I)=FACP + ELSE +C...pi_tc -> f + fbar. + FCOF=1D0 + IKA=IABS(KFDP(IDC,1)) + IF(IKA.LT.10) FCOF=3D0*RADC + HM1=PM1 + HM2=PM2 + IF(IKA.GE.4.AND.IKA.LE.6) THEN + FCOF=FCOF*RTCM(1+IKA)**2 + HM1=PYMRUN(KFDP(IDC,1),SH) + HM2=PYMRUN(KFDP(IDC,2),SH) + ELSEIF(IKA.EQ.15) THEN + FCOF=FCOF*RTCM(8)**2 + ENDIF + WDTP(I)=FAC*FCOF*(HM1+HM2)**2* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 340 CONTINUE + + ELSEIF(KFLA.EQ.KTECHN+211) THEN +C...pi+_tc + FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR + DO 350 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 350 + PM1=PMAS(PYCOMP(KFDP(IDC,1)),1) + PM2=PMAS(PYCOMP(KFDP(IDC,2)),1) + PM3=0D0 + IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1) + RM1=PM1**2/SH + RM2=PM2**2/SH + RM3=PM3**2/SH + IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350 + WID2=1D0 +C...pi_tc -> f + f'. + FCOF=1D0 + IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC +C...pi_tc+ -> W b b~ + IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN + FCOF=3D0*RADC + XMT2=PMAS(6,1)**2/SH + FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2 + KFC3=PYCOMP(KFDP(IDC,3)) + CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3) + CHECK = SQRT(RM1) + T0 = (1D0-CHECK**2)* + & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)- + & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2) + T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2) + & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3) + T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1) + WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0)) + & +T3*LOG(CHECK)) + IF(KFLR.GT.0) THEN + WID2=WIDS(24,2) + ELSE + WID2=WIDS(24,3) + ENDIF + ELSE + FCOF=1D0 + IKA=IABS(KFDP(IDC,1)) + IF(IKA.LT.10) FCOF=3D0*RADC + HM1=PM1 + HM2=PM2 + IF(I.GE.1.AND.I.LE.5) THEN + IF(I.LE.2) THEN + FCOF=FCOF*RTCM(5)**2 + ELSEIF(I.LE.4) THEN + FCOF=FCOF*RTCM(6)**2 + ELSEIF(I.EQ.5) THEN + FCOF=FCOF*RTCM(7)**2 + ENDIF + HM1=PYMRUN(KFDP(IDC,1),SH) + HM2=PYMRUN(KFDP(IDC,2),SH) + ELSEIF(I.EQ.8) THEN + FCOF=FCOF*RTCM(8)**2 + ENDIF + WDTP(I)=FAC*FCOF*(HM1+HM2)**2* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 350 CONTINUE + + ELSEIF(KFLA.EQ.KTECHN+331) THEN +C...Techni-eta. + FAC=(SH/PARP(46)**2)*SHR + DO 360 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 360 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360 + WID2=1D0 + IF(I.LE.2) THEN + WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1)) + IF(I.EQ.2) WID2=WIDS(6,1) + ELSE + WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 360 CONTINUE + + ELSEIF(KFLA.EQ.KTECHN+113) THEN +C...Techni-rho0: + ALPRHT=2.16D0*(3D0/ITCM(1)) + FAC=(ALPRHT/12D0)*SHR + FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR + SQMZ=PMAS(23,1)**2 + SQMW=PMAS(24,1)**2 + SHP=SH + CALL PYWIDX(23,SHP,WDTPP,WDTEP) + GMMZ=SHR*WDTPP(0) + XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW)) + BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) + BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) + DO 370 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 370 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370 + WID2=1D0 + IF(I.EQ.1) THEN +C...rho_tc0 -> W+ + W-. +C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T + WDTP(I)=FAC*RTCM(3)**4* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ + & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)* + & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3 + WID2=WIDS(24,1) + ELSEIF(I.EQ.2) THEN +C...rho_tc0 -> W+ + pi_tc-. +C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T + WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ + & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)* + & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3 + WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3) + ELSEIF(I.EQ.3) THEN +C...rho_tc0 -> pi_tc+ + W-. + WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ + & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)* + & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3 + WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3) + ELSEIF(I.EQ.4) THEN +C...rho_tc0 -> pi_tc+ + pi_tc-. + WDTP(I)=FAC*(1D0-RTCM(3)**2)**2* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + WID2=WIDS(PYCOMP(KTECHN+211),1) + ELSEIF(I.EQ.5) THEN +C...rho_tc0 -> gamma + pi_tc0 + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2* + & SHR**3 + WID2=WIDS(PYCOMP(KTECHN+111),2) + ELSEIF(I.EQ.6) THEN +C...rho_tc0 -> gamma + pi_tc0' + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3 + WID2=WIDS(PYCOMP(KTECHN+221),2) + ELSEIF(I.EQ.7) THEN +C...rho_tc0 -> Z0 + pi_tc0 + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2* + & XW/XW1*SHR**3 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2) + ELSEIF(I.EQ.8) THEN +C...rho_tc0 -> Z0 + pi_tc0' + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/ + & XW/XW1*SHR**3 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2) + ELSEIF(I.EQ.9) THEN +C...rho_tc0 -> gamma + Z0 + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3 + WID2=WIDS(23,2) + ELSEIF(I.EQ.10) THEN +C...rho_tc0 -> Z0 + Z0 + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2* + & SHR**3 + WID2=WIDS(23,1) + ELSE +C...rho_tc0 -> f + fbar. + WID2=1D0 + IF(I.LE.18) THEN + IA=I-10 + 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.16D0*(3D0/ITCM(1)) + FAC=(ALPRHT/12D0)*SHR + SQMZ=PMAS(23,1)**2 + SQMW=PMAS(24,1)**2 + SHP=SH + CALL PYWIDX(24,SHP,WDTPP,WDTEP) + GMMW=SHR*WDTPP(0) + FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR* + & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2) + DO 380 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 380 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380 + WID2=1D0 + PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) +c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2) +c & /3D0*SHR**3 + IF(I.EQ.1) THEN +C...rho_tc+ -> W+ + Z0. +C......Goldstone + WDTP(I)=FAC*RTCM(3)**4* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2 + AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1 +C......W_L Z_T + WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2) + & /3D0*SHR**3 + VA2=0D0 + AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW +C......W_T Z_L + WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2) + & /3D0*SHR**3 + IF(KFLR.GT.0) THEN + WID2=WIDS(24,2)*WIDS(23,2) + ELSE + WID2=WIDS(24,3)*WIDS(23,2) + ENDIF + ELSEIF(I.EQ.2) THEN +C...rho_tc+ -> W+ + pi_tc0. + WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ + & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)* + & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3 + IF(KFLR.GT.0) THEN + WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2) + ELSE + WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2) + ENDIF + ELSEIF(I.EQ.3) THEN +C...rho_tc+ -> pi_tc+ + Z0. + WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ + & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))* + & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)* + & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+ + & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2* + & SHR**3*XW/XW1 + IF(KFLR.GT.0) THEN + WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2) + ELSE + WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2) + ENDIF + ELSEIF(I.EQ.4) THEN +C...rho_tc+ -> pi_tc+ + pi_tc0. + WDTP(I)=FAC*(1D0-RTCM(3)**2)**2* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + IF(KFLR.GT.0) THEN + WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2) + ELSE + WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2) + ENDIF + ELSEIF(I.EQ.5) THEN +C...rho_tc+ -> pi_tc+ + gamma + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2* + & SHR**3 + IF(KFLR.GT.0) THEN + WID2=WIDS(PYCOMP(KTECHN+211),2) + ELSE + WID2=WIDS(PYCOMP(KTECHN+211),3) + ENDIF + ELSEIF(I.EQ.6) THEN +C...rho_tc+ -> W+ + pi_tc0' + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3 + IF(KFLR.GT.0) THEN + WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2) + ELSE + WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2) + ENDIF + ELSEIF(I.EQ.7) THEN +C...rho_tc+ -> W+ + gamma + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3 + IF(KFLR.GT.0) THEN + WID2=WIDS(24,2) + ELSE + WID2=WIDS(24,3) + ENDIF + ELSE +C...rho_tc+ -> f + fbar'. + IA=I-7 + 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.16D0*(3D0/ITCM(1)) + FAC=(ALPRHT/12D0)*SHR + FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2 + SQMZ=PMAS(23,1)**2 + SHP=SH + CALL PYWIDX(23,SHP,WDTPP,WDTEP) + GMMZ=SHR*WDTPP(0) + BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) + BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) + DO 390 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 390 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390 + WID2=1D0 + IF(I.EQ.1) THEN +C...omega_tc0 -> gamma + pi_tc0. + WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3 + WID2=WIDS(PYCOMP(KTECHN+111),2) + ELSEIF(I.EQ.2) THEN +C...omega_tc0 -> Z0 + pi_tc0 + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/ + & XW/XW1*SHR**3 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2) + ELSEIF(I.EQ.3) THEN +C...omega_tc0 -> gamma + pi_tc0' + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2* + & SHR**3 + WID2=WIDS(PYCOMP(KTECHN+221),2) + ELSEIF(I.EQ.4) THEN +C...omega_tc0 -> Z0 + pi_tc0' + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2* + & XW/XW1*SHR**3 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2) + ELSEIF(I.EQ.5) THEN +C...omega_tc0 -> W+ + pi_tc- + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+ + & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3) + ELSEIF(I.EQ.6) THEN +C...omega_tc0 -> pi_tc+ + W- + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+ + & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2) + ELSEIF(I.EQ.7) THEN +C...omega_tc0 -> W+ + W-. +C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T + WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+ + & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3 + WID2=WIDS(24,1) + ELSEIF(I.EQ.8) THEN +C...omega_tc0 -> pi_tc+ + pi_tc-. + WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3 + WID2=WIDS(PYCOMP(KTECHN+211),1) +C...omega_tc0 -> gamma + Z0 + ELSEIF(I.EQ.9) THEN + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3 + WID2=WIDS(23,2) +C...omega_tc0 -> Z0 + Z0 + ELSEIF(I.EQ.10) THEN + WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3* + & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0 + & /24D0/RTCM(12)**2*SHR**3 + WID2=WIDS(23,1) + ELSE +C...omega_tc0 -> f + fbar. + WID2=1D0 + IF(I.LE.18) THEN + IA=I-10 + FCOF=3D0*RADC + IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1) + ELSE + IA=I-8 + FCOF=1D0 + IF(IA.GE.17) WID2=WIDS(IA,1) + ENDIF + EI=KCHG(IA,1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=-0.5D0*(VI+AI) + VARI=-0.5D0*(VI-AI) + WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)* + & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+ + & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*( + & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2)) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 390 CONTINUE + +C.....V8 -> quark anti-quark + ELSEIF(KFLA.EQ.KTECHN+100021) THEN + FAC=AS/6D0*SHR + TANT3=RTCM(21) + IF(ITCM(2).EQ.0) THEN + IMDL=1 + ELSEIF(ITCM(2).EQ.1) THEN + IMDL=2 + ENDIF + DO 400 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 400 + PM1=PMAS(PYCOMP(KFDP(IDC,1)),1) + RM1=PM1**2/SH + IF(RM1.GT.0.25D0) GOTO 400 + WID2=1D0 + IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN + FMIX=1D0/TANT3**2 + ELSE + FMIX=TANT3**2 + ENDIF + WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX + IF(I.EQ.6) WID2=WIDS(6,1) + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 400 CONTINUE + + ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN + FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR + CLEBF=0D0 + DO 410 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 410 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410 + WID2=1D0 +C...pi_tc -> g + g + IF(I.EQ.7) THEN + IF(KFLA.EQ.KTECHN+100111) THEN + CLEBG=4D0/3D0 + ELSE + CLEBG=5D0/3D0 + ENDIF + FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2 + & /(2D0*PARU(1))*SH*SHR*CLEBG + WDTP(I)=FACP + ELSE +C...pi_tc -> f + fbar. + IF(I.EQ.6) WID2=WIDS(6,1) + FCOF=1D0 + IKA=IABS(KFDP(IDC,1)) + IF(IKA.LT.10) FCOF=3D0*RADC + HM1=PYMRUN(KFDP(IDC,1),SH) + WDTP(I)=FAC*FCOF*HM1**2*CLEBF* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 410 CONTINUE + + ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN + FAC=AS/6D0*SHR + ALPRHT=2.16D0*(3D0/ITCM(1)) + TANT3=RTCM(21) + SIN2T=2D0*TANT3/(TANT3**2+1D0) + SINT3=TANT3/SQRT(TANT3**2+1D0) + CSXPP=RTCM(22) + RM82=RTCM(27)**2 + X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+ + & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0) + X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+ + & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0) + X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)- + & SINT3**2)*2D0 + X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)- + & SINT3**2)*2D0 + CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP) + + IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR + GMV8=SHR*WDTPP(0) + RMV8=PMAS(PYCOMP(KTECHN+100021),1) + FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2) + FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2) + IF(ITCM(2).EQ.0) THEN + IMDL=1 + ELSE + IMDL=2 + ENDIF + DO 420 I=1,MDCY(KC,3) + IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR. + & KFLA.EQ.KTECHN+300113)) GOTO 420 + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 420 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420 + WID2=1D0 + IF(I.LE.6) THEN + IF(I.EQ.6) WID2=WIDS(6,1) + XIG=1D0 + IF(KFLA.EQ.KTECHN+200113) THEN + XIG=0D0 + XIJ=X12 + ELSEIF(KFLA.EQ.KTECHN+300113) THEN + XIG=0D0 + XIJ=X21 + ELSEIF(KFLA.EQ.KTECHN+100113) THEN + XIJ=X11 + ELSE + XIJ=X22 + ENDIF + IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN + FMIX=1D0/TANT3/SIN2T + ELSE + FMIX=-TANT3/SIN2T + ENDIF + XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2 + WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC + ELSEIF(I.EQ.7) THEN + WDTP(I)=SHR*AS**2/(4D0*ALPRHT) + ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN + PSH=SHR*(1D0-RM1)/2D0 + WDTP(I)=AS/9D0*PSH**3/RM82 + IF(I.EQ.8) THEN + WDTP(I)=2D0*WDTP(I)*CSXPP**2 + WID2=WIDS(PYCOMP(KFDP(IDC,1)),2) + ELSE + WDTP(I)=5D0*WDTP(I) + WID2=WIDS(PYCOMP(KFDP(IDC,1)),2) + ENDIF + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 420 CONTINUE + + ELSEIF(KFLA.EQ.KEXCIT+1) THEN +C...d* excited quark. + FAC=(SH/RTCM(41)**2)*SHR + DO 430 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 430 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430 + WID2=1D0 + IF(I.EQ.1) THEN +C...d* -> g + d. + WDTP(I)=FAC*AS*RTCM(45)**2/3D0 + WID2=1D0 + ELSEIF(I.EQ.2) THEN +C...d* -> gamma + d. + QF=-RTCM(43)/2D0+RTCM(44)/6D0 + WDTP(I)=FAC*AEM*QF**2/4D0 + WID2=1D0 + ELSEIF(I.EQ.3) THEN +C...d* -> Z0 + d. + QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0 + WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)* + & (1D0-RM1)**2*(2D0+RM1) + WID2=WIDS(23,2) + ELSEIF(I.EQ.4) THEN +C...d* -> W- + u. + WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)* + & (1D0-RM1)**2*(2D0+RM1) + IF(KFLR.GT.0) WID2=WIDS(24,3) + IF(KFLR.LT.0) WID2=WIDS(24,2) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 430 CONTINUE + + ELSEIF(KFLA.EQ.KEXCIT+2) THEN +C...u* excited quark. + FAC=(SH/RTCM(41)**2)*SHR + DO 440 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 440 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440 + WID2=1D0 + IF(I.EQ.1) THEN +C...u* -> g + u. + WDTP(I)=FAC*AS*RTCM(45)**2/3D0 + WID2=1D0 + ELSEIF(I.EQ.2) THEN +C...u* -> gamma + u. + QF=RTCM(43)/2D0+RTCM(44)/6D0 + WDTP(I)=FAC*AEM*QF**2/4D0 + WID2=1D0 + ELSEIF(I.EQ.3) THEN +C...u* -> Z0 + u. + QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0 + WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)* + & (1D0-RM1)**2*(2D0+RM1) + WID2=WIDS(23,2) + ELSEIF(I.EQ.4) THEN +C...u* -> W+ + d. + WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)* + & (1D0-RM1)**2*(2D0+RM1) + IF(KFLR.GT.0) WID2=WIDS(24,2) + IF(KFLR.LT.0) WID2=WIDS(24,3) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 440 CONTINUE + + ELSEIF(KFLA.EQ.KEXCIT+11) THEN +C...e* excited lepton. + FAC=(SH/RTCM(41)**2)*SHR + DO 450 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 450 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450 + WID2=1D0 + IF(I.EQ.1) THEN +C...e* -> gamma + e. + QF=-RTCM(43)/2D0-RTCM(44)/2D0 + WDTP(I)=FAC*AEM*QF**2/4D0 + WID2=1D0 + ELSEIF(I.EQ.2) THEN +C...e* -> Z0 + e. + QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0 + WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)* + & (1D0-RM1)**2*(2D0+RM1) + WID2=WIDS(23,2) + ELSEIF(I.EQ.3) THEN +C...e* -> W- + nu. + WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)* + & (1D0-RM1)**2*(2D0+RM1) + IF(KFLR.GT.0) WID2=WIDS(24,3) + IF(KFLR.LT.0) WID2=WIDS(24,2) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 450 CONTINUE + + ELSEIF(KFLA.EQ.KEXCIT+12) THEN +C...nu*_e excited neutrino. + FAC=(SH/RTCM(41)**2)*SHR + DO 460 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 460 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460 + WID2=1D0 + IF(I.EQ.1) THEN +C...nu*_e -> Z0 + nu*_e. + QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0 + WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)* + & (1D0-RM1)**2*(2D0+RM1) + WID2=WIDS(23,2) + ELSEIF(I.EQ.2) THEN +C...nu*_e -> W+ + e. + WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)* + & (1D0-RM1)**2*(2D0+RM1) + IF(KFLR.GT.0) WID2=WIDS(24,2) + IF(KFLR.LT.0) WID2=WIDS(24,3) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 460 CONTINUE + + ELSEIF(KFLA.EQ.KDIMEN+39) THEN +C...G* (graviton resonance): + FAC=(PARP(50)**2/PARU(1))*SHR + DO 470 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 470 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470 + WID2=1D0 + IF(I.LE.8) THEN +C...G* -> q + qbar + FCOF=3D0*RADC + IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF* + & PYHFTH(SH,SH*RM1,1D0) + WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3* + & (1D0+8D0*RM1/3D0)/320D0 + IF(I.EQ.6) WID2=WIDS(6,1) + IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1) + ELSEIF(I.LE.16) THEN +C...G* -> l+ + l-, nu + nubar + FCOF=1D0 + WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3* + & (1D0+8D0*RM1/3D0)/320D0 + IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1) + ELSEIF(I.EQ.17) THEN +C...G* -> g + g. + WDTP(I)=FAC/20D0 + ELSEIF(I.EQ.18) THEN +C...G* -> gamma + gamma. + WDTP(I)=FAC/160D0 + ELSEIF(I.EQ.19) THEN +C...G* -> Z0 + Z0. + WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+ + & 14D0*RM1/3D0+4D0*RM1**2)/160D0 + WID2=WIDS(23,1) + ELSEIF(I.EQ.20) THEN +C...G* -> W+ + W-. + WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+ + & 14D0*RM1/3D0+4D0*RM1**2)/80D0 + WID2=WIDS(24,1) + ENDIF + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 470 CONTINUE + + ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN +C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos. + PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1)) + FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4 + DO 480 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 480 + PM1=PMAS(PYCOMP(KFDP(IDC,1)),1) + PM2=PMAS(PYCOMP(KFDP(IDC,2)),1) + PM3=PMAS(PYCOMP(KFDP(IDC,3)),1) + IF(PM1+PM2+PM3.GE.SHR) GOTO 480 + WID2=1D0 + IF(I.LE.9) THEN +C...nu_lR -> l- qbar q' + FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1) + IF(MOD(I,3).EQ.0) WID2=WIDS(6,2) + ELSEIF(I.LE.18) THEN +C...nu_lR -> l+ q qbar' + FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1) + IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3) + ELSE +C...nu_lR -> l- l'+ nu_lR' + charge conjugate. + FCOF=1D0 + WID2=WIDS(PYCOMP(KFDP(IDC,3)),2) + ENDIF + X=(PM1+PM2+PM3)/SHR + FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X) + Y=(SHR/PMWR)**2 + FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4 + WDTP(I)=FAC*FCOF*FX*FY + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 480 CONTINUE + + ELSEIF(KFLA.EQ.9900023) THEN +C...Z_R0: + FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR + DO 490 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 490 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490 + WID2=1D0 + SYMMET=1D0 + IF(I.LE.6) THEN +C...Z_R0 -> q + qbar + EF=KCHG(I,1)/3D0 + AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW) + VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW + FCOF=3D0*RADC + IF(I.EQ.6) WID2=WIDS(6,1) + ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN +C...Z_R0 -> l+ + l- + AF=-(1D0-2D0*XW) + VF=-1D0+4D0*XW + FCOF=1D0 + ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN +C...Z0 -> nu_L + nu_Lbar, assumed Majorana. + AF=-2D0*XW + VF=0D0 + FCOF=1D0 + SYMMET=0.5D0 + ELSEIF(I.LE.15) THEN +C...Z0 -> nu_R + nu_R, assumed Majorana. + AF=2D0*XW1 + VF=0D0 + FCOF=1D0 + WID2=WIDS(PYCOMP(KFDP(IDC,1)),1) + SYMMET=0.5D0 + ENDIF + WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))* + & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 490 CONTINUE + + ELSEIF(KFLA.EQ.9900024) THEN +C...W_R+/-: + FAC=(AEM/(24D0*XW))*SHR + DO 500 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 500 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500 + WID2=1D0 + IF(I.LE.9) THEN +C...W_R+/- -> q + qbar' + FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1) + IF(KFLR.GT.0) THEN + IF(MOD(I,3).EQ.0) WID2=WIDS(6,2) + ELSE + IF(MOD(I,3).EQ.0) WID2=WIDS(6,3) + ENDIF + ELSEIF(I.LE.12) THEN +C...W_R+/- -> l+/- + nu_R + FCOF=1D0 + ENDIF + WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 500 CONTINUE + + ELSEIF(KFLA.EQ.9900041) THEN +C...H_L++/--: + FAC=(1D0/(8D0*PARU(1)))*SHR + DO 510 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 510 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510 + WID2=1D0 + IF(I.LE.6) THEN +C...H_L++/-- -> l+/- + l'+/- + FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+ + & (IABS(KFDP(IDC,2))-9)/2)**2 + IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF + ELSEIF(I.EQ.7) THEN +C...H_L++/-- -> W_L+/- + W_L+/- + FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2* + & (3D0*RM1+0.25D0/RM1-1D0) + WID2=WIDS(24,4+(1-KFLS)/2) + ENDIF + WDTP(I)=FAC*FCOF* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 510 CONTINUE + + ELSEIF(KFLA.EQ.9900042) THEN +C...H_R++/--: + FAC=(1D0/(8D0*PARU(1)))*SHR + DO 520 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 520 + RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520 + WID2=1D0 + IF(I.LE.6) THEN +C...H_R++/-- -> l+/- + l'+/- + FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+ + & (IABS(KFDP(IDC,2))-9)/2)**2 + IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF + ELSEIF(I.EQ.7) THEN +C...H_R++/-- -> W_R+/- + W_R+/- + FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0) + WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2) + ENDIF + WDTP(I)=FAC*FCOF* + & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + WDTP(I)=FUDGE*WDTP(I) + WDTP(0)=WDTP(0)+WDTP(I) + IF(MDME(IDC,1).GT.0) THEN + WDTE(I,MDME(IDC,1))=WDTP(I)*WID2 + WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1)) + WDTE(I,0)=WDTE(I,MDME(IDC,1)) + WDTE(0,0)=WDTE(0,0)+WDTE(I,0) + ENDIF + 520 CONTINUE + + ELSEIF(KFLA.EQ.KTECHN+115) THEN +C...Techni-a2: +C...Need to update to alpha_rho + ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2 + 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/(4D0*XW*(1D0-XW)) + BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) + BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) + DO 530 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 530 + 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 530 + WID2=1D0 + PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + IF(I.LE.4) THEN + FACPV=PCM**2 + FACPA=PCM**2+1.5D0*RM1 + VA2=0D0 + AA2=0D0 +C...a2_tc0 -> W+ + W- + IF(I.EQ.1) THEN + AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2 +C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL) + WID2=WIDS(24,1) +C...a2_tc0 -> W+ + pi_tc- + c.c. + ELSEIF(I.EQ.2.OR.I.EQ.3) THEN + AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2 + IF(I.EQ.6) THEN + WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3) + ELSE + WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2) + ENDIF + ELSEIF(I.EQ.4) THEN +C...a2_tc0 -> Z0 + pi_tc0' + VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2) + ENDIF + WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA) + ELSEIF(I.GE.5.AND.I.LE.10) THEN + FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2 + FACPA=PCM**2*(1D0+RM1+RM2) + VA2=0D0 + AA2=0D0 + IF(I.EQ.5) THEN +C...a_T^0 -> gamma rho_T^0 + VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4 + WID2=WIDS(PYCOMP(KTECHN+113),2) + ELSEIF(I.EQ.6) THEN +C...a_T^0 -> gamma omega_T + VA2=1D0/RTCM(50)**4 + WID2=WIDS(PYCOMP(KTECHN+223),2) + ELSEIF(I.EQ.7.OR.I.EQ.8) THEN +C...a_T^0 -> W^+- rho_T^-+ + AA2=.25D0/XW/RTCM(51)**4 + IF(I.EQ.7) THEN + WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3) + ELSE + WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2) + ENDIF + ELSEIF(I.EQ.9) THEN +C...a_T^0 -> Z^0 rho_T^0 + VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2) + ELSEIF(I.EQ.10) THEN +C...a_T^0 -> Z^0 omega_T + VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2) + ENDIF + WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA) + ELSE +C...a2_tc0 -> f + fbar. + WID2=1D0 + IF(I.LE.18) THEN + IA=I-10 + FCOF=3D0*RADC + IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1) + ELSE + IA=I-8 + 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)* + & ((VALI*BWZR)**2+(VALI*BWZI)**2+ + & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*( + & (VALI*BWZR)*(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 + 530 CONTINUE + + ELSEIF(KFLA.EQ.KTECHN+215) THEN +C...Techni-a2+/-: + ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2 + 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 540 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 540 + 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 540 + WID2=1D0 + PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + IF(KFLR.GT.0) THEN + ICHANN=2 + ELSE + ICHANN=3 + ENDIF + IF(I.LE.7) THEN + AA2=0 + VA2=0 +C...a2_tc+ -> gamma + W+. + IF(I.EQ.1) THEN + AA2=RTCM(3)**2/RTCM(49)**2 + WID2=WIDS(24,ICHANN) +C...a2_tc+ -> gamma + pi_tc+. + ELSEIF(I.EQ.2) THEN + AA2=(1D0-RTCM(3)**2)/RTCM(49)**2 + WID2=WIDS(PYCOMP(KTECHN+211),ICHANN) +C...a2_tc+ -> W+ + Z + ELSEIF(I.EQ.3) THEN + AA2=RTCM(3)**2*(1D0/4D0/XW1 + + & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2 + WID2=WIDS(24,ICHANN)*WIDS(23,2) +C...a2_tc+ -> W+ + pi_tc0. + ELSEIF(I.EQ.4) THEN + AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2 + WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2) +C...a2_tc+ -> W+ + pi_tc'0. + ELSEIF(I.EQ.5) THEN + VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2 + WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2) +C...a2_tc+ -> Z0 + pi_tc+. + ELSEIF(I.EQ.6) THEN + AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/ + & RTCM(49)**2 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN) + ENDIF + WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2) + & /3D0*SHR**3 + ELSEIF(I.LE.10) THEN + FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2 + FACPA=PCM**2*(1D0+RM1+RM2) + VA2=0D0 + AA2=0D0 +C...a2_tc+ -> gamma + rho_tc+ + IF(I.EQ.7) THEN + VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4 + WID2=WIDS(PYCOMP(KTECHN+213),ICHANN) +C...a2_tc+ -> W+ + rho_T^0 + ELSEIF(I.EQ.8) THEN + AA2=1D0/(4D0*XW)/RTCM(51)**4 + WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2) +C...a2_tc+ -> W+ + omega_T + ELSEIF(I.EQ.9) THEN + VA2=.25D0/XW/RTCM(50)**4 + WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2) +C...a2_tc+ -> Z^0 + rho_T^+ + ELSEIF(I.EQ.10) THEN + VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4 + AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4 + WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN) + ENDIF + WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA) + ELSE +C...a2_tc+ -> f + fbar'. + IA=I-10 + 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 + 540 CONTINUE + + ENDIF + MINT(61)=0 + MINT(62)=0 + MINT(63)=0 + RETURN + END + +C*********************************************************************** + +C...PYOFSH +C...Calculates partial width and differential cross-section maxima +C...of channels/processes not allowed on mass-shell, and selects +C...masses in such channels/processes. + + SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT2/,/PYINT5/ +C...Local arrays. + DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2), + &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100), + &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400), + &WDTE(0:400,0:5) + +C...Find if particles equal, maximum mass, matrix elements, etc. + MINT(51)=0 + ISUB=MINT(1) + KFD(1)=IABS(KFD1) + KFD(2)=IABS(KFD2) + MEQL=0 + IF(KFD(1).EQ.KFD(2)) MEQL=1 + MLM=0 + IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0)) + IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN + NOFF=44 + PMMX=PMMO + ELSE + NOFF=40 + PMMX=VINT(1) + IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1)) + ENDIF + MMED=0 + IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND. + &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1 + IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR. + &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2 + IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR. + &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3 + LOOP=1 + +C...Find where Breit-Wigners are required, else select discrete masses. + 100 DO 110 I=1,2 + KFCA=PYCOMP(KFD(I)) + IF(KFCA.GT.0) THEN + PMD(I)=PMAS(KFCA,1) + PGD(I)=PMAS(KFCA,2) + ELSE + PMD(I)=0D0 + PGD(I)=0D0 + ENDIF + IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN + MBW(I)=0 + PMG(I)=PMD(I) + RMG(I)=(PMG(I)/PMMX)**2 + ELSE + MBW(I)=1 + ENDIF + 110 CONTINUE + +C...Find allowed mass range and Breit-Wigner parameters. + DO 120 I=1,2 + IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN + PML(I)=PARP(42) + PMU(I)=PMMX-PARP(42) + IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I)) + IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1 + ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN + ILM=I + IF(MLM.EQ.2) ILM=3-I + PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42)) + IF(MBW(3-I).EQ.0) THEN + PMU(I)=PMMX-PMD(3-I) + ELSE + PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42)) + ENDIF + IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)= + & MIN(PMU(I),CKIN(NOFF+2*ILM)) + IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX) + IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX) + IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1 + IF(MBW(I).EQ.1) THEN + ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I))) + ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I))) + IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)* + & PGD(I))) + ENDIF + ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN + ILM=I + IF(MLM.EQ.2) ILM=3-I + PML(I)=MAX(CKIN(48+I),PARP(42)) + PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42)) + IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I)) + IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX) + IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX) + IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1 + IF(MBW(I).EQ.1) THEN + ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I))) + ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I))) + IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)* + & PGD(I))) + ENDIF + ENDIF + 120 CONTINUE + IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0)) + &THEN + CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses') + MINT(51)=1 + RETURN + ENDIF + +C...Calculation of partial width of resonance. + IF(MOFSH.EQ.1) THEN + +C..If only one integration, pick that to be the inner. + IF(MBW(1).EQ.0) THEN + PM2=PMD(1) + PMD(1)=PMD(2) + PGD(1)=PGD(2) + PML(1)=PML(2) + PMU(1)=PMU(2) + ELSEIF(MBW(2).EQ.0) THEN + PM2=PMD(2) + ENDIF + +C...Start outer loop of integration. + IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN + ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2))) + ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2))) + NPT2=1 + XPT2(1)=1D0 + INX2(1)=0 + FMAX2=0D0 + ENDIF + 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN + PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2)) + PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S)))) + ENDIF + RM2=(PM2/PMMX)**2 + +C...Start inner loop of integration. + PML1=PML(1) + PMU1=MIN(PMU(1),PMMX-PM2) + IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2) + ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1))) + ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1))) + IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN + FUNC2=0D0 + GOTO 180 + ENDIF + NPT1=1 + XPT1(1)=1D0 + INX1(1)=0 + FMAX1=0D0 + 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1)) + PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S)))) + RM1=(PM1/PMMX)**2 + +C...Evaluate function value - inner loop. + FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2) + IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+ + & RM2**2+10D0*RM1*RM2) + IF(FUNC1.GT.FMAX1) FMAX1=FUNC1 + FPT1(NPT1)=FUNC1 + +C...Go to next position in inner loop. + IF(NPT1.EQ.1) THEN + NPT1=NPT1+1 + XPT1(NPT1)=0D0 + INX1(NPT1)=1 + GOTO 140 + ELSEIF(NPT1.LE.8) THEN + NPT1=NPT1+1 + IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1 + ISH1=ISH1+1 + XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1))) + INX1(NPT1)=INX1(ISH1) + INX1(ISH1)=NPT1 + GOTO 140 + ELSEIF(NPT1.LT.100) THEN + ISN1=ISH1 + 150 ISH1=ISH1+1 + IF(ISH1.GT.NPT1) ISH1=2 + IF(ISH1.EQ.ISN1) GOTO 160 + DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1))) + IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150 + NPT1=NPT1+1 + XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1))) + INX1(NPT1)=INX1(ISH1) + INX1(ISH1)=NPT1 + GOTO 140 + ENDIF + +C...Calculate integral over inner loop. + 160 FSUM1=0D0 + DO 170 IPT1=2,NPT1 + FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))* + & (XPT1(INX1(IPT1))-XPT1(IPT1)) + 170 CONTINUE + FUNC2=FSUM1*(ATU1-ATL1)/PARU(1) + 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN + IF(FUNC2.GT.FMAX2) FMAX2=FUNC2 + FPT2(NPT2)=FUNC2 + +C...Go to next position in outer loop. + IF(NPT2.EQ.1) THEN + NPT2=NPT2+1 + XPT2(NPT2)=0D0 + INX2(NPT2)=1 + GOTO 130 + ELSEIF(NPT2.LE.8) THEN + NPT2=NPT2+1 + IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1 + ISH2=ISH2+1 + XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2))) + INX2(NPT2)=INX2(ISH2) + INX2(ISH2)=NPT2 + GOTO 130 + ELSEIF(NPT2.LT.100) THEN + ISN2=ISH2 + 190 ISH2=ISH2+1 + IF(ISH2.GT.NPT2) ISH2=2 + IF(ISH2.EQ.ISN2) GOTO 200 + DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2))) + IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190 + NPT2=NPT2+1 + XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2))) + INX2(NPT2)=INX2(ISH2) + INX2(ISH2)=NPT2 + GOTO 130 + ENDIF + +C...Calculate integral over outer loop. + 200 FSUM2=0D0 + DO 210 IPT2=2,NPT2 + FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))* + & (XPT2(INX2(IPT2))-XPT2(IPT2)) + 210 CONTINUE + FSUM2=FSUM2*(ATU2-ATL2)/PARU(1) + IF(MEQL.EQ.1) FSUM2=2D0*FSUM2 + ELSE + FSUM2=FUNC2 + ENDIF + +C...Save result; second integration for user-selected mass range. + IF(LOOP.EQ.1) WIDW=FSUM2 + WID2=FSUM2 + IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47) + & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN + LOOP=2 + GOTO 100 + ENDIF + RET1=WIDW + RET2=WID2/WIDW + +C...Select two decay product masses of a resonance. + ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN + 220 DO 230 I=1,2 + IF(MBW(I).EQ.0) GOTO 230 + PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)* + & (ATU(I)-ATL(I))) + PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW)))) + RMG(I)=(PMG(I)/PMMX)**2 + 230 CONTINUE + IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR. + & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220 + +C...Weight with matrix element (if none known, use beta factor). + FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2))) + IF(MMED.EQ.1) THEN + WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2)) + ELSEIF(MMED.EQ.2) THEN + WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+ + & RMG(2)**2+10D0*RMG(1)*RMG(2)) + ELSEIF(MMED.EQ.3) THEN + WTBE=FLAM*(RMG(1)+FLAM**2/12D0) + ELSE + WTBE=FLAM + ENDIF + IF(WTBE.LT.PYR(0)) GOTO 220 + RET1=PMG(1) + RET2=PMG(2) + +C...Find suitable set of masses for initialization of 2 -> 2 processes. + ELSEIF(MOFSH.EQ.3) THEN + IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN + PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1))) + PMG(2)=PMD(2) + ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN + PMG(1)=PMD(1) + PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2))) + ELSE + IDIV=-1 + 240 IDIV=IDIV+1 + PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1))) + PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2))) + IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240 + ENDIF + RET1=PMG(1) + RET2=PMG(2) + +C...Evaluate importance of excluded tails of Breit-Wigners. + IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2) + & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2 + IF(MEQL.LE.1) THEN + VINT(80)=1D0 + DO 250 I=1,2 + IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/ + & PARU(1) + 250 CONTINUE + ELSE + VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))* + & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2))) + ENDIF + IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND. + & MSTP(43).NE.2) VINT(80)=2D0*VINT(80) + IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80) + IF(MEQL.GE.1) VINT(80)=2D0*VINT(80) + +C...Pick one particle to be the lighter (if improves efficiency). + ELSEIF(MOFSH.EQ.4) THEN + IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2) + & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2 + 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0)) + +C...Select two masses according to Breit-Wigner + flat in s + 1/s. + DO 270 I=1,2 + IF(MBW(I).EQ.0) GOTO 270 + PMV=PMU(I) + IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I) + ATV=ATU(I) + IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I) + RBR=PYR(0) + IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR. + & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR + IF(RBR.LT.0.8D0) THEN + PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I))) + PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR)))) + ELSEIF(RBR.LT.0.9D0) THEN + PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2))) + ELSEIF(RBR.LT.1.5D0) THEN + PMG(I)=PML(I)*(PMV/PML(I))**PYR(0) + ELSE + PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)* + & (PMV**2-PML(I)**2)))) + ENDIF + 270 CONTINUE + IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR. + & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN + IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN + NGEN(0,1)=NGEN(0,1)+1 + NGEN(MINT(1),1)=NGEN(MINT(1),1)+1 + GOTO 260 + ELSE + MINT(51)=1 + RETURN + ENDIF + ENDIF + RET1=PMG(1) + RET2=PMG(2) + +C...Give weight for selected mass distribution. + VINT(80)=1D0 + DO 280 I=1,2 + IF(MBW(I).EQ.0) GOTO 280 + PMV=PMU(I) + IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I) + ATV=ATU(I) + IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I) + F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+ + & (PMD(I)*PGD(I))**2)/PARU(1) + F1=1D0 + F2=1D0/PMG(I)**2 + F3=1D0/PMG(I)**4 + FI0=(ATV-ATL(I))/PARU(1) + FI1=PMV**2-PML(I)**2 + FI2=2D0*LOG(PMV/PML(I)) + FI3=1D0/PML(I)**2-1D0/PMV**2 + IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR. + & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN + VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+ + & 5D0*F3/FI3)) + ELSE + VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2)) + ENDIF + VINT(80)=VINT(80)*FI0 + 280 CONTINUE + IF(MEQL.GE.1) VINT(80)=2D0*VINT(80) + ENDIF + + RETURN + END + +C*********************************************************************** + +C...PYRECO +C...Handles the possibility of colour reconnection in W+W- events, +C...Based on the main scenarios of the Sjostrand and Khoze study: +C...I, II, II', intermediate and instantaneous; plus one model +C...along the lines of the Gustafson and Hakkinen: GH. +C...Note: also handles Z0 Z0 and W-W+ events, but notation below +C...is as if first resonance is W+ and second W-. + + SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter value; number of points in MC integration. + PARAMETER (NPT=100) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ +C...Local arrays. + DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3), + &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3), + &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3), + &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20), + &TMC(20),IJOIN(100) + +C...Functions to give four-product and to do determinants. + FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) + DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+ + &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+ + &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3) + +C...Only allow fraction of recoupling for GH, intermediate and +C...instantaneous. + IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN + IF(PYR(0).GT.PARP(120)) RETURN + ENDIF + ISUB=MINT(1) + +C...Common part for scenarios I, II, II', and GH. + IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR. + &MSTP(115).EQ.5) THEN + +C...Read out frequently-used parameters. + PI=PARU(1) + HBAR=PARU(3) + PMW=PMAS(24,1) + IF(ISUB.EQ.22) PMW=PMAS(23,1) + PGW=PMAS(24,2) + IF(ISUB.EQ.22) PGW=PMAS(23,2) + TFRAG=PARP(115) + RHAD=PARP(116) + FACT=PARP(117) + BLOWR=PARP(118) + BLOWT=PARP(119) + +C...Find range of decay products of the W's. +C...Background: the W's are stored in IW1 and IW2. +C...Their direct decay products in NSD1+1 through NSD1+4. +C...Products after shower (if any) in NSD1+5 through NAFT1 +C...for first W and in NAFT1+1 through N for the second. + IF(NAFT1.GT.NSD1+4) THEN + NBEG(1)=NSD1+5 + NEND(1)=NAFT1 + ELSE + NBEG(1)=NSD1+1 + NEND(1)=NSD1+2 + ENDIF + IF(N.GT.NAFT1) THEN + NBEG(2)=NAFT1+1 + NEND(2)=N + ELSE + NBEG(2)=NSD1+3 + NEND(2)=NSD1+4 + ENDIF + +C...Rearrange parton shower products along strings. + NOLD=N + CALL PYPREP(NSD1+1) + IF(MINT(51).NE.0) RETURN + +C...Find partons pointing back to W+ and W-; store them with quark +C...end of string first. + NNP=0 + NNM=0 + ISGP=0 + ISGM=0 + DO 120 I=NOLD+1,N + IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120 + IF(IABS(K(I,2)).GE.22) GOTO 120 + IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN + IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2)) + NNP=NNP+1 + IF(ISGP.EQ.1) THEN + INP(NNP)=I + ELSE + DO 100 I1=NNP,2,-1 + INP(I1)=INP(I1-1) + 100 CONTINUE + INP(1)=I + ENDIF + IF(K(I,1).EQ.1) ISGP=0 + ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN + IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2)) + NNM=NNM+1 + IF(ISGM.EQ.1) THEN + INM(NNM)=I + ELSE + DO 110 I1=NNM,2,-1 + INM(I1)=INM(I1-1) + 110 CONTINUE + INM(1)=I + ENDIF + IF(K(I,1).EQ.1) ISGM=0 + ENDIF + 120 CONTINUE + +C...Boost to W+W- rest frame (not strictly needed). + DO 130 J=1,3 + BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4)) + 130 CONTINUE + CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3)) + CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3)) + CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3)) + +C...Select decay vertices of W+ and W-. + TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/ + & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2) + TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/ + & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2) + GTMAX=MAX(TP,TM) + DO 140 J=1,3 + XP(J)=TP*P(IW1,J)/P(IW1,4) + XM(J)=TM*P(IW2,J)/P(IW2,4) + 140 CONTINUE + +C...Begin scenario I specifics. + IF(MSTP(115).EQ.1) THEN + +C...Reconstruct velocity and direction of W+ string pieces. + DO 170 IIP=1,NNP-1 + IF(K(INP(IIP),2).LT.0) GOTO 170 + I1=INP(IIP) + I2=INP(IIP+1) + P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2) + P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2) + DO 150 J=1,3 + V1(J)=P(I1,J)/P1A + V2(J)=P(I2,J)/P2A + BETP(IIP,J)=0.5D0*(V1(J)+V2(J)) + DIRP(IIP,J)=V1(J)-V2(J) + 150 CONTINUE + BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2- + & BETP(IIP,3)**2) + DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2) + DO 160 J=1,3 + DIRP(IIP,J)=DIRP(IIP,J)/DIRL + 160 CONTINUE + 170 CONTINUE + +C...Reconstruct velocity and direction of W- string pieces. + DO 200 IIM=1,NNM-1 + IF(K(INM(IIM),2).LT.0) GOTO 200 + I1=INM(IIM) + I2=INM(IIM+1) + P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2) + P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2) + DO 180 J=1,3 + V1(J)=P(I1,J)/P1A + V2(J)=P(I2,J)/P2A + BETM(IIM,J)=0.5D0*(V1(J)+V2(J)) + DIRM(IIM,J)=V1(J)-V2(J) + 180 CONTINUE + BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2- + & BETM(IIM,3)**2) + DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2) + DO 190 J=1,3 + DIRM(IIM,J)=DIRM(IIM,J)/DIRL + 190 CONTINUE + 200 CONTINUE + +C...Loop over number of space-time points. + NACC=0 + SUM=0D0 + DO 250 IPT=1,NPT + +C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively). + R=SQRT(-LOG(PYR(0))) + PHI=2D0*PI*PYR(0) + X=BLOWR*RHAD*R*COS(PHI) + Y=BLOWR*RHAD*R*SIN(PHI) + R=SQRT(-LOG(PYR(0))) + PHI=2D0*PI*PYR(0) + Z=BLOWR*RHAD*R*COS(PHI) + T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI)) + +C...Reject impossible points. Weight for sample distribution. + IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250 + WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)* + & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2) + +C...Loop over W+ string pieces and find one with largest weight. + IMAXP=0 + WTMAXP=1D-10 + XD(1)=X-XP(1) + XD(2)=Y-XP(2) + XD(3)=Z-XP(3) + XD(4)=T-TP + DO 220 IIP=1,NNP-1 + IF(K(INP(IIP),2).LT.0) GOTO 220 + BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3) + BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4)) + DO 210 J=1,3 + XB(J)=XD(J)+BEDG*BETP(IIP,J) + 210 CONTINUE + XB(4)=BETP(IIP,4)*(XD(4)-BED) + SR2=XB(1)**2+XB(2)**2+XB(3)**2 + SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+ + & DIRP(IIP,3)*XB(3))**2 + WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/ + & TFRAG**2) + IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0 + IF(WTP.GT.WTMAXP) THEN + IMAXP=IIP + WTMAXP=WTP + ENDIF + 220 CONTINUE + +C...Loop over W- string pieces and find one with largest weight. + IMAXM=0 + WTMAXM=1D-10 + XD(1)=X-XM(1) + XD(2)=Y-XM(2) + XD(3)=Z-XM(3) + XD(4)=T-TM + DO 240 IIM=1,NNM-1 + IF(K(INM(IIM),2).LT.0) GOTO 240 + BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3) + BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4)) + DO 230 J=1,3 + XB(J)=XD(J)+BEDG*BETM(IIM,J) + 230 CONTINUE + XB(4)=BETM(IIM,4)*(XD(4)-BED) + SR2=XB(1)**2+XB(2)**2+XB(3)**2 + SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+ + & DIRM(IIM,3)*XB(3))**2 + WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/ + & TFRAG**2) + IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0 + IF(WTM.GT.WTMAXM) THEN + IMAXM=IIM + WTMAXM=WTM + ENDIF + 240 CONTINUE + +C...Result of integration. + WT=0D0 + IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN + WT=WTMAXP*WTMAXM/WTSMP + SUM=SUM+WT + NACC=NACC+1 + IAP(NACC)=IMAXP + IAM(NACC)=IMAXM + WTA(NACC)=WT + ENDIF + 250 CONTINUE + RES=BLOWR**3*BLOWT*SUM/NPT + +C...Decide whether to reconnect and, if so, where. + IACC=0 + PREC=1D0-EXP(-FACT*RES) + IF(PREC.GT.PYR(0)) THEN + RSUM=PYR(0)*SUM + DO 260 IA=1,NACC + IACC=IA + RSUM=RSUM-WTA(IA) + IF(RSUM.LE.0D0) GOTO 270 + 260 CONTINUE + 270 IIP=IAP(IACC) + IIM=IAM(IACC) + ENDIF + +C...Begin scenario II and II' specifics. + ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN + +C...Loop through all string pieces, one from W+ and one from W-. + NCROSS=0 + TC(0)=0D0 + DO 340 IIP=1,NNP-1 + IF(K(INP(IIP),2).LT.0) GOTO 340 + I1P=INP(IIP) + I2P=INP(IIP+1) + DO 330 IIM=1,NNM-1 + IF(K(INM(IIM),2).LT.0) GOTO 330 + I1M=INM(IIM) + I2M=INM(IIM+1) + +C...Find endpoint velocity vectors. + DO 280 J=1,3 + V1P(J)=P(I1P,J)/P(I1P,4) + V2P(J)=P(I2P,J)/P(I2P,4) + V1M(J)=P(I1M,J)/P(I1M,4) + V2M(J)=P(I2M,J)/P(I2M,4) + 280 CONTINUE + +C...Define q matrix and find t. + DO 290 J=1,3 + Q(1,J)=V2P(J)-V1P(J) + Q(2,J)=-(V2M(J)-V1M(J)) + Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J) + Q(4,J)=V1P(J)-V1M(J) + 290 CONTINUE + T=-DETER(1,2,3)/DETER(1,2,4) + +C...Find alpha and beta; i.e. coordinates of crossing point. + S11=Q(1,1)*(T-TP) + S12=Q(2,1)*(T-TM) + S13=Q(3,1)+Q(4,1)*T + S21=Q(1,2)*(T-TP) + S22=Q(2,2)*(T-TM) + S23=Q(3,2)+Q(4,2)*T + DEN=S11*S22-S12*S21 + ALP=(S12*S23-S22*S13)/DEN + BET=(S21*S13-S11*S23)/DEN + +C...Check if solution acceptable. + IANSW=1 + IF(T.LT.GTMAX) IANSW=0 + IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0 + IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0 + +C...Find point of crossing and check that not inconsistent. + DO 300 J=1,3 + XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP) + XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM) + 300 CONTINUE + D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+ + & (XPP(3)-XMM(3))**2 + D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2 + D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2 + IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1 + +C...Find string eigentimes at crossing. + IF(IANSW.EQ.1) THEN + TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2- + & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2)) + TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2- + & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2)) + ELSE + TAUP=0D0 + TAUM=0D0 + ENDIF + +C...Order crossings by time. End loop over crossings. + IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN + NCROSS=NCROSS+1 + DO 310 I1=NCROSS,1,-1 + IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN + IPC(I1)=IIP + IMC(I1)=IIM + TC(I1)=T + TPC(I1)=TAUP + TMC(I1)=TAUM + GOTO 320 + ELSE + IPC(I1)=IPC(I1-1) + IMC(I1)=IMC(I1-1) + TC(I1)=TC(I1-1) + TPC(I1)=TPC(I1-1) + TMC(I1)=TMC(I1-1) + ENDIF + 310 CONTINUE + 320 CONTINUE + ENDIF + 330 CONTINUE + 340 CONTINUE + +C...Loop over crossings; find first (if any) acceptable one. + IACC=0 + IF(NCROSS.GE.1) THEN + DO 350 IC=1,NCROSS + PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2) + IF(PNFRAG.GT.PYR(0)) THEN +C...Scenario II: only compare with fragmentation time. + IF(MSTP(115).EQ.2) THEN + IACC=IC + IIP=IPC(IACC) + IIM=IMC(IACC) + GOTO 360 +C...Scenario II': also require that string length decreases. + ELSE + IIP=IPC(IC) + IIM=IMC(IC) + I1P=INP(IIP) + I2P=INP(IIP+1) + I1M=INM(IIM) + I2M=INM(IIM+1) + ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M) + ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P) + IF(ELNEW.LT.ELOLD) THEN + IACC=IC + IIP=IPC(IACC) + IIM=IMC(IACC) + GOTO 360 + ENDIF + ENDIF + ENDIF + 350 CONTINUE + 360 CONTINUE + ENDIF + +C...Begin scenario GH specifics. + ELSEIF(MSTP(115).EQ.5) THEN + +C...Loop through all string pieces, one from W+ and one from W-. + IACC=0 + ELMIN=1D0 + DO 380 IIP=1,NNP-1 + IF(K(INP(IIP),2).LT.0) GOTO 380 + I1P=INP(IIP) + I2P=INP(IIP+1) + DO 370 IIM=1,NNM-1 + IF(K(INM(IIM),2).LT.0) GOTO 370 + I1M=INM(IIM) + I2M=INM(IIM+1) + +C...Look for largest decrease of (exponent of) Lambda measure. + ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M) + ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P) + ELDIF=ELNEW/MAX(1D-10,ELOLD) + IF(ELDIF.LT.ELMIN) THEN + IACC=IIP+IIM + ELMIN=ELDIF + IPC(1)=IIP + IMC(1)=IIM + ENDIF + 370 CONTINUE + 380 CONTINUE + IIP=IPC(1) + IIM=IMC(1) + ENDIF + +C...Common for scenarios I, II, II' and GH: reconnect strings. + IF(IACC.NE.0) THEN + MINT(32)=1 + NJOIN=0 + DO 390 IS=1,NNP+NNM + NJOIN=NJOIN+1 + IF(IS.LE.IIP) THEN + I=INP(IS) + ELSEIF(IS.LE.IIP+NNM-IIM) THEN + I=INM(IS-IIP+IIM) + ELSEIF(IS.LE.IIP+NNM) THEN + I=INM(IS-IIP-NNM+IIM) + ELSE + I=INP(IS-NNM) + ENDIF + IJOIN(NJOIN)=I + IF(K(I,2).LT.0) THEN + CALL PYJOIN(NJOIN,IJOIN) + NJOIN=0 + ENDIF + 390 CONTINUE + +C...Restore original event record if no reconnection. + ELSE + DO 400 I=NSD1+1,NOLD + IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN + K(I,4)=MOD(K(I,4),MSTU(5)**2) + K(I,5)=MOD(K(I,5),MSTU(5)**2) + ENDIF + 400 CONTINUE + DO 410 I=NOLD+1,N + K(K(I,3),1)=3 + 410 CONTINUE + N=NOLD + ENDIF + +C...Boost back system. + CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3)) + CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3)) + IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0, + & BEWW(1),BEWW(2),BEWW(3)) + +C...Common part for intermediate and instantaneous scenarios. + ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN + MINT(32)=1 + +C...Remove old shower products and reset showering ones. + N=NSD1+4 + DO 420 I=NSD1+1,NSD1+4 + K(I,1)=3 + K(I,4)=MOD(K(I,4),MSTU(5)**2) + K(I,5)=MOD(K(I,5),MSTU(5)**2) + 420 CONTINUE + +C...Identify quark-antiquark pairs. + IQ1=NSD1+1 + IQ2=NSD1+2 + IQ3=NSD1+3 + IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4 + IQ4=2*NSD1+7-IQ3 + +C...Reconnect strings. + IJOIN(1)=IQ1 + IJOIN(2)=IQ4 + CALL PYJOIN(2,IJOIN) + IJOIN(1)=IQ3 + IJOIN(2)=IQ2 + CALL PYJOIN(2,IJOIN) + +C...Do new parton showers in intermediate scenario. + IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN + MSTJ50=MSTJ(50) + MSTJ(50)=0 + CALL PYSHOW(IQ1,IQ2,P(IW1,5)) + CALL PYSHOW(IQ3,IQ4,P(IW2,5)) + MSTJ(50)=MSTJ50 + +C...Do new parton showers in instantaneous scenario. + ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN + PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2- + & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2 + PPM=SQRT(MAX(0D0,PPM2)) + CALL PYSHOW(IQ1,IQ4,PPM) + PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2- + & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2 + PPM=SQRT(MAX(0D0,PPM2)) + CALL PYSHOW(IQ3,IQ2,PPM) + ENDIF + ENDIF + + RETURN + END + +C*********************************************************************** + +C...PYKLIM +C...Checks generated variables against pre-set kinematical limits; +C...also calculates limits on variables used in generation. + + SUBROUTINE PYKLIM(ILIM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/, + &/PYINT1/,/PYINT2/ + +C...Common kinematical expressions. + MINT(51)=0 + ISUB=MINT(1) + ISTSB=ISET(ISUB) + IF(ISUB.EQ.96) GOTO 100 + SQM3=VINT(63) + SQM4=VINT(64) + IF(ILIM.NE.0) THEN + IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN + CKIN09=MAX(CKIN(9),CKIN(13)) + CKIN10=MIN(CKIN(10),CKIN(14)) + CKIN11=MAX(CKIN(11),CKIN(15)) + CKIN12=MIN(CKIN(12),CKIN(16)) + ELSE + CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13))) + CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14))) + CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15))) + CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16))) + ENDIF + ENDIF + IF(ILIM.NE.1) THEN + TAU=VINT(21) + RM3=SQM3/(TAU*VINT(2)) + RM4=SQM4/(TAU*VINT(2)) + BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) + ENDIF + PTHMIN=CKIN(3) + IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3) + &PTHMIN=MAX(CKIN(3),CKIN(5)) + + IF(ILIM.EQ.0) THEN +C...Check generated values of tau, y*, cos(theta-hat), and tau' against +C...pre-set kinematical limits. + YST=VINT(22) + CTH=VINT(23) + TAUP=VINT(26) + TAUE=TAU + IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP + X1=SQRT(TAUE)*EXP(YST) + X2=SQRT(TAUE)*EXP(-YST) + XF=X1-X2 + IF(MINT(47).NE.1) THEN + IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1 + IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1 + IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1 + IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1 + ENDIF + IF(MINT(45).NE.1) THEN + IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1 + ENDIF + IF(MINT(46).NE.1) THEN + IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1 + ENDIF + IF(MINT(45).EQ.2) THEN + IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1 + ENDIF + IF(MINT(46).EQ.2) THEN + IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1 + ENDIF + IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN + PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2)) + EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/ + & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH))) + EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/ + & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH))) + Y3=YST+0.5D0*LOG(EXPY3) + Y4=YST+0.5D0*LOG(EXPY4) + YLARGE=MAX(Y3,Y4) + YSMALL=MIN(Y3,Y4) + ETALAR=20D0 + ETASMA=-20D0 + STH=SQRT(MAX(0D0,1D0-CTH**2)) + EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)* + & CTH)**2-4D0*RM3)) + EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)* + & CTH)**2-4D0*RM4)) + IF(STH.GE.1D-10) THEN + EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/ + & (BE34*STH) + EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/ + & (BE34*STH) + ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3))) + ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4))) + ETALAR=MAX(ETA3,ETA4) + ETASMA=MIN(ETA3,ETA4) + ENDIF + CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3 + CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4 + CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4)) + CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4)) + SH=TAU*VINT(2) + RPTS=4D0*VINT(71)**2/SH + BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS)) + RM34=MAX(1D-20,2D0*RM3*RM4) + IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0) + & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2))) + RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L) + THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH) + UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH) + IF(PTH.LT.PTHMIN) MINT(51)=1 + IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1 + IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1 + IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1 + IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1 + IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1 + IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1 + IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1 + IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1 + IF(THA.LT.CKIN(35)) MINT(51)=1 + IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1 + IF(UHA.LT.CKIN(37)) MINT(51)=1 + IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1 + ENDIF + IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN + IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1 + IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1 + ENDIF + +C...Additional cuts on W2 (approximately) in DIS. + IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN + XBJ=X2 + IF(IABS(MINT(12)).LT.20) XBJ=X1 + Q2BJ=THA + W2BJ=Q2BJ*(1D0-XBJ)/XBJ + IF(W2BJ.LT.CKIN(39)) MINT(51)=1 + IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1 + ENDIF + + ELSEIF(ILIM.EQ.1) THEN +C...Calculate limits on tau +C...0) due to definition + TAUMN0=0D0 + TAUMX0=1D0 +C...1) due to limits on subsystem mass + TAUMN1=CKIN(1)**2/VINT(2) + TAUMX1=1D0 + IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2) +C...2) due to limits on pT-hat (and non-overlapping rapidity intervals) + TM3=SQRT(SQM3+PTHMIN**2) + TM4=SQRT(SQM4+PTHMIN**2) + YDCOSH=1D0 + IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12) + TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2) + TAUMX2=1D0 +C...3) due to limits on pT-hat and cos(theta-hat) + CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2) + CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2) + TAUMN3=0D0 + IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3= + & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+ + & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2) + TAUMX3=1D0 + IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3= + & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+ + & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2) +C...4) due to limits on x1 and x2 + TAUMN4=CKIN(21)*CKIN(23) + TAUMX4=CKIN(22)*CKIN(24) +C...5) due to limits on xF + TAUMN5=0D0 + TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26)) +C...6) due to limits on that and uhat + TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2) + TAUMX6=1D0 + IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6= + & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2) + +C...Net effect of all separate limits. + VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6) + VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6) + IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN + VINT(11)=1D0-1D-9 + VINT(31)=1D0+1D-9 + ELSEIF(MINT(47).EQ.5) THEN + VINT(31)=MIN(VINT(31),1D0-2D-10) + ELSEIF(MINT(47).GE.6) THEN + VINT(31)=MIN(VINT(31),1D0-1D-10) + ENDIF + IF(VINT(31).LE.VINT(11)) MINT(51)=1 + + ELSEIF(ILIM.EQ.2) THEN +C...Calculate limits on y* + TAUE=TAU + IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26) + TAURT=SQRT(TAUE) +C...0) due to kinematics + YSTMN0=LOG(TAURT) + YSTMX0=-YSTMN0 +C...1) due to explicit limits + YSTMN1=CKIN(7) + YSTMX1=CKIN(8) +C...2) due to limits on x1 + YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT) + YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT) +C...3) due to limits on x2 + YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT) + YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT) +C...4) due to limits on xF + YEPMN4=0.5D0*ABS(CKIN(25))/TAURT + YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25)) + YEPMX4=0.5D0*ABS(CKIN(26))/TAURT + YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26)) +C...5) due to simultaneous limits on y-large and y-small + YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11) + YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12) + YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN))) + YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX))) + YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN) + YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX) +C...6) due to simultaneous limits on cos(theta-hat) and y-large or +C... y-small + CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2)))) + RZMN=BE34*MAX(CKIN(27),-CTHLIM) + RZMX=BE34*MIN(CKIN(28),CTHLIM) + YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX) + YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN) + YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN) + YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX) + YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX)) + YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN)) + +C...Net effect of all separate limits. + VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6) + VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6) + IF(MINT(47).EQ.1) THEN + VINT(12)=-1D-9 + VINT(32)=1D-9 + ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN + VINT(12)=(1D0-1D-9)*YSTMX0 + VINT(32)=(1D0+1D-9)*YSTMX0 + ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN + VINT(12)=-(1D0+1D-9)*YSTMX0 + VINT(32)=-(1D0-1D-9)*YSTMX0 + ELSEIF(MINT(47).EQ.5) THEN + YSTEE=LOG((1D0-1D-10)/TAURT) + VINT(12)=MAX(VINT(12),-YSTEE) + VINT(32)=MIN(VINT(32),YSTEE) + ENDIF + IF(VINT(32).LE.VINT(12)) MINT(51)=1 + + ELSEIF(ILIM.EQ.3) THEN +C...Calculate limits on cos(theta-hat) + YST=VINT(22) +C...0) due to definition + CTNMN0=-1D0 + CTNMX0=0D0 + CTPMN0=0D0 + CTPMX0=1D0 +C...1) due to explicit limits + CTNMN1=MIN(0D0,CKIN(27)) + CTNMX1=MIN(0D0,CKIN(28)) + CTPMN1=MAX(0D0,CKIN(27)) + CTPMX1=MAX(0D0,CKIN(28)) +C...2) due to limits on pT-hat + CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2)))) + CTPMX2=-CTNMN2 + CTNMX2=0D0 + CTPMN2=0D0 + IF(CKIN(4).GE.0D0) THEN + CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/ + & (BE34**2*TAU*VINT(2)))) + CTPMN2=-CTNMX2 + ENDIF +C...3) due to limits on y-large and y-small + CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST), + & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST))) + CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST), + & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST)) + CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST), + & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST)) + CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST), + & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST))) +C...4) due to limits on that + CTNMN4=-1D0 + CTNMX4=0D0 + CTPMN4=0D0 + CTPMX4=1D0 + SH=TAU*VINT(2) + IF(CKIN(35).GT.0D0) THEN + CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34 + IF(CTLIM.GT.0D0) THEN + CTPMX4=CTLIM + ELSE + CTPMX4=0D0 + CTNMX4=CTLIM + ENDIF + ENDIF + IF(CKIN(36).GT.0D0) THEN + CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34 + IF(CTLIM.LT.0D0) THEN + CTNMN4=CTLIM + ELSE + CTNMN4=0D0 + CTPMN4=CTLIM + ENDIF + ENDIF +C...5) due to limits on uhat + CTNMN5=-1D0 + CTNMX5=0D0 + CTPMN5=0D0 + CTPMX5=1D0 + IF(CKIN(37).GT.0D0) THEN + CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34 + IF(CTLIM.LT.0D0) THEN + CTNMN5=CTLIM + ELSE + CTNMN5=0D0 + CTPMN5=CTLIM + ENDIF + ENDIF + IF(CKIN(38).GT.0D0) THEN + CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34 + IF(CTLIM.GT.0D0) THEN + CTPMX5=CTLIM + ELSE + CTPMX5=0D0 + CTNMX5=CTLIM + ENDIF + ENDIF + +C...Net effect of all separate limits. + VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5) + VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5) + VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5) + VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5) + IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1 + + IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14) + IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13) + + ELSEIF(ILIM.EQ.4) THEN +C...Calculate limits on tau' +C...0) due to kinematics + TAPMN0=TAU + IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN + PQRAT=(VINT(201)+VINT(206))/VINT(1) + TAPMN0=(SQRT(TAU)+PQRAT)**2 + ENDIF + TAPMX0=1D0 +C...1) due to explicit limits + TAPMN1=CKIN(31)**2/VINT(2) + TAPMX1=1D0 + IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2) + +C...Net effect of all separate limits. + VINT(16)=MAX(TAPMN0,TAPMN1) + VINT(36)=MIN(TAPMX0,TAPMX1) + IF(MINT(47).EQ.1) THEN + VINT(16)=1D0-1D-9 + VINT(36)=1D0+1D-9 + ELSEIF(MINT(47).EQ.5) THEN + VINT(36)=MIN(VINT(36),1D0-2D-10) + ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN + VINT(36)=MIN(VINT(36),1D0-1D-10) + ENDIF + IF(VINT(36).LE.VINT(16)) MINT(51)=1 + + ENDIF + RETURN + +C...Special case for low-pT and multiple interactions: +C...effective kinematical limits for tau, y*, cos(theta-hat). + 100 IF(ILIM.EQ.0) THEN + ELSEIF(ILIM.EQ.1) THEN + IF(MSTP(82).LE.1) THEN + VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/ + & VINT(2) + ELSE + VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2) + ENDIF + VINT(31)=1D0 + ELSEIF(ILIM.EQ.2) THEN + VINT(12)=0.5D0*LOG(VINT(21)) + VINT(32)=-VINT(12) + ELSEIF(ILIM.EQ.3) THEN + IF(MSTP(82).LE.1) THEN + ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/ + & (VINT(21)*VINT(2)) + ELSE + ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/ + & (VINT(21)*VINT(2)) + ENDIF + VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF)) + VINT(33)=0D0 + VINT(14)=0D0 + VINT(34)=-VINT(13) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYKMAP +C...Maps a uniform distribution into a distribution of a kinematical +C...variable according to one of the possibilities allowed. It is +C...assumed that kinematical limits have been set by a PYKLIM call. + + SUBROUTINE PYKMAP(IVAR,MVAR,VVAR) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/ + +C...Convert VVAR to tau variable. + ISUB=MINT(1) + ISTSB=ISET(ISUB) + IF(IVAR.EQ.1) THEN + TAUMIN=VINT(11) + TAUMAX=VINT(31) + IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN + TAURE=VINT(73) + GAMRE=VINT(74) + ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN + TAURE=VINT(75) + GAMRE=VINT(76) + ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN + TAURE=VINT(77) + GAMRE=VINT(78) + 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.OR.MVAR.EQ.8) THEN + RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX + TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN) + ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) 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(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYPUED/IUED(0:99),RUED(0:99) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + COMMON/PYTCCO/COEFX(194:380,2) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/, + &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/, + &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/,/PYSGCM/,/PYTCCO/ +C...Local arrays and complex variables + DIMENSION XPQ(-25:25) + +C...Map of processes onto which routine to call +C...in order to evaluate cross section: +C...0 = not implemented; +C...1 = standard QCD (including photons); +C...2 = heavy flavours; +C...3 = W/Z; +C...4 = Higgs (2 doublets; including longitudinal W/Z scattering); +C...5 = SUSY; +C...6 = Technicolor; +C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*). +C...8 = Universal Extra Dimensions + DIMENSION MAPPR(500) + DATA (MAPPR(I),I=1,180)/ + & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1, + 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3, + 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3, + 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0, + 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0, + 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3, + 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1, + 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0, + 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0, + & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4, + 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0, + 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, + 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0, + 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0, + 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0, + 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/ + DATA (MAPPR(I),I=181,500)/ + 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, + 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0, + & 100*5, + & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0, + & 8, 8, 8, 8, 8, 8, 8, 8, 8, 0, + 1 20*0, + 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0, + 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6, + 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, + 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0, + 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0, + & 4, 4, 18*0, + 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0, + 4 20*0, + 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0, + 8 7, 7, 18*0/ + +C...Reset number of channels and cross-section + NCHN=0 + SIGS=0D0 + +C...Read process to consider. + ISUB=MINT(1) + ISUBSV=ISUB + MAP=MAPPR(ISUB) + +C...Read kinematical variables and limits + ISTSB=ISET(ISUBSV) + TAUMIN=VINT(11) + YSTMIN=VINT(12) + CTNMIN=VINT(13) + CTPMIN=VINT(14) + TAUPMN=VINT(16) + TAU=VINT(21) + YST=VINT(22) + CTH=VINT(23) + XT2=VINT(25) + TAUP=VINT(26) + TAUMAX=VINT(31) + YSTMAX=VINT(32) + CTNMAX=VINT(33) + CTPMAX=VINT(34) + TAUPMX=VINT(36) + +C...Derive kinematical quantities + TAUE=TAU + IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP + X(1)=SQRT(TAUE)*EXP(YST) + X(2)=SQRT(TAUE)*EXP(-YST) + IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN + IF(X(1).GT.1D0-1D-7) RETURN + ELSEIF(MINT(45).EQ.3) THEN + X(1)=MIN(1D0-1.1D-10,X(1)) + ENDIF + IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN + IF(X(2).GT.1D0-1D-7) RETURN + ELSEIF(MINT(46).EQ.3) THEN + X(2)=MIN(1D0-1.1D-10,X(2)) + ENDIF + SH=MAX(1D0,TAU*VINT(2)) + SQM3=VINT(63) + SQM4=VINT(64) + RM3=SQM3/SH + RM4=SQM4/SH + BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) + RPTS=4D0*VINT(71)**2/SH + BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS)) + RM34=MAX(1D-20,2D0*RM3*RM4) + RSQM=1D0+RM34 + IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0) + &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2))) + RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L) + IF(ISTSB.EQ.0) THEN + TH=VINT(45) + UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH) + SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2) + ELSE +C...Kinematics with incoming masses tricky: now depends on how +C...subprocess has been set up w.r.t. order of incoming partons. + RM1=0D0 + IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH + RM2=0D0 + IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH + IF(ISUB.EQ.35) THEN + RM2=MIN(RM1,RM2) + RM1=0D0 + ENDIF + BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)) + TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4) + TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3- + & BE12*BE34*CTH) + UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+ + & BE12*BE34*CTH) + SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2)) + ENDIF + SHR=SQRT(SH) + SH2=SH**2 + TH2=TH**2 + UH2=UH**2 + +C...Choice of Q2 scale for hard process (e.g. alpha_s). + IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN + Q2=SH + ELSEIF(ISTSB.EQ.8) THEN + IF(MINT(107).EQ.4) Q2=VINT(307) + IF(MINT(108).EQ.4) Q2=VINT(308) + ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN + Q2IN1=0D0 + IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2 + Q2IN2=0D0 + IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2 + IF(MSTP(32).EQ.1) THEN + Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2) + ELSEIF(MSTP(32).EQ.2) THEN + Q2=SQPTH+0.5D0*(SQM3+SQM4) + ELSEIF(MSTP(32).EQ.3) THEN + Q2=MIN(-TH,-UH) + ELSEIF(MSTP(32).EQ.4) THEN + Q2=SH + ELSEIF(MSTP(32).EQ.5) THEN + Q2=-TH + ELSEIF(MSTP(32).EQ.6) THEN + XSF1=X(1) + IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143) + XSF2=X(2) + IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144) + Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)* + & (SQPTH+0.5D0*(SQM3+SQM4)) + ELSEIF(MSTP(32).EQ.7) THEN + Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4)) + ELSEIF(MSTP(32).EQ.8) THEN + Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4) + ELSEIF(MSTP(32).EQ.9) THEN + Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4 + ELSEIF(MSTP(32).EQ.10) THEN + Q2=VINT(2) +C..Begin JA 040914 + ELSEIF(MSTP(32).EQ.11) THEN + Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4)) + ELSEIF(MSTP(32).EQ.12) THEN + Q2=PARP(193) +C..End JA + ELSEIF(MSTP(32).EQ.13) THEN + Q2=SQPTH + ENDIF + IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH + IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+ + & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2 + ENDIF + +C...Choice of Q2 scale for parton densities. + Q2SF=Q2 +C..Begin JA 040914 + IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) + & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5)) + & Q2=PARP(194) +C..End JA + IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN + Q2SF=PMAS(23,1)**2 + IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR. + & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2 + IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2 + IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR. + & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN + Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2 + IF(MSTP(39).EQ.2) Q2SF= + & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207)) + IF(MSTP(39).EQ.3) Q2SF=SH + IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2) + IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2 +C..Begin JA 040914 + IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2 + IF(MSTP(39).EQ.7) Q2SF= + & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0 + IF(MSTP(39).EQ.8) Q2SF=PARP(193) +C..End JA + ENDIF + ENDIF + IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH + + Q2PS=Q2SF + Q2SF=Q2SF*PARP(34) + IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2) + IF(MSTP(69).GE.2) Q2SF=VINT(2) + +C...Identify to which class(es) subprocess belongs + ISMECR=0 + ISQCD=0 + ISJETS=0 + IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR. + & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR. + & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR. + & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1 + IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR. + & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1 + IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1 + IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1 + IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1 + IF (ISTSB.EQ.9) ISQCD=1 + IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR. + & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND. + & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR. + & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR. + & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR. + & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND. + & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR. + & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1 +C...WBF is special case of ISJETS + IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR. + & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR. + & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR. + & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR. + & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR. + & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR. + & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR. + & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR. + & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2 +C...Some processes with photons also belong here. + IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR. + & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR. + & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR. + & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR. + & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR. + & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3 + +C...Choice of Q2 scale for parton-shower activity. + IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND. + &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN + XBJ=X(2) + IF(MINT(43).EQ.3) XBJ=X(1) + IF(MSTP(22).EQ.1) THEN + Q2PS=-TH + ELSEIF(MSTP(22).EQ.2) THEN + Q2PS=((1D0-XBJ)/XBJ)*(-TH) + ELSEIF(MSTP(22).EQ.3) THEN + Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH) + ELSE + Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH) + ENDIF + ENDIF +C...For multiple interactions, start from scale defined above +C...For all other QCD or "+jets"-type events, start shower from pThard. + IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH + IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN +C...Max shower scale = s for ME corrected processes. +C...(pT-ordering: max pT2 is s/4) + Q2PS=VINT(2) + IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0 + ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN +C...Max shower scale = s for all non-QCD, non-"+ jet" type processes. +C...(pT-ordering: max pT2 is s/4) + Q2PS=VINT(2) + IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0 + ENDIF + IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH + +C...Elastic and diffractive events not associated with scales so set 0. + IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN + Q2SF=0D0 + Q2PS=0D0 + ENDIF + +C...Store derived kinematical quantities + VINT(41)=X(1) + VINT(42)=X(2) + VINT(44)=SH + VINT(43)=SQRT(SH) + VINT(45)=TH + VINT(46)=UH + IF(ISTSB.NE.8) VINT(48)=SQPTH + IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH) + VINT(50)=TAUP*VINT(2) + VINT(49)=SQRT(MAX(0D0,VINT(50))) + VINT(52)=Q2 + VINT(51)=SQRT(Q2) + VINT(54)=Q2SF + VINT(53)=SQRT(Q2SF) + VINT(56)=Q2PS + VINT(55)=SQRT(Q2PS) + +C...Set starting scale for multiple interactions + IF (ISUBSV.EQ.95) THEN + XT2GMX=0D0 + ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND. + & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND. + & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND. + & ISUBSV.NE.96)) THEN +C...All accessible phase space allowed. + XT2GMX=(1D0-VINT(41))*(1D0-VINT(42)) + ELSE +C...Scale of hard process sets limit. +C...2 -> 1. Limit is tau = x1*x2. +C...2 -> 2. Limit is XT2 for hard process + FS masses. +C...2 -> n > 2. Limit is tau' = tau of outer process. + XT2GMX=VINT(25) + IF(ISTSB.EQ.1) XT2GMX=VINT(21) + IF(ISTSB.EQ.2) + & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2) + IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26) + ENDIF + VINT(62)=0.25D0*XT2GMX*VINT(2) + VINT(61)=SQRT(MAX(0D0,VINT(62))) + +C...Calculate parton distributions + IF(ISTSB.LE.0) GOTO 160 + IF(MINT(47).GE.2) THEN + DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46)) + XSF=X(I) + IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I) + IF(ISUB.EQ.99) THEN + IF(MINT(140+I).EQ.0) THEN + XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2) + ELSE + XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308)) + ENDIF + VINT(40+I)=XSF + Q2SF=VINT(309-I) + ENDIF + MINT(105)=MINT(102+I) + MINT(109)=MINT(106+I) + VINT(120)=VINT(2+I) +C...Default is to use standard PDFs, but for interactions after the first +C...in the new multiple-parton-interactions framework, set which side to +C...evaluate the MPI-modified PDFs on. + MINT(30)=0 + IF (MINT(31).GE.1) MINT(30)=I + IF(MSTP(57).LE.1) THEN + CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ) + ELSE + CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ) + ENDIF +C...Safety margin against heavy flavour very close to threshold, +C...e.g. caused by mismatch in c and b masses. + IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN + XPQ(4)=0D0 + XPQ(-4)=0D0 + ENDIF + IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN + XPQ(5)=0D0 + XPQ(-5)=0D0 + ENDIF + DO 100 KFL=-25,25 + XSFX(I,KFL)=XPQ(KFL) + 100 CONTINUE + 110 CONTINUE + ENDIF + +C...Calculate alpha_em, alpha_strong and K-factor + XW=PARU(102) + XWV=XW + IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW= + &1D0-(PMAS(24,1)/PMAS(23,1))**2 + XW1=1D0-XW + XWC=1D0/(16D0*XW*XW1) + AEM=PYALEM(Q2) + IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1) + IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2) + FACK=1D0 + FACA=1D0 + IF(MSTP(33).EQ.1) THEN + FACK=PARP(31) + ELSEIF(MSTP(33).EQ.2) THEN + FACK=PARP(31) + FACA=PARP(32)/PARP(31) + ELSEIF(MSTP(33).EQ.3) THEN + Q2AS=PARP(33)*Q2 + IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+ + & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90) + AS=PYALPS(Q2AS) +C...PS (12 Feb 2010) +C...New options MSTP(33) = 10 and 11 +C... 10: use K-factor = PARP(32) only for process 96 (MPI) +C... 11: as for 10, but also use K-factor = PARP(31) for other procs + ELSEIF(MSTP(33).GE.10) THEN + IF (ISUB.EQ.96) THEN + FACK = PARP(32) + ELSEIF (ISUB.NE.96.AND.MSTP(33).EQ.11) THEN + FACK = PARP(31) + ENDIF + ENDIF + VINT(138)=1D0 + VINT(57)=AEM + VINT(58)=AS + +C...Set flags for allowed reacting partons/leptons + DO 140 I=1,2 + DO 120 J=-25,25 + KFAC(I,J)=0 + 120 CONTINUE + IF(MINT(44+I).EQ.1) THEN + KFAC(I,MINT(10+I))=1 + ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN + KFAC(I,MINT(10+I))=1 + KFAC(I,22)=1 + KFAC(I,24)=1 + KFAC(I,-24)=1 + ELSE + DO 130 J=-25,25 + KFAC(I,J)=KFIN(I,J) + IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0 + IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0 + 130 CONTINUE + ENDIF + 140 CONTINUE + +C...Lower and upper limit for fermion flavour loops + MMIN1=0 + MMAX1=0 + MMIN2=0 + MMAX2=0 + DO 150 J=-20,20 + IF(KFAC(1,-J).EQ.1) MMIN1=-J + IF(KFAC(1,J).EQ.1) MMAX1=J + IF(KFAC(2,-J).EQ.1) MMIN2=-J + IF(KFAC(2,J).EQ.1) MMAX2=J + 150 CONTINUE + MMINA=MIN(MMIN1,MMIN2) + MMAXA=MAX(MMAX1,MMAX2) + +C...Common resonance mass and width combinations + SQMZ=PMAS(23,1)**2 + SQMW=PMAS(24,1)**2 + GMMZ=PMAS(23,1)*PMAS(23,2) + GMMW=PMAS(24,1)*PMAS(24,2) + +C...Polarization factors...implemented so far for W+W-(25) + POLR=(1D0+PARJ(132))*(1D0-PARJ(131)) + POLL=(1D0-PARJ(132))*(1D0+PARJ(131)) + POLRR=(1D0+PARJ(132))*(1D0+PARJ(131)) + POLLL=(1D0-PARJ(132))*(1D0-PARJ(131)) + +C...Phase space integral in tau + COMFAC=PARU(1)*PARU(5)/VINT(2) + IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK + IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND. + &ISTSB.NE.8.AND.ISTSB.NE.9) THEN + ATAU1=LOG(TAUMAX/TAUMIN) + ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN) + H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU + IF(MINT(72).GE.1) THEN + TAUR1=VINT(73) + GAMR1=VINT(74) + ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1)) + ATAU3=ATAUD/TAUR1 + IF(ATAUD.GT.1D-10) H1=H1+ + & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1) + ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1) + ATAU4=ATAUD/GAMR1 + IF(ATAUD.GT.1D-10) H1=H1+ + & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2) + ENDIF + IF(MINT(72).GE.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(72).EQ.3) THEN + TAUR3=VINT(77) + GAMR3=VINT(78) + ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3)) + ATAU50=ATAUD/TAUR3 + IF(ATAUD.GT.1D-10) H1=H1+ + & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3) + ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3) + ATAU60=ATAUD/GAMR3 + IF(ATAUD.GT.1D-10) H1=H1+ + & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2) + ENDIF + IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN + ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX)) + IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/ + & MAX(2D-10,1D0-TAU) + ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN + ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX)) + IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/ + & MAX(1D-10,1D0-TAU) + ENDIF + COMFAC=COMFAC*ATAU1/(TAU*H1) + ENDIF + +C...Phase space integral in y* + IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9) + &THEN + AYST0=YSTMAX-YSTMIN + IF(AYST0.LT.1D-10) THEN + COMFAC=0D0 + ELSE + AYST1=0.5D0*(YSTMAX-YSTMIN)**2 + AYST2=AYST1 + AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN))) + H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+ + & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+ + & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST) + IF(MINT(45).EQ.3) THEN + YST0=-0.5D0*LOG(TAUE) + AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/ + & MAX(1D-10,EXP(YST0-YSTMAX)-1D0)) + IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/ + & MAX(1D-10,1D0-EXP(YST-YST0)) + ENDIF + IF(MINT(46).EQ.3) THEN + YST0=-0.5D0*LOG(TAUE) + AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/ + & MAX(1D-10,EXP(YST0+YSTMIN)-1D0)) + IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/ + & MAX(1D-10,1D0-EXP(-YST-YST0)) + ENDIF + COMFAC=COMFAC*AYST0/H2 + ENDIF + ENDIF + +C...2 -> 1 processes: reduction in angular part of phase space integral +C...for case of decaying resonance + ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN + IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN + IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN + IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR. + & KFPR(ISUB,1).EQ.39) THEN + COMFAC=COMFAC*0.5D0*ACTH0 + ELSE + COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+ + & CTPMAX**3-CTPMIN**3) + ENDIF + ENDIF + +C...2 -> 2 processes: angular part of phase space integral + ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN + ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/ + & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX))) + ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/ + & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN))) + ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+ + & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN) + ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+ + & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX) + H3=COEF(ISUBSV,13)+ + & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+ + & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+ + & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+ + & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2 + COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3 + +C...2 -> 2 processes: take into account final state Breit-Wigners + COMFAC=COMFAC*VINT(80) + ENDIF + +C...2 -> 3, 4 processes: phace space integral in tau' + IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN + ATAUP1=LOG(TAUPMX/TAUPMN) + ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU) + H4=COEF(ISUBSV,18)+ + & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP + IF(MINT(47).EQ.5) THEN + ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX)) + H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP) + ELSEIF(MINT(47).GE.6) THEN + ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX)) + H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP) + ENDIF + COMFAC=COMFAC*ATAUP1/H4 + ENDIF + +C...2 -> 3, 4 processes: effective W/Z parton distributions + IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN + IF(1D0-TAU/TAUP.GT.1D-4) THEN + FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP) + ELSE + FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP + ENDIF + COMFAC=COMFAC*FZW + ENDIF + +C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror + IF(ISTSB.EQ.5) THEN + COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/ + & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP) + ENDIF + +C...Phase space integral for low-pT and multiple interactions + IF(ISTSB.EQ.9) THEN + COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2 + ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0) + ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2) + H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU) + COMFAC=COMFAC*ATAU1/H1 + AYST0=YSTMAX-YSTMIN + AYST1=0.5D0*(YSTMAX-YSTMIN)**2 + AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN))) + H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+ + & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+ + & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST) + COMFAC=COMFAC*AYST0/H2 + IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0) +C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is +C...introduced to make cross-section finite for xT2 -> 0 + IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)* + & (1D0+VINT(149))) + ENDIF + +C...Real gamma + gamma: include factor 2 when different nature + 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND. + &MSTP(14).LE.10) COMFAC=2D0*COMFAC + +C...Extra factors to include the effects of +C...longitudinal resolved photons (but not direct or DIS ones). + DO 170 ISDE=1,2 + IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND. + & MINT(106+ISDE).LE.3) THEN + VINT(314+ISDE)=1D0 + XY=PARP(166+ISDE) + IF(MSTP(16).EQ.0) THEN + IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0) + & XY=VINT(304+ISDE) + ELSE + IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0) + & XY=VINT(308+ISDE) + ENDIF + Q2GA=VINT(306+ISDE) + IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND. + & Q2GA.GT.0D0) THEN + REDUCE=0D0 + IF(MSTP(17).EQ.1) THEN + REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2 + ELSEIF(MSTP(17).EQ.2) THEN + REDUCE=4D0*Q2GA/(Q2+Q2GA) + ELSEIF(MSTP(17).EQ.3) THEN + PMVIRT=PMAS(PYCOMP(113),1) + REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA) + ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN + PMVIRT=PMAS(PYCOMP(113),1) + REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2 + ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN + PMVIRT=PMAS(PYCOMP(113),1) + REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2 + ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN + PMVSMN=4D0*PARP(15)**2 + PMVSMX=4D0*VINT(154)**2 + REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA) + REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3- + & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3 + REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA + ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN + PMVIRT=PMAS(PYCOMP(113),1) + REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA) + ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN + PMVIRT=PMAS(PYCOMP(113),1) + REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA) + ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN + PMVSMN=4D0*PARP(15)**2 + PMVSMX=4D0*VINT(154)**2 + REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA) + REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2 + REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA + ENDIF + BEAMAS=PYMASS(11) + IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE) + FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)* + & (1D0-2D0*BEAMAS**2/Q2GA)) + VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT + ENDIF + ELSE + VINT(314+ISDE)=1D0 + ENDIF + COMFAC=COMFAC*VINT(314+ISDE) + 170 CONTINUE + +C...Evaluate cross sections - done in separate routines by kind +C...of physics, to keep PYSIGH of sensible size. + IF(MAP.EQ.1) THEN +C...Standard QCD (including photons). + CALL PYSGQC(NCHN,SIGS) + ELSEIF(MAP.EQ.2) THEN +C...Heavy flavours. + CALL PYSGHF(NCHN,SIGS) + ELSEIF(MAP.EQ.3) THEN +C...W/Z. + CALL PYSGWZ(NCHN,SIGS) + ELSEIF(MAP.EQ.4) THEN +C...Higgs (2 doublets; including longitudinal W/Z scattering). + CALL PYSGHG(NCHN,SIGS) + ELSEIF(MAP.EQ.5) THEN +C...SUSY. + CALL PYSGSU(NCHN,SIGS) + ELSEIF(MAP.EQ.6) THEN +C...Technicolor. + CALL PYSGTC(NCHN,SIGS) + ELSEIF(MAP.EQ.7) THEN +C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*). + CALL PYSGEX(NCHN,SIGS) + ELSEIF(MAP.EQ.8) THEN +C... Universal Extra Dimensions + CALL PYXUED(NCHN,SIGS) + ENDIF + +C...Multiply with parton distributions + IF(ISUB.LE.90.OR.ISUB.GE.96) THEN + DO 180 ICHN=1,NCHN + IF(MINT(45).GE.2) THEN + KFL1=ISIG(ICHN,1) + SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1) + ENDIF + IF(MINT(46).GE.2) THEN + KFL2=ISIG(ICHN,2) + SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2) + ENDIF + SIGS=SIGS+SIGH(ICHN) + 180 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSGQC +C...Subprocess cross sections for QCD processes, +C...including photons. +C...Auxiliary to PYSIGH. + + SUBROUTINE PYSGQC(NCHN,SIGS) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/, + &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/ +C...Local arrays + DIMENSION WDTP(0:400),WDTE(0:400,0:5) + +C...Differential cross section expressions. + + IF(ISUB.LE.20) THEN + IF(ISUB.EQ.10) THEN +C...f + f' -> f + f' (gamma/Z/W exchange) + FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2 + FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ)) + FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2 + FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2 + DO 110 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110 + IA=IABS(I) + DO 100 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100 + JA=IABS(J) +C...Electroweak couplings + EI=KCHG(IA,1)*ISIGN(1,I)/3D0 + AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I) + VI=AI-4D0*EI*XWV + EJ=KCHG(JA,1)*ISIGN(1,J)/3D0 + AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J) + VJ=AJ-4D0*EJ*XWV + EPSIJ=ISIGN(1,I*J) +C...gamma/Z exchange, only gamma exchange, or only Z exchange + IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN + IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN + FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ* + & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+ + & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+ + & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2)) + ELSEIF(MSTP(21).EQ.2) THEN + FACNCF=FACGGF*EI**2*EJ**2 + ELSE + FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)* + & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2)) + ENDIF +C...Extrafactor 2 for only one incoming neutrino spin state. + IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF + IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACNCF + ENDIF +C...W exchange + IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN + FACCCF=FACWWF*VINT(180+I)*VINT(180+J) + IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2 + IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF + IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACCCF + ENDIF + 100 CONTINUE + 110 CONTINUE + + ELSEIF(ISUB.EQ.11) THEN +C...f + f' -> f + f' (g exchange) + FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2 + FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA- + & MSTP(34)*2D0/3D0*UH2/(SH*TH)) + FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2- + & MSTP(34)*2D0/3D0*SH2/(TH*UH)) + DO 130 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130 + DO 120 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1 + IF(I.EQ.-J) SIGH(NCHN)=FACQQB + IF(I.EQ.J) THEN + SIGH(NCHN)=0.5D0*SIGH(NCHN) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + SIGH(NCHN)=0.5D0*FACQQ2 + ENDIF + 120 CONTINUE + 130 CONTINUE + + ELSEIF(ISUB.EQ.12) THEN +C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only) + CALL PYWIDT(21,SH,WDTP,WDTE) + FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2* + & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + DO 140 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQB + 140 CONTINUE + + ELSEIF(ISUB.EQ.13) THEN +C...f + fbar -> g + g (q + qbar -> g + g only) + FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* + & UH2/SH2) + FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* + & TH2/SH2) + DO 150 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=0.5D0*FACGG1 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=0.5D0*FACGG2 + 150 CONTINUE + + ELSEIF(ISUB.EQ.14) THEN +C...f + fbar -> g + gamma (q + qbar -> g + gamma only) + FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH) + DO 160 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160 + EI=KCHG(IABS(I),1)/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGG*EI**2 + 160 CONTINUE + + ELSEIF(ISUB.EQ.18) THEN +C...f + fbar -> gamma + gamma + FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH) + DO 170 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170 + EI=KCHG(IABS(I),1)/3D0 + FCOI=1D0 + IF(IABS(I).LE.10) FCOI=FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4 + 170 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.40) THEN + IF(ISUB.EQ.28) THEN +C...f + g -> f + g (q + g -> q + g only) + FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2- + & UH/SH)*FACA + FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2- + & SH/UH) + DO 190 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190 + DO 180 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQG1 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQG2 + 180 CONTINUE + 190 CONTINUE + + ELSEIF(ISUB.EQ.29) THEN +C...f + g -> f + gamma (q + g -> q + gamma only) + FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH) + DO 210 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210 + EI=KCHG(IABS(I),1)/3D0 + FACGQ=FGQ*EI**2 + DO 200 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGQ + 200 CONTINUE + 210 CONTINUE + + ELSEIF(ISUB.EQ.33) THEN +C...f + gamma -> f + g (q + gamma -> q + g only) + FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH) + DO 230 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230 + EI=KCHG(IABS(I),1)/3D0 + FACGQ=FGQ*EI**2 + DO 220 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGQ + 220 CONTINUE + 230 CONTINUE + + ELSEIF(ISUB.EQ.34) THEN +C...f + gamma -> f + gamma + FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH) + DO 250 I=MMINA,MMAXA + IF(I.EQ.0) GOTO 250 + EI=KCHG(IABS(I),1)/3D0 + FACGQ=FGQ*EI**4 + DO 240 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGQ + 240 CONTINUE + 250 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.80) THEN + IF(ISUB.EQ.53) THEN +C...g + g -> f + fbar (g + g -> q + qbar only) + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270 + IDC0=MDCY(21,2)-1 +C...Begin by d, u, s flavours. + FLAVWT=0D0 + IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH)) + IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH)) + IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH)) + FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* + & UH2/SH2)*FLAVWT*FACA + FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* + & TH2/SH2)*FLAVWT*FACA + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQ2 +C...Next c and b flavours: modified that and uhat for fixed +C...cos(theta-hat). + DO 260 IFL=4,5 + SQMAVG=PMAS(IFL,1)**2 + IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN + BE34=SQRT(1D0-4D0*SQMAVG/SH) + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + THUHQ=THQ*UHQ-SQMAVG*SH + IF(MSTP(34).EQ.0) THEN + FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2 + FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2 + ELSE + FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ) + FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ) + ENDIF + FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34 + FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1+2*(IFL-3) + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2+2*(IFL-3) + SIGH(NCHN)=FACQQ2 + ENDIF + 260 CONTINUE + 270 CONTINUE + + ELSEIF(ISUB.EQ.54) THEN +C...g + gamma -> f + fbar (g + gamma -> q + qbar only) + CALL PYWIDT(21,SH,WDTP,WDTE) + WDTESU=0D0 + DO 280 I=1,MIN(8,MDCY(21,3)) + EF=KCHG(I,1)/3D0 + WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+ + & WDTE(I,4)) + 280 CONTINUE + FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH) + IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ + ENDIF + IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ + ENDIF + + ELSEIF(ISUB.EQ.58) THEN +C...gamma + gamma -> f + fbar + CALL PYWIDT(22,SH,WDTP,WDTE) + WDTESU=0D0 + DO 290 I=1,MIN(12,MDCY(22,3)) + IF(I.LE.8) EF= KCHG(I,1)/3D0 + IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0 + WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+ + & WDTE(I,4)) + 290 CONTINUE + FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH) + IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACFF + ENDIF + + ELSEIF(ISUB.EQ.68) THEN +C...g + g -> g + g + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300 + FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+ + & TH2/SH2)*FACA + FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+ + & SH2/UH2)*FACA + FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+ + & UH2/TH2) + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=0.5D0*FACGG1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=0.5D0*FACGG2 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=3 + SIGH(NCHN)=0.5D0*FACGG3 + 300 CONTINUE + + ELSEIF(ISUB.EQ.80) THEN +C...q + gamma -> q' + pi+/- + FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2) + ASSH=PYALPS(MAX(0.5D0,0.5D0*SH)) + Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH)) + DELSH=UH*SQRT(ASSH*Q2FPSH) + ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH)) + Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH)) + DELUH=SH*SQRT(ASUH*Q2FPUH) + DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA) + IF(I.EQ.0) GOTO 320 + EI=KCHG(IABS(I),1)/3D0 + EJ=SIGN(1D0-ABS(EI),EI) + DO 310 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2 + 310 CONTINUE + 320 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.100) THEN + IF(ISUB.EQ.91) THEN +C...Elastic scattering + SIGS=VINT(315)*VINT(316)*SIGT(0,0,1) + + ELSEIF(ISUB.EQ.92) THEN +C...Single diffractive scattering (first side, i.e. XB) + SIGS=VINT(315)*VINT(316)*SIGT(0,0,2) + + ELSEIF(ISUB.EQ.93) THEN +C...Single diffractive scattering (second side, i.e. AX) + SIGS=VINT(315)*VINT(316)*SIGT(0,0,3) + + ELSEIF(ISUB.EQ.94) THEN +C...Double diffractive scattering + SIGS=VINT(315)*VINT(316)*SIGT(0,0,4) + + ELSEIF(ISUB.EQ.95) THEN +C...Low-pT scattering + SIGS=VINT(315)*VINT(316)*SIGT(0,0,5) + + ELSEIF(ISUB.EQ.96) THEN +C...Multiple interactions: sum of QCD processes + CALL PYWIDT(21,SH,WDTP,WDTE) + +C...q + q' -> q + q' + FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2 + FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA- + & MSTP(34)*2D0/3D0*UH2/(SH*TH)) + FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2 + FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH) + RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2) + DO 340 I=-5,5 + IF(I.EQ.0) GOTO 340 + DO 330 J=-5,5 + IF(J.EQ.0) GOTO 330 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=111 + SIGH(NCHN)=FACQQ1 + IF(I.EQ.-J) SIGH(NCHN)=FACQQB + IF(I.EQ.J) THEN + SIGH(NCHN)=0.5D0*FACQQ1*RATQQI + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=112 + SIGH(NCHN)=0.5D0*FACQQ2*RATQQI + ENDIF + 330 CONTINUE + 340 CONTINUE + +C...q + qbar -> q' + qbar' or g + g + FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2* + & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4)) + FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* + & UH2/SH2) + FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* + & TH2/SH2) + DO 350 I=-5,5 + IF(I.EQ.0) GOTO 350 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=121 + SIGH(NCHN)=FACQQB + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=131 + SIGH(NCHN)=0.5D0*FACGG1 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=132 + SIGH(NCHN)=0.5D0*FACGG2 + 350 CONTINUE + +C...q + g -> q + g + FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2- + & UH/SH)*FACA + FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2- + & SH/UH) + DO 370 I=-5,5 + IF(I.EQ.0) GOTO 370 + DO 360 ISDE=1,2 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=281 + SIGH(NCHN)=FACQG1 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=282 + SIGH(NCHN)=FACQG2 + 360 CONTINUE + 370 CONTINUE + +C...g + g -> q + qbar (only d, u, s) + IDC0=MDCY(21,2)-1 + FLAVWT=0D0 + IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH)) + IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH)) + IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH)) + FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* + & UH2/SH2)*FLAVWT*FACA + FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* + & TH2/SH2)*FLAVWT*FACA + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=531 + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=532 + SIGH(NCHN)=FACQQ2 + +C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed +C...cos(theta-hat) + DO 380 IFL=4,5 + SQMAVG=PMAS(IFL,1)**2 + IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN + BE34=SQRT(1D0-4D0*SQMAVG/SH) + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + THUHQ=THQ*UHQ-SQMAVG*SH + IF(MSTP(34).EQ.0) THEN + FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2 + FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2 + ELSE + FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ) + FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ) + ENDIF + FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34 + FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=531+2*(IFL-3) + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=532+2*(IFL-3) + SIGH(NCHN)=FACQQ2 + ENDIF + 380 CONTINUE + +C...g + g -> g + g + FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+ + & 2D0*TH/SH+TH2/SH2)*FACA + FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+ + & 2D0*SH/UH+SH2/UH2)*FACA + FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+ + & 2D0*UH/TH+UH2/TH2) + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=681 + SIGH(NCHN)=0.5D0*FACGG1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=682 + SIGH(NCHN)=0.5D0*FACGG2 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=683 + SIGH(NCHN)=0.5D0*FACGG3 + + ELSEIF(ISUB.EQ.99) THEN +C...f + gamma* -> f. + IF(MINT(107).EQ.4) THEN + Q2GA=VINT(307) + P2GA=VINT(308) + ISDE=2 + ELSE + Q2GA=VINT(308) + P2GA=VINT(307) + ISDE=1 + ENDIF + COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316) + PM2RHO=PMAS(PYCOMP(113),1)**2 + IF(MSTP(19).EQ.0) THEN + COMFAC=COMFAC/Q2GA + ELSEIF(MSTP(19).EQ.1) THEN + COMFAC=COMFAC/(Q2GA+PM2RHO) + ELSEIF(MSTP(19).EQ.2) THEN + COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2 + ELSE + COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2 + W2GA=VINT(2) + IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN + RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2* + & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2)) + XGA=Q2GA/(W2GA+VINT(307)+VINT(308)) + ELSE + RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2* + & Q2GA**0.57D0) + XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2) + ENDIF + COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS)) + IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA) + ENDIF + DO 390 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390 + IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390 + EI=KCHG(IABS(I),1)/3D0 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=COMFAC*EI**2 + 390 CONTINUE + ENDIF + + ELSE + IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN +C...g + g -> gamma + gamma or g + g -> g + gamma + A0STUR=0D0 + A0STUI=0D0 + A0TSUR=0D0 + A0TSUI=0D0 + A0UTSR=0D0 + A0UTSI=0D0 + A1STUR=0D0 + A1STUI=0D0 + A2STUR=0D0 + A2STUI=0D0 + ALST=LOG(-SH/TH) + ALSU=LOG(-SH/UH) + ALTU=LOG(TH/UH) + IMAX=2*MSTP(1) + IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38) + DO 400 I=1,IMAX + EI=KCHG(IABS(I),1)/3D0 + EIWT=EI**2 + IF(ISUB.EQ.115) EIWT=EI + SQMQ=PMAS(I,1)**2 + EPSS=4D0*SQMQ/SH + EPST=4D0*SQMQ/TH + EPSU=4D0*SQMQ/UH + IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN + B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+ + & PARU(1)**2) + B0STUI=0D0 + B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2 + B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU) + B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2 + B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST) + B1STUR=-1D0 + B1STUI=0D0 + B2STUR=-1D0 + B2STUI=0D0 + ELSE + CALL PYWAUX(1,EPSS,W1SR,W1SI) + CALL PYWAUX(1,EPST,W1TR,W1TI) + CALL PYWAUX(1,EPSU,W1UR,W1UI) + CALL PYWAUX(2,EPSS,W2SR,W2SI) + CALL PYWAUX(2,EPST,W2TR,W2TI) + CALL PYWAUX(2,EPSU,W2UR,W2UI) + CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI) + CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI) + CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI) + CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI) + CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI) + CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI) + B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+ + & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)- + & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)- + & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+ + & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+ + & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR) + B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+ + & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)- + & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)- + & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+ + & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+ + & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI) + B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+ + & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)- + & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)- + & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+ + & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+ + & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR) + B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+ + & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)- + & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)- + & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+ + & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+ + & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI) + B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+ + & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)- + & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)- + & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+ + & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+ + & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR) + B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+ + & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)- + & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)- + & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+ + & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+ + & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI) + B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+ + & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+ + & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+ + & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR) + B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+ + & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+ + & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+ + & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI) + B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+ + & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+ + & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR) + B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+ + & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+ + & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI) + ENDIF + A0STUR=A0STUR+EIWT*B0STUR + A0STUI=A0STUI+EIWT*B0STUI + A0TSUR=A0TSUR+EIWT*B0TSUR + A0TSUI=A0TSUI+EIWT*B0TSUI + A0UTSR=A0UTSR+EIWT*B0UTSR + A0UTSI=A0UTSI+EIWT*B0UTSI + A1STUR=A1STUR+EIWT*B1STUR + A1STUI=A1STUI+EIWT*B1STUI + A2STUR=A2STUR+EIWT*B2STUR + A2STUI=A2STUI+EIWT*B2STUI + 400 CONTINUE + ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+ + & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2 + FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM + FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG + IF(ISUB.EQ.115) SIGH(NCHN)=FACGP + 410 CONTINUE + + ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN +C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only) + PH=0D0 + IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0) + & PH=VINT(3)**2 + IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0) + & PH=VINT(4)**2 + IF(ISUB.EQ.131) THEN + FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2* + & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2) + ELSE + FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH) + ENDIF + DO 430 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430 + EI=KCHG(IABS(I),1)/3D0 + FACGQ=FGQ*EI**2 + DO 420 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGQ + 420 CONTINUE + 430 CONTINUE + + ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN +C...f + gamma*_(T,L) -> f + gamma + PH=0D0 + IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0) + & PH=VINT(3)**2 + IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0) + & PH=VINT(4)**2 + IF(ISUB.EQ.133) THEN + FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2* + & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2) + ELSE + FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH) + ENDIF + DO 450 I=MMINA,MMAXA + IF(I.EQ.0) GOTO 450 + EI=KCHG(IABS(I),1)/3D0 + FACGQ=FGQ*EI**4 + DO 440 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGQ + 440 CONTINUE + 450 CONTINUE + + ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN +C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only) + PH=0D0 + IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0) + & PH=VINT(3)**2 + IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0) + & PH=VINT(4)**2 + CALL PYWIDT(21,SH,WDTP,WDTE) + WDTESU=0D0 + DO 460 I=1,MIN(8,MDCY(21,3)) + EF=KCHG(I,1)/3D0 + WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+ + & WDTE(I,4)) + 460 CONTINUE + IF(ISUB.EQ.135) THEN + FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2* + & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2) + ELSE + FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH + ENDIF + IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ + ENDIF + IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ + ENDIF + + ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN +C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar + PH1=0D0 + IF(VINT(3).LT.0D0) PH1=VINT(3)**2 + PH2=0D0 + IF(VINT(4).LT.0D0) PH2=VINT(4)**2 + CALL PYWIDT(22,SH,WDTP,WDTE) + WDTESU=0D0 + DO 470 I=1,MIN(12,MDCY(22,3)) + IF(I.LE.8) EF= KCHG(I,1)/3D0 + IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0 + WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+ + & WDTE(I,4)) + 470 CONTINUE + DLAMB2=(TH+UH)**2-4D0*PH1*PH2 + IF(ISUB.EQ.137) THEN + FPARAM=-SH*(TH+UH)/DLAMB2 + FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)* + & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))- + & 2D0*PH1*PH2*FPARAM**2) + ELSEIF(ISUB.EQ.138) THEN + FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)* + & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+ + & 2D0*PH1**2*(TH-UH)**2) + ELSEIF(ISUB.EQ.139) THEN + FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)* + & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+ + & 2D0*PH2**2*(TH-UH)**2) + ELSE + FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)* + & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2 + ENDIF + IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACFF + ENDIF + + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSGHF +C...Subprocess cross sections for heavy flavour production, +C...open and closed. +C...Auxiliary to PYSIGH. + + SUBROUTINE PYSGHF(NCHN,SIGS) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/, + &/PYINT4/,/PYSGCM/ +C...Local arrays + DIMENSION WDTP(0:400),WDTE(0:400,0:5) + +C...Determine where are charmonium/bottomonium wave function parameters. + IONIUM=140 + IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145 + +C...Convert bottomonium process into equivalent charmonium ones. + IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40 + +C...Differential cross section expressions. + + IF(ISUB.LE.100) THEN + IF(ISUB.EQ.81) THEN +C...q + qbar -> Q + Qbar + SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+ + & 2D0*SQMAVG/SH) + IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0) + WID2=1D0 + IF(MINT(55).EQ.6) WID2=WIDS(6,1) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1) + FACQQB=FACQQB*WID2 + DO 100 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQB + 100 CONTINUE + + ELSEIF(ISUB.EQ.82) THEN +C...g + g -> Q + Qbar + SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + THUHQ=THQ*UHQ-SQMAVG*SH + IF(MSTP(34).EQ.0) THEN + FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2 + FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2 + ELSE + FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ) + FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ) + ENDIF + FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1 + FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2 + IF(MSTP(35).GE.1) THEN + FATRE=PYHFTH(SH,SQMAVG,2D0/7D0) + FACQQ1=FACQQ1*FATRE + FACQQ2=FACQQ2*FATRE + ENDIF + WID2=1D0 + IF(MINT(55).EQ.6) WID2=WIDS(6,1) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1) + FACQQ1=FACQQ1*WID2 + FACQQ2=FACQQ2*WID2 + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQ2 + 110 CONTINUE + + ELSEIF(ISUB.EQ.83) THEN +C...f + q -> f' + Q + FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2 + FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2 + DO 130 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130 + DO 120 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120 + IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120 + IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120 + IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1) + & THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2, + & (IABS(I)+1)/2)*VINT(180+J) + IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2, + & (MINT(55)+1)/2)*VINT(180+J) + WID2=1D0 + IF(I.GT.0) THEN + IF(MINT(55).EQ.6) WID2=WIDS(6,2) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2= + & WIDS(MINT(55),2) + ELSE + IF(MINT(55).EQ.6) WID2=WIDS(6,3) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2= + & WIDS(MINT(55),3) + ENDIF + IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2 + IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2 + ENDIF + IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1) + & THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2, + & (IABS(J)+1)/2)*VINT(180+I) + IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2, + & (MINT(55)+1)/2)*VINT(180+I) + WID2=1D0 + IF(J.GT.0) THEN + IF(MINT(55).EQ.6) WID2=WIDS(6,2) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2= + & WIDS(MINT(55),2) + ELSE + IF(MINT(55).EQ.6) WID2=WIDS(6,3) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2= + & WIDS(MINT(55),3) + ENDIF + IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2 + IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2 + ENDIF + 120 CONTINUE + 130 CONTINUE + + ELSEIF(ISUB.EQ.84) THEN +C...g + gamma -> Q + Qbar + SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2* + & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/ + & (THQ*UHQ) + IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0) + WID2=1D0 + IF(MINT(55).EQ.6) WID2=WIDS(6,1) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1) + FACQQ=FACQQ*WID2 + IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ + ENDIF + IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ + ENDIF + + ELSEIF(ISUB.EQ.85) THEN +C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton) + SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0* + & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)* + & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))* + & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2 + IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF + IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1) + & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0) + WID2=1D0 + IF(MINT(56).EQ.6) WID2=WIDS(6,1) + IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1) + IF(MINT(56).EQ.17) WID2=WIDS(17,1) + FACFF=FACFF*WID2 + IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACFF + ENDIF + + ELSEIF(ISUB.EQ.86) THEN +C...g + g -> J/Psi + g + FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)* + & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/ + & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG + ENDIF + + ELSEIF(ISUB.EQ.87) THEN +C...g + g -> chi_0c + g + PGTW=(SH*TH+TH*UH+UH*SH)/SH2 + QGTW=(SH*TH*UH)/SH**3 + RGTW=SQM3/SH + FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)* + & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)- + & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)- + & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+ + & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/ + & (QGTW*(QGTW-RGTW*PGTW)**4) + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG + ENDIF + + ELSEIF(ISUB.EQ.88) THEN +C...g + g -> chi_1c + g + PGTW=(SH*TH+TH*UH+UH*SH)/SH2 + QGTW=(SH*TH*UH)/SH**3 + RGTW=SQM3/SH + FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)* + & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+ + & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/ + & (QGTW-RGTW*PGTW)**4 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG + ENDIF + + ELSEIF(ISUB.EQ.89) THEN +C...g + g -> chi_2c + g + PGTW=(SH*TH+TH*UH+UH*SH)/SH2 + QGTW=(SH*TH*UH)/SH**3 + RGTW=SQM3/SH + FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)* + & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)- + & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+ + & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+ + & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2* + & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4) + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG + ENDIF + ENDIF + + ELSEIF(ISUB.LE.200) THEN + IF(ISUB.EQ.104) THEN +C...g + g -> chi_c0. + KC=PYCOMP(10441) + FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/ + & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2) + IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACBW + ENDIF + + ELSEIF(ISUB.EQ.105) THEN +C...g + g -> chi_c2. + KC=PYCOMP(445) + FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/ + & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2) + IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACBW + ENDIF + + ELSEIF(ISUB.EQ.106) THEN +C...g + g -> J/Psi + gamma. + EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0 + FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)* + & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/ + & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG + ENDIF + + ELSEIF(ISUB.EQ.107) THEN +C...g + gamma -> J/Psi + g. + EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0 + FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)* + & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/ + & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2 + IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG + ENDIF + IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG + ENDIF + + ELSEIF(ISUB.EQ.108) THEN +C...gamma + gamma -> J/Psi + gamma. + EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0 + FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)* + & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/ + & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2 + IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG + ENDIF + ENDIF + +C...QUARKONIA+++ +C...Additional code by Stefan Wolf + ELSE + +C...Common code for quarkonium production. + SHTH=SH+TH + THUH=TH+UH + UHSH=UH+SH + SHTH2=SHTH**2 + THUH2=THUH**2 + UHSH2=UHSH**2 + IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR. + & (ISUB.GE.431.AND.ISUB.LE.433)) THEN + SQMQQ=SQM3 + ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR. + & (ISUB.GE.434.AND.ISUB.LE.439)) THEN + SQMQQ=SQM4 + ENDIF + SQMQQR=SQRT(SQMQQ) + IF(MSTP(145).EQ.1) THEN + IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR. + & (ISUB.GE.431.AND.ISUB.LE.436)) THEN + AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2)) + BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2)) + ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ + ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ + BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ + BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ + ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR. + & ISUB.GE.437) THEN + AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2)) + BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2)) + ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ + ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ + BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ + BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ + ENDIF + AQ2=AQ**2 + BQ2=BQ**2 + SMQQ2=SQMQQ*VINT(2) +C...Polarisation frames + IF(MSTP(146).EQ.1) THEN +C...Recoil frame + POLH1=SQRT(AQ2-SMQQ2) + POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2)) + AZ=-SQMQQR/POLH1 + BZ=0D0 + AX=AQ*BQ/(POLH1*POLH2) + BX=-POLH1/POLH2 + ELSEIF(MSTP(146).EQ.2) THEN +C...Gottfried Jackson frame + POLH1=AQ+BQ + POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2)) + AZ=SQMQQR/POLH1 + BZ=AZ + AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2 + BX=(AQ2+AQ*BQ-SMQQ2)/POLH2 + ELSEIF(MSTP(146).EQ.3) THEN +C...Target frame + POLH1=AQ-BQ + POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2)) + AZ=-SQMQQR/POLH1 + BZ=-AZ + AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2 + BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2 + ELSEIF(MSTP(146).EQ.4) THEN +C...Collins Soper frame + POLH1=AQ2-BQ2 + POLH2=SQRT(VINT(2)*POLH1) + AZ=-BQ/POLH2 + BZ=AQ/POLH2 + AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2)) + BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2)) + ENDIF +C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta) + EL1K10=AZ*ATILK1+BZ*BTILK1 + EL1K20=AZ*ATILK2+BZ*BTILK2 + EL2K10=EL1K10 + EL2K20=EL1K20 + EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1) + EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2) + EL2K11=EL1K11 + EL2K21=EL1K21 + ENDIF + + IF(ISUB.EQ.421) THEN +C...g + g -> QQ~[3S11] + g + IF(MSTP(145).EQ.0) THEN +* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR* +* & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2) + FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR* + & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2 +* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR* +* & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2)) + ELSE + FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2 + AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0 + BB=2D0*(SH2+TH2) + CC=2D0*(SH2+UH2) + DD=2D0*SH2 + IF(MSTP(147).EQ.0) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20 + & +DD*(EL1K11*EL2K20+EL1K21*EL2K10)) + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+1) + ENDIF + + ELSEIF(ISUB.EQ.422) THEN +C...g + g -> QQ~[3S18] + g + IF(MSTP(145).EQ.0) THEN + FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)* + & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/ + & (SQMQQ*SQMQQR)* + & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2) + ELSE + FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/ + & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2) + AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0 + BB=2D0*(SH2+TH2) + CC=2D0*(SH2+UH2) + DD=2D0*SH2 + IF(MSTP(147).EQ.0) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20 + & +DD*(EL1K11*EL2K20+EL1K21*EL2K10)) + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF +C...Split total contribution into different colour flows just like +C...in g g -> g g (recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2 + FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2 + FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2 + FACGGS=FACGG1+FACGG2+FACGG3 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=3 + SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS + ENDIF + + ELSEIF(ISUB.EQ.423) THEN +C...g + g -> QQ~[1S08] + g + IF(MSTP(145).EQ.0) THEN +* FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)* +* & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)* +* & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/ +* & (SHTH2*THUH2*UHSH2) + FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR* + & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+ + & TH2/(SHTH2*THUH2))* + & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH)) + ELSE + FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR* + & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+ + & TH2/(SHTH2*THUH2))* + & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH)) + IF(MSTP(147).EQ.0) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=COMFAC*2D0*FA + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=0D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=0D0 + ENDIF + ENDIF +C...Split total contribution into different colour flows just like +C...in g g -> g g (recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2 + FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2 + FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2 + FACGGS=FACGG1+FACGG2+FACGG3 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=3 + SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS + ENDIF + + ELSEIF(ISUB.EQ.424) THEN +C...g + g -> QQ~[3PJ8] + g + POLY=SH2+SH*TH+TH2 + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4 + & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2 + & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5 + & +7D0*TH**6) + & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH + & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4 + & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7 + & +35D0*TH**8) + & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2 + & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4 + & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7 + & +84D0*TH**8) + & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH + & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4 + & +451D0*SH*TH**5+126D0*TH**6) + & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH + & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4 + & +171D0*SH*TH**5+42D0*TH**6) + & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH + & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4) + & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2 + & +99D0*SH*TH**3+35D0*TH**4) + & +7D0*SQMQQ**8*SHTH*POLY)/ + & (SH*TH*UH*SQMQQR*SQMQQ* + & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2) + ELSE + FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2 + & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2) + AA=SH*TH*UH*(SH*TH*SHTH*POLY**4 + & -SQMQQ*SHTH2*POLY**2* + & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4) + & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2 + & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5 + & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8) + & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2 + & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5 + & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8) + & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH + & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4 + & +145D0*SH*TH**5+34D0*TH**6) + & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2 + & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5 + & +44D0*TH**6) + & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH + & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4) + & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2) + & *(5D0*SH2+11D0*SH*TH+5D0*TH2) + & +3D0*SQMQQ**8*SHTH*POLY) + BB=4D0*SHTH2*POLY**3 + & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4) + & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2 + & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5 + & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8 + & +84D0*SH*TH**9+20D0*TH**10) + & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH + & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4 + & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7 + & +40D0*TH**8) + & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH + & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4 + & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7 + & +40D0*TH**8) + & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2 + & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5 + & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8) + & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2 + & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5 + & +4D0*TH**6) + & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH + & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4) + & +8D0*SQMQQ**7*SH*TH*SHTH*POLY + CC=4D0*TH2*POLY**3 + & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4) + & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2 + & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5 + & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8 + & +28D0*TH**9) + & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2 + & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5 + & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8 + & +394D0*SH*TH**9+84D0*TH**10) + & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2 + & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5 + & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8) + & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2 + & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5 + & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8) + & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2 + & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5 + & +266D0*SH*TH**6+84D0*TH**7) + & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2 + & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5 + & +28D0*TH**6) + & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2 + & +7D0*SH*TH**3+4*TH**4) + & +SQMQQ**8*SH*(SH-TH)**2*TH + DD=2D0*TH2*SHTH2*POLY**3 + & *(-SH2+2*SH*TH+2*TH2) + & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2 + & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5 + & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8 + & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11) + & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH + & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4 + & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7 + & -210D0*SH*TH**8-60D0*TH**9) + & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH + & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4 + & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7 + & -80D0*TH**8) + & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2 + & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5 + & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8) + & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2 + & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5 + & -30D0*SH*TH**6-24D0*TH**7) + & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2 + & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5 + & -4D0*TH**6) + & +4D0*SQMQQ**7*SH*TH*SHTH*POLY + IF(MSTP(147).EQ.0) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20 + & +DD*(EL1K11*EL2K20+EL1K21*EL2K10)) + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF +C...Split total contribution into different colour flows just like +C...in g g -> g g (recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2 + FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2 + FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2 + FACGGS=FACGG1+FACGG2+FACGG3 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=3 + SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS + ENDIF + + ELSEIF(ISUB.EQ.425) THEN +C...q + g -> q + QQ~[3S18] + IF(MSTP(145).EQ.0) THEN + FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)* + & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/ + & (SQMQQ*SQMQQR*SH*UH*UHSH2) + ELSE + FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/ + & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2) + AA=SHTH2+THUH2 + BB=4D0 + CC=8D0 + DD=4D0 + IF(MSTP(147).EQ.0) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20 + & +DD*(EL1K11*EL2K20+EL1K21*EL2K10)) + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF +C...Split total contribution into different colour flows just like +C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)] +C...(recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH + FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP + FACQGS=FACQG1+FACQG2 + DO 2442 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442 + DO 2441 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS + 2441 CONTINUE + 2442 CONTINUE + + ELSEIF(ISUB.EQ.426) THEN +C...q + g -> q + QQ~[1S08] + IF(MSTP(145).EQ.0) THEN + FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)* + & (SH2+UH2)/(SQMQQR*TH*UHSH2) + ELSE + FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2) + IF(MSTP(147).EQ.0) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=COMFAC*2D0*FA + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=0D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=0D0 + ENDIF + ENDIF +C...Split total contribution into different colour flows just like +C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)] +C...(recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH + FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP + FACQGS=FACQG1+FACQG2 + DO 2444 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444 + DO 2443 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS + 2443 CONTINUE + 2444 CONTINUE + + ELSEIF(ISUB.EQ.427) THEN +C...q + g -> q + QQ~[3PJ8] + IF(MSTP(145).EQ.0) THEN + FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)* + & ((7D0*UHSH+8D0*TH)*(SH2+UH2) + & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/ + & (SQMQQ*SQMQQR*TH*UHSH2*UHSH) + ELSE + FF=10D0*PARU(1)*AS**3/ + & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH) + AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2) + BB=8D0*(SHTH2+TH*UH) + CC=8D0*UHSH*(SHTH+THUH) + DD=4D0*(2D0*SQMQQ*SH+TH*UHSH) + IF(MSTP(147).EQ.0) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20 + & +DD*(EL1K11*EL2K20+EL1K21*EL2K10)) + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF +C...Split total contribution into different colour flows just like +C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)] +C...(recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH + FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP + FACQGS=FACQG1+FACQG2 + DO 2446 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446 + DO 2445 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS + 2445 CONTINUE + 2446 CONTINUE + + ELSEIF(ISUB.EQ.428) THEN +C...q + q~ -> g + QQ~[3S18] + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)* + & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/ + & (SQMQQ*SQMQQR*TH*UH*THUH2) + ELSE + FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/ + & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2) + AA=SHTH2+UHSH2 + BB=4D0 + CC=4D0 + DD=0D0 + IF(MSTP(147).EQ.0) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20 + & +DD*(EL1K11*EL2K20+EL1K21*EL2K10)) + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF +C...Split total contribution into different colour flows just like +C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)] +C...(recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACGG1=UH/TH-9D0/4D0*UH2/SH2 + FACGG2=TH/UH-9D0/4D0*TH2/SH2 + FACGGS=FACGG1+FACGG2 + DO 2447 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS + 2447 CONTINUE + + ELSEIF(ISUB.EQ.429) THEN +C...q + q~ -> g + QQ~[1S08] + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)* + & (TH2+UH2)/(SQMQQR*SH*THUH2) + ELSE + FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2) + IF(MSTP(147).EQ.0) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=COMFAC*2D0*FA + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=0D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=0D0 + ENDIF + ENDIF +C...Split total contribution into different colour flows just like +C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)] +C...(recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACGG1=UH/TH-9D0/4D0*UH2/SH2 + FACGG2=TH/UH-9D0/4D0*TH2/SH2 + FACGGS=FACGG1+FACGG2 + DO 2448 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS + 2448 CONTINUE + + ELSEIF(ISUB.EQ.430) THEN +C...q + q~ -> g + QQ~[3PJ8] + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)* + & ((7D0*THUH+8D0*SH)*(TH2+UH2) + & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/ + & (SQMQQ*SQMQQR*SH*THUH2*THUH) + ELSE + FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH) + AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2) + BB=8D0*(UHSH2+SH*TH) + CC=8D0*(SHTH2+SH*UH) + DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2) + IF(MSTP(147).EQ.0) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20 + & +DD*(EL1K10*EL2K20+EL1K20*EL2K10)) + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20 + & +DD*(EL1K11*EL2K20+EL1K21*EL2K10)) + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21 + & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF +C...Split total contribution into different colour flows just like +C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)] +C...(recalculate kinematics for massless partons). + THP=-0.5D0*SH*(1D0-CTH) + UHP=-0.5D0*SH*(1D0+CTH) + FACGG1=UH/TH-9D0/4D0*UH2/SH2 + FACGG2=TH/UH-9D0/4D0*TH2/SH2 + FACGGS=FACGG1+FACGG2 + DO 2449 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS + 2449 CONTINUE + + ELSEIF(ISUB.EQ.431) THEN +C...g + g -> QQ~[3P01] + g + PGTW=(SH*TH+TH*UH+UH*SH)/SH2 + QGTW=(SH*TH*UH)/SH**3 + RGTW=SQMQQ/SH + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)* + & (9D0*RGTW**2*PGTW**4* + & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2) + & -6D0*RGTW*PGTW**3*QGTW* + & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2) + & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2) + & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW) + & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4) + ELSE + FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)* + & (9D0*RGTW**2*PGTW**4* + & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2) + & -6D0*RGTW*PGTW**3*QGTW* + & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2) + & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2) + & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW) + & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4) + IF(MSTP(147).EQ.0) THEN + FACQQG=COMFAC*FC1 + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=COMFAC*2D0*FC1 + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=COMFAC*FC1 + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=COMFAC*FC1 + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=0D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=0D0 + ENDIF + ENDIF + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + ENDIF + + ELSEIF(ISUB.EQ.432) THEN +C...g + g -> QQ~[3P11] + g + PGTW=(SH*TH+TH*UH+UH*SH)/SH2 + QGTW=(SH*TH*UH)/SH**3 + RGTW=SQMQQ/SH + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)* + & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW) + & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2) + & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4 + ELSE + FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2 + C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2 + & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW + & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2 + & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5 + C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH) + & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH) + & *(PGTW**2-QGTW*(SH+2D0*UH)/SH)) + C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH) + & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH) + & *(PGTW**2-QGTW*(SH+2D0*TH)/SH)) + C4=-4D0*THUH*(TH-UH)**2* + & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH) + & -SH2*TH*UH*(TH2+UH2)) + & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2) + & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2) + & +SH2*(5D0*THUH2-17D0*TH*UH))) + IF(MSTP(147).EQ.0) THEN + FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20 + & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20 + & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0 + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20 + & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0 + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + ENDIF + + ELSEIF(ISUB.EQ.433) THEN +C...g + g -> QQ~[3P21] + g + PGTW=(SH*TH+TH*UH+UH*SH)/SH2 + QGTW=(SH*TH*UH)/SH**3 + RGTW=SQMQQ/SH + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)* + & (12D0*RGTW**2*PGTW**4* + & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2) + & -3D0*RGTW*PGTW**3*QGTW* + & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2) + & +2D0*PGTW**2*QGTW**2* + & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2) + & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW) + & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4) + ELSE + FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/ + & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2) + C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW) + & *SH*SH2**7 + C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH + & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH) + & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH) + & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2) + & +10D0*(SH2**2+TH2**2)) + & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH) + & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3 + & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2)) + & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH) + & +4D0*SH*TH*UH2**4*SHTH2) + C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH + & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH) + & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH) + & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2) + & +10D0*(SH2**2+UH2**2)) + & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH) + & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3 + & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2)) + & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH) + & +4D0*SH*UH*TH2**4*UHSH2) + C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3 + & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH) + & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2 + & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH) + & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH) + & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH + & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5)) + & -SH2**2*TH*UH*(114D0*TH**3*UH**3 + & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2) + & +3D0*(TH2**3+UH2**3))) + C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2 + & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2)) + C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2 + & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2)) + C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH) + & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2) + & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+ + & 82D0*TH**3) + & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2 + & +45D0*TH**3) + & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+ + & 8D0*TH**3) + & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2) + & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH) + & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH)) + C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH) + & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2) + & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+ + & 82D0*UH**3) + & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2 + & +45D0*UH**3) + & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+ + & 8D0*UH**3) + & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2) + & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH) + & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH)) + C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH + & +4D0*SH*TH2**2*UH2**2*THUH2 + & -SH2*TH**3*UH**3*THUH*(TH2+UH2) + & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2) + & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2)) + & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH) + & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))) + C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ + & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH) + & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH) + & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2 + & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2)) + & +SH**5*TH*UH*(-428D0*TH**3*UH**3 + & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2) + & +2D0*(TH2**3+UH2**3)) + & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2) + & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)) + & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2) + & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))) + IF(MSTP(147).EQ.0) THEN + FACQQG=1D0/3D0*(C1*3D0 + & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11) + & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21) + & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21) + & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2 + & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2 + & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11) + & *(EL1K10*EL2K20-EL1K11*EL2K21) + & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21) + & *(EL1K10*EL2K20-EL1K11*EL2K21) + & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11) + & *(EL1K20*EL2K20-EL1K21*EL2K21) + & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=C1*2D0 + & -C2*(EL1K10*EL2K10+EL1K11*EL2K11) + & -C3*(EL1K20*EL2K20+EL1K21*EL2K21) + & -C4*(EL1K10*EL2K20+EL1K11*EL2K21) + & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11 + & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21 + & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21 + & +EL1K10*EL2K20*EL1K11*EL2K11) + & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21 + & +EL1K10*EL2K20*EL1K21*EL2K21) + & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21 + & +C0*(EL1K10*EL2K10*EL1K21*EL2K21 + & +2D0*EL1K10*EL2K20*EL1K11*EL2K21 + & +EL1K20*EL2K20*EL1K11*EL2K11) + ELSEIF(MSTP(147).EQ.2) THEN + FACQQG=2D0*(C1 + & -C2*EL1K11*EL2K11 + & -C3*EL1K21*EL2K21 + & -C4*EL1K11*EL2K21 + & +C5*(EL1K11*EL2K11)**2 + & +C6*(EL1K21*EL2K21)**2 + & +C7*EL1K11*EL2K11*EL1K11*EL2K21 + & +C8*EL1K21*EL2K21*EL1K11*EL2K21 + & +(C9+C0)*(EL1K11*EL2K21)**2) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + ENDIF + + ELSEIF(ISUB.EQ.434) THEN +C...q + g -> q + QQ~[3P01] + IF(MSTP(145).EQ.0) THEN + FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)* + & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2) + ELSE + FA=-PARU(1)*AS**3*(16D0/243D0)* + & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2) + IF(MSTP(147).EQ.0) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=COMFAC*2D0*FA + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=0D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=0D0 + ENDIF + ENDIF + DO 2452 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452 + DO 2451 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + 2451 CONTINUE + 2452 CONTINUE + + ELSEIF(ISUB.EQ.435) THEN +C...q + g -> q + QQ~[3P11] + IF(MSTP(145).EQ.0) THEN + FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)* + & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2) + ELSE + FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2) + C1=SH*UH + C2=2D0*SH + C3=0D0 + C4=2D0*(SH-UH) + IF(MSTP(147).EQ.0) THEN + FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20 + & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20 + & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0 + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20 + & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0 + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF + DO 2454 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454 + DO 2453 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + 2453 CONTINUE + 2454 CONTINUE + + ELSEIF(ISUB.EQ.436) THEN +C...q + g -> q + QQ~[3P21] + IF(MSTP(145).EQ.0) THEN + FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)* + & ((6D0*SQMQQ**2+TH2)*UHSH2 + & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/ + & (SQMQQR*TH*UHSH2**2) + ELSE + FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2) + C1=TH*UHSH2 + C2=4D0*(SH2+TH2+2D0*TH*UHSH) + C3=4D0*UHSH2 + C4=8D0*SH*UHSH + C5=8D0*TH + C6=0D0 + C7=16D0*TH + C8=0D0 + C9=-16D0*UHSH + C0=16D0*SQMQQ + IF(MSTP(147).EQ.0) THEN + FACQQG=1D0/3D0*(C1*3D0 + & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11) + & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21) + & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21) + & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2 + & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2 + & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11) + & *(EL1K10*EL2K20-EL1K11*EL2K21) + & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21) + & *(EL1K10*EL2K20-EL1K11*EL2K21) + & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11) + & *(EL1K20*EL2K20-EL1K21*EL2K21) + & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=C1*2D0 + & -C2*(EL1K10*EL2K10+EL1K11*EL2K11) + & -C3*(EL1K20*EL2K20+EL1K21*EL2K21) + & -C4*(EL1K10*EL2K20+EL1K11*EL2K21) + & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11 + & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21 + & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21 + & +EL1K10*EL2K20*EL1K11*EL2K11) + & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21 + & +EL1K10*EL2K20*EL1K21*EL2K21) + & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21 + & +C0*(EL1K10*EL2K10*EL1K21*EL2K21 + & +2D0*EL1K10*EL2K20*EL1K11*EL2K21 + & +EL1K20*EL2K20*EL1K11*EL2K11) + ELSEIF(MSTP(147).EQ.2) THEN + FACQQG=2D0*(C1 + & -C2*EL1K11*EL2K11 + & -C3*EL1K21*EL2K21 + & -C4*EL1K11*EL2K21 + & +C5*(EL1K11*EL2K11)**2 + & +C6*(EL1K21*EL2K21)**2 + & +C7*EL1K11*EL2K11*EL1K11*EL2K21 + & +C8*EL1K21*EL2K21*EL1K11*EL2K21 + & +(C9+C0)*(EL1K11*EL2K21)**2) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF + DO 2456 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456 + DO 2455 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + 2455 CONTINUE + 2456 CONTINUE + + ELSEIF(ISUB.EQ.437) THEN +C...q + q~ -> g + QQ~[3P01] + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)* + & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2) + ELSE + FA=PARU(1)*AS**3*(128D0/729D0)* + & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2) + IF(MSTP(147).EQ.0) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=COMFAC*2D0*FA + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=COMFAC*FA + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=0D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=0D0 + ENDIF + ENDIF + DO 2457 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + 2457 CONTINUE + + ELSEIF(ISUB.EQ.438) THEN +C...q + q~ -> g + QQ~[3P11] + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0* + & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2) + ELSE + FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2) + C1=TH*UH + C2=2D0*UH + C3=2D0*TH + C4=2D0*THUH + IF(MSTP(147).EQ.0) THEN + FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20 + & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0) + ELSEIF(MSTP(147).EQ.3) THEN + FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20 + & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.4) THEN + FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0 + ELSEIF(MSTP(147).EQ.5) THEN + FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20 + & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0 + ELSEIF(MSTP(147).EQ.6) THEN + FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21 + & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0 + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF + DO 2458 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + 2458 CONTINUE + + ELSEIF(ISUB.EQ.439) THEN +C...q + q~ -> g + QQ~[3P21] + IF(MSTP(145).EQ.0) THEN + FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)* + & ((6D0*SQMQQ**2+SH2)*THUH2 + & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/ + & (SQMQQR*SH*THUH2**2) + ELSE + FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2) + C1=SH*THUH2 + C2=4D0*(SH2+UH2+2D0*SH*THUH) + C3=4D0*(SH2+TH2+2D0*SH*THUH) + C4=8D0*(SH2-TH*UH+2D0*SH*THUH) + C5=8D0*SH + C6=C5 + C7=16D0*SH + C8=C7 + C9=-16D0*THUH + C0=16D0*SQMQQ + IF(MSTP(147).EQ.0) THEN + FACQQG=1D0/3D0*(C1*3D0 + & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11) + & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21) + & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21) + & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2 + & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2 + & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11) + & *(EL1K10*EL2K20-EL1K11*EL2K21) + & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21) + & *(EL1K10*EL2K20-EL1K11*EL2K21) + & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11) + & *(EL1K20*EL2K20-EL1K21*EL2K21) + & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2) + ELSEIF(MSTP(147).EQ.1) THEN + FACQQG=C1*2D0 + & -C2*(EL1K10*EL2K10+EL1K11*EL2K11) + & -C3*(EL1K20*EL2K20+EL1K21*EL2K21) + & -C4*(EL1K10*EL2K20+EL1K11*EL2K21) + & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11 + & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21 + & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21 + & +EL1K10*EL2K20*EL1K11*EL2K11) + & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21 + & +EL1K10*EL2K20*EL1K21*EL2K21) + & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21 + & +C0*(EL1K10*EL2K10*EL1K21*EL2K21 + & +2D0*EL1K10*EL2K20*EL1K11*EL2K21 + & +EL1K20*EL2K20*EL1K11*EL2K11) + ELSEIF(MSTP(147).EQ.2) THEN + FACQQG=2D0*(C1 + & -C2*EL1K11*EL2K11 + & -C3*EL1K21*EL2K21 + & -C4*EL1K11*EL2K21 + & +C5*(EL1K11*EL2K11)**2 + & +C6*(EL1K21*EL2K21)**2 + & +C7*EL1K11*EL2K11*EL1K11*EL2K21 + & +C8*EL1K21*EL2K21*EL1K11*EL2K21 + & +(C9+C0)*(EL1K11*EL2K21)**2) + ENDIF + FACQQG=COMFAC*FF*FACQQG + ENDIF + DO 2459 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQG*PARP(IONIUM+5) + 2459 CONTINUE + ENDIF +C...QUARKONIA--- + + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSGWZ +C...Subprocess cross sections for W/Z processes, +C...except that longitudinal WW scattering is in Higgs sector. +C...Auxiliary to PYSIGH. + + SUBROUTINE PYSGWZ(NCHN,SIGS) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/ +C...Local arrays and complex numbers + DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3), + &HL4(3),HR4(3) + COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS + +C...Differential cross section expressions. + + IF(ISUB.LE.20) THEN + IF(ISUB.EQ.1) THEN +C...f + fbar -> gamma*/Z0 + MINT(61)=2 + CALL PYWIDT(23,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACZ=4D0*COMFAC*3D0 + HP0=AEM/3D0*SH + HP1=AEM/3D0*XWC*SH + DO 100 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + HI0=HP0 + IF(IABS(I).LE.10) HI0=HI0*FACA/3D0 + HI1=HP1 + IF(IABS(I).LE.10) HI1=HI1*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+ + & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)* + & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/ + & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)) + 100 CONTINUE + + ELSEIF(ISUB.EQ.2) THEN +C...f + fbar' -> W+/- + CALL PYWIDT(24,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0 + HP=AEM/(24D0*XW)*SH + DO 120 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120 + IA=IABS(I) + DO 110 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110 + JA=IABS(J) + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 110 + KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + HI=HP*2D0 + IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4)) + SIGH(NCHN)=HI*FACBW*HF + 110 CONTINUE + 120 CONTINUE + + ELSEIF(ISUB.EQ.15) THEN +C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only) + FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH) +C...gamma, gamma/Z interference and Z couplings to final fermion pairs + HFGG=0D0 + HFGZ=0D0 + HFZZ=0D0 + RADC4=1D0+PYALPS(SQM4)/PARU(1) + DO 130 I=1,MIN(16,MDCY(23,3)) + IDC=I+MDCY(23,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 130 + IMDM=0 + IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4) + & IMDM=1 + IF(I.LE.8) THEN + EF=KCHG(I,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ELSEIF(I.LE.16) THEN + EF=KCHG(I+2,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ENDIF + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4 + IF(4D0*RM1.LT.1D0) THEN + FCOF=1D0 + IF(I.LE.8) FCOF=3D0*RADC4 + BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(IMDM.EQ.1) THEN + HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34 + HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 + HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+ + & AF**2*(1D0-4D0*RM1))*BE34 + ENDIF + ENDIF + 130 CONTINUE +C...Propagators: as simulated in PYOFSH and as desired + HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) + MINT15=MINT(15) + MINT(15)=1 + MINT(61)=1 + CALL PYWIDT(23,SQM4,WDTP,WDTE) + MINT(15)=MINT15 + HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) + HFGG=HFGG*HFAEM*VINT(111)/SQM4 + HFGZ=HFGZ*HFAEM*VINT(112)/SQM4 + HFZZ=HFZZ*HFAEM*VINT(114)/SQM4 +C...Loop over flavours; consider full gamma/Z structure + DO 140 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+ + & (VI**2+AI**2)*HFZZ)/HBW4 + 140 CONTINUE + + ELSEIF(ISUB.EQ.16) THEN +C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only) + FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH) +C...Propagators: as simulated in PYOFSH and as desired + HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2) + CALL PYWIDT(24,SQM4,WDTP,WDTE) + GMMWC=SQRT(SQM4)*WDTP(0) + HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2) + FACWG=FACWG*HBW4C/HBW4 + DO 160 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160 + DO 150 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150 + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150 + KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0) + FCKM=VCKM((IA+1)/2,(JA+1)/2) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACWG*FCKM*WIDSC + 150 CONTINUE + 160 CONTINUE + + ELSEIF(ISUB.EQ.19) THEN +C...f + fbar -> gamma + (gamma*/Z0) + FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH) +C...gamma, gamma/Z interference and Z couplings to final fermion pairs + HFGG=0D0 + HFGZ=0D0 + HFZZ=0D0 + RADC4=1D0+PYALPS(SQM4)/PARU(1) + DO 170 I=1,MIN(16,MDCY(23,3)) + IDC=I+MDCY(23,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 170 + IMDM=0 + IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4) + & IMDM=1 + IF(I.LE.8) THEN + EF=KCHG(I,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ELSEIF(I.LE.16) THEN + EF=KCHG(I+2,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ENDIF + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4 + IF(4D0*RM1.LT.1D0) THEN + FCOF=1D0 + IF(I.LE.8) FCOF=3D0*RADC4 + BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(IMDM.EQ.1) THEN + HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34 + HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 + HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+ + & AF**2*(1D0-4D0*RM1))*BE34 + ENDIF + ENDIF + 170 CONTINUE +C...Propagators: as simulated in PYOFSH and as desired + HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) + MINT15=MINT(15) + MINT(15)=1 + MINT(61)=1 + CALL PYWIDT(23,SQM4,WDTP,WDTE) + MINT(15)=MINT15 + HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) + HFGG=HFGG*HFAEM*VINT(111)/SQM4 + HFGZ=HFGZ*HFAEM*VINT(112)/SQM4 + HFZZ=HFZZ*HFAEM*VINT(114)/SQM4 +C...Loop over flavours; consider full gamma/Z structure + DO 180 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + FCOI=1D0 + IF(IABS(I).LE.10) FCOI=FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+ + & (VI**2+AI**2)*HFZZ)/HBW4 + 180 CONTINUE + + ELSEIF(ISUB.EQ.20) THEN +C...f + fbar' -> gamma + W+/- + FACGW=COMFAC*0.5D0*AEM**2/XW +C...Propagators: as simulated in PYOFSH and as desired + HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2) + CALL PYWIDT(24,SQM4,WDTP,WDTE) + GMMWC=SQRT(SQM4)*WDTP(0) + HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2) + FACGW=FACGW*HBW4C/HBW4 +C...Anomalous couplings + TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH) + TERM2=0D0 + TERM3=0D0 + IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN + TERM2=RTCM(46)*(TH-UH)/(TH+UH) + TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/ + & (4D0*SQMW))/(TH+UH)**2 + ENDIF + DO 200 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200 + DO 190 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190 + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 190 + KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0) + IF(IA.LE.10) THEN + FACWR=UH/(TH+UH)-1D0/3D0 + FCKM=VCKM((IA+1)/2,(JA+1)/2) + FCOI=FACA/3D0 + ELSE + FACWR=-TH/(TH+UH) + FCKM=1D0 + FCOI=1D0 + ENDIF + FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC + 190 CONTINUE + 200 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.40) THEN + IF(ISUB.EQ.22) THEN +C...f + fbar -> (gamma*/Z0) + (gamma*/Z0) +C...Kinematics dependence + FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)- + & SQM3*SQM4*(1D0/TH2+1D0/UH2)) +C...gamma, gamma/Z interference and Z couplings to final fermion pairs + DO 220 I=1,6 + DO 210 J=1,3 + HGZ(I,J)=0D0 + 210 CONTINUE + 220 CONTINUE + RADC3=1D0+PYALPS(SQM3)/PARU(1) + RADC4=1D0+PYALPS(SQM4)/PARU(1) + DO 230 I=1,MIN(16,MDCY(23,3)) + IDC=I+MDCY(23,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 230 + IMDM=0 + IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1 + IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2 + IF(I.LE.8) THEN + EF=KCHG(I,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ELSEIF(I.LE.16) THEN + EF=KCHG(I+2,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ENDIF + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3 + IF(4D0*RM1.LT.1D0) THEN + FCOF=1D0 + IF(I.LE.8) FCOF=3D0*RADC3 + BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(IMDM.GE.1) THEN + HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34 + HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 + HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+ + & AF**2*(1D0-4D0*RM1))*BE34 + ENDIF + ENDIF + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4 + IF(4D0*RM1.LT.1D0) THEN + FCOF=1D0 + IF(I.LE.8) FCOF=3D0*RADC4 + BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(IMDM.GE.1) THEN + HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34 + HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 + HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+ + & AF**2*(1D0-4D0*RM1))*BE34 + ENDIF + ENDIF + 230 CONTINUE +C...Propagators: as simulated in PYOFSH and as desired + HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2) + HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) + MINT15=MINT(15) + MINT(15)=1 + MINT(61)=1 + CALL PYWIDT(23,SQM3,WDTP,WDTE) + MINT(15)=MINT15 + HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) + DO 240 J=1,3 + HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3 + HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3 + HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3 + 240 CONTINUE + MINT15=MINT(15) + MINT(15)=1 + MINT(61)=1 + CALL PYWIDT(23,SQM4,WDTP,WDTE) + MINT(15)=MINT15 + HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) + DO 250 J=1,3 + HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4 + HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4 + HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4 + 250 CONTINUE +C...Loop over flavours; separate left- and right-handed couplings + DO 270 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + VALI=VI-AI + VARI=VI+AI + FCOI=1D0 + IF(IABS(I).LE.10) FCOI=FACA/3D0 + DO 260 J=1,3 + HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J) + HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J) + HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J) + HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J) + 260 CONTINUE + FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+ + & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+ + & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+ + & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4) + 270 CONTINUE + + ELSEIF(ISUB.EQ.23) THEN +C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.) + FACZW=COMFAC*0.5D0*(AEM/XW)**2 + FACZW=FACZW*WIDS(23,2) + THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) + FACBW=1D0/((SH-SQMW)**2+GMMW**2) + DO 290 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290 + DO 280 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280 + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 280 + KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + EI=KCHG(IA,1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + EJ=KCHG(JA,1)/3D0 + AJ=SIGN(1D0,EJ+0.1D0) + VJ=AJ-4D0*EJ*XWV + IF(VI+AI.GT.0) THEN + VISAV=VI + AISAV=AI + VI=VJ + AI=AJ + VJ=VISAV + AJ=AISAV + ENDIF + FCKM=1D0 + IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) + FCOI=1D0 + IF(IA.LE.10) FCOI=FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+ + & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))* + & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+ + & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+ + & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))* + & WIDS(24,(5-KCHW)/2) +C***Protect against slightly negative cross sections. (Reason yet to be +C***sorted out. One possibility: addition of width to the W propagator.) + SIGH(NCHN)=MAX(0D0,SIGH(NCHN)) + 280 CONTINUE + 290 CONTINUE + + ELSEIF(ISUB.EQ.25) THEN +C...f + fbar -> W+ + W- +C...Propagators: Z0, W+- as simulated in PYOFSH and as desired + GMMZC=GMMZ + HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2) + HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2) + CALL PYWIDT(24,SQM3,WDTP,WDTE) + GMMW3=SQRT(SQM3)*WDTP(0) + HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2) + HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2) + CALL PYWIDT(24,SQM4,WDTP,WDTE) + GMMW4=SQRT(SQM4)*WDTP(0) + HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2) +C...Kinematical functions + THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) + THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4) + GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2 + GT=THUH34+4D0*THUH/TH2 + GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH + GU=THUH34+4D0*THUH/UH2 + GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH +C...Common factors and couplings + FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4) + FACWW=FACWW*WIDS(24,1) + CGG=AEM**2/2D0 + CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH) + CZZ=AEM**2/(32D0*XW**2)*HBWZC + CNG=AEM**2/(4D0*XW) + CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH) + CNN=AEM**2/(16D0*XW**2) +C...Coulomb factor for W+W- pair + IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN + COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1)) + COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH)) + IF(COULE.LT.100D0*PMAS(24,2)) THEN + COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+ + & PMAS(24,2)**2)-COULE)) + ELSE + COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE)) + ENDIF + IF(COULE.GT.-100D0*PMAS(24,2)) THEN + COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+ + & PMAS(24,2)**2)+COULE)) + ELSE + COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/ + & ABS(COULE))) + ENDIF + IF(MSTP(40).EQ.1) THEN + COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/ + & MAX(1D-10,2D0*COULP*COULP1)) + FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34) + ELSEIF(MSTP(40).EQ.2) THEN + COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2)) + COULCP=DCMPLX(0D0,DBLE(COULP)) + COULCD=(COULCK+COULCP)/(COULCK-COULCP) + COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/ + & (4D0*COULCP)*LOG(COULCD) + COULCS=DCMPLX(0D0,0D0) + NSTP=100 + DO 300 ISTP=1,NSTP + COULXX=(ISTP-0.5)/NSTP + COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/ + & (1D0+COULXX/COULCD)) + 300 CONTINUE + COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)* + & (COULCS/NSTP) + FACCOU=ABS(COULCR)**2 + ELSEIF(MSTP(40).EQ.3) THEN + COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+ + & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1)) + FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34) + ENDIF + ELSEIF(MSTP(40).EQ.4) THEN + FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34) + ELSE + FACCOU=1D0 + ENDIF + VINT(95)=FACCOU + FACWW=FACWW*FACCOU +C...Loop over allowed flavours + DO 310 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + FCOI=1D0 + IF(IABS(I).LE.10) FCOI=FACA/3D0 + IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN + IF(AI.LT.0D0) THEN + DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+ + & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT + ELSE + DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS- + & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU + ENDIF + ELSE + XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH + BET=SQRT(1D0-4D0*XMW02/SH) + GAT=1D0/SQRT(1D0-BET**2) + STHE2=1D0-CTH**2 + AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2) + AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+ + & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2) + AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+ + & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/ + & (1D0-2D0*BET*CTH+BET**2)) + PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH) + PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC + A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL + A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL + A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0 + ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG + ATOT=ATOT*CNN/SQMW*SH/BET*2D0 + DSIGWW=ATOT + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACWW*FCOI*DSIGWW + 310 CONTINUE + + ELSEIF(ISUB.EQ.30) THEN +C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only) + FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/ + & (-SH*UH) +C...gamma, gamma/Z interference and Z couplings to final fermion pairs + HFGG=0D0 + HFGZ=0D0 + HFZZ=0D0 + RADC4=1D0+PYALPS(SQM4)/PARU(1) + DO 320 I=1,MIN(16,MDCY(23,3)) + IDC=I+MDCY(23,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 320 + IMDM=0 + IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4) + & IMDM=1 + IF(I.LE.8) THEN + EF=KCHG(I,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ELSEIF(I.LE.16) THEN + EF=KCHG(I+2,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ENDIF + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4 + IF(4D0*RM1.LT.1D0) THEN + FCOF=1D0 + IF(I.LE.8) FCOF=3D0*RADC4 + BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(IMDM.EQ.1) THEN + HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34 + HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 + HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+ + & AF**2*(1D0-4D0*RM1))*BE34 + ENDIF + ENDIF + 320 CONTINUE +C...Propagators: as simulated in PYOFSH and as desired + HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) + MINT15=MINT(15) + MINT(15)=1 + MINT(61)=1 + CALL PYWIDT(23,SQM4,WDTP,WDTE) + MINT(15)=MINT15 + HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) + HFGG=HFGG*HFAEM*VINT(111)/SQM4 + HFGZ=HFGZ*HFAEM*VINT(112)/SQM4 + HFZZ=HFZZ*HFAEM*VINT(114)/SQM4 +C...Loop over flavours; consider full gamma/Z structure + DO 340 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+ + & (VI**2+AI**2)*HFZZ)/HBW4 + DO 330 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZQ + 330 CONTINUE + 340 CONTINUE + + ELSEIF(ISUB.EQ.31) THEN +C...f + g -> f' + W+/- (q + g -> q' + W+/- only) + FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0* + & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH) +C...Propagators: as simulated in PYOFSH and as desired + HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2) + CALL PYWIDT(24,SQM4,WDTP,WDTE) + GMMWC=SQRT(SQM4)*WDTP(0) + HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2) + FACWQ=FACWQ*HBW4C/HBW4 + DO 360 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360 + IA=IABS(I) + KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I)) + WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0) + DO 350 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC + 350 CONTINUE + 360 CONTINUE + + ELSEIF(ISUB.EQ.35) THEN +C...f + gamma -> f + (gamma*/Z0) + IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN + FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH + FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2) + ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN + FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH + FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2) + ELSE + FZQN=SH2+UH2+2D0*SQM4*TH + FZQDTM=-SH*UH + ENDIF + FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN) +C...gamma, gamma/Z interference and Z couplings to final fermion pairs + HFGG=0D0 + HFGZ=0D0 + HFZZ=0D0 + RADC4=1D0+PYALPS(SQM4)/PARU(1) + DO 370 I=1,MIN(16,MDCY(23,3)) + IDC=I+MDCY(23,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 370 + IMDM=0 + IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4) + & IMDM=1 + IF(I.LE.8) THEN + EF=KCHG(I,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ELSEIF(I.LE.16) THEN + EF=KCHG(I+2,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + ENDIF + RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4 + IF(4D0*RM1.LT.1D0) THEN + FCOF=1D0 + IF(I.LE.8) FCOF=3D0*RADC4 + BE34=SQRT(MAX(0D0,1D0-4D0*RM1)) + IF(IMDM.EQ.1) THEN + HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34 + HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34 + HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+ + & AF**2*(1D0-4D0*RM1))*BE34 + ENDIF + ENDIF + 370 CONTINUE +C...Propagators: as simulated in PYOFSH and as desired + HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2) + MINT15=MINT(15) + MINT(15)=1 + MINT(61)=1 + CALL PYWIDT(23,SQM4,WDTP,WDTE) + MINT(15)=MINT15 + HFAEM=(PARU(108)/PARU(2))*(2D0/3D0) + HFGG=HFGG*HFAEM*VINT(111)/SQM4 + HFGZ=HFGZ*HFAEM*VINT(112)/SQM4 + HFZZ=HFZZ*HFAEM*VINT(114)/SQM4 +C...Loop over flavours; consider full gamma/Z structure + DO 390 I=MMINA,MMAXA + IF(I.EQ.0) GOTO 390 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+ + & (VI**2+AI**2)*HFZZ)/HBW4 + FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM) + DO 380 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZQ*FZQN/FZQD + 380 CONTINUE + 390 CONTINUE + + ELSEIF(ISUB.EQ.36) THEN +C...f + gamma -> f' + W+/- + FWQ=COMFAC*AEM**2/(2D0*XW)* + & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH) +C...Propagators: as simulated in PYOFSH and as desired + HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2) + CALL PYWIDT(24,SQM4,WDTP,WDTE) + GMMWC=SQRT(SQM4)*WDTP(0) + HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2) + FWQ=FWQ*HBW4C/HBW4 + DO 410 I=MMINA,MMAXA + IF(I.EQ.0) GOTO 410 + IA=IABS(I) + EIA=ABS(KCHG(IABS(I),1)/3D0) + FACWQ=FWQ*(EIA-SH/(SH+UH))**2 + KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I)) + WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0) + DO 400 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC + 400 CONTINUE + 410 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.100) THEN + IF(ISUB.EQ.69) THEN +C...gamma + gamma -> W+ + W- + SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4)) + FPROP=SH2/((SQMWE-TH)*(SQMWE-UH)) + FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+ + & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1) + IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420 + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACWW + 420 CONTINUE + + ELSEIF(ISUB.EQ.70) THEN +C...gamma + W+/- -> Z0 + W+/- + SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4)) + FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH)) + FACZW=COMFAC*6D0*AEM**2*(XW1/XW)* + & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+ + & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2) + DO 440 KCHW=1,-1,-2 + DO 430 ISDE=1,2 + IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=22 + ISIG(NCHN,3-ISDE)=24*KCHW + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2) + 430 CONTINUE + 440 CONTINUE + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSGHG +C...Subprocess cross sections for Higgs processes, +C...except Higgs pairs in PYSGSU, but including WW scattering. +C...Auxiliary to PYSIGH. + + SUBROUTINE PYSGHG(NCHN,SIGS) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/, + &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/ +C...Local arrays and complex variables + DIMENSION WDTP(0:400),WDTE(0:400,0:5) + COMPLEX*16 A004,A204,A114,A00U,A20U,A11U + COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF + +C...Convert H or A process into equivalent h one + IHIGG=1 + KFHIGG=25 + IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN + KFHIGG=KFPR(ISUB,1) + END IF + IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND. + &ISUB.LE.190)) THEN + IHIGG=2 + IF(MOD(ISUB-1,10).GE.5) IHIGG=3 + KFHIGG=33+IHIGG + IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3 + IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102 + IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103 + IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24 + IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26 + IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123 + IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124 + IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121 + IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122 + IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111 + IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112 + IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113 + ENDIF + SQMH=PMAS(KFHIGG,1)**2 + GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2) + +C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron + IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ. + &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN +C...Calculate M_R and N_R functions for Higgs-like and QCD-like models + IF(MSTP(46).LE.4) THEN + HDTLH=LOG(PMAS(25,1)/PARP(44)) + HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0 + HDTNR=-1D0/18D0+HDTLH/6D0 + ELSE + HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2) + HDTLQ=LOG(PARP(45)/PARP(44)) + HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0 + HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0 + ENDIF + +C...Calculate lowest and next-to-lowest order partial wave amplitudes + HDTV=1D0/(16D0*PARU(1)*PARP(47)**2) + A00L=DBLE(HDTV*SH) + A20L=-0.5D0*A00L + A11L=A00L/6D0 + HDTLS=LOG(SH/PARP(44)**2) + A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))* + & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0- + & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1))) + A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))* + & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0- + & (20D0/9D0)*HDTLS),DBLE(PARU(1))) + A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))* + & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0)) + +C...Unitarize partial wave amplitudes with Pade or K-matrix method + IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN + A00U=A00L/(1D0-A004/A00L) + A20U=A20L/(1D0-A204/A20L) + A11U=A11L/(1D0-A114/A11L) + ELSE + A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004))) + A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204))) + A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114))) + ENDIF + ENDIF + +C...Differential cross section expressions. + + IF(ISUB.LE.60) THEN + IF(ISUB.EQ.3) THEN +C...f + fbar -> h0 (or H0, or A0) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) + & FACBW=0D0 + HP=AEM/(8D0*XW)*SH/SQMW*SH + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + DO 100 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100 + IA=IABS(I) + RMQ=PYMRUN(IA,SH)**2/SH + HI=HP*RMQ + IF(IA.LE.10) HI=HP*RMQ*FACA/3D0 + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN + IKFI=1 + IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2 + IF(IA.GT.10) IKFI=3 + HI=HI*PARU(150+10*IHIGG+IKFI)**2 + IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN + HI=HI/(1D0+RMSS(41))**2 + IF(IHIGG.NE.3) THEN + HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/ + & PARU(151+10*IHIGG))**2 + ENDIF + ENDIF + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 100 CONTINUE + + ELSEIF(ISUB.EQ.5) THEN +C...Z0 + Z0 -> h0 + CALL PYWIDT(25,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0 + HP=AEM/(8D0*XW)*SH/SQMW*SH + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + HI=HP/4D0 + FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2 + DO 120 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120 + DO 110 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + EJ=KCHG(IABS(J),1)/3D0 + AJ=SIGN(1D0,EJ) + VJ=AJ-4D0*EJ*XWV + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF + 110 CONTINUE + 120 CONTINUE + + ELSEIF(ISUB.EQ.8) THEN +C...W+ + W- -> h0 + CALL PYWIDT(25,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0 + HP=AEM/(8D0*XW)*SH/SQMW*SH + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + HI=HP/2D0 + FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2 + DO 140 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140 + EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1) + DO 130 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130 + EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1) + IF(EI*EJ.GT.0D0) GOTO 130 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF + 130 CONTINUE + 140 CONTINUE + + ELSEIF(ISUB.EQ.24) THEN +C...f + fbar -> Z0 + h0 (or H0, or A0) +C...Propagators: Z0, h0 as simulated in PYOFSH and as desired + HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2) + CALL PYWIDT(23,SQM3,WDTP,WDTE) + GMMZ3=SQRT(SQM3)*WDTP(0) + HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2) + HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) + CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE) + GMMH4=SQRT(SQM4)*WDTP(0) + HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2) + THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) + FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2* + & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2) + FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2) + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ* + & PARU(154+10*IHIGG)**2 + DO 150 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + FCOI=1D0 + IF(IABS(I).LE.10) FCOI=FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2) + 150 CONTINUE + + ELSEIF(ISUB.EQ.26) THEN +C...f + fbar' -> W+/- + h0 (or H0, or A0) +C...Propagators: W+-, h0 as simulated in PYOFSH and as desired + HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2) + CALL PYWIDT(24,SQM3,WDTP,WDTE) + GMMW3=SQRT(SQM3)*WDTP(0) + HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2) + HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) + CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE) + GMMH4=SQRT(SQM4)*WDTP(0) + HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2) + THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2) + FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/ + & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4) + FACHW=FACHW*WIDS(KFHIGG,2) + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW* + & PARU(155+10*IHIGG)**2 + DO 170 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170 + DO 160 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160 + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 160 + KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + FCKM=1D0 + IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) + FCOI=1D0 + IF(IA.LE.10) FCOI=FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2) + 160 CONTINUE + 170 CONTINUE + + ELSEIF(ISUB.EQ.32) THEN +C...f + g -> f + h0 (q + g -> q + h0 only) + FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0 +C...H propagator: as simulated in PYOFSH and as desired + SQMHC=PMAS(25,1)**2 + GMMHC=PMAS(25,1)*PMAS(25,2) + HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2) + CALL PYWIDT(25,SQM4,WDTP,WDTE) + GMMHCC=SQRT(SQM4)*WDTP(0) + HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2) + FHCQ=FHCQ*HBW4C/HBW4 + DO 190 I=MMINA,MMAXA + IA=IABS(I) + IF(IA.NE.5) GOTO 190 + SQML=PYMRUN(IA,SH)**2 + SQMQ=PMAS(IA,1)**2 + FACHCQ=FHCQ*SQML/SQMW* + & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH- + & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)* + & (SQM4-SQMQ-SH)/SH) + DO 180 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACHCQ*WIDS(25,2) + 180 CONTINUE + 190 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.80) THEN + IF(ISUB.EQ.71) THEN +C...Z0 + Z0 -> Z0 + Z0 + IF(SH.LE.4.01D0*SQMZ) GOTO 220 + + IF(MSTP(46).LE.2) THEN +C...Exact scattering ME:s for on-mass-shell gauge bosons + BE2=1D0-4D0*SQMZ/SH + TH=-0.5D0*SH*BE2*(1D0-CTH) + UH=-0.5D0*SH*BE2*(1D0+CTH) + IF(MAX(TH,UH).GT.-1D0) GOTO 220 + SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2 + ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG + ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG + THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2 + ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG + ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG + UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2 + AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG + AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG + FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)* + & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2 + IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2) + IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+ + & (ASHIM+ATHIM+AUHIM)**2) + IF(MSTP(46).EQ.2) FACZZ=0D0 + + ELSE +C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron + FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)* + & ABS(A00U+2D0*A20U)**2 + ENDIF + FACZZ=FACZZ*WIDS(23,1) + + DO 210 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + AVI=AI**2+VI**2 + DO 200 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200 + EJ=KCHG(IABS(J),1)/3D0 + AJ=SIGN(1D0,EJ) + VJ=AJ-4D0*EJ*XWV + AVJ=AJ**2+VJ**2 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ + 200 CONTINUE + 210 CONTINUE + 220 CONTINUE + + ELSEIF(ISUB.EQ.72) THEN +C...Z0 + Z0 -> W+ + W- + IF(SH.LE.4.01D0*SQMZ) GOTO 250 + + IF(MSTP(46).LE.2) THEN +C...Exact scattering ME:s for on-mass-shell gauge bosons + BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH)) + CTH2=CTH**2 + TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH) + UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH) + IF(MAX(TH,UH).GT.-1D0) GOTO 250 + SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)* + & (1D0-2D0*SQMZ/SH) + ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG + ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG + ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0* + & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0* + & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2* + & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+ + & 2D0*(SQMW+SQMZ)/SH*BE2*CTH)) + ATWIM=0D0 + AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0* + & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0* + & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2* + & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2- + & 2D0*(SQMW+SQMZ)/SH*BE2*CTH)) + AUWIM=0D0 + A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH) + A4IM=0D0 + FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)* + & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2 + IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2) + IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+ + & (ASHIM+ATWIM+AUWIM+A4IM)**2) + IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+ + & (ATWIM+AUWIM+A4IM)**2) + + ELSE +C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron + FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)* + & ABS(A00U-A20U)**2 + ENDIF + FACWW=FACWW*WIDS(24,1) + + DO 240 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + AVI=AI**2+VI**2 + DO 230 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230 + EJ=KCHG(IABS(J),1)/3D0 + AJ=SIGN(1D0,EJ) + VJ=AJ-4D0*EJ*XWV + AVJ=AJ**2+VJ**2 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACWW*AVI*AVJ + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + + ELSEIF(ISUB.EQ.73) THEN +C...Z0 + W+/- -> Z0 + W+/- + IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280 + + IF(MSTP(46).LE.2) THEN +C...Exact scattering ME:s for on-mass-shell gauge bosons + BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2 + EP1=1D0-(SQMZ-SQMW)/SH + EP2=1D0+(SQMZ-SQMW)/SH + TH=-0.5D0*SH*BE2*(1D0-CTH) + UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH) + IF(MAX(TH,UH).GT.-1D0) GOTO 280 + THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH) + ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG + ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG + ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+ + & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+ + & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH- + & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2) + ASWIM=0D0 + AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)* + & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)* + & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)- + & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0* + & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+ + & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2* + & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)* + & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)* + & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2* + & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2* + & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW* + & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2) + AUWIM=0D0 + A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)- + & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2) + A4IM=0D0 + FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4* + & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2 + IF(MSTP(46).LE.0) FACZW=0D0 + IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+ + & (ATHIM+ASWIM+AUWIM+A4IM)**2) + IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+ + & (ASWIM+AUWIM+A4IM)**2) + + ELSE +C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron + FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0* + & ABS(A20U+3D0*A11U*DBLE(CTH))**2 + ENDIF + FACZW=FACZW*WIDS(23,2) + + DO 270 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + AVI=AI**2+VI**2 + KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I)) + DO 260 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260 + EJ=KCHG(IABS(J),1)/3D0 + AJ=SIGN(1D0,EJ) + VJ=AI-4D0*EJ*XWV + AVJ=AJ**2+VJ**2 + KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J)) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ + 260 CONTINUE + 270 CONTINUE + 280 CONTINUE + + ELSEIF(ISUB.EQ.75) THEN +C...W+ + W- -> gamma + gamma + + ELSEIF(ISUB.EQ.76) THEN +C...W+ + W- -> Z0 + Z0 + IF(SH.LE.4.01D0*SQMZ) GOTO 310 + + IF(MSTP(46).LE.2) THEN +C...Exact scattering ME:s for on-mass-shell gauge bosons + BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH)) + CTH2=CTH**2 + TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH) + UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH) + IF(MAX(TH,UH).GT.-1D0) GOTO 310 + SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)* + & (1D0-2D0*SQMZ/SH) + ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG + ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG + ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0* + & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0* + & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2* + & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+ + & 2D0*(SQMW+SQMZ)/SH*BE2*CTH)) + ATWIM=0D0 + AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0* + & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0* + & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2* + & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2- + & 2D0*(SQMW+SQMZ)/SH*BE2*CTH)) + AUWIM=0D0 + A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH) + A4IM=0D0 + FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4* + & (SH/SQMW)**2*SH2 + IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2) + IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+ + & (ASHIM+ATWIM+AUWIM+A4IM)**2) + IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+ + & (ATWIM+AUWIM+A4IM)**2) + + ELSE +C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron + FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)* + & ABS(A00U-A20U)**2 + ENDIF + FACZZ=FACZZ*WIDS(23,1) + + DO 300 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300 + EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1) + DO 290 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290 + EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1) + IF(EI*EJ.GT.0D0) GOTO 290 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J) + 290 CONTINUE + 300 CONTINUE + 310 CONTINUE + + ELSEIF(ISUB.EQ.77) THEN +C...W+/- + W+/- -> W+/- + W+/- + IF(SH.LE.4.01D0*SQMW) GOTO 340 + + IF(MSTP(46).LE.2) THEN +C...Exact scattering ME:s for on-mass-shell gauge bosons + BE2=1D0-4D0*SQMW/SH + BE4=BE2**2 + CTH2=CTH**2 + CTH3=CTH**3 + TH=-0.5D0*SH*BE2*(1D0-CTH) + UH=-0.5D0*SH*BE2*(1D0+CTH) + IF(MAX(TH,UH).GT.-1D0) GOTO 340 + SHANG=(1D0+BE2)**2 + ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG + ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG + THANG=(BE2-CTH)**2 + ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG + ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG + UHANG=(BE2+CTH)**2 + AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG + AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG + SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH + ASGRE=XW*SGZANG + ASGIM=0D0 + ASZRE=XW1*SH/(SH-SQMZ)*SGZANG + ASZIM=0D0 + TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+ + & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3) + ATGRE=0.5D0*XW*SH/TH*TGZANG + ATGIM=0D0 + ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG + ATZIM=0D0 + UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+ + & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3) + AUGRE=0.5D0*XW*SH/UH*UGZANG + AUGIM=0D0 + AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG + AUZIM=0D0 + A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2) + A4AIM=0D0 + A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2) + A4SIM=0D0 + FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4* + & (SH/SQMW)**2*SH2 + IF(MSTP(46).LE.0) THEN + AWWARE=ASHRE + AWWAIM=ASHIM + AWWSRE=0D0 + AWWSIM=0D0 + ELSEIF(MSTP(46).EQ.1) THEN + AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE + AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM + AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE + AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM + ELSE + AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE + AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM + AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE + AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM + ENDIF + AWWA2=AWWARE**2+AWWAIM**2 + AWWS2=AWWSRE**2+AWWSIM**2 + + ELSE +C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron + FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)* + & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2 + FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2 + ENDIF + + DO 330 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330 + EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1) + DO 320 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320 + EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1) + IF(EI*EJ.LT.0D0) THEN +C...W+W- + IF(MSTP(45).EQ.1) GOTO 320 + IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1) + IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1) + ELSE +C...W+W+/W-W- + IF(MSTP(45).EQ.2) GOTO 320 + IF(MSTP(46).LE.2) FACWW=FWW*AWWS2 + IF(MSTP(46).GE.3) FACWW=FWWS + IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4) + IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5) + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J) + IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN) + 320 CONTINUE + 330 CONTINUE + 340 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.120) THEN + IF(ISUB.EQ.102) THEN +C...g + g -> h0 (or H0, or A0) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + 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 +C...PS: Only use fixed-width when using SLHA decay table for this Higgs + IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN + WDTP13=0D0 + DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1 + IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND. + & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC) + 345 CONTINUE + IF(WDTP13.EQ.0D0) CALL PYERRM(26, + & '(PYSGHG:) did not find Higgs -> g g channel') + HI=SHR*WDTP13/32D0 + ELSE + HI=SHR*WDTP(13)/32D0 + ENDIF + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 350 CONTINUE + + ELSEIF(ISUB.EQ.103) THEN +C...gamma + gamma -> h0 (or H0, or A0) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + 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 +C...PS: Only use fixed-width when using SLHA decay table for this Higgs + IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN + WDTP14=0D0 + DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1 + IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND. + & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC) + 355 CONTINUE + IF(WDTP14.EQ.0D0) CALL PYERRM(26, + & '(PYSGHG:) did not find Higgs -> gamma gamma channel') + HI=SHR*WDTP14*2D0 + ELSE + HI=SHR*WDTP(14)*2D0 + ENDIF + IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360 + NCHN=NCHN+1 + ISIG(NCHN,1)=22 + ISIG(NCHN,2)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 360 CONTINUE + + ELSEIF(ISUB.EQ.110) THEN +C...f + fbar -> gamma + h0 + THUH=MAX(TH*UH,SH*CKIN(3)**2) + FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH + FACHG=FACHG*WIDS(KFHIGG,2) +C...Calculate loop contributions for intermediate gamma* and Z0 + CIGTOT=DCMPLX(0D0,0D0) + CIZTOT=DCMPLX(0D0,0D0) + JMAX=3*MSTP(1)+1 + DO 370 J=1,JMAX + IF(J.LE.2*MSTP(1)) THEN + FNC=1D0 + EJ=KCHG(J,1)/3D0 + AJ=SIGN(1D0,EJ+0.1D0) + VJ=AJ-4D0*EJ*XWV + BALP=SQM4/(2D0*PMAS(J,1))**2 + BBET=SH/(2D0*PMAS(J,1))**2 + ELSEIF(J.LE.3*MSTP(1)) THEN + FNC=3D0 + JL=2*(J-2*MSTP(1))-1 + EJ=KCHG(10+JL,1)/3D0 + AJ=SIGN(1D0,EJ+0.1D0) + VJ=AJ-4D0*EJ*XWV + BALP=SQM4/(2D0*PMAS(10+JL,1))**2 + BBET=SH/(2D0*PMAS(10+JL,1))**2 + ELSE + BALP=SQM4/(2D0*PMAS(24,1))**2 + BBET=SH/(2D0*PMAS(24,1))**2 + ENDIF + BABI=1D0/(BALP-BBET) + IF(BALP.LT.1D0) THEN + F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0) + F1ALP=F0ALP**2 + ELSE + F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))), + & -DBLE(0.5D0*PARU(1))) + F1ALP=-F0ALP**2 + ENDIF + F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP + IF(BBET.LT.1D0) THEN + F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0) + F1BET=F0BET**2 + ELSE + F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))), + & -DBLE(0.5D0*PARU(1))) + F1BET=-F0BET**2 + ENDIF + F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET + IF(J.LE.3*MSTP(1)) THEN + FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+ + & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP)) + CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF + CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF + ELSE + TXW=XW/XW1 + CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)* + & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+ + & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP))) + CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP* + & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+ + & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))* + & (F1BET-F1ALP)) + ENDIF + 370 CONTINUE + CIGTOT=CIGTOT/DBLE(SH) + CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ)) +C...Loop over initial flavours + DO 380 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + FCOI=1D0 + IF(IABS(I).LE.10) FCOI=FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)* + & CIZTOT)**2+AI**2*ABS(CIZTOT)**2) + 380 CONTINUE + + ELSEIF(ISUB.EQ.111) THEN +C...f + fbar -> g + h0 (q + qbar -> g + h0 only) + IF(MSTP(38).NE.0) THEN +C...Simple case: only do gg <-> h exactly. + CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE) +C...PS: Only use fixed-width when using SLHA decay table for this Higgs + IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN + WDTP13=0D0 + DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1 + IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND. + & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC) + 385 CONTINUE + IF(WDTP13.EQ.0D0) CALL PYERRM(26, + & '(PYSGHG:) did not find Higgs -> g g channel') + FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))* + & (TH**2+UH**2)/(SH*SQM4) + ELSE + FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))* + & (TH**2+UH**2)/(SH*SQM4) + ENDIF +C...Propagators: as simulated in PYOFSH and as desired + HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) + GMMHC=SQRT(SQM4)*WDTP(0) + HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/ + & ((SQM4-SQMH)**2+GMMHC**2) + FACGH=FACGH*HBW4C/HBW4 + ELSE +C...Messy case: do full loop integrals + A5STUR=0D0 + A5STUI=0D0 + DO 390 I=1,2*MSTP(1) + SQMQ=PMAS(I,1)**2 + EPSS=4D0*SQMQ/SH + EPSH=4D0*SQMQ/SQMH + CALL PYWAUX(1,EPSS,W1SR,W1SI) + CALL PYWAUX(1,EPSH,W1HR,W1HI) + CALL PYWAUX(2,EPSS,W2SR,W2SI) + CALL PYWAUX(2,EPSH,W2HR,W2HI) + A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+ + & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR)) + A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+ + & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI)) + 390 CONTINUE + FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW* + & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2) + FACGH=FACGH*WIDS(25,2) + ENDIF + DO 400 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGH + 400 CONTINUE + + ELSEIF(ISUB.EQ.112) THEN +C...f + g -> f + h0 (q + g -> q + h0 only) + IF(MSTP(38).NE.0) THEN +C...Simple case: only do gg <-> h exactly. + CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE) +C...PS: Only use fixed-width when using SLHA decay table for this Higgs + IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN + WDTP13=0D0 + DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1 + IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND. + & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC) + 405 CONTINUE + IF(WDTP13.EQ.0D0) CALL PYERRM(26, + & '(PYSGHG:) did not find Higgs -> g g channel') + FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))* + & (SH**2+UH**2)/(-TH*SQM4) + ELSE + FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))* + & (SH**2+UH**2)/(-TH*SQM4) + ENDIF +C...Propagators: as simulated in PYOFSH and as desired + HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) + GMMHC=SQRT(SQM4)*WDTP(0) + HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/ + & ((SQM4-SQMH)**2+GMMHC**2) + FACQH=FACQH*HBW4C/HBW4 + ELSE +C...Messy case: do full loop integrals + A5TSUR=0D0 + A5TSUI=0D0 + DO 410 I=1,2*MSTP(1) + SQMQ=PMAS(I,1)**2 + EPST=4D0*SQMQ/TH + EPSH=4D0*SQMQ/SQMH + CALL PYWAUX(1,EPST,W1TR,W1TI) + CALL PYWAUX(1,EPSH,W1HR,W1HI) + CALL PYWAUX(2,EPST,W2TR,W2TI) + CALL PYWAUX(2,EPSH,W2HR,W2HI) + A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+ + & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR)) + A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+ + & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI)) + 410 CONTINUE + FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW* + & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2) + FACQH=FACQH*WIDS(25,2) + ENDIF + DO 430 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430 + DO 420 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQH + 420 CONTINUE + 430 CONTINUE + + ELSEIF(ISUB.EQ.113) THEN +C...g + g -> g + h0 + IF(MSTP(38).NE.0) THEN +C...Simple case: only do gg <-> h exactly. + CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE) +C...PS: Only use fixed-width when using SLHA decay table for this Higgs + IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN + WDTP13=0D0 + DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1 + IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND. + & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC) + 435 CONTINUE + IF(WDTP13.EQ.0D0) CALL PYERRM(26, + & '(PYSGHG:) did not find Higgs -> g g channel') + FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))* + & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4) + ELSE + FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))* + & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4) + ENDIF +C...Propagators: as simulated in PYOFSH and as desired + HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) + GMMHC=SQRT(SQM4)*WDTP(0) + HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/ + & ((SQM4-SQMH)**2+GMMHC**2) + FACGH=FACGH*HBW4C/HBW4 + ELSE +C...Messy case: do full loop integrals + A2STUR=0D0 + A2STUI=0D0 + A2USTR=0D0 + A2USTI=0D0 + A2TUSR=0D0 + A2TUSI=0D0 + A4STUR=0D0 + A4STUI=0D0 + DO 440 I=1,2*MSTP(1) + SQMQ=PMAS(I,1)**2 + EPSS=4D0*SQMQ/SH + EPST=4D0*SQMQ/TH + EPSU=4D0*SQMQ/UH + EPSH=4D0*SQMQ/SQMH + IF(EPSH.LT.1D-6) GOTO 440 + CALL PYWAUX(1,EPSS,W1SR,W1SI) + CALL PYWAUX(1,EPST,W1TR,W1TI) + CALL PYWAUX(1,EPSU,W1UR,W1UI) + CALL PYWAUX(1,EPSH,W1HR,W1HI) + CALL PYWAUX(2,EPSS,W2SR,W2SI) + CALL PYWAUX(2,EPST,W2TR,W2TI) + CALL PYWAUX(2,EPSU,W2UR,W2UI) + CALL PYWAUX(2,EPSH,W2HR,W2HI) + CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI) + CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI) + CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI) + CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI) + CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI) + CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI) + CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI) + CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI) + CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI) + CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI) + CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI) + CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI) + W3STUR=YHSTUR-Y3STUR-Y3UTSR + W3STUI=YHSTUI-Y3STUI-Y3UTSI + W3SUTR=YHSUTR-Y3SUTR-Y3TUSR + W3SUTI=YHSUTI-Y3SUTI-Y3TUSI + W3TSUR=YHTSUR-Y3TSUR-Y3USTR + W3TSUI=YHTSUI-Y3TSUI-Y3USTI + W3TUSR=YHTUSR-Y3TUSR-Y3SUTR + W3TUSI=YHTUSI-Y3TUSI-Y3SUTI + W3USTR=YHUSTR-Y3USTR-Y3TSUR + W3USTI=YHUSTI-Y3USTI-Y3TSUI + W3UTSR=YHUTSR-Y3UTSR-Y3STUR + W3UTSI=YHUTSI-Y3UTSI-Y3STUI + B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH* + & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)* + & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/ + & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH* + & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR) + B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2* + & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+ + & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))* + & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0* + & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI) + B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH* + & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)* + & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/ + & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH* + & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR) + B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2* + & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+ + & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))* + & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0* + & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI) + B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH* + & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)* + & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/ + & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH* + & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR) + B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2* + & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+ + & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))* + & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0* + & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI) + B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH* + & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)* + & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/ + & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH* + & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR) + B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2* + & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+ + & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))* + & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0* + & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI) + B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH* + & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)* + & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/ + & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH* + & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR) + B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2* + & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+ + & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))* + & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0* + & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI) + B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH* + & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)* + & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/ + & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH* + & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR) + B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2* + & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+ + & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))* + & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0* + & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI) + B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)* + & (W2SR-W2HR+W3STUR)) + B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI) + B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)* + & (W2TR-W2HR+W3TUSR)) + B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI) + B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)* + & (W2UR-W2HR+W3USTR)) + B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI) + A2STUR=A2STUR+B2STUR+B2SUTR + A2STUI=A2STUI+B2STUI+B2SUTI + A2USTR=A2USTR+B2USTR+B2UTSR + A2USTI=A2USTI+B2USTI+B2UTSI + A2TUSR=A2TUSR+B2TUSR+B2TSUR + A2TUSI=A2TUSI+B2TUSI+B2TSUI + A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR + A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI + 440 CONTINUE + FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3* + & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+ + & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2) + FACGH=FACGH*WIDS(25,2) + ENDIF + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGH + 450 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.170) THEN + IF(ISUB.EQ.121) THEN +C...g + g -> Q + Qbar + h0 + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460 + IA=KFPR(ISUBSV,2) + PMF=PYMRUN(IA,SH) + FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2* + & (0.5D0*PMF/PMAS(24,1))**2 + WID2=1D0 + IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1) + FACQQH=FACQQH*WID2 + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN + IKFI=1 + IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2 + IF(IA.GT.10) IKFI=3 + FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2 + IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN + FACQQH=FACQQH/(1D0+RMSS(41))**2 + IF(IHIGG.NE.3) THEN + FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/ + & PARU(151+10*IHIGG))**2 + ENDIF + ENDIF + ENDIF + CALL PYQQBH(WTQQBH) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) + & FACBW=0D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQH*WTQQBH*FACBW + 460 CONTINUE + + ELSEIF(ISUB.EQ.122) THEN +C...q + qbar -> Q + Qbar + h0 + IA=KFPR(ISUBSV,2) + PMF=PYMRUN(IA,SH) + FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2* + & (0.5D0*PMF/PMAS(24,1))**2 + WID2=1D0 + IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1) + FACQQH=FACQQH*WID2 + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN + IKFI=1 + IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2 + IF(IA.GT.10) IKFI=3 + FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2 + IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN + FACQQH=FACQQH/(1D0+RMSS(41))**2 + IF(IHIGG.NE.3) THEN + FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/ + & PARU(151+10*IHIGG))**2 + ENDIF + ENDIF + ENDIF + CALL PYQQBH(WTQQBH) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) + & FACBW=0D0 + DO 470 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQH*WTQQBH*FACBW + 470 CONTINUE + + ELSEIF(ISUB.EQ.123) THEN +C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as +C...inner process) + FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0 + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR* + & PARU(154+10*IHIGG)**2 + FACPRP=1D0/((VINT(215)-VINT(204)**2)* + & (VINT(216)-VINT(209)**2))**2 + FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219) + FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) + & FACBW=0D0 + DO 490 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490 + IA=IABS(I) + DO 480 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480 + JA=IABS(J) + EI=KCHG(IA,1)*ISIGN(1,I)/3D0 + AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I) + VI=AI-4D0*EI*XWV + EJ=KCHG(JA,1)*ISIGN(1,J)/3D0 + AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J) + VJ=AJ-4D0*EJ*XWV + FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ + FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW + 480 CONTINUE + 490 CONTINUE + + ELSEIF(ISUB.EQ.124) THEN +C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as +C...inner process) + FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW + IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR* + & PARU(155+10*IHIGG)**2 + FACPRP=1D0/((VINT(215)-VINT(204)**2)* + & (VINT(216)-VINT(209)**2))**2 + FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) + & FACBW=0D0 + DO 510 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510 + EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1) + DO 500 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500 + EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1) + IF(EI*EJ.GT.0D0) GOTO 500 + FACLR=VINT(180+I)*VINT(180+J) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACLR*FACWW*FACBW + 500 CONTINUE + 510 CONTINUE + + ELSEIF(ISUB.EQ.143) THEN +C...f + fbar' -> H+/- + SQMHC=PMAS(37,1)**2 + CALL PYWIDT(37,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2) + HP=AEM/(8D0*XW)*SH/SQMW*SH + DO 530 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530 + IA=IABS(I) + IM=(MOD(IA,10)+1)/2 + DO 520 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520 + JA=IABS(J) + JM=(MOD(JA,10)+1)/2 + IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 520 + IF(MOD(IA,2).EQ.0) THEN + IU=IA + IL=JA + ELSE + IU=JA + IL=IA + ENDIF + RML=PYMRUN(IL,SH)**2/SH + RMU=PYMRUN(IU,SH)**2/SH + HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2) + IF(IA.LE.10) HI=HI*FACA/3D0 + KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4)) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 520 CONTINUE + 530 CONTINUE + + ELSEIF(ISUB.EQ.161) THEN +C...f + g -> f' + H+/- (b + g -> t + H+/- only) +C...(choice of only b and t to avoid kinematics problems) + FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24 +C...H propagator: as simulated in PYOFSH and as desired + SQMHC=PMAS(37,1)**2 + GMMHC=PMAS(37,1)*PMAS(37,2) + HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2) + CALL PYWIDT(37,SQM4,WDTP,WDTE) + GMMHCC=SQRT(SQM4)*WDTP(0) + HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2) + FHCQ=FHCQ*HBW4C/HBW4 + Q2RM=SH + IF(MSTP(32).EQ.12) Q2RM=PARP(194) + DO 550 I=MMINA,MMAXA + IA=IABS(I) + IF(IA.NE.5) GOTO 550 + SQML=PYMRUN(IA,Q2RM)**2 + IUA=IA+MOD(IA,2) + SQMQ=PYMRUN(IUA,Q2RM)**2 + FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW* + & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH- + & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)* + & (SQMHC-SQMQ-SH)/SH) + KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I)) + DO 540 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2) + IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2) + 540 CONTINUE + 550 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.402) THEN + IF(ISUB.EQ.401) THEN +C... g + g -> t + bbar + H- + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560 + IA=KFPR(ISUBSV,2) + CALL PYSTBH(WTTBH) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) + & FACBW=0D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW +c Since we don't know yet if H+ or H-, assume H+ +c when calculating suppression due to closed channels. + SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3) + IF(ABS(WIDS(37,2)-WIDS(37,3)) + & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR. + & ABS(WIDS(6,2)-WIDS(6,3)) + & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN + WRITE(*,*)'Error: Process 401 cannot handle different' + WRITE(*,*)'decays for H+ and H- or t and tbar.' + WRITE(*,*)'Execution stopped.' + CALL PYSTOP(108) + END IF + 560 CONTINUE + + ELSEIF(ISUB.EQ.402) THEN +C... q + qbar -> t + bbar + H- + IA=KFPR(ISUBSV,2) + CALL PYSTBH(WTTBH) + CALL PYWIDT(KFHIGG,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2)) + & FACBW=0D0 + DO 570 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW +c Since we don't know yet if H+ or H-, assume H+ +c when calculating suppression due to closed channels. + SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3) + IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3)) + & .GE.1D-6.OR. + & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3)) + & .GE.1D-6) THEN + WRITE(*,*)'Error: Process 402 cannot handle different' + WRITE(*,*)'decays for H+ and H- or t and tbar.' + WRITE(*,*)'Execution stopped.' + CALL PYSTOP(108) + END IF + 570 CONTINUE + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSGSU +C...Subprocess cross sections for SUSY processes, +C...including Higgs pair production. +C...Auxiliary to PYSIGH. + + SUBROUTINE PYSGSU(NCHN,SIGS) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/, + &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/ +C...Local arrays and complex variables + DIMENSION WDTP(0:400),WDTE(0:400,0:5) + COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR + COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ + COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2) + +CMRENNA++ +C...Z and W width, combinations of weak mixing angle + ZWID=PMAS(23,2) + WWID=PMAS(24,2) + TANW=SQRT(XW/XW1) + CT2W=(1D0-2D0*XW)/(2D0*XW/TANW) + +C...Convert almost equivalent SUSY processes into each other +C...Extract differences in flavours and couplings + +C...Sleptons and sneutrinos + IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN + KFID=MOD(KFPR(ISUB,1),KSUSY1) + ISUB=201 + ILR=0 + ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN + KFID=MOD(KFPR(ISUB,1),KSUSY1) + ISUB=201 + ILR=1 + ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN + KFID=MOD(KFPR(ISUB,1),KSUSY1) + ISUB=203 + ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN + IF(ISUB.EQ.210) THEN + RKF=2.0D0 + ELSEIF(ISUB.EQ.211) THEN + RKF=SFMIX(15,1)**2 + ELSEIF(ISUB.EQ.212) THEN + RKF=SFMIX(15,2)**2 + ENDIF + ISUB=210 + ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN + IF(ISUB.EQ.213) THEN + KFID=MOD(KFPR(ISUB,1),KSUSY1) + RKF=2.0D0 + ELSEIF(ISUB.EQ.214) THEN + KFID=16 + RKF=1.0D0 + ENDIF + ISUB=213 + +C...Neutralinos + ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN + IF(ISUB.EQ.216) THEN + IZID1=1 + IZID2=1 + ELSEIF(ISUB.EQ.217) THEN + IZID1=2 + IZID2=2 + ELSEIF(ISUB.EQ.218) THEN + IZID1=3 + IZID2=3 + ELSEIF(ISUB.EQ.219) THEN + IZID1=4 + IZID2=4 + ELSEIF(ISUB.EQ.220) THEN + IZID1=1 + IZID2=2 + ELSEIF(ISUB.EQ.221) THEN + IZID1=1 + IZID2=3 + ELSEIF(ISUB.EQ.222) THEN + IZID1=1 + IZID2=4 + ELSEIF(ISUB.EQ.223) THEN + IZID1=2 + IZID2=3 + ELSEIF(ISUB.EQ.224) THEN + IZID1=2 + IZID2=4 + ELSEIF(ISUB.EQ.225) THEN + IZID1=3 + IZID2=4 + ENDIF + ISUB=216 + +C...Charginos + ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN + IF(ISUB.EQ.226) THEN + IZID1=1 + IZID2=1 + ELSEIF(ISUB.EQ.227) THEN + IZID1=2 + IZID2=2 + ELSEIF(ISUB.EQ.228) THEN + IZID1=1 + IZID2=2 + ENDIF + ISUB=226 + +C...Neutralino + chargino + ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN + IF(ISUB.EQ.229) THEN + IZID1=1 + IZID2=1 + ELSEIF(ISUB.EQ.230) THEN + IZID1=1 + IZID2=2 + ELSEIF(ISUB.EQ.231) THEN + IZID1=1 + IZID2=3 + ELSEIF(ISUB.EQ.232) THEN + IZID1=1 + IZID2=4 + ELSEIF(ISUB.EQ.233) THEN + IZID1=2 + IZID2=1 + ELSEIF(ISUB.EQ.234) THEN + IZID1=2 + IZID2=2 + ELSEIF(ISUB.EQ.235) THEN + IZID1=2 + IZID2=3 + ELSEIF(ISUB.EQ.236) THEN + IZID1=2 + IZID2=4 + ENDIF + ISUB=229 + +C...Gluino + neutralino + ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN + IF(ISUB.EQ.237) THEN + IZID=1 + ELSEIF(ISUB.EQ.238) THEN + IZID=2 + ELSEIF(ISUB.EQ.239) THEN + IZID=3 + ELSEIF(ISUB.EQ.240) THEN + IZID=4 + ENDIF + ISUB=237 + +C...Gluino + chargino + ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN + IF(ISUB.EQ.241) THEN + IZID=1 + ELSEIF(ISUB.EQ.242) THEN + IZID=2 + ENDIF + ISUB=241 + +C...Squark + neutralino + ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN + ILR=0 + IF(MOD(ISUB,2).NE.0) ILR=1 + IF(ISUB.LE.247) THEN + IZID=1 + ELSEIF(ISUB.LE.249) THEN + IZID=2 + ELSEIF(ISUB.LE.251) THEN + IZID=3 + ELSEIF(ISUB.LE.253) THEN + IZID=4 + ENDIF + ISUB=246 + RKF=5D0 + +C...Squark + chargino + ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN + IF(ISUB.LE.255) THEN + IZID=1 + ELSEIF(ISUB.LE.257) THEN + IZID=2 + ENDIF + IF(MOD(ISUB,2).EQ.0) THEN + ILR=0 + ELSE + ILR=1 + ENDIF + ISUB=254 + RKF=5D0 + +C...Squark + gluino + ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN + ISUB=258 + RKF=4D0 + +C...Stops + ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN + ILR=0 + IF(ISUB.EQ.262) ILR=1 + ISUB=261 + ELSEIF(ISUB.EQ.265) THEN + ISUB=264 + +C...Squarks + ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN + ILR=0 + IF(ISUB.LE.273) THEN + IF(ISUB.EQ.273) ILR=1 + ISUB=271 + RKF=16D0 + ELSEIF(ISUB.LE.276) THEN + IF(ISUB.EQ.276) ILR=1 + ISUB=274 + RKF=16D0 + ELSEIF(ISUB.LE.278) THEN + IF(ISUB.EQ.278) ILR=1 + ISUB=277 + RKF=4D0 + ELSE + IF(ISUB.EQ.280) ILR=1 + ISUB=279 + RKF=4D0 + ENDIF +C...Sbottoms + ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN + ILR=0 + IF(ISUB.LE.283) THEN + IF(ISUB.EQ.283) ILR=1 + ISUB=271 + RKF=4D0 + ELSEIF(ISUB.LE.286) THEN + IF(ISUB.EQ.286) ILR=1 + ISUB=274 + RKF=4D0 + ELSEIF(ISUB.LE.288) THEN + IF(ISUB.EQ.288) ILR=1 + ISUB=277 + RKF=1D0 + ELSEIF(ISUB.LE.290) THEN + IF(ISUB.EQ.290) ILR=1 + ISUB=279 + RKF=1D0 + ELSEIF(ISUB.LE.293) THEN + IF(ISUB.EQ.293) ILR=1 + ISUB=271 + RKF=1D0 + ELSEIF(ISUB.EQ.296) THEN + ILR=1 + ISUB=274 + RKF=1D0 +C...Squark + gluino + ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN + ISUB=258 + RKF=1D0 + ENDIF +C...H+/- + H0 + ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN + IF(ISUB.EQ.297) THEN + RKF=.5D0*PARU(195)**2 + ELSEIF(ISUB.EQ.298) THEN + RKF=.5D0*(1D0-PARU(195)**2) + ENDIF + ISUB=210 +C...A0 + H0 + ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN + IF(ISUB.EQ.299) THEN + RKF=PARU(186)**2 + KFID=25 + ELSEIF(ISUB.EQ.300) THEN + RKF=PARU(187)**2 + KFID=35 + ENDIF + ISUB=213 +C...H+ + H- + ELSEIF(ISUB.EQ.301) THEN + KFID=37 + RKF=1D0 + ISUB=201 + ENDIF + +C...Supersymmetric processes - all of type 2 -> 2 : +C...correct final-state Breit-Wigners from fixed to running width. + IF(MSTP(42).GT.0) THEN + DO 100 I=1,2 + KFLW=KFPR(ISUBSV,I) + KCW=PYCOMP(KFLW) + IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100 + IF(I.EQ.1) SQMI=SQM3 + IF(I.EQ.2) SQMI=SQM4 + SQMS=PMAS(KCW,1)**2 + GMMS=PMAS(KCW,1)*PMAS(KCW,2) + HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2) + CALL PYWIDT(KFLW,SQMI,WDTP,WDTE) + GMMI=SQRT(SQMI)*WDTP(0) + HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2) + COMFAC=COMFAC*(HBWI/HBWS) + 100 CONTINUE + ENDIF + +C...Differential cross section expressions. + + IF(ISUB.LE.210) THEN + IF(ISUB.EQ.201) THEN +C...f + fbar -> e_L + e_Lbar + COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + DO 130 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130 + EI=KCHG(IA,1)/3D0 + TT3I=SIGN(1D0,EI+1D-6)/2D0 + EJ=-1D0 + TT3J=-1D0/2D0 + FCOL=1D0 +C...Color factor for e+ e- + IF(IA.GE.11) FCOL=3D0 + IF(ISUBSV.EQ.301) THEN + A1=1D0 + A2=0D0 + ELSEIF(ILR.EQ.1) THEN + A1=SFMIX(KFID,3)**2 + A2=SFMIX(KFID,4)**2 + ELSEIF(ILR.EQ.0) THEN + A1=SFMIX(KFID,1)**2 + A2=SFMIX(KFID,2)**2 + ENDIF + XLQ=(TT3J-EJ*XW)*A1 + XRQ=(-EJ*XW)*A2 + XLF=(TT3I-EI*XW) + XRF=(-EI*XW) + TAA=(EI*EJ)**2*(POLL+POLR) + TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2 + TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2) + TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1 + TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH) + TNN=0.0D0 + TAN=0.0D0 + TZN=0.0D0 + IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN + FAC2=SQRT(2D0) + TNN1=0D0 + TNN2=0D0 + TNN3=0D0 + DO 120 II=1,4 + DK=1D0/(TH-SMZ(II)**2) + FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)* + & ZMIX(II,1)) + FREK=FAC2*TANW*EI*ZMIX(II,1) + TNN1=TNN1+FLEK**2*DK + TNN2=TNN2+FREK**2*DK + DO 110 JJ=1,4 + DL=1D0/(TH-SMZ(JJ)**2) + FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)* + & ZMIX(JJ,1)) + FREL=FAC2*TANW*EJ*ZMIX(JJ,1) + TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ) + 110 CONTINUE + 120 CONTINUE + TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+ + & A2**2*TNN2**2*POLR) + TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+ + & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2 + TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)* + & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR) + TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)* + & (1D0-SQMZ/SH)/SH + TZN=TZN/XW**2/XW1 + TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+ + & A2*TNN2*POLR)/XW + ENDIF + FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0 + FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2 + FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1+FACQQ2 + 130 CONTINUE + + ELSEIF(ISUB.EQ.203) THEN +C...f + fbar -> e_L + e_Rbar + DO 160 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160 + EI=KCHG(IABS(I),1)/3D0 + TT3I=SIGN(1D0,EI)/2D0 + EJ=-1 + TT3J=-1D0/2D0 + FCOL=1D0 +C...Color factor for e+ e- + IF(IA.GE.11) FCOL=3D0 + A1=SFMIX(KFID,1)**2 + A2=SFMIX(KFID,2)**2 + XLQ=(TT3J-EJ*XW) + XRQ=(-EJ*XW) + XLF=(TT3I-EI*XW) + XRF=(-EI*XW) + TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2 + & /XW**2/XW1**2*A1*A2 + TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2) + TNN=0.0D0 + TZN=0.0D0 + TNNA=0D0 + TNNB=0D0 + IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN + FAC2=SQRT(2D0) + TNN1=0D0 + TNN2=0D0 + TNN3=0D0 + DO 150 II=1,4 + DK=1D0/(TH-SMZ(II)**2) + FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)* + & ZMIX(II,1)) + FREK=FAC2*TANW*EI*ZMIX(II,1) + TNN1=TNN1+FLEK**2*DK + TNN2=TNN2+FREK**2*DK + DO 140 JJ=1,4 + DL=1D0/(TH-SMZ(JJ)**2) + FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)* + & ZMIX(JJ,1)) + FREL=FAC2*TANW*EJ*ZMIX(JJ,1) + TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ) + 140 CONTINUE + 150 CONTINUE + TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL) + TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0 + TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0 + TZN=(UH*TH-SQM3*SQM4)*A1*A2 + TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1 + TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)* + & (1D0-SQMZ/SH)/SH + ENDIF + FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2 + FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0 + FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0 +C%%%%%%%%%%% + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),3) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + 160 CONTINUE + + ELSEIF(ISUB.EQ.210) THEN +C...q + qbar' -> W*- > ~l_L + ~nu_L + FAC0=RKF*COMFAC*AEM**2/XW**2/12D0 + FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW) + DO 180 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180 + DO 170 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170 + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170 + FCKM=3D0 + IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) + KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J) + KCHW=2 + IF(KCHSUM.LT.0) KCHW=3 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN + FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + ELSE + FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW) + ENDIF + SIGH(NCHN)=FAC0*FAC1*FCKM*FACR + 170 CONTINUE + 180 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.220) THEN + IF(ISUB.EQ.213) THEN +C...f + fbar -> ~nu_L + ~nu_Lbar + IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN + FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + ELSE + FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + ENDIF + COMFAC=COMFAC*FACR + PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ + XLL=0.5D0 + XLR=0.0D0 + DO 190 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190 + EI=KCHG(IA,1)/3D0 + FCOL=1D0 +C...Color factor for e+ e- + IF(IA.GE.11) FCOL=3D0 + XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0 + XRQ=-EI*XW + TZC=0.0D0 + TCC=0.0D0 + IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN + TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/ + & (TH-SMW(2)**2) + TCC=TZC**2 + TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL + ENDIF + FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2 + FACQQ2=TZC+TCC/4D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC + & *AEM**2*FCOL/3D0/XW**2 + 190 CONTINUE + + ELSEIF(ISUB.EQ.216) THEN +C...q + qbar -> ~chi0_1 + ~chi0_1 + IF(IZID1.EQ.IZID2) THEN + COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + ELSE + COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + ENDIF + FACXX=COMFAC*AEM**2/3D0/XW**2 + IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0 + ZM12=SQM3 + ZM22=SQM4 + WU2 = (UH-ZM12)*(UH-ZM22) + WT2 = (TH-ZM12)*(TH-ZM22) + WS2 = SMZ(IZID1)*SMZ(IZID2)*SH + PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2 + PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2) + DO 200 I=1,4 + ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I)) + IF(IZID2.NE.IZID1) THEN + ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I)) + ENDIF + 200 CONTINUE + OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))- + & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0 + ORPP=DCONJG(OLPP) + DO 210 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210 + EI=KCHG(IABS(I),1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2 + XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2 + GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))* + & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1)) + GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2 + QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2) + QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ) + & /DCMPLX(TH-XML2) + QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2) + QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ + & -DCONJG(GRIJ)/DCMPLX(UH-XMR2) + FCOL=1D0 + IF(IABS(I).GE.11) FCOL=3D0 + FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+ + & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+ + & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+ + & QRL*DCONJG(QRR)*POLR)*WS2 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACXX*FACGG1*FCOL + 210 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.230) THEN + IF(ISUB.EQ.226) THEN +C...f + fbar -> ~chi+_1 + ~chi-_1 + FACXX=COMFAC*AEM**2/3D0 + ZM12=SQM3 + ZM22=SQM4 + WU2 = (UH-ZM12)*(UH-ZM22) + WT2 = (TH-ZM12)*(TH-ZM22) + WS2 = SMW(IZID1)*SMW(IZID2)*SH + PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2 + PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2) + DIFF=0D0 + IF(IZID1.EQ.IZID2) DIFF=1D0 + DO 220 I=1,2 + VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I)) + UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I)) + IF(IZID2.NE.IZID1) THEN + VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I)) + UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I)) + ENDIF + 220 CONTINUE + OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))- + & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF) + ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))- + & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF) + DO 230 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230 + EI=KCHG(IABS(I),1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP + QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP + QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP + IF(MOD(I,2).EQ.0) THEN + XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2 + QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)* + & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))* + & DCMPLX(T3I/XW/(TH-XML2)) + ELSE + XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2 + QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)* + & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))* + & DCMPLX(T3I/XW/(TH-XML2)) + ENDIF + FCOL=1D0 + IF(IABS(I).GE.11) FCOL=3D0 + FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+ + & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+ + & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+ + & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + IF(IZID1.EQ.IZID2) THEN + SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + ELSE + SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),3) + ENDIF + 230 CONTINUE + + ELSEIF(ISUB.EQ.229) THEN +C...q + qbar' -> ~chi0_1 + ~chi+-_1 + FACXX=COMFAC*AEM**2/6D0/XW**2 + ZM12=SQM3 + ZM22=SQM4 + WU2 = (UH-ZM12)*(UH-ZM22) + WT2 = (TH-ZM12)*(TH-ZM22) + WS2 = SMW(IZID1)*SMZ(IZID2)*SH + RT2I = 1D0/SQRT(2D0) + PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/ + & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0) + DO 240 I=1,2 + VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I)) + UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I)) + 240 CONTINUE + DO 250 I=1,4 + ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I)) + 250 CONTINUE + OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)- + & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW + OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+ + & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW + + DO 270 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270 + EI=KCHG(IA,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + DO 260 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260 + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260 + EJ=KCHG(JA,1)/3D0 + T3J=SIGN(1D0,EJ+1D-6)/2D0 + FCKM=3D0 + IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) + KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J) + KCHW=2 + IF(KCHSUM.LT.0) KCHW=3 + IF(MOD(IA,2).EQ.0) THEN + ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2 + ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2 + QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)* + & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2) + QLR=OR-DCONJG(UMIXC(IZID1,1))*( + & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J) + & /DCMPLX(TH-ZMJ2) + ELSE + ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2 + ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2 + QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)* + & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2) + QLR=OR-DCONJG(UMIXC(IZID1,1))*( + & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I) + & /DCMPLX(TH-ZMI2) + ENDIF + ZINTR=DBLE(QLR*DCONJG(QLL)) + FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+ + & 2D0*ZINTR*WS2) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW) + 260 CONTINUE + 270 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.240) THEN + IF(ISUB.EQ.237) THEN +C...q + qbar -> gluino + ~chi0_1 + COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + ASYUK=RMSS(42)*AS + FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW + GM2=SQM3 + ZM2=SQM4 + DO 280 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 280 + EI=KCHG(IABS(I),1)/3D0 + IA=IABS(I) + XLQC = -TANW*EI*ZMIX(IZID,1) + XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW* + & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0 + XLQ2=XLQC**2 + XRQ2=XRQC**2 + XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2 + XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2 + ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2 + AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2 + ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2) + SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN) + ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2 + AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2 + ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2) + SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR) + 280 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.250) THEN + IF(ISUB.EQ.241) THEN +C...q + qbar' -> ~chi+-_1 + gluino + FACWG=COMFAC*AS*AEM/XW*2D0/9D0 + GM2=SQM3 + ZM2=SQM4 + FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1) + FAC0=UMIX(IZID,1)**2 + FAC1=VMIX(IZID,1)**2 + DO 300 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300 + DO 290 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290 + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290 + FCKM=1D0 + IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2) + KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J) + KCHW=2 + IF(KCHSUM.LT.0) KCHW=3 + XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2 + XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2 + ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2 + AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2 + ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2) + XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2 + XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2 + ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0 + AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0 + ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)* + & SH/(TH-XMU2)/(UH-XMD2))/2D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN- + & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW) + 290 CONTINUE + 300 CONTINUE + + ELSEIF(ISUB.EQ.243) THEN +C...q + qbar -> gluino + gluino + COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + XMT=SQM3-TH + XMU=SQM3-UH + DO 310 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310 + NCHN=NCHN+1 + XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH + XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH + FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+ + & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+ + & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*( + & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU )) + XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH + XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH + FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+ + & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+ + & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*( + & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU )) + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 +C...1/2 for identical particles + SIGH(NCHN)=0.25D0*(FACGG1+FACGG2) + 310 CONTINUE + + ELSEIF(ISUB.EQ.244) THEN +C...g + g -> gluino + gluino + COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + XMT=SQM3-TH + XMU=SQM3-UH + FACQQ1=COMFAC*AS**2*9D0/4D0*( + & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 - + & (XMT*XMU+SQM3*(UH-TH))/SH/XMT ) + FACQQ2=COMFAC*AS**2*9D0/4D0*( + & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 - + & (XMU*XMT+SQM3*(TH-UH))/SH/XMU ) + FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 + + & SQM3*(SH-4D0*SQM3)/XMT/XMU) + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1/2D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQ2/2D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=3 + SIGH(NCHN)=FACQQ3/2D0 + 320 CONTINUE + + ELSEIF(ISUB.EQ.246) THEN +C...g + q_j -> ~chi0_1 + ~q_j + FAC0=COMFAC*AS*AEM/6D0/XW + ZM2=SQM4 + QM2=SQM3 + FACZQ0=FAC0*( (ZM2-TH)/SH + + & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 - + & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) ) + KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1) + DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ + IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340 + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340 + EI=KCHG(IABS(I),1)/3D0 + IA=IABS(I) + XRQZ = -TANW*EI*ZMIX(IZID,1) + XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW* + & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0 + IF(ILR.EQ.0) THEN + BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2 + ELSE + BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2 + ENDIF + FACZQ=FACZQ0*BS + KCHQ=2 + IF(I.LT.0) KCHQ=3 + DO 330 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + 330 CONTINUE + 340 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.260) THEN + IF(ISUB.EQ.254) THEN +C...g + q_j -> ~chi1_1 + ~q_i + FAC0=COMFAC*AS*AEM/12D0/XW + ZM2=SQM4 + QM2=SQM3 + AU=UMIX(IZID,1)**2 + AD=VMIX(IZID,1)**2 + FACZQ0=FAC0*( (ZM2-TH)/SH + + & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 - + & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) ) + KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1) + IF(MOD(KFNSQ1,2).EQ.0) THEN + KFNSQ=KFNSQ1-1 + KCHW=2 + ELSE + KFNSQ=KFNSQ1+1 + KCHW=3 + ENDIF + DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ + IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360 + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360 + IA=IABS(I) + IF(MOD(IA,2).EQ.0) THEN + FACZQ=FACZQ0*AU + ELSE + FACZQ=FACZQ0*AD + ENDIF + FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2 + KCHQ=2 + IF(I.LT.0) KCHQ=3 + KCHWQ=KCHW + IF(I.LT.0) KCHWQ=5-KCHW + DO 350 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ) + 350 CONTINUE + 360 CONTINUE + + ELSEIF(ISUB.EQ.258) THEN +C...g + q_j -> gluino + ~q_i + XG2=SQM4 + XQ2=SQM3 + XMT=XG2-TH + XMU=XG2-UH + XST=XQ2-TH + XSU=XQ2-UH + FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 - + & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) + + & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) + + & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU + FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0* + & (SH*(UH+XG2) + & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH + + & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+ + & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU + ASYUK=RMSS(42)*AS + FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0 + FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0 + KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1) + DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ + IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380 + IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380 + KCHQ=2 + IF(I.LT.0) KCHQ=3 + FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + DO 370 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQG1*FACSEL + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQG2*FACSEL + 370 CONTINUE + 380 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.270) THEN + IF(ISUB.EQ.261) THEN +C...q_i + q_ibar -> ~t_1 + ~t_1bar + FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )* + & WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1) + FAC0=AS**2*4D0/9D0 + DO 390 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390 + IF(IA.GE.11.AND.IA.LE.18) THEN + EI=KCHG(IA,1)/3D0 + EJ=KCHG(KFNSQ,1)/3D0 + T3I=SIGN(1D0,EI)/2D0 + T3J=SIGN(1D0,EJ)/2D0 + XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2 + XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2 + XLF=2D0*(T3I-EI*XW) + XRF=2D0*(-EI*XW) + TAA=0.5D0*(EI*EJ)**2 + TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2 + TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2) + TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1 + TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH) + FAC0=AEM**2*12D0*(TAA+TZZ+TAZ) + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1*FAC0 + 390 CONTINUE + + ELSEIF(ISUB.EQ.263) THEN +C...f + fbar -> ~t1 + ~t2bar + DO 400 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400 + EI=KCHG(IABS(I),1)/3D0 + TT3I=SIGN(1D0,EI)/2D0 + EJ=2D0/3D0 + TT3J=1D0/2D0 + FCOL=1D0 +C...Color factor for e+ e- + IF(IA.GE.11) FCOL=3D0 + XLQ=2D0*(TT3J-EJ*XW) + XRQ=2D0*(-EJ*XW) + XLF=2D0*(TT3I-EI*XW) + XRF=2D0*(-EI*XW) + TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2 + TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2 + TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2) +C...Factor of 2 for t1 t2bar + t2 t1bar +C...PS: bug fix 24 Aug 2010. Factor 2 accounted for by the 2 channels. + FACQQ1=COMFAC*AEM**2*TZZ*FCOL*4D0 + FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),3) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),2) + 400 CONTINUE + + ELSEIF(ISUB.EQ.264) THEN +C...g + g -> ~t_1 + ~t_1bar + XSU=SQM3-UH + XST=SQM3-TH + FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0* + & WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST) + FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST) + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQ2 + 410 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.280) THEN + IF(ISUB.EQ.271) THEN +C...q + q' -> ~q + ~q' (~g exchange) + XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2 + XMT=XMG2-TH + XMU=XMG2-UH + XSU1=SQM3-UH + XSU2=SQM4-UH + XST1=SQM3-TH + XST2=SQM4-TH + ASYUK=RMSS(42)*AS + IF(ILR.EQ.1) THEN + FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 ) + FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 ) + FACQQB=0.0D0 + ELSE + FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 ) + FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 ) + FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/ + & XMT/XMU ) + ENDIF + KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1) + KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1) + DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI + IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430 + KCHQ=2 + IF(I.LT.0) KCHQ=3 + DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ + IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420 + IF(I*J.LT.0) GOTO 420 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ) + IF(I.EQ.J) THEN + IF(ILR.EQ.0) THEN + SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF* + & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2) + ELSE + SIGH(NCHN)=0.5D0*FACQQ1*RKF* + & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ) + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + IF(ILR.EQ.0) THEN + SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF* + & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2) + ELSE + SIGH(NCHN)=0.5D0*FACQQ2*RKF* + & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ) + ENDIF + ENDIF + 420 CONTINUE + 430 CONTINUE + + ELSEIF(ISUB.EQ.274) THEN +C...q + qbar' -> ~q + ~qbar' + XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2 + XMT=XMG2-TH + XMU=XMG2-UH + IF(ILR.EQ.0) THEN +C...Mrenna...Normalization.and.1/XMT + FACQQ1=COMFAC*AS**2*2D0/9D0*( + & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2 + FACQQB=COMFAC*AS**2*4D0/9D0*( + & (UH*TH-SQM3*SQM4)/SH2 ) + FACQQI=-COMFAC*AS**2*4D0/27D0*( + & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42) + FACQQB=FACQQB+FACQQ1+FACQQI + ELSE + FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2 + FACQQB=FACQQ1 + ENDIF + KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1) + KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1) + DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI + IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450 + KCHQ=2 + IF(I.LT.0) KCHQ=3 + DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ + IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440 + IF(I*J.GT.0) GOTO 440 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)* + & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ) + IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF* + & WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + 440 CONTINUE + 450 CONTINUE + + ELSEIF(ISUB.EQ.277) THEN +C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j +C...if i .eq. j covered in 274 + FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 ) + KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1) + FAC0=0D0 + DO 460 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460 + IF(IA.EQ.KFNSQ) GOTO 460 + IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN + EI=KCHG(IA,1)/3D0 + EJ=KCHG(KFNSQ,1)/3D0 + T3J=SIGN(0.5D0,EJ) + T3I=SIGN(1D0,EI)/2D0 + IF(ILR.EQ.0) THEN + XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1) + XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2) + ELSE + XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3) + XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4) + ENDIF + XLF=2D0*(T3I-EI*XW) + XRF=2D0*(-EI*XW) + IF(ILR.EQ.0) THEN + XRQ=0D0 + ELSE + XLQ=0D0 + ENDIF + TAA=0.5D0*(EI*EJ)**2 + TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2 + TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2) + TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1 + TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH) + FAC0=AEM**2*12D0*(TAA+TZZ+TAZ) + ELSEIF(IA.LE.6) THEN + FAC0=AS**2*8D0/9D0/2D0 + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + 460 CONTINUE + + ELSEIF(ISUB.EQ.279) THEN +C...g + g -> ~q_j + ~q_jbar + XSU=SQM3-UH + XST=SQM3-TH +C...4=RKF because ~t ~tbar and ~b ~bbar treated separately + FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 ) + FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST) + FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST) + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1) + 470 CONTINUE + + ENDIF + ENDIF +CMRENNA-- + + RETURN + END + +C********************************************************************* + +C...PYSGTC +C...Subprocess cross sections for Technicolor processes. +C...Auxiliary to PYSIGH. + + SUBROUTINE PYSGTC(NCHN,SIGS) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/, + &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/ +C...Local arrays and complex variables + DIMENSION WDTP(0:400),WDTE(0:400,0:5) + COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME + COMPLEX*16 SSMX,DAAST,DZAST,DWAST + COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO + COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU + COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS + COMPLEX*16 DVVS,DVVT,DVVU + INTEGER INDX(6) + +C...Combinations of weak mixing angle. + TANW=SQRT(XW/XW1) + CT2W=(1D0-2D0*XW)/(2D0*XW/TANW) + +C...Convert almost equivalent technicolor processes into +C...a few basic processes, and set distinguishing parameters. + IF(ISUB.GE.361.AND.ISUB.LE.380) THEN + SQTV=RTCM(12)**2 + SQTA=RTCM(13)**2 + SN2W=2D0*SQRT(XW*XW1) + CS2W=1D0-2D0*XW + CT2W=CS2W/SN2W + CSXI=COS(ASIN(RTCM(3))) + CSXIP=COS(ASIN(RTCM(4))) + QUPD=2D0*RTCM(2)-1D0 + Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2 + CAB2=0D0 + VOGP=0D0 + VRGP=0D0 + AOGP=0D0 + ARGP=0D0 + VXGP=0D0 + AXGP=0D0 + VAGP=0D0 + VZGP=0D0 + VWGP=0D0 +C... rho_tc0, etc. -> W_L W_L, W_L W_T + IF(ISUB.EQ.361) THEN + KFA=24 + KFB=24 + CAB2=RTCM(3)**4 + AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49) + ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13) + VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12) +C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T. + AXGP = SQRT(2D0)*AXGP + ARGP = SQRT(2D0)*ARGP + VOGP = SQRT(2D0)*VOGP +C... rho_tc0 -> W_L pi_tc- + ELSEIF(ISUB.EQ.362) THEN + KFA=24 + KFB=KTECHN+211 + ISUB=361 + CAB2=RTCM(3)**2*(1D0-RTCM(3)**2) +C... pi_tc pi_tc + ELSEIF(ISUB.EQ.363) THEN + KFA=KTECHN+211 + KFB=KTECHN+211 + ISUB=361 + CAB2=(1D0-RTCM(3)**2)**2 +C... rho_tc0/omega_tc -> gamma pi_tc + ELSEIF(ISUB.EQ.364) THEN + KFA=22 + KFB=KTECHN+111 + ISUB=361 + VOGP=CSXI/RTCM(12) + VRGP=VOGP*QUPD + VAGP=2D0*QUPD*CSXI + VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W +C... gamma pi_tc' + ELSEIF(ISUB.EQ.365) THEN + KFA=22 + KFB=KTECHN+221 + ISUB=361 + VRGP=CSXIP/RTCM(12) + VOGP=VRGP*QUPD + VAGP=2D0*Q2UD*CSXIP + VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD) +C... Z pi_tc + ELSEIF(ISUB.EQ.366) THEN + KFA=23 + KFB=KTECHN+111 + ISUB=361 + VOGP=CSXI*CT2W/RTCM(12) + VRGP=-QUPD*CSXI*TANW/RTCM(12) + VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W + VZGP=-QUPD*CSXI*CS2W/XW1 +C... Z pi_tc' + ELSEIF(ISUB.EQ.367) THEN + KFA=23 + KFB=KTECHN+221 + ISUB=361 +C...RTCM(48) is the M_V for the techni-a + VXGP=-CSXIP/SN2W/RTCM(48) + VRGP=CSXIP*CT2W/RTCM(12) + VOGP=-QUPD*CSXIP*TANW/RTCM(12) + VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W + VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2 +C... W_T pi_tc + ELSEIF(ISUB.EQ.368) THEN + KFA=24 + KFB=KTECHN+211 + ISUB=361 +C...RTCM(49) is the M_A for the techni-a + AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49) + VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12) + ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13) + VAGP=QUPD*CSXI/(2D0*SQRT(XW)) + VZGP=-QUPD*CSXI/(2D0*SQRT(XW1)) +C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L + ELSEIF(ISUB.EQ.370) THEN + KFA=24 + KFB=23 + CAB2=RTCM(3)**4 + ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13) + AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49) +C... W_L pi_tc0 + ELSEIF(ISUB.EQ.371) THEN + KFA=24 + KFB=KTECHN+111 + ISUB=370 + CAB2=RTCM(3)**2*(1D0-RTCM(3)**2) +C... Z_L pi_tc+ + ELSEIF(ISUB.EQ.372) THEN + KFA=KTECHN+211 + KFB=23 + ISUB=370 + CAB2=RTCM(3)**2*(1D0-RTCM(3)**2) +C... pi_tc+ pi_tc0 + ELSEIF(ISUB.EQ.373) THEN + KFA=KTECHN+211 + KFB=KTECHN+111 + ISUB=370 + CAB2=(1D0-RTCM(3)**2)**2 +C... gamma pi_tc+ + ELSEIF(ISUB.EQ.374) THEN + KFA=KTECHN+211 + KFB=22 + ISUB=370 + VRGP=QUPD*CSXI/RTCM(12) + VWGP=QUPD*CSXI/(2D0*SQRT(XW)) + AXGP=-CSXI/RTCM(49) +C... Z_T pi_tc+ + ELSEIF(ISUB.EQ.375) THEN + KFA=KTECHN+211 + KFB=23 + ISUB=370 + VRGP=-QUPD*CSXI*TANW/RTCM(12) + ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13) + VWGP=-QUPD*CSXI/(2D0*SQRT(XW1)) + AXGP=-CSXI*CT2W/RTCM(49) +C... W_T pi_tc0 + ELSEIF(ISUB.EQ.376) THEN + KFA=24 + KFB=KTECHN+111 + ISUB=370 + VRGP=0D0 + ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13) + AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49) +C... W_T pi_tc0' + ELSEIF(ISUB.EQ.377) THEN + KFA=24 + KFB=KTECHN+221 + ISUB=370 + VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12) + VWGP=CSXIP/(2D0*XW) + VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48) +C... gamma W+ + ELSEIF(ISUB.EQ.378) THEN + KFA=24 + KFB=22 + ISUB=370 + VRGP=QUPD*RTCM(3)/RTCM(12) + AXGP=-RTCM(3)/RTCM(49) +C... gamma Z + ELSEIF(ISUB.EQ.379) THEN + KFA=23 + KFB=22 + ISUB=361 + VOGP=RTCM(3)/RTCM(12) + VRGP=QUPD*RTCM(3)/RTCM(12) + ELSEIF(ISUB.EQ.380) THEN + KFA=23 + KFB=23 + ISUB=361 + VOGP=RTCM(3)*CT2W/RTCM(12) + VRGP=-QUPD*RTCM(3)*TANW/RTCM(12) + ENDIF + ENDIF + +C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange. + IF(ISUB.GE.381.AND.ISUB.LE.388) THEN + IF(ITCM(5).LE.4) THEN + SQDQQS=1D0/SH2 + SQDQQT=1D0/TH2 + SQDQQU=1D0/UH2 + SQDGGS=SQDQQS + SQDGGT=SQDQQT + SQDGGU=SQDQQU + REDGGS=1D0/SH + REDGGT=1D0/TH + REDGGU=1D0/UH + REDGTU=1D0/UH/TH + REDGSU=1D0/SH/UH + REDGST=1D0/SH/TH + REDQST=1D0/SH/TH + REDQTU=1D0/UH/TH + SQDLGS=0D0 + SQDLGT=0D0 + SQDQTS=SQDQQS + ELSEIF(ITCM(5).EQ.5) THEN + TANT3=RTCM(21) + IF(ITCM(2).EQ.0) THEN + IMDL=1 + ELSE + IMDL=2 + ENDIF + ALPRHT=2.16D0*(3D0/ITCM(1)) + SIN2T=2D0*TANT3/(TANT3**2+1D0) + SINT3=TANT3/SQRT(TANT3**2+1D0) + XIG=SQRT(PYALPS(SH)/ALPRHT) + X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+ + & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T + X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+ + & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T + X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)- + & SINT3**2)*2D0/SIN2T + X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)- + & SINT3**2)*2D0/SIN2T + + SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2 + SM1112=X12*RTCM(28)**2*SIN2T + SM1121=-X21*RTCM(28)**2*SIN2T + SM2212=-SM1112 + SM2221=-SM1121 + SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+ + & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2 + +C.........SH LOOP + ZTC(1,1)=DCMPLX(SH,0D0) + CALL PYWIDT(3100021,SH,WDTP,WDTE) + IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR + ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0)) + CALL PYWIDT(3100113,SH,WDTP,WDTE) + ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0)) + CALL PYWIDT(3400113,SH,WDTP,WDTE) + ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0)) + CALL PYWIDT(3200113,SH,WDTP,WDTE) + ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0)) + CALL PYWIDT(3300113,SH,WDTP,WDTE) + ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0)) + ZTC(1,2)=(0D0,0D0) + ZTC(1,3)=DCMPLX(SH*XIG,0D0) + ZTC(1,4)=ZTC(1,3) + ZTC(1,5)=ZTC(1,2) + ZTC(1,6)=ZTC(1,2) + ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0) + ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0) + ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0) + ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0) + ZTC(3,4)=-SM1122 + ZTC(3,5)=-SM1112 + ZTC(3,6)=-SM1121 + ZTC(4,5)=-SM2212 + ZTC(4,6)=-SM2221 + ZTC(5,6)=-SM1221 + + DO 110 I=1,5 + DO 100 J=I+1,6 + ZTC(J,I)=ZTC(I,J) + 100 CONTINUE + 110 CONTINUE + CALL PYLDCM(ZTC,6,6,INDX,D) + DO 130 I=1,6 + DO 120 J=1,6 + YTC(I,J)=(0D0,0D0) + IF(I.EQ.J) YTC(I,J)=(1D0,0D0) + 120 CONTINUE + 130 CONTINUE + + DO 140 I=1,6 + CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I)) + 140 CONTINUE + DGGS=YTC(1,1) + DVVS=YTC(2,2) + DGVS=YTC(1,2) + + XIG=SQRT(PYALPS(-TH)/ALPRHT) +C.........TH LOOP + ZTC(1,1)=DCMPLX(TH) + ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2) + ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2) + ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2) + ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2) + ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2) + ZTC(1,2)=(0D0,0D0) + ZTC(1,3)=DCMPLX(TH*XIG,0D0) + ZTC(1,4)=ZTC(1,3) + ZTC(1,5)=ZTC(1,2) + ZTC(1,6)=ZTC(1,2) + ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0) + ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0) + ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0) + ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0) + ZTC(3,4)=-SM1122 + ZTC(3,5)=-SM1112 + ZTC(3,6)=-SM1121 + ZTC(4,5)=-SM2212 + ZTC(4,6)=-SM2221 + ZTC(5,6)=-SM1221 + DO 160 I=1,5 + DO 150 J=I+1,6 + ZTC(J,I)=ZTC(I,J) + 150 CONTINUE + 160 CONTINUE + CALL PYLDCM(ZTC,6,6,INDX,D) + DO 180 I=1,6 + DO 170 J=1,6 + YTC(I,J)=(0D0,0D0) + IF(I.EQ.J) YTC(I,J)=(1D0,0D0) + 170 CONTINUE + 180 CONTINUE + DO 190 I=1,6 + CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I)) + 190 CONTINUE + DGGT=YTC(1,1) + DVVT=YTC(2,2) + DGVT=YTC(1,2) + + XIG=SQRT(PYALPS(-UH)/ALPRHT) +C.........UH LOOP + ZTC(1,1)=DCMPLX(UH,0D0) + ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2) + ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2) + ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2) + ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2) + ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2) + ZTC(1,2)=(0D0,0D0) + ZTC(1,3)=DCMPLX(UH*XIG,0D0) + ZTC(1,4)=ZTC(1,3) + ZTC(1,5)=ZTC(1,2) + ZTC(1,6)=ZTC(1,2) + ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0) + ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0) + ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0) + ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0) + ZTC(3,4)=-SM1122 + ZTC(3,5)=-SM1112 + ZTC(3,6)=-SM1121 + ZTC(4,5)=-SM2212 + ZTC(4,6)=-SM2221 + ZTC(5,6)=-SM1221 + DO 210 I=1,5 + DO 200 J=I+1,6 + ZTC(J,I)=ZTC(I,J) + 200 CONTINUE + 210 CONTINUE + CALL PYLDCM(ZTC,6,6,INDX,D) + DO 230 I=1,6 + DO 220 J=1,6 + YTC(I,J)=(0D0,0D0) + IF(I.EQ.J) YTC(I,J)=(1D0,0D0) + 220 CONTINUE + 230 CONTINUE + DO 240 I=1,6 + CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I)) + 240 CONTINUE + DGGU=YTC(1,1) + DVVU=YTC(2,2) + DGVU=YTC(1,2) + + IF(IMDL.EQ.1) THEN + DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3) + DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3) + DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3) + DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3) + DQGS=DGGS-DGVS*DCMPLX(TANT3) + DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3) + ELSE + DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3) + DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3) + DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3) + DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3) + DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3) + DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3) + ENDIF + + SQDQTS=ABS(DQTS)**2 + SQDQQS=ABS(DQQS)**2 + SQDQQT=ABS(DQQT)**2 + SQDQQU=ABS(DQQU)**2 + SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2 + REDLGS=DBLE(DQGS) + SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2 + REDHGS=DBLE(DTGS) + SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2 + + SQDGGS=ABS(DGGS)**2 + SQDGGT=ABS(DGGT)**2 + SQDGGU=ABS(DGGU)**2 + REDGGS=DBLE(DGGS) + REDGGT=DBLE(DGGT) + REDGGU=DBLE(DGGU) + REDGTU=DBLE(DGGU*DCONJG(DGGT)) + REDGSU=DBLE(DGGU*DCONJG(DGGS)) + REDGST=DBLE(DGGS*DCONJG(DGGT)) + REDQST=DBLE(DQQS*DCONJG(DQQT)) + REDQTU=DBLE(DQQT*DCONJG(DQQU)) + ENDIF + ENDIF + + +C...Differential cross section expressions. + + IF(ISUB.LE.190) THEN + IF(ISUB.EQ.149) THEN +C...g + g -> eta_tc + KCTC=PYCOMP(KTECHN+331) + CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2) + IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0 + HP=SH + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250 + HI=HP*WDTP(3) + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 250 CONTINUE + + ELSEIF(ISUB.EQ.165) THEN +C...q + qbar -> l+ + l- (including contact term for compositeness) + ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) + ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) + KFF=IABS(KFPR(ISUB,1)) + EF=KCHG(KFF,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + VALF=VF+AF + VARF=VF-AF + FCOF=1D0 + IF(KFF.LE.10) FCOF=3D0 + WID2=1D0 + IF(KFF.EQ.6) WID2=WIDS(6,1) + IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1) + IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1) + DO 260 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=VI+AI + VARI=VI-AI + FCOI=1D0 + IF(IABS(I).LE.10) FCOI=FACA/3D0 + IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN + FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/ + & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+ + & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2 + ELSE + FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+ + & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2 + ENDIF + FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+ + & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2 + FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2) + IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND. + & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2 + 260 CONTINUE + + ELSEIF(ISUB.EQ.166) THEN +C...q + q'bar -> l + nu_l (including contact term for compositeness) + WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2) + WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4) + KFF=IABS(KFPR(ISUB,1)) + FCOF=1D0 + IF(KFF.LE.10) FCOF=3D0 + DO 280 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280 + IA=IABS(I) + DO 270 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270 + JA=IABS(J) + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 270 + FCOI=1D0 + IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0 + WID2=1D0 + IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND. + & MOD(J,2).EQ.0)) THEN + IF(KFF.EQ.5) WID2=WIDS(6,2) + IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3) + IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3) + ELSE + IF(KFF.EQ.5) WID2=WIDS(6,3) + IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2) + IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2) + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2 + IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4) + & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2 + 270 CONTINUE + 280 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.200) THEN + IF(ISUB.EQ.191) THEN +C...q + qbar -> rho_tc0. + KCTC=PYCOMP(KTECHN+113) + SQMRHT=PMAS(KCTC,1)**2 + CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2) + IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0 + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + ALPRHT=2.16D0*(3D0/ITCM(1)) + HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH) + XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW)) + BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) + BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) + DO 290 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290 + IA=IABS(I) + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=0.5D0*(VI+AI) + VARI=0.5D0*(VI-AI) + HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+ + & (EI+VARI*BWZR)**2+(VARI*BWZI)**2) + IF(IA.LE.10) HI=HI*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 290 CONTINUE + + ELSEIF(ISUB.EQ.192) THEN +C...q + qbar' -> rho_tc+/-. + KCTC=PYCOMP(KTECHN+213) + SQMRHT=PMAS(KCTC,1)**2 + CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2) + IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0 + ALPRHT=2.16D0*(3D0/ITCM(1)) + HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)* + & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2) + DO 310 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310 + IA=IABS(I) + DO 300 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300 + JA=IABS(J) + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 300 + KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4)) + HI=HP + IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 300 CONTINUE + 310 CONTINUE + + ELSEIF(ISUB.EQ.193) THEN +C...q + qbar -> omega_tc0. + KCTC=PYCOMP(KTECHN+223) + SQMOMT=PMAS(KCTC,1)**2 + CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2) + IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0 + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + ALPRHT=2.16D0*(3D0/ITCM(1)) + HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)* + & (2D0*RTCM(2)-1D0)**2 + BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2) + BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2) + DO 320 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320 + IA=IABS(I) + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=0.5D0*(VI+AI) + VARI=0.5D0*(VI-AI) + HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+ + & (EI-VARI*BWZR)**2+(VARI*BWZI)**2) + IF(IA.LE.10) HI=HI*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 320 CONTINUE + + ELSEIF(ISUB.EQ.194) THEN +C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0. +C...Default final state is e+e- + KFA=KFPR(ISUBSV,1) + ALPRHT=2.16D0*(3D0/ITCM(1)) + HP=AEM**2*COMFAC + + SN2W=2D0*SQRT(XW*XW1) +C TANW=SQRT(PARU(102)/(1D0-PARU(102))) +C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW) + + QUPD=2D0*RTCM(2)-1D0 + FAR=SQRT(AEM/ALPRHT) + FAO=FAR*QUPD + FZR=FAR*CT2W + FZO=-FAO*TANW +C...RTCM(47) is the ratio g_{rho_T}/g_{a_T} + FZX=-FAR/SN2W*RTCM(47) + SFAR=FAR**2 + SFAO=FAO**2 + SFZR=FZR**2 + SFZO=FZO**2 + SFZX=FZX**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) + CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE) + SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR) +C...Propagator including a_T^0 + DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO- + $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ +C...Add in techni-a contribution + DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO) + DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)- + $ SFZX*SSMR*SSMO)/DETD/SH + DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX + DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX + + XWRHT=1D0/(4D0*XW*(1D0-XW)) + KFF=IABS(KFPR(ISUB,1)) + EF=KCHG(KFF,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*XWV + VALF=0.5D0*(VF+AF) + VARF=0.5D0*(VF-AF) + FCOF=1D0 + IF(KFF.LE.10) FCOF=3D0 + + WID2=1D0 + IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1) + IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1) + DZZ=DZZ*DCMPLX(XWRHT,0D0) + DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0) + + DO 330 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=0.5D0*(VI+AI) + VARI=0.5D0*(VI-AI) + FCOI=FCOF + IF(IABS(I).LE.10) FCOI=FCOI/3D0 + DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2 + DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2 + DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2 + DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2 + FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+ + & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=HP*FCOI*FACSIG*WID2 + 330 CONTINUE + + ELSEIF(ISUB.EQ.195) THEN +C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+ + KFA=KFPR(ISUBSV,1) + KFB=KFA+1 + ALPRHT=2.16D0*(3D0/ITCM(1)) + FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0 + + FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW)) +C...RTCM(47) is the ratio g_{rho_T}/g_{a_T} +C +C...Propagator including a_T^+ + FWX=-FWR*RTCM(47) + 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) + CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE) + SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR) + DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))- + & DCMPLX(FWX**2,0D0)*SSMR + DWW=SSMR*SSMX/DETD/SH + FCOF=1D0 + IF(KFA.LE.8) FCOF=3D0 + HP=FACTC*ABS(DWW)**2*FCOF + + DO 350 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350 + IA=IABS(I) + DO 340 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340 + JA=IABS(J) + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 340 + KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + HI=HP + IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2) + 340 CONTINUE + 350 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.380) THEN + ALPRHT=2.16D0*(3D0/ITCM(1)) + IF(ISUB.EQ.361) THEN + FAR=SQRT(AEM/ALPRHT) + FAO=FAR*QUPD + FZR=FAR*CT2W + FZO=-FAO*TANW +C...RTCM(47) is the ratio g_{rho_T}/g_{a_T} + FZX=-FAR/SN2W*RTCM(47) + SFAR=FAR**2 + SFAO=FAO**2 + SFZR=FZR**2 + SFZO=FZO**2 + SFZX=FZX**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) + CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE) + SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),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 +C...Add in techni-a contribution + DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO) + DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)- + $ SFZX*FAR*SSMO)/DETD/SH + DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX + DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)- + $ SFZX*FAO*SSMR)/DETD/SH + DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX + DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH + DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH + DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)- + $ SFZX*SSMR*SSMO)/DETD/SH + DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX + DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX + +C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc', +C...W+W-, W pi_tc, pi_T pi_T, etc. + FACA=(SH**2*BE34**2-(TH-UH)**2) + VFAC=(TH**2+UH**2-2D0*SQM3*SQM4) + AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3) + FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1) + HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH + DO 370 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370 + IA=IABS(I) + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011 + VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011 +C...........Eqs. (5) and (6) in LSTC-rates.pdf + F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP + F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP + F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP + F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+ + $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1))) + F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP + F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP + F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP + F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+ + $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1))) + HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC +C...........Eqs. (5) and (7) in LSTC-rates.pdf + F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP + F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP + F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP + F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP + F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP + F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP + HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC +C +C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped. +C +c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+ +c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1) +c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+ +c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1) + F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1) + F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1) + HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH + HI=HI+HJ+HK + 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) + ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN + 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) + ELSE + SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2) + ENDIF + 370 CONTINUE + + ELSEIF(ISUB.EQ.370) THEN +C...f + fbar' -> W_L Z_L, W_L Z_T, W_T, Z_L, W_L pi_tc, Z_L pi_tc, pi_tc pi_tc +C...f + fbar' -> gamma pi_tc, etc. + FACA=(SH**2*BE34**2-(TH-UH)**2) + FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1) + VFAC=(TH**2+UH**2-2D0*SQM3*SQM4) + AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3) + ALPRHT=2.16D0*(3D0/ITCM(1)) + FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH + FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW)) +C...RTCM(47) is the ratio g_{rho_T}/g_{a_T} + FWX=-FWR*RTCM(47) + 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) + CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE) + SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR) + DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))- + & DCMPLX(FWX**2,0D0)*SSMR + DWW=SSMR*SSMX/DETD/SH + DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH + DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH + HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+ + $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2) +C +C...........Eq. (25) in PRD67-115011 with DWW term dropped. +C +c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2 + HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2 +C...Add in W_L Z_T axial and vector contributions. + IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*( + $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses. + $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+ + $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2) + DO 410 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410 + IA=IABS(I) + DO 400 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400 + JA=IABS(J) + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 400 + KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + HI=HP + IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN + SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2) + ELSE + SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)* + & WIDS(PYCOMP(KFB),2) + ENDIF + 400 CONTINUE + 410 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.390) THEN + IF(ISUB.EQ.381) THEN +C...f + f' -> f + f' (g exchange) + FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT + FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA- + & MSTP(34)*2D0/3D0*UH2*REDQST) + FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU + FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH) + RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2) + IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN +C...Modifications from contact interactions (compositeness) + FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4) + FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)* + & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4) + FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)* + & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4) + FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4) + RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2) + ELSEIF(ITCM(5).EQ.5) THEN + FACCI1=FACQQ1 + FACCIB=FACQQB + FACCI2=FACQQ2 + FACCI3=FACQQ1 +CSM.......Check this change from +CSM RATCII=1D0 + RATCII=RATQQI + ENDIF + DO 430 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430 + DO 420 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR. + & JA.GE.3))) THEN + SIGH(NCHN)=FACQQ1 + IF(I.EQ.-J) SIGH(NCHN)=FACQQB + ELSE + SIGH(NCHN)=FACCI1 + IF(I*J.LT.0) SIGH(NCHN)=FACCI3 + IF(I.EQ.-J) SIGH(NCHN)=FACCIB + ENDIF + IF(I.EQ.J) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN + SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI + SIGH(NCHN)=0.5D0*FACQQ2*RATQQI + ELSE + SIGH(NCHN-1)=0.5D0*FACCI1*RATCII + SIGH(NCHN)=0.5D0*FACCI2*RATCII + ENDIF + ENDIF + 420 CONTINUE + 430 CONTINUE + + ELSEIF(ISUB.EQ.382) THEN +C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only) + CALL PYWIDT(21,SH,WDTP,WDTE) + FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2) + FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + IF(ITCM(5).EQ.1) THEN +C...Modifications from contact interactions (compositeness) + FACCIB=FACQQB + DO 440 I=1,2 + FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+ + & WDTE(I,2)+WDTE(I,4)) + 440 CONTINUE + ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN + FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)* + & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + ELSEIF(ITCM(5).EQ.5) THEN + FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)- + & WDTE(5,1)-WDTE(5,2)-WDTE(5,4)) + FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4)) + ENDIF + DO 450 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN + SIGH(NCHN)=FACQQB + ELSEIF(ITCM(5).EQ.5) THEN + SIGH(NCHN)=FACQQB + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACCIB + ELSE + SIGH(NCHN)=FACCIB + ENDIF + 450 CONTINUE + + ELSEIF(ISUB.EQ.383) THEN +C...f + fbar -> g + g (q + qbar -> g + g only) + FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* + & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS) + FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* + & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS) + IF(ITCM(5).EQ.5) THEN + FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* + & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS) + FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* + & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS) + ENDIF + DO 460 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=0.5D0*FACGG1 + IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=2 + SIGH(NCHN)=0.5D0*FACGG2 + IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4 + 460 CONTINUE + + ELSEIF(ISUB.EQ.384) THEN +C...f + g -> f + g (q + g -> q + g only) + FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2- + & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA + FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2- + & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT) + DO 480 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480 + DO 470 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQG1 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQG2 + 470 CONTINUE + 480 CONTINUE + + ELSEIF(ISUB.EQ.385) THEN +C...g + g -> f + fbar (g + g -> q + qbar only) + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500 + IDC0=MDCY(21,2)-1 +C...Begin by d, u, s flavours. + FLAVWT=0D0 + IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH)) + IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH)) + IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+ + & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH)) + FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)* + & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA + FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)* + & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQ2 +C...Next c and b flavours: modified that and uhat for fixed +C...cos(theta-hat). + DO 490 IFL=4,5 + SQMAVG=PMAS(IFL,1)**2 + IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN + BE34=SQRT(1D0-4D0*SQMAVG/SH) + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + THUHQ=THQ*UHQ-SQMAVG*SH + IF(MSTP(34).EQ.0) THEN + FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2 + FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2 + ELSE + FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ) + FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ) + ENDIF + IF(ITCM(5).GE.5) THEN + IF(IFL.EQ.4) THEN + FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+ + & 2.25D0*THQ*UHQ/SH2*SQDLGS + FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+ + & 2.25D0*THQ*UHQ/SH2*SQDLGS + ELSE + FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+ + & 2.25D0*THQ*UHQ/SH2*SQDHGS + FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+ + & 2.25D0*THQ*UHQ/SH2*SQDHGS + ENDIF + ENDIF + FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34 + FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1+2*(IFL-3) + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2+2*(IFL-3) + SIGH(NCHN)=FACQQ2 + ENDIF + 490 CONTINUE + 500 CONTINUE + + ELSEIF(ISUB.EQ.386) THEN +C...g + g -> g + g + IF(ITCM(5).LE.4) THEN + FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+ + & 2D0*TH/SH+TH2/SH2)*FACA + FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+ + & 2D0*SH/UH+SH2/UH2)*FACA + FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+ + & 2D0*UH/TH+UH2/TH2) + ELSE + GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 + + & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+ + & 4D0*REDGST*(SH + 2D0*TH)* + & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 + + & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) + + & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2- + & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) + + & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH + + & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0 + GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 + + & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+ + & 4D0*REDGSU*(SH + 2D0*UH)* + & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 + + & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) + + & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2- + & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) + + & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH + + & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0 + GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 + + & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 - + & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 + + & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 - + & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 + + & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 + + & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+ + & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 + + & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+ + & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH + + & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) + + & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 + + & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0 + FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA + FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA + FACGG3=COMFAC*AS**2*9D0/4D0*GUT + ENDIF + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=0.5D0*FACGG1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=0.5D0*FACGG2 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=3 + SIGH(NCHN)=0.5D0*FACGG3 + 510 CONTINUE + + ELSEIF(ISUB.EQ.387) THEN +C...q + qbar -> Q + Qbar + SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+ + & 2D0*SQMAVG/SH) + IF(ITCM(5).GE.5) THEN + IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN + FACQQB=FACQQB*SH2*SQDQTS + ELSE + FACQQB=FACQQB*SH2*SQDQQS + ENDIF + ENDIF + IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0) + WID2=1D0 + IF(MINT(55).EQ.6) WID2=WIDS(6,1) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1) + FACQQB=FACQQB*WID2 + DO 520 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQB + 520 CONTINUE + + ELSEIF(ISUB.EQ.388) THEN +C...g + g -> Q + Qbar + SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH + THQ=-0.5D0*SH*(1D0-BE34*CTH) + UHQ=-0.5D0*SH*(1D0+BE34*CTH) + THUHQ=THQ*UHQ-SQMAVG*SH + IF(MSTP(34).EQ.0) THEN + FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2 + FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2 + ELSE + FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ) + FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/ + & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ) + ENDIF + IF(ITCM(5).GE.5) THEN + IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN + FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+ + & 2.25D0*THQ*UHQ/SH2*SQDHGS + FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+ + & 2.25D0*THQ*UHQ/SH2*SQDHGS + ELSE + FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+ + & 2.25D0*THQ*UHQ/SH2*SQDLGS + FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+ + & 2.25D0*THQ*UHQ/SH2*SQDLGS + ENDIF + ENDIF + FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1 + FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2 + IF(MSTP(35).GE.1) THEN + FATRE=PYHFTH(SH,SQMAVG,2D0/7D0) + FACQQ1=FACQQ1*FATRE + FACQQ2=FACQQ2*FATRE + ENDIF + WID2=1D0 + IF(MINT(55).EQ.6) WID2=WIDS(6,1) + IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1) + FACQQ1=FACQQ1*WID2 + FACQQ2=FACQQ2*WID2 + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACQQ1 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=2 + SIGH(NCHN)=FACQQ2 + 530 CONTINUE + ENDIF + ENDIF + +CMRENNA-- + + RETURN + END + +C********************************************************************* + +C...PYSGEX +C...Subprocess cross sections for assorted exotic processes, +C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*. +C...Auxiliary to PYSIGH. + + SUBROUTINE PYSGEX(NCHN,SIGS) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/, + &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/ +C...Local arrays + DIMENSION WDTP(0:400),WDTE(0:400,0:5) + +C...Differential cross section expressions. + + IF(ISUB.LE.160) THEN + IF(ISUB.EQ.141) THEN +C...f + fbar -> gamma*/Z0/Z'0 + SQMZP=PMAS(32,1)**2 + MINT(61)=2 + CALL PYWIDT(32,SH,WDTP,WDTE) + HP0=AEM/3D0*SH + HP1=AEM/3D0*XWC*SH + HP2=HP1 + HS=SHR*VINT(117) + HSP=SHR*WDTP(0) + FACZP=4D0*COMFAC*3D0 + DO 100 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI) + VI=AI-4D0*EI*XWV + IA=IABS(I) + IF(IA.LT.10) THEN + IF(IA.LE.2) THEN + VPI=PARU(123-2*MOD(IABS(I),2)) + API=PARU(124-2*MOD(IABS(I),2)) + ELSEIF(IA.LE.4) THEN + VPI=PARJ(182-2*MOD(IABS(I),2)) + API=PARJ(183-2*MOD(IABS(I),2)) + ELSE + VPI=PARJ(190-2*MOD(IABS(I),2)) + API=PARJ(191-2*MOD(IABS(I),2)) + ENDIF + ELSE + IF(IA.LE.12) THEN + VPI=PARU(127-2*MOD(IABS(I),2)) + API=PARU(128-2*MOD(IABS(I),2)) + ELSEIF(IA.LE.14) THEN + VPI=PARJ(186-2*MOD(IABS(I),2)) + API=PARJ(187-2*MOD(IABS(I),2)) + ELSE + VPI=PARJ(194-2*MOD(IABS(I),2)) + API=PARJ(195-2*MOD(IABS(I),2)) + ENDIF + ENDIF + HI0=HP0 + IF(IABS(I).LE.10) HI0=HI0*FACA/3D0 + HI1=HP1 + IF(IABS(I).LE.10) HI1=HI1*FACA/3D0 + HI2=HP2 + IF(IABS(I).LE.10) HI2=HI2*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 +C...Special case: if only branching ratios known then use them. + IF(MWID(32).EQ.2.AND.MSTP(44).EQ.3) THEN + HI=0D0 + IF(IA.LT.10) THEN + HI=SHR*WDTP(IA)*FACA/9D0 + ELSEIF(IA.LT.20) THEN + HI=SHR*WDTP(IA-2) + ENDIF + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + SIGH(NCHN)=HI*FACZP*HF/((SH-SQMZP)**2+HSP**2) + ELSE +C...Normal cross section. + 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)) + ENDIF + 100 CONTINUE + + ELSEIF(ISUB.EQ.142) THEN +C...f + fbar' -> W'+/- + SQMWP=PMAS(34,1)**2 + CALL PYWIDT(34,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0 + HP=AEM/(24D0*XW)*SH + DO 120 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120 + IA=IABS(I) + DO 110 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110 + JA=IABS(J) + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 110 + KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 +C...Special case: if only branching ratios known then use them. + IF(MWID(34).EQ.2) THEN + HI=0D0 + DO 105 IDC=MDCY(34,2),MDCY(34,2)+MDCY(34,3)-1 + IF((IA.EQ.IABS(KFDP(IDC,1)).AND.JA.EQ. + & IABS(KFDP(IDC,2))).OR.(IA.EQ.IABS(KFDP(IDC,2)) + & .AND.JA.EQ.IABS(KFDP(IDC,1)))) + & HI=SHR*WDTP(IDC+1-MDCY(34,2)) + 105 CONTINUE + IF(IA.LT.10) HI=HI*FACA/9D0 + ELSE +C...Normal cross section. + 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 + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4)) + SIGH(NCHN)=HI*FACBW*HF + 110 CONTINUE + 120 CONTINUE + + ELSEIF(ISUB.EQ.144) THEN +C...f + fbar' -> R + SQMR=PMAS(41,1)**2 + CALL PYWIDT(41,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0 + HP=AEM/(12D0*XW)*SH + DO 140 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140 + IA=IABS(I) + DO 130 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130 + JA=IABS(J) + IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130 + HI=HP + IF(IA.LE.10) HI=HI*FACA/3D0 + HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4)) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 130 CONTINUE + 140 CONTINUE + + ELSEIF(ISUB.EQ.145) THEN +C...q + l -> LQ (leptoquark) + SQMLQ=PMAS(42,1)**2 + CALL PYWIDT(42,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2) + IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0 + HP=AEM/4D0*SH + KFLQQ=KFDP(MDCY(42,2),1) + KFLQL=KFDP(MDCY(42,2),2) + DO 160 I=MMIN1,MMAX1 + IF(KFAC(1,I).EQ.0) GOTO 160 + IA=IABS(I) + IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160 + DO 150 J=MMIN2,MMAX2 + IF(KFAC(2,J).EQ.0) GOTO 150 + JA=IABS(J) + IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150 + IF(I*J.NE.KFLQQ*KFLQL) GOTO 150 + IF(JA.EQ.IA) GOTO 150 + IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I) + IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J) + HI=HP*PARU(151) + HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4)) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 150 CONTINUE + 160 CONTINUE + + ELSEIF(ISUB.EQ.146) THEN +C...e + gamma* -> e* (excited lepton) + KFQSTR=KFPR(ISUB,1) + KCQSTR=PYCOMP(KFQSTR) + KFQEXC=MOD(KFQSTR,KEXCIT) + CALL PYWIDT(KFQSTR,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2) + QF=-RTCM(43)/2D0-RTCM(44)/2D0 + FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2 + IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2)) + & FACBW=0D0 + HP=SH + DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC + DO 170 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170 + HI=HP + IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4)) + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 170 CONTINUE + 180 CONTINUE + + ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN +C...d + g -> d* and u + g -> u* (excited quarks) + KFQSTR=KFPR(ISUB,1) + KCQSTR=PYCOMP(KFQSTR) + KFQEXC=MOD(KFQSTR,KEXCIT) + CALL PYWIDT(KFQSTR,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2) + FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2) + IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2)) + & FACBW=0D0 + HP=SH + DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC + DO 190 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190 + HI=HP + IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4)) + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 190 CONTINUE + 200 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.190) THEN + IF(ISUB.EQ.162) THEN +C...q + g -> LQ + lbar; LQ=leptoquark + SQMLQ=PMAS(42,1)**2 + FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)* + & (UH2+SQMLQ**2)/(UH-SQMLQ)**2 + KFLQQ=KFDP(MDCY(42,2),1) + DO 220 I=MMINA,MMAXA + IF(IABS(I).NE.KFLQQ) GOTO 220 + KCHLQ=ISIGN(1,I) + DO 210 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2) + 210 CONTINUE + 220 CONTINUE + + ELSEIF(ISUB.EQ.163) THEN +C...g + g -> LQ + LQbar; LQ=leptoquark + SQMLQ=PMAS(42,1)**2 + FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)* + & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/ + & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/ + & ((TH-SQMLQ)*(UH-SQMLQ))) + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 +C...Since don't know proper colour flow, randomize between alternatives + ISIG(NCHN,3)=INT(1.5D0+PYR(0)) + SIGH(NCHN)=FACLQ + 230 CONTINUE + + ELSEIF(ISUB.EQ.164) THEN +C...q + qbar -> LQ + LQbar; LQ=leptoquark + DELTA=0.25D0*(SQM3-SQM4)**2/SH + SQMLQ=0.5D0*(SQM3+SQM4)-DELTA + TH=TH-DELTA + UH=UH-DELTA +C SQMLQ=PMAS(42,1)**2 + FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)* + & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2 + FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)* + & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)* + & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH)) + KFLQQ=KFDP(MDCY(42,2),1) + DO 240 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACLQA + IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS + 240 CONTINUE + + ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN +C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks) + KFQSTR=KFPR(ISUB,2) + KCQSTR=PYCOMP(KFQSTR) + KFQEXC=MOD(KFQSTR,KEXCIT) + FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH) + FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)* + & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH) +C...Propagators: as simulated in PYOFSH and as desired + GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2) + HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2) + CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE) + GMMQC=SQRT(SQM4)*WDTP(0) + HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2) + FACQSA=FACQSA*HBW4C/HBW4 + FACQSB=FACQSB*HBW4C/HBW4 +C...Branching ratios. + BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0) + BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0) + DO 260 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260 + DO 250 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250 + IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS + IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS + IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG + ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2 + IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS + IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG + ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS + IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS + IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG + ELSEIF(I.EQ.-J) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS + IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS + IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG + ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2 + IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS + IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG + ENDIF + 250 CONTINUE + 260 CONTINUE + + ELSEIF(ISUB.EQ.169) THEN +C...q + qbar -> e + e* (excited lepton) + KFQSTR=KFPR(ISUB,2) + KCQSTR=PYCOMP(KFQSTR) + KFQEXC=MOD(KFQSTR,KEXCIT) + FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)* + & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH) +C...Propagators: as simulated in PYOFSH and as desired + GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2) + HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2) + CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE) + GMMQC=SQRT(SQM4)*WDTP(0) + HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2) + FACQSB=FACQSB*HBW4C/HBW4 +C...Branching ratios. + BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0) + BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0) + DO 270 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270 + J=-I + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS + IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=2 + IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS + IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG + 270 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.360) THEN + IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN +C...l + l -> H_L++/-- or H_R++/--. + KFRES=KFPR(ISUB,1) + KFREC=PYCOMP(KFRES) + CALL PYWIDT(KFRES,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2) + DO 290 I=MMIN1,MMAX1 + IA=IABS(I) + IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0) + & GOTO 290 + DO 280 J=MMIN2,MMAX2 + JA=IABS(J) + IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0) + & GOTO 280 + IF(I*J.LT.0) GOTO 280 + KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1)) + HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4)) + SIGH(NCHN)=HI*FACBW*HF + 280 CONTINUE + 290 CONTINUE + + ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN +C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'. + KFRES=KFPR(ISUB,1) + KFREC=PYCOMP(KFRES) +C...Propagators: as simulated in PYOFSH and as desired + HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+ + & (PMAS(KFREC,1)*PMAS(KFREC,2))**2) + CALL PYWIDT(KFRES,SQM3,WDTP,WDTE) + GMMC=SQRT(SQM3)*WDTP(0) + HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2) + FHCC=COMFAC*AEM*HBW3C/HBW3 + DO 310 I=MMINA,MMAXA + IA=IABS(I) + IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310 + SQML=PMAS(IA,1)**2 + J=ISIGN(KFPR(ISUB,2),-I) + KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I)) + WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0) + SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/ + & (UH-SQM3)**2 + SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH- + & (TH-SQM4)*SH)/(TH-SQM4)**2 + SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)* + & SH)/(SH-SQML)**2 + SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3- + & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/ + & ((UH-SQM3)*(TH-SQM4)) + SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)* + & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/ + & ((UH-SQM3)*(SH-SQML)) + SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)- + & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/ + & ((SH-SQML)*(TH-SQM4)) + SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)* + & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1)) + DO 300 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300 + IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=22 + ISIG(NCHN,3)=0 + SIGH(NCHN)=FHCC*SMM*WIDSC + 300 CONTINUE + 310 CONTINUE + + ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN +C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R-- + KFRES=KFPR(ISUB,1) + KFREC=PYCOMP(KFRES) + SQMH=PMAS(KFREC,1)**2 + GMMH=PMAS(KFREC,1)*PMAS(KFREC,2) +C...Propagators: H++/-- as simulated in PYOFSH and as desired + HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2) + CALL PYWIDT(KFRES,SQM3,WDTP,WDTE) + GMMH3=SQRT(SQM3)*WDTP(0) + HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2) + HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) + CALL PYWIDT(KFRES,SQM4,WDTP,WDTE) + GMMH4=SQRT(SQM4)*WDTP(0) + HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2) +C...Kinematical and coupling functions + FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4) + XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV)) +C...Loop over allowed flavours + DO 320 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320 + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*XWV + FCOI=1D0 + IF(IABS(I).LE.10) FCOI=FACA/3D0 + IF(ISUB.EQ.349) THEN + HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2) + IF(IABS(I).LT.10) THEN + DSIGHH=8D0*AEM**2*(EI**2/SH2+ + & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+ + & (VI**2+AI**2)*XWHH**2*HBWZ) + ELSE + IAOFF=181+3*((IABS(I)-11)/2) + HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/ + & (4D0*PARU(1)) + DSIGHH=8D0*AEM**2*(EI**2/SH2+ + & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+ + & (VI**2+AI**2)*XWHH**2*HBWZ)+ + & 8D0*AEM*(EI*HSUM/(SH*TH)+ + & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+ + & 4D0*HSUM**2/TH2 + ENDIF + ELSE + IF(IABS(I).LT.10) THEN + DSIGHH=8D0*AEM**2*EI**2/SH2 + ELSE + IAOFF=181+3*((IABS(I)-11)/2) + HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/ + & (4D0*PARU(1)) + DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+ + & 4D0*HSUM**2/TH2 + ENDIF + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACHH*FCOI*DSIGHH + 320 CONTINUE + + ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN +C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process) + KFRES=KFPR(ISUB,1) + KFREC=PYCOMP(KFRES) + SQMH=PMAS(KFREC,1)**2 + IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2 + IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0* + & PMAS(PYCOMP(9900024),1)**2 + FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219) + FACPRT=1D0/((VINT(204)**2-VINT(215))* + & (VINT(209)**2-VINT(216))) + FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))* + & (VINT(209)**2+2D0*VINT(218))) + CALL PYWIDT(KFRES,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2) + IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2)) + & FACBW=0D0 + DO 340 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340 + IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340 + KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I) + DO 330 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330 + IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330 + KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J) + KCHH=KCHWI+KCHWJ + IF(IABS(KCHH).NE.2) GOTO 330 + FACLR=VINT(180+I)*VINT(180+J) + HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4)) + IF(I.EQ.J.AND.IABS(I).GT.10) THEN + FACPRP=0.5D0*(FACPRT+FACPRU)**2 + ELSE + FACPRP=FACPRT**2 + ENDIF + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF + 330 CONTINUE + 340 CONTINUE + + ELSEIF(ISUB.EQ.353) THEN +C...f + fbar -> Z_R0 + SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2 + CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0 + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH + DO 350 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350 + IF(IABS(I).LE.8) THEN + EI=KCHG(IABS(I),1)/3D0 + AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW) + VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW + ELSE + AI=-(1D0-2D0*XW) + VI=-1D0+4D0*XW + ENDIF + HI=HP*(VI**2+AI**2) + IF(IABS(I).LE.10) HI=HI*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=HI*FACBW*HF + 350 CONTINUE + + ELSEIF(ISUB.EQ.354) THEN +C...f + fbar' -> W_R+/- + SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2 + CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0 + HP=AEM/(24D0*XW)*SH + DO 370 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370 + IA=IABS(I) + DO 360 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360 + JA=IABS(J) + IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360 + IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10)) + & GOTO 360 + KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3 + HI=HP*2D0 + IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4)) + SIGH(NCHN)=HI*FACBW*HF + 360 CONTINUE + 370 CONTINUE + ENDIF + + ELSEIF(ISUB.LE.400) THEN + IF(ISUB.EQ.391) THEN +C...f + fbar -> G*. + KFGSTR=KFPR(ISUB,1) + KCGSTR=PYCOMP(KFGSTR) + CALL PYWIDT(KFGSTR,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/ + & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2) +C...Modify cross section in wings of peak. + FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4 + DO 380 I=MMINA,MMAXA + IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380 + HI=1D0 + IF(IABS(I).LE.10) HI=HI*FACA/3D0 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACG*HI + 380 CONTINUE + + ELSEIF(ISUB.EQ.392) THEN +C...g + g -> G*. + KFGSTR=KFPR(ISUB,1) + KCGSTR=PYCOMP(KFGSTR) + CALL PYWIDT(KFGSTR,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/ + & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2) +C...Modify cross section in wings of peak. + FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4 + IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390 + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACG + 390 CONTINUE + + ELSEIF(ISUB.EQ.393) THEN +C...q + qbar -> g + G*. + KFGSTR=KFPR(ISUB,2) + KCGSTR=PYCOMP(KFGSTR) + FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)* + & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+ + & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+ + & 2D0*SH2/(TH*UH)) +C...Propagators: as simulated in PYOFSH and as desired + GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2) + HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2) + CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE) + HS=SQRT(SQM4)*WDTP(0) + HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2) + FACG=FACG*HBW4C/HBW4 + DO 400 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACG + 400 CONTINUE + + ELSEIF(ISUB.EQ.394) THEN +C...q + g -> q + G*. + KFGSTR=KFPR(ISUB,2) + KCGSTR=PYCOMP(KFGSTR) + FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)* + & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+ + & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+ + & 2D0*TH2*TH/(UH*SH2)) +C...Propagators: as simulated in PYOFSH and as desired + GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2) + HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2) + CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE) + HS=SQRT(SQM4)*WDTP(0) + HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2) + FACG=FACG*HBW4C/HBW4 + DO 420 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420 + DO 410 ISDE=1,2 + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACG + 410 CONTINUE + 420 CONTINUE + + ELSEIF(ISUB.EQ.395) THEN +C...g + g -> g + G*. + KFGSTR=KFPR(ISUB,2) + KCGSTR=PYCOMP(KFGSTR) + FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)* + & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+ + & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH)) +C...Propagators: as simulated in PYOFSH and as desired + GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2) + HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2) + CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE) + HS=SQRT(SQM4)*WDTP(0) + HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)) + HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2) + FACG=FACG*HBW4C/HBW4 + IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=FACG + ENDIF + ENDIF + ELSEIF(ISUB.LE.500) THEN + IF(ISUBSV.EQ.481) ISUB=482 +c... GENERIC 2->(1)->2 + IF(ISUB.EQ.482) THEN + KFRES=9900001 + KCRES=PYCOMP(KFRES) + IF(KCRES.EQ.0) RETURN + IDCY=MDCY(KCRES,2) + KCOL=KCHG(KCRES,2) + KCEM=KCHG(KCRES,1) + FACT=COMFAC + KCF1=PYCOMP(KFPR(ISUB,1)) + KCF2=PYCOMP(KFPR(ISUB,2)) + IF(ISUBSV.EQ.481) THEN + SQMZR=PMAS(KCRES,1)**2 + CALL PYWIDT(KFRES,SH,WDTP,WDTE) + HS=SHR*WDTP(0) + FACBW=SH2/((SH-SQMZR)**2+HS**2) + FACT=FACT*FACBW + ELSE + SQMH=PMAS(KCF1,1)**2 + GMMH=PMAS(KCF1,1)*PMAS(KCF1,2) +C...Propagators: as simulated in PYOFSH and as desired + HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2) + CALL PYWIDT(KFPR(ISUB,1),SQM3,WDTP,WDTE) + GMMH3=SQRT(SQM3)*WDTP(0) + HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2) + SQMH=PMAS(KCF2,1)**2 + GMMH=PMAS(KCF2,1)*PMAS(KCF2,2) + HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2) + CALL PYWIDT(KFPR(ISUB,2),SQM4,WDTP,WDTE) + GMMH4=SQRT(SQM4)*WDTP(0) + HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2) + FACT=FACT*(HBW3C/HBW3)*(HBW4C/HBW4) + ENDIF + + KCI1=ABS(PYCOMP(KFDP(IDCY,1))) + KCI2=ABS(PYCOMP(KFDP(IDCY,2))) + JCOL1=SIGN(KCHG(KCF1,2),KFPR(ISUB,1)) + JCOL2=SIGN(KCHG(KCF2,2),KFPR(ISUB,2)) + IF(KCOL.EQ.0) THEN + NCOL=1 + ELSEIF(KCI1.EQ.21.AND.KCI2.EQ.21.AND.KCOL.EQ.2) THEN + IF(JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN + NCOL=3 + ELSE + NCOL=2 + ENDIF + ELSEIF(KCOL.EQ.-1.OR.KCOL.EQ.1) THEN + NCOL=2 + ELSEIF(KCI1.EQ.21.AND.KCI2.EQ.21.AND.JCOL1.EQ.0.AND. + $ JCOL2.EQ.0) THEN + NCOL=1 + ELSEIF(KCOL.EQ.2.AND.((JCOL1.EQ.0.AND.JCOL2.EQ.2).OR. + $ (JCOL1.EQ.2.AND.JCOL2.EQ.0))) THEN + NCOL=1 + ELSE + NCOL=2 + ENDIF + DO 440 I=MMIN1,MMAX1 + IF(KFAC(1,I).EQ.0) GOTO 440 + IP=I + IF(IP.EQ.0) IP=21 + IA=ABS(IP) + DO 430 J=MMIN2,MMAX2 + IF(KFAC(2,J).EQ.0) GOTO 430 + JP=J + IF(JP.EQ.0) JP=21 + JA=ABS(JP) + IF((IA.EQ.KCI1.AND.JA.EQ.KCI2).OR. + $ (JA.EQ.KCI1.AND.IA.EQ.KCI2)) THEN + KCHW=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J) + IF(ABS(KCHW).EQ.ABS(KCEM)) THEN + DO II=1,NCOL + NCHN=NCHN+1 + ISIG(NCHN,1)=IP + ISIG(NCHN,2)=JP + ISIG(NCHN,3)=II + SIGH(NCHN)=FACT/NCOL + ENDDO + ENDIF + ENDIF + 430 CONTINUE + 440 CONTINUE + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYPDFU +C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon +C...parton distributions according to a few different parametrizations. +C...Note that what is coded is x times the probability distribution, +C...i.e. xq(x,Q2) etc. + + SUBROUTINE PYPDFU(KF,X,Q2,XPQ) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6), + &XPDIR(-6:6) + COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6) + COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6), + & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1), + & XMI(2,240),PT2MI(240),IMISEP(0:240) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/, + &/PYINT9/,/PYINTM/ +C...Local arrays. + DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6), + &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2) + SAVE PPAR + +C...Interface to PDFLIB. + COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX + SAVE /W50513/ + DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU, + &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX + CHARACTER*20 PARM(20) + DATA VALUE/20*0D0/,PARM/20*' '/ +C--use nuclear pdf? + COMMON/NPDF/MASS,NSET,EPS09,INITSTR + INTEGER NSET + DOUBLE PRECISION MASS + LOGICAL EPS09 + CHARACTER*10 INITSTR + +C...Data related to Schuler-Sjostrand photon distributions. + DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/ + +C...Valence PDF momentum integral parametrizations PER PARTON! + DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/ + DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/ + PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)* + &LOG(LOG(MAX(Q2,1D0)/0.04D0))) + +C...Reset parton distributions. + MINT(92)=0 + DO 100 KFL=-25,25 + XPQ(KFL)=0D0 + 100 CONTINUE + DO 110 KFL=-6,6 + XPVAL(KFL)=0D0 + 110 CONTINUE + +C...Check x and particle species. + IF(X.LE.0D0.OR.X.GE.1D0) THEN + WRITE(MSTU(11),5000) X + GOTO 9999 + ENDIF + KFA=IABS(KF) + IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND. + &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND. + &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND. + &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND. + &KFA.NE.310.AND.KFA.NE.130) THEN + WRITE(MSTU(11),5100) KF + GOTO 9999 + ENDIF + +C...Electron (or muon or tau) parton distribution call. + IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN + CALL PYPDEL(KFA,X,Q2,XPEL) + DO 120 KFL=-25,25 + XPQ(KFL)=XPEL(KFL) + 120 CONTINUE + +C...Photon parton distribution call (VDM+anomalous). + ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN + IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN + CALL PYPDGA(X,Q2,XPGA) + DO 130 KFL=-6,6 + XPQ(KFL)=XPGA(KFL) + 130 CONTINUE + XPVU=4D0*(XPQ(2)-XPQ(1))/3D0 + XPVAL(1)=XPVU/4D0 + XPVAL(2)=XPVU + XPVAL(3)=MIN(XPQ(3),XPVU/4D0) + XPVAL(4)=MIN(XPQ(4),XPVU) + XPVAL(5)=MIN(XPQ(5),XPVU/4D0) + XPVAL(-1)=XPVAL(1) + XPVAL(-2)=XPVAL(2) + XPVAL(-3)=XPVAL(3) + XPVAL(-4)=XPVAL(4) + XPVAL(-5)=XPVAL(5) + ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN + Q2MX=Q2 + P2MX=0.36D0 + IF(MSTP(55).GE.7) P2MX=4.0D0 + IF(MSTP(57).EQ.0) Q2MX=P2MX + P2=0D0 + IF(VINT(120).LT.0D0) P2=VINT(120)**2 + CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA) + DO 140 KFL=-6,6 + XPQ(KFL)=XPGA(KFL) + XPVAL(KFL)=VXPDGM(KFL) + 140 CONTINUE + VINT(231)=P2MX + ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN + Q2MX=Q2 + P2MX=0.36D0 + IF(MSTP(55).GE.11) P2MX=4.0D0 + IF(MSTP(57).EQ.0) Q2MX=P2MX + P2=0D0 + IF(VINT(120).LT.0D0) P2=VINT(120)**2 + CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA) + DO 150 KFL=-6,6 + XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL) + XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL) + 150 CONTINUE + VINT(231)=P2MX + ELSEIF(MSTP(56).EQ.2) THEN +C...Call PDFLIB parton distributions. + PARM(1)='NPTYPE' + VALUE(1)=3 + PARM(2)='NGROUP' + VALUE(2)=MSTP(55)/1000 + PARM(3)='NSET' + VALUE(3)=MOD(MSTP(55),1000) + IF(MINT(93).NE.3000000+MSTP(55)) THEN + CALL PDFSET(PARM,VALUE) + MINT(93)=3000000+MSTP(55) + ENDIF + XX=X + QQ2=MAX(0D0,Q2MIN,Q2) + IF(MSTP(57).EQ.0) QQ2=Q2MIN + P2=0D0 + IF(VINT(120).LT.0D0) P2=VINT(120)**2 + IP2=MSTP(60) + IF(MSTP(55).EQ.5004) THEN + IF(5D0*P2.LT.QQ2.AND. + & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND. + & P2.GE.0D0.AND.P2.LT.10D0.AND. + & XX.GT.1D-4.AND.XX.LT.1D0) THEN + CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM, + & BOT,TOP,GLU) + ELSE + UPV=0D0 + DNV=0D0 + USEA=0D0 + DSEA=0D0 + STR=0D0 + CHM=0D0 + BOT=0D0 + TOP=0D0 + GLU=0D0 + ENDIF + ELSE + IF(P2.LT.QQ2) THEN + CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM, + & BOT,TOP,GLU) + ELSE + UPV=0D0 + DNV=0D0 + USEA=0D0 + DSEA=0D0 + STR=0D0 + CHM=0D0 + BOT=0D0 + TOP=0D0 + GLU=0D0 + ENDIF + ENDIF + VINT(231)=Q2MIN + XPQ(0)=GLU + XPQ(1)=DNV + XPQ(-1)=DNV + XPQ(2)=UPV + XPQ(-2)=UPV + XPQ(3)=STR + XPQ(-3)=STR + XPQ(4)=CHM + XPQ(-4)=CHM + XPQ(5)=BOT + XPQ(-5)=BOT + XPQ(6)=TOP + XPQ(-6)=TOP + XPVU=4D0*(XPQ(2)-XPQ(1))/3D0 + XPVAL(1)=XPVU/4D0 + XPVAL(2)=XPVU + XPVAL(3)=MIN(XPQ(3),XPVU/4D0) + XPVAL(4)=MIN(XPQ(4),XPVU) + XPVAL(5)=MIN(XPQ(5),XPVU/4D0) + XPVAL(-1)=XPVAL(1) + XPVAL(-2)=XPVAL(2) + XPVAL(-3)=XPVAL(3) + XPVAL(-4)=XPVAL(4) + XPVAL(-5)=XPVAL(5) + ELSE + WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55) + ENDIF + +C...Pion/gammaVDM parton distribution call. + ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR. + &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN + IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND. + & MSTP(55).LE.12) THEN + ISET=1+MOD(MSTP(55)-1,4) + Q2MX=Q2 + P2MX=0.36D0 + IF(ISET.GE.3) P2MX=4.0D0 + IF(MSTP(57).EQ.0) Q2MX=P2MX + P2=0D0 + IF(VINT(120).LT.0D0) P2=VINT(120)**2 + CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA) + DO 160 KFL=-6,6 + XPQ(KFL)=XPVMD(KFL) + XPVAL(KFL)=VXPVMD(KFL) + 160 CONTINUE + VINT(231)=P2MX + ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN + CALL PYPDPI(X,Q2,XPPI) + DO 170 KFL=-6,6 + XPQ(KFL)=XPPI(KFL) + 170 CONTINUE + XPVAL(2)=XPQ(2)-XPQ(-2) + XPVAL(-1)=XPQ(-1)-XPQ(1) + ELSEIF(MSTP(54).EQ.2) THEN +C...Call PDFLIB parton distributions. + PARM(1)='NPTYPE' + VALUE(1)=2 + PARM(2)='NGROUP' + VALUE(2)=MSTP(53)/1000 + PARM(3)='NSET' + VALUE(3)=MOD(MSTP(53),1000) + IF(MINT(93).NE.2000000+MSTP(53)) THEN + CALL PDFSET(PARM,VALUE) + MINT(93)=2000000+MSTP(53) + ENDIF + XX=X + QQ=SQRT(MAX(0D0,Q2MIN,Q2)) + IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN) + CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU) + VINT(231)=Q2MIN + XPQ(0)=GLU + XPQ(1)=DSEA + XPQ(-1)=UPV+DSEA + XPQ(2)=UPV+USEA + XPQ(-2)=USEA + XPQ(3)=STR + XPQ(-3)=STR + XPQ(4)=CHM + XPQ(-4)=CHM + XPQ(5)=BOT + XPQ(-5)=BOT + XPQ(6)=TOP + XPQ(-6)=TOP + XPVAL(2)=UPV + XPVAL(-1)=UPV + ELSE + WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53) + ENDIF + +C...Anomalous photon parton distribution call. + ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN + Q2MX=Q2 + P2MX=PARP(15)**2 + IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN + IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0 + IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0 + IF(MSTP(57).EQ.0) Q2MX=P2MX + P2=0D0 + IF(VINT(120).LT.0D0) P2=VINT(120)**2 + CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA) + DO 180 KFL=-6,6 + XPQ(KFL)=XPANL(KFL)+XPANH(KFL) + XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL) + 180 CONTINUE + VINT(231)=P2MX + ELSEIF(MSTP(56).EQ.1) THEN + IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0 + IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0 + IF(MSTP(57).EQ.0) Q2MX=P2MX + P2=0D0 + IF(VINT(120).LT.0D0) P2=VINT(120)**2 + CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA) + DO 190 KFL=-6,6 + XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)) + XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)) + 190 CONTINUE + VINT(231)=P2MX + ELSEIF(MSTP(56).EQ.2) THEN + IF(MSTP(57).EQ.0) Q2MX=P2MX + CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA) + DO 200 KFL=-6,6 + XPQ(KFL)=XPGA(KFL) + XPVAL(KFL)=VXPGA(KFL) + 200 CONTINUE + VINT(231)=P2MX + ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN + IF(MSTP(57).EQ.0) Q2MX=P2MX + CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA) + DO 210 KFL=-6,6 + XPQ(KFL)=XPGA(KFL) + XPVAL(KFL)=VXPGA(KFL) + 210 CONTINUE + VINT(231)=P2MX + ELSE + 220 RKF=11D0*PYR(0) + KFR=1 + IF(RKF.GT.1D0) KFR=2 + IF(RKF.GT.5D0) KFR=3 + IF(RKF.GT.6D0) KFR=4 + IF(RKF.GT.10D0) KFR=5 + IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220 + IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220 + IF(MSTP(57).EQ.0) Q2MX=P2MX + CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA) + DO 230 KFL=-6,6 + XPQ(KFL)=XPGA(KFL) + XPVAL(KFL)=VXPGA(KFL) + 230 CONTINUE + VINT(231)=P2MX + ENDIF + +C...Proton parton distribution call. + ELSE + IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN + CALL PYPDPR(X,Q2,XPPR) + DO 240 KFL=-6,6 + XPQ(KFL)=XPPR(KFL) + 240 CONTINUE +C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently) + XPVAL(1)=MAX(0D0,XPQ(1)-XPQ(-1)) + XPVAL(2)=MAX(0D0,XPQ(2)-XPQ(-2)) + ELSEIF(MSTP(52).EQ.2) THEN +C...Call PDFLIB parton distributions. + PARM(1)='NPTYPE' + VALUE(1)=1 + PARM(2)='NGROUP' + VALUE(2)=MSTP(51)/1000 + PARM(3)='NSET' + VALUE(3)=MOD(MSTP(51),1000) + IF(MINT(93).NE.1000000+MSTP(51)) THEN + call setlhaparm('SILENT') + CALL PDFSET(PARM,VALUE) + MINT(93)=1000000+MSTP(51) + ENDIF + XX=X + QQ=SQRT(MAX(0D0,Q2MIN,Q2)) + IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN) +! IF(EPS09)THEN +! call setlhaparm(INITSTR) +! CALL STRUCTA(XX,QQ,MASS,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP, +! & GLU) +! ELSE + CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU) +! ENDIF + VINT(231)=Q2MIN + XPQ(0)=GLU + XPQ(1)=DNV+DSEA + XPQ(-1)=DSEA + XPQ(2)=UPV+USEA + XPQ(-2)=USEA + XPQ(3)=STR + XPQ(-3)=STR + XPQ(4)=CHM + XPQ(-4)=CHM + XPQ(5)=BOT + XPQ(-5)=BOT + XPQ(6)=TOP + XPQ(-6)=TOP + XPVAL(1)=DNV + XPVAL(2)=UPV + ELSE + WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51) + ENDIF + ENDIF + +C...Isospin average for pi0/gammaVDM. + IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN + IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN + XPV=XPQ(2)-XPQ(1) + XPQ(2)=XPQ(1) + XPQ(-2)=XPQ(-1) + ELSE + XPS=0.5D0*(XPQ(1)+XPQ(-2)) + XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS + XPQ(2)=XPS + XPQ(-1)=XPS + ENDIF + XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+ + & XPVAL(3)+XPVAL(4)+XPVAL(5) + DO 250 KFL=-6,6 + XPVAL(KFL)=0D0 + 250 CONTINUE + IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN + XPQ(1)=XPQ(1)+0.2D0*XPV + XPQ(2)=XPQ(2)+0.8D0*XPV + XPVAL(1)=0.2D0*XPVL + XPVAL(2)=0.8D0*XPVL + ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN + XPQ(3)=XPQ(3)+XPV + XPVAL(3)=XPVL + ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN + XPQ(4)=XPQ(4)+XPV + XPVAL(4)=XPVL + IF(MSTP(55).GE.9) THEN + DO 260 KFL=-6,6 + XPQ(KFL)=0D0 + 260 CONTINUE + ENDIF + ELSE + XPQ(1)=XPQ(1)+0.5D0*XPV + XPQ(2)=XPQ(2)+0.5D0*XPV + XPVAL(1)=0.5D0*XPVL + XPVAL(2)=0.5D0*XPVL + ENDIF + DO 270 KFL=1,6 + XPQ(-KFL)=XPQ(KFL) + XPVAL(-KFL)=XPVAL(KFL) + 270 CONTINUE + +C...Rescale for gammaVDM by effective gamma -> rho coupling. +C+++Do not rescale? + IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1 + & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN + DO 280 KFL=-6,6 + XPQ(KFL)=VINT(281)*XPQ(KFL) + XPVAL(KFL)=VINT(281)*XPVAL(KFL) + 280 CONTINUE + VINT(232)=VINT(281)*XPV + ENDIF + +C...Simple recipes for kaons. + ELSEIF(KFA.EQ.321) THEN + XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1) + XPQ(-1)=XPQ(1) + XPVAL(-3)=XPVAL(-1) + XPVAL(-1)=0D0 + ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN + XPS=0.5D0*(XPQ(1)+XPQ(-2)) + XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS + XPQ(2)=XPS + XPQ(-1)=XPS + XPQ(1)=XPQ(1)+0.5D0*XPV + XPQ(-1)=XPQ(-1)+0.5D0*XPV + XPQ(3)=XPQ(3)+0.5D0*XPV + XPQ(-3)=XPQ(-3)+0.5D0*XPV + XPV=0.5D0*(XPVAL(2)+XPVAL(-1)) + XPVAL(2)=0D0 + XPVAL(-1)=0D0 + XPVAL(1)=0.5D0*XPV + XPVAL(-1)=0.5D0*XPV + XPVAL(3)=0.5D0*XPV + XPVAL(-3)=0.5D0*XPV + +C...Isospin conjugation for neutron. + ELSEIF(KFA.EQ.2112) THEN + XPSV=XPQ(1) + XPQ(1)=XPQ(2) + XPQ(2)=XPSV + XPSV=XPQ(-1) + XPQ(-1)=XPQ(-2) + XPQ(-2)=XPSV + XPSV=XPVAL(1) + XPVAL(1)=XPVAL(2) + XPVAL(2)=XPSV + +C...Simple recipes for hyperon (average valence parton distribution). + ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222 + & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN + XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0 + XPS=0.5D0*(XPQ(-1)+XPQ(-2)) + XPQ(1)=XPS + XPQ(2)=XPS + XPQ(-1)=XPS + XPQ(-2)=XPS + XPQ(KFA/1000)=XPQ(KFA/1000)+XPV + XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV + XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV + XPV=(XPVAL(1)+XPVAL(2))/3D0 + XPVAL(1)=0D0 + XPVAL(2)=0D0 + XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV + XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV + XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV + ENDIF + +C...Charge conjugation for antiparticle. + IF(KF.LT.0) THEN + DO 290 KFL=1,25 + IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290 + XPSV=XPQ(KFL) + XPQ(KFL)=XPQ(-KFL) + XPQ(-KFL)=XPSV + 290 CONTINUE + DO 300 KFL=1,6 + XPSV=XPVAL(KFL) + XPVAL(KFL)=XPVAL(-KFL) + XPVAL(-KFL)=XPSV + 300 CONTINUE + ENDIF + +C...MULTIPLE INTERACTIONS - PDF RESHAPING. +C...Set side. + JS=MINT(30) +C...Only reshape PDFs for the non-first interactions; +C...But need valence/sea separation already from first interaction. + IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN + KFVSEL=KFIVAL(JS,1) +C...If valence quark kicked out of pi0 or gamma then that decides +C...whether we should consider state as d dbar, u ubar, s sbar, etc. + IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN + XPVL=0D0 + DO 310 KFL=1,6 + XPVL=XPVL+XPVAL(KFL) + XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL)) + XPVAL(KFL)=0D0 + 310 CONTINUE + XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL + XPVAL(IABS(KFVSEL))=XPVL + DO 320 KFL=1,6 + XPQ(-KFL)=XPQ(KFL) + XPVAL(-KFL)=XPVAL(KFL) + 320 CONTINUE + +C...If valence quark kicked out of K0S or K0S then that decides whether +C...we should consider state as d sbar or s dbar. + ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN + KFS=1 + IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1 + XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS) + XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS) + XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS)) + XPVAL(-KFS)=0D0 + KFS=-3*KFS + XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS) + XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS) + XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS)) + XPVAL(-KFS)=0D0 + ENDIF + +C...XPQ distributions are nominal for a (signed) beam particle +C...of KF type, with 1-Sum(x_prev) rescaled to 1. + CMPFAC=1D0 + NRESC=0 + 345 NRESC=NRESC+1 + PVCTOT(JS,-1)=0D0 + PVCTOT(JS, 0)=0D0 + PVCTOT(JS, 1)=0D0 + DO 350 IFL=-6,6 + IF(IFL.EQ.0) GOTO 350 + +C...Count up number of original IFL valence quarks. + IVORG=0 + IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1 + IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1 + IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1 +C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here +C...bookkeep as if d dbar (for total momentum sum in valence sector). + IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1 +C...Count down number of remaining IFL valence quarks. Skip current +C...interaction initiator. + IVREM=IVORG + DO 330 I1=1,NMI(JS) + IF (I1.EQ.MINT(36)) GOTO 330 + IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0) + & IVREM=IVREM-1 + 330 CONTINUE + +C...Separate out original VALENCE and SEA content. + VAL=XPVAL(IFL) + SEA=MAX(0D0,XPQ(IFL)-VAL) + XPSVC(IFL,0)=VAL + XPSVC(IFL,-1)=SEA + +C...Rescale valence content if changed. + IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)= + & (VAL*IVREM)/IVORG + +C...Momentum integrals of original and removed valence quarks. + IF(IVORG.NE.0) THEN +C...For p/n/pbar/nbar beams can split into d_val and u_val. +C...Isospin conjugation for neutrons + IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN + IAFLP=IABS(IFL) + IF (KFA.EQ.2112) IAFLP=3-IAFLP + VPAVG=PAVG(IAFLP,Q2) +C...For other baryons average d_val and u_val, like for PDFs. + ELSEIF(KFA.GT.1000) THEN + VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0 +C...For mesons and photon average d_val and u_val and scale by 3/2. +C...Very crude, especially for photon. + ELSE + VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2)) + ENDIF + PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG + PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG + ENDIF + +C...Now add companions (at X with partner having been at Z=XASSOC). +C...NOTE: due to the assumed simple x scaling, the partner was at what +C...corresponds to a higher Z than XASSOC, if there were intermediate +C...scatterings. Nothing done about that for the moment. + DO 340 IVC=1,NVC(JS,IFL) +C...Skip companions that have been kicked out + IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN + XPSVC(IFL,IVC)=0D0 + GOTO 340 + ELSE +C...Momentum fraction of the partner quark. +C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest". + XS=XASSOC(JS,IFL,IVC) + XREM=VINT(142+JS) + YS=XS/(XREM+XS) +C...Momentum fraction of the companion quark. +C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS). + Y=X*(1D0-YS) + XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87)) +C...Add to momentum sum, with rescaling compensation factor. + XCFAC=(XREM+XS)/XREM*CMPFAC + PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87)) + ENDIF + 340 CONTINUE + 350 CONTINUE + +C...Wait until all flavours treated, then rescale seas and gluon. + XPSVC(0,-1)=XPQ(0) + XPSVC(0,0)=0D0 + RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1)) + IF (RSFAC.LE.0D0) THEN +C...First calculate factor needed to exactly restore pz cons. + IF (NRESC.EQ.1) CMPFAC = + & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1) +C...Add a bit of headroom + CMPFAC=0.99*CMPFAC +C...Try a few times if more headroom is needed, then print error message. + IF (NRESC.LE.10) GOTO 345 + CALL PYERRM(15, + & '(PYPDFU:) Negative reshaping factor persists!') + WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC + RSFAC=0D0 + ENDIF + DO 370 IFL=-6,6 + XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1) +C...Also store resulting distributions in XPQ + XPQ(IFL)=0D0 + DO 360 ISVC=-1,NVC(JS,IFL) + XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC) + 360 CONTINUE + 370 CONTINUE +C...Save companion reweighting factor for PYPTIS. + VINT(140)=CMPFAC + ENDIF + + +C...Allow gluon also in position 21. + XPQ(21)=XPQ(0) + +C...Check positivity and reset above maximum allowed flavour. + DO 380 KFL=-25,25 + XPQ(KFL)=MAX(0D0,XPQ(KFL)) + IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0 + 380 CONTINUE + +C...Formats for error printouts. + 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3) + 5100 FORMAT(' Error: illegal particle code for parton distribution;', + &' KF =',I5) + 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =', + &3I5) + 5300 FORMAT(' Original valence momentum fraction : ',F6.3/ + & ' Removed valence momentum fraction : ',F6.3/ + & ' Added companion momentum fraction : ',F6.3/ + & ' Resulting rescale factor : ',F6.3) + +C...Reset side pointer and return + 9999 MINT(30)=0 + + RETURN + END + +C********************************************************************* + +C...PYPDFL +C...Gives proton parton distribution at small x and/or Q^2 according to +C...correct limiting behaviour. + + SUBROUTINE PYPDFL(KF,X,Q2,XPQ) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ +C...Local arrays. + DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3) + DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/ + +C...Send everything but protons/neutrons/VMD pions directly to PYPDFU. + MINT(92)=0 + KFA=IABS(KF) + IACC=0 + IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1 + IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1 + IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1 + IF(IACC.EQ.0) THEN + CALL PYPDFU(KF,X,Q2,XPQ) + RETURN + ENDIF + +C...Reset. Check x. + DO 100 KFL=-25,25 + XPQ(KFL)=0D0 + 100 CONTINUE + IF(X.LE.0D0.OR.X.GE.1D0) THEN + WRITE(MSTU(11),5000) X + RETURN + ENDIF + +C...Define valence content. + KFC=KF + NV1=2 + NV2=1 + IF(KF.EQ.2212) THEN + KFV1=2 + KFV2=1 + ELSEIF(KF.EQ.-2212) THEN + KFV1=-2 + KFV2=-1 + ELSEIF(KF.EQ.2112) THEN + KFV1=1 + KFV2=2 + ELSEIF(KF.EQ.-2112) THEN + KFV1=-1 + KFV2=-2 + ELSEIF(KF.EQ.211) THEN + NV1=1 + KFV1=2 + KFV2=-1 + ELSEIF(KF.EQ.-211) THEN + NV1=1 + KFV1=-2 + KFV2=1 + ELSEIF(MINT(105).LE.223) THEN + KFV1=1 + WTV1=0.2D0 + KFV2=2 + WTV2=0.8D0 + ELSEIF(MINT(105).EQ.333) THEN + KFV1=3 + WTV1=1.0D0 + KFV2=1 + WTV2=0.0D0 + ELSEIF(MINT(105).EQ.443) THEN + KFV1=4 + WTV1=1.0D0 + KFV2=1 + WTV2=0.0D0 + ENDIF + +C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0. + MINT30=MINT(30) + CALL PYPDFU(KFC,X,Q2,XPA) + Q2MN=MAX(3D0,VINT(231)) + Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X)))) + XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0 + +C...Large Q2 and large x: naive call is enough. + IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN + DO 110 KFL=-25,25 + XPQ(KFL)=XPA(KFL) + 110 CONTINUE + MINT(92)=1 + +C...Small Q2 and large x: dampen boundary value. + ELSEIF(X.GT.XMN) THEN + +C...Evaluate at boundary and define dampening factors. + MINT(30)=MINT30 + CALL PYPDFU(KFC,X,Q2MN,XPA) + FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN)) + FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0 + +C...Separate valence and sea parts of parton distribution. + IF(KFA.NE.22) THEN + XFV1=XPA(KFV1)-XPA(-KFV1) + XPA(KFV1)=XPA(-KFV1) + XFV2=XPA(KFV2)-XPA(-KFV2) + XPA(KFV2)=XPA(-KFV2) + ELSE + XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232) + XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232) + XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232) + XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232) + ENDIF + +C...Dampen valence and sea separately. Put back together. + DO 120 KFL=-25,25 + XPQ(KFL)=FS*XPA(KFL) + 120 CONTINUE + IF(KFA.NE.22) THEN + XPQ(KFV1)=XPQ(KFV1)+FV*XFV1 + XPQ(KFV2)=XPQ(KFV2)+FV*XFV2 + ELSE + XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232) + XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232) + XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232) + XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232) + ENDIF + MINT(92)=2 + +C...Large Q2 and small x: interpolate behaviour. + ELSEIF(Q2.GT.Q2MN) THEN + +C...Evaluate at extremes and define coefficients for interpolation. + MINT(30)=MINT30 + CALL PYPDFU(KFC,XMN,Q2MN,XPA) + VI232A=VINT(232) + MINT(30)=MINT30 + CALL PYPDFU(KFC,X,Q2B,XPB) + VI232B=VINT(232) + FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN) + FVA=(X/XMN)**0.45D0*FLA + FSA=(X/XMN)**(-0.08D0)*FLA + FB=1D0-FLA + +C...Separate valence and sea parts of parton distribution. + IF(KFA.NE.22) THEN + XFVA1=XPA(KFV1)-XPA(-KFV1) + XPA(KFV1)=XPA(-KFV1) + XFVA2=XPA(KFV2)-XPA(-KFV2) + XPA(KFV2)=XPA(-KFV2) + XFVB1=XPB(KFV1)-XPB(-KFV1) + XPB(KFV1)=XPB(-KFV1) + XFVB2=XPB(KFV2)-XPB(-KFV2) + XPB(KFV2)=XPB(-KFV2) + ELSE + XPA(KFV1)=XPA(KFV1)-WTV1*VI232A + XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A + XPA(KFV2)=XPA(KFV2)-WTV2*VI232A + XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A + XPB(KFV1)=XPB(KFV1)-WTV1*VI232B + XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B + XPB(KFV2)=XPB(KFV2)-WTV2*VI232B + XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B + ENDIF + +C...Interpolate for valence and sea. Put back together. + DO 130 KFL=-25,25 + XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL) + 130 CONTINUE + IF(KFA.NE.22) THEN + XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1) + XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2) + ELSE + XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B) + XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B) + XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B) + XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B) + ENDIF + MINT(92)=3 + +C...Small Q2 and small x: dampen boundary value and add term. + ELSE + +C...Evaluate at boundary and define dampening factors. + MINT(30)=MINT30 + CALL PYPDFU(KFC,XMN,Q2MN,XPA) + FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN) + FA=1D0-FB + FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0 + FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0 + FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0 + FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0 + FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0 + FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0 + +C...Separate valence and sea parts of parton distribution. + IF(KFA.NE.22) THEN + XFV1=XPA(KFV1)-XPA(-KFV1) + XPA(KFV1)=XPA(-KFV1) + XFV2=XPA(KFV2)-XPA(-KFV2) + XPA(KFV2)=XPA(-KFV2) + ELSE + XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232) + XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232) + XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232) + XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232) + ENDIF + +C...Dampen valence and sea separately. Add constant terms. +C...Put back together. + DO 140 KFL=-25,25 + XPQ(KFL)=FSA*XPA(KFL) + 140 CONTINUE + IF(KFA.NE.22) THEN + DO 150 KFL=-3,3 + XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL) + 150 CONTINUE + XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1) + XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2) + ELSE + DO 160 KFL=-3,3 + XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL) + 160 CONTINUE + XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281)) + XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281)) + XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281)) + XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281)) + ENDIF + XPQ(21)=XPQ(0) + MINT(92)=4 + ENDIF + +C...Format for error printout. + 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3) + + RETURN + END + +C********************************************************************* + +C...PYPDEL +C...Gives electron (or muon, or tau) parton distribution. + + SUBROUTINE PYPDEL(KFA,X,Q2,XPEL) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ +C...Local arrays. + DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6) + +C...Interface to PDFLIB. + COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX + SAVE /W50513/ + DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU, + &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX + CHARACTER*20 PARM(20) + DATA VALUE/20*0D0/,PARM/20*' '/ + +C...Some common constants. + DO 100 KFL=-25,25 + XPEL(KFL)=0D0 + 100 CONTINUE + AEM=PARU(101) + PME=PMAS(11,1) + IF(KFA.EQ.13) PME=PMAS(13,1) + IF(KFA.EQ.15) PME=PMAS(15,1) + XL=LOG(MAX(1D-10,X)) + X1L=LOG(MAX(1D-10,1D0-X)) + HLE=LOG(MAX(3D0,Q2/PME**2)) + HBE2=(AEM/PARU(1))*(HLE-1D0) + +C...Electron inside electron, see R. Kleiss et al., in Z physics at +C...LEP 1, CERN 89-08, p. 34 + IF(MSTP(59).LE.1) THEN + HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2* + & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0) + HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))- + & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)- + & 4D0*XL/(1D0-X)-5D0-X) + ELSE + HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/ + & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)* + & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X) + ENDIF +C...Zero distribution for very large x and rescale it for intermediate. + IF(X.GT.1D0-1D-10) THEN + HEE=0D0 + ELSEIF(X.GT.1D0-1D-7) THEN + HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0) + ENDIF + XPEL(KFA)=X*HEE + +C...Photon and (transverse) W- inside electron. + AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2) + IF(MSTP(13).LE.1) THEN + HLG=HLE + ELSE + HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2)) + ENDIF + XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2) + HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102)) + XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2) + +C...Electron or positron inside photon inside electron. + IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN + XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+ + & 2D0*X*(1D0+X)*XL) + XPEL(11)=XPEL(11)+XFSEA + XPEL(-11)=XFSEA + +C...Initialize PDFLIB photon parton distributions. + IF(MSTP(56).EQ.2) THEN + PARM(1)='NPTYPE' + VALUE(1)=3 + PARM(2)='NGROUP' + VALUE(2)=MSTP(55)/1000 + PARM(3)='NSET' + VALUE(3)=MOD(MSTP(55),1000) + IF(MINT(93).NE.3000000+MSTP(55)) THEN + CALL PDFSET(PARM,VALUE) + MINT(93)=3000000+MSTP(55) + ENDIF + ENDIF + +C...Quarks and gluons inside photon inside electron: +C...numerical convolution required. + DO 110 KFL=0,6 + SXP(KFL)=0D0 + 110 CONTINUE + SUMXPP=0D0 + ITER=-1 + 120 ITER=ITER+1 + SUMXP=SUMXPP + NSTP=2**(ITER-1) + IF(ITER.EQ.0) NSTP=2 + DO 130 KFL=0,6 + SXP(KFL)=0.5D0*SXP(KFL) + 130 CONTINUE + WTSTP=0.5D0/NSTP + IF(ITER.EQ.0) WTSTP=0.5D0 +C...Pick grid of x_{gamma} values logarithmically even. + DO 150 ISTP=1,NSTP + IF(ITER.EQ.0) THEN + XLE=XL*(ISTP-1) + ELSE + XLE=XL*(ISTP-0.5D0)/NSTP + ENDIF + XE=MIN(1D0-1D-10,EXP(XLE)) + XG=MIN(1D0-1D-10,X/XE) +C...Evaluate photon inside electron parton distribution for convolution. + XPGP=1D0+(1D0-XE)**2 + IF(MSTP(13).LE.1) THEN + XPGP=XPGP*HLE + ELSE + XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2)) + ENDIF +C...Evaluate photon parton distributions for convolution. + IF(MSTP(56).EQ.1) THEN + IF(MSTP(55).EQ.1) THEN + CALL PYPDGA(XG,Q2,XPGA) + ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN + Q2MX=Q2 + P2MX=0.36D0 + IF(MSTP(55).GE.7) P2MX=4.0D0 + IF(MSTP(57).EQ.0) Q2MX=P2MX + P2=0D0 + IF(VINT(120).LT.0D0) P2=VINT(120)**2 + CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA) + VINT(231)=P2MX + ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN + Q2MX=Q2 + P2MX=0.36D0 + IF(MSTP(55).GE.11) P2MX=4.0D0 + IF(MSTP(57).EQ.0) Q2MX=P2MX + P2=0D0 + IF(VINT(120).LT.0D0) P2=VINT(120)**2 + CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA) + VINT(231)=P2MX + ENDIF + DO 140 KFL=0,5 + SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL) + 140 CONTINUE + ELSEIF(MSTP(56).EQ.2) THEN +C...Call PDFLIB parton distributions. + XX=XG + QQ=SQRT(MAX(0D0,Q2MIN,Q2)) + IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN) + CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU) + SXP(0)=SXP(0)+WTSTP*XPGP*GLU + SXP(1)=SXP(1)+WTSTP*XPGP*DNV + SXP(2)=SXP(2)+WTSTP*XPGP*UPV + SXP(3)=SXP(3)+WTSTP*XPGP*STR + SXP(4)=SXP(4)+WTSTP*XPGP*CHM + SXP(5)=SXP(5)+WTSTP*XPGP*BOT + SXP(6)=SXP(6)+WTSTP*XPGP*TOP + ENDIF + 150 CONTINUE + SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2) + IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT. + & PARP(14)*(SUMXPP+SUMXP))) GOTO 120 + +C...Put convolution into output arrays. + FCONV=AEMP*(-XL) + XPEL(0)=FCONV*SXP(0) + DO 160 KFL=1,6 + XPEL(KFL)=FCONV*SXP(KFL) + XPEL(-KFL)=XPEL(KFL) + 160 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYPDGA +C...Gives photon parton distribution. + + SUBROUTINE PYPDGA(X,Q2,XPGA) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYDAT1/,/PYPARS/,/PYINT1/ +C...Local arrays. + DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3), + &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3), + &DGCS(4,3),DGDS(4,3),DGES(4,3) + +C...The following data lines are coefficients needed in the +C...Drees and Grassie photon parton distribution parametrization. + DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0, + &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/ + DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0, + &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/ + DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0, + &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/ + DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0, + &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/ + DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0, + &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/ + DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1, + &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/ + DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0, + &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/ + DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0, + &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/ + DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0, + &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/ + DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0, + &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/ + DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0, + &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/ + DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0, + &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/ + DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0, + &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/ + +C...Photon parton distribution from Drees and Grassie. +C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2. + DO 100 KFL=-6,6 + XPGA(KFL)=0D0 + 100 CONTINUE + VINT(231)=1D0 + IF(MSTP(57).LE.0) THEN + T=LOG(1D0/0.16D0) + ELSE + T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0) + ENDIF + X1=1D0-X + NF=3 + IF(Q2.GT.25D0) NF=4 + IF(Q2.GT.300D0) NF=5 + NFE=NF-2 + AEM=PARU(101) + +C...Evaluate gluon content. + DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE)) + DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE)) + DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE)) + XPGL=DGA*X**DGB*X1**DGC + +C...Evaluate up- and down-type quark content. + DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE)) + DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE)) + DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE)) + DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE)) + DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE)) + XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE + DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE)) + DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE)) + DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE)) + DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE)) + DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE)) + DGF=9D0 + IF(NF.EQ.4) DGF=10D0 + IF(NF.EQ.5) DGF=55D0/6D0 + XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE + IF(NF.LE.3) THEN + XPQU=(XPQS+9D0*XPQN)/6D0 + XPQD=(XPQS-4.5D0*XPQN)/6D0 + ELSEIF(NF.EQ.4) THEN + XPQU=(XPQS+6D0*XPQN)/8D0 + XPQD=(XPQS-6D0*XPQN)/8D0 + ELSE + XPQU=(XPQS+7.5D0*XPQN)/10D0 + XPQD=(XPQS-5D0*XPQN)/10D0 + ENDIF + +C...Put into output arrays. + XPGA(0)=AEM*XPGL + XPGA(1)=AEM*XPQD + XPGA(2)=AEM*XPQU + XPGA(3)=AEM*XPQD + IF(NF.GE.4) XPGA(4)=AEM*XPQU + IF(NF.GE.5) XPGA(5)=AEM*XPQD + DO 110 KFL=1,6 + XPGA(-KFL)=XPGA(KFL) + 110 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYGGAM +C...Constructs the F2 and parton distributions of the photon +C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms. +C...For F2, c and b are included by the Bethe-Heitler formula; +C...in the 'MSbar' scheme additionally a Cgamma term is added. +C...Contains the SaS sets 1D, 1M, 2D and 2M. +C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. + + SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6), + &XPDIR(-6:6) + COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6) + SAVE /PYINT8/,/PYINT9/ +C...Local arrays. + DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6) +C...Charm and bottom masses (low to compensate for J/psi etc.). + DATA PMC/1.3D0/, PMB/4.6D0/ +C...alpha_em and alpha_em/(2*pi). + DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/ +C...Lambda value for 4 flavours. + DATA ALAM/0.20D0/ +C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum. + DATA FRACU/0.8D0/ +C...VMD couplings f_V**2/(4*pi). + DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/ +C...Masses for rho (=omega) and phi. + DATA PMRHO/0.770D0/, PMPHI/1.020D0/ +C...Number of points in integration for IP2=1. + DATA NSTEP/100/ + +C...Reset output. + F2GM=0D0 + DO 100 KFL=-6,6 + XPDFGM(KFL)=0D0 + XPVMD(KFL)=0D0 + XPANL(KFL)=0D0 + XPANH(KFL)=0D0 + XPBEH(KFL)=0D0 + XPDIR(KFL)=0D0 + VXPVMD(KFL)=0D0 + VXPANL(KFL)=0D0 + VXPANH(KFL)=0D0 + VXPDGM(KFL)=0D0 + 100 CONTINUE + +C...Set Q0 cut-off parameter as function of set used. + IF(ISET.LE.2) THEN + Q0=0.6D0 + ELSE + Q0=2D0 + ENDIF + Q02=Q0**2 + +C...Scale choice for off-shell photon; common factors. + Q2A=Q2 + FACNOR=1D0 + IF(IP2.EQ.1) THEN + P2MX=P2+Q02 + Q2A=Q2+P2*Q02/MAX(Q02,Q2) + FACNOR=LOG(Q2/Q02)/NSTEP + ELSEIF(IP2.EQ.2) THEN + P2MX=MAX(P2,Q02) + ELSEIF(IP2.EQ.3) THEN + P2MX=P2+Q02 + Q2A=Q2+P2*Q02/MAX(Q02,Q2) + ELSEIF(IP2.EQ.4) THEN + P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/ + & ((Q2+P2)*(Q02+P2))) + ELSEIF(IP2.EQ.5) THEN + P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/ + & ((Q2+P2)*(Q02+P2))) + P2MX=Q0*SQRT(P2MXA) + FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX) + ELSEIF(IP2.EQ.6) THEN + P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/ + & ((Q2+P2)*(Q02+P2))) + P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02) + ELSE + P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/ + & ((Q2+P2)*(Q02+P2))) + P2MX=Q0*SQRT(P2MXA) + P2MXB=P2MX + P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02) + P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA + IF(ABS(Q2-Q02).GT.1D-6) THEN + FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB) + ELSEIF(P2.LT.Q02) THEN + FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0) + ELSE + FACNOR=1D0 + ENDIF + ENDIF + +C...Call VMD parametrization for d quark and use to give rho, omega, +C...phi. Note dipole dampening for off-shell photon. + CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA) + XFVAL=VXPGA(1) + XPGA(1)=XPGA(2) + XPGA(-1)=XPGA(-2) + FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2 + FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2 + DO 110 KFL=-5,5 + XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL) + 110 CONTINUE + XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL + XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL + XPVMD(3)=XPVMD(3)+FACS*XFVAL + XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL + XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL + XPVMD(-3)=XPVMD(-3)+FACS*XFVAL + VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL + VXPVMD(2)=FRACU*FACUD*XFVAL + VXPVMD(3)=FACS*XFVAL + VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL + VXPVMD(-2)=FRACU*FACUD*XFVAL + VXPVMD(-3)=FACS*XFVAL + + IF(IP2.NE.1) THEN +C...Anomalous parametrizations for different strategies +C...for off-shell photons; except full integration. + +C...Call anomalous parametrization for d + u + s. + CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA) + DO 120 KFL=-5,5 + XPANL(KFL)=FACNOR*XPGA(KFL) + VXPANL(KFL)=FACNOR*VXPGA(KFL) + 120 CONTINUE + +C...Call anomalous parametrization for c and b. + CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA) + DO 130 KFL=-5,5 + XPANH(KFL)=FACNOR*XPGA(KFL) + VXPANH(KFL)=FACNOR*VXPGA(KFL) + 130 CONTINUE + CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA) + DO 140 KFL=-5,5 + XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL) + VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL) + 140 CONTINUE + + ELSE +C...Special option: loop over flavours and integrate over k2. + DO 170 KF=1,5 + DO 160 ISTEP=1,NSTEP + Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP) + IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR. + & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160 + CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA) + FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR + IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0) + IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0) + DO 150 KFL=-5,5 + IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL) + IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL) + IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL) + IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + ENDIF + +C...Call Bethe-Heitler term expression for charm and bottom. + CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH) + XPBEH(4)=XPBH + XPBEH(-4)=XPBH + CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH) + XPBEH(5)=XPBH + XPBEH(-5)=XPBH + +C...For MSbar subtraction call C^gamma term expression for d, u, s. + IF(ISET.EQ.2.OR.ISET.EQ.4) THEN + CALL PYGDIR(X,Q2,P2,Q02,XPGA) + DO 180 KFL=-5,5 + XPDIR(KFL)=XPGA(KFL) + 180 CONTINUE + ENDIF + +C...Store result in output array. + DO 190 KFL=-5,5 + CHSQ=1D0/9D0 + IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0 + XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL) + IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2 + XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL) + VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL) + 190 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYGVMD +C...Evaluates the VMD parton distributions of a photon, +C...evolved homogeneously from an initial scale P2 to Q2. +C...Does not include dipole suppression factor. +C...ISET is parton distribution set, see above; +C...additionally ISET=0 is used for the evolution of an anomalous photon +C...which branched at a scale P2 and then evolved homogeneously to Q2. +C...ALAM is the 4-flavour Lambda, which is automatically converted +C...to 3- and 5-flavour equivalents as needed. +C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. + + SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Local arrays and data. + DIMENSION XPGA(-6:6), VXPGA(-6:6) + DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/ + +C...Reset output. + DO 100 KFL=-6,6 + XPGA(KFL)=0D0 + VXPGA(KFL)=0D0 + 100 CONTINUE + KFA=IABS(KF) + +C...Calculate Lambda; protect against unphysical Q2 and P2 input. + ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0) + ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0) + P2EFF=MAX(P2,1.2D0*ALAM3**2) + IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2) + IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2) + Q2EFF=MAX(Q2,P2EFF) + +C...Find number of flavours at lower and upper scale. + NFP=4 + IF(P2EFF.LT.PMC**2) NFP=3 + IF(P2EFF.GT.PMB**2) NFP=5 + NFQ=4 + IF(Q2EFF.LT.PMC**2) NFQ=3 + IF(Q2EFF.GT.PMB**2) NFQ=5 + +C...Find s as sum of 3-, 4- and 5-flavour parts. + S=0D0 + IF(NFP.EQ.3) THEN + Q2DIV=PMC**2 + IF(NFQ.EQ.3) Q2DIV=Q2EFF + S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2)) + ENDIF + IF(NFP.LE.4.AND.NFQ.GE.4) THEN + P2DIV=P2EFF + IF(NFP.EQ.3) P2DIV=PMC**2 + Q2DIV=Q2EFF + IF(NFQ.EQ.5) Q2DIV=PMB**2 + S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2)) + ENDIF + IF(NFQ.EQ.5) THEN + P2DIV=PMB**2 + IF(NFP.EQ.5) P2DIV=P2EFF + S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2)) + ENDIF + +C...Calculate frequent combinations of x and s. + X1=1D0-X + XL=-LOG(X) + S2=S**2 + S3=S**3 + S4=S**4 + +C...Evaluate homogeneous anomalous parton distributions below or +C...above threshold. + IF(ISET.EQ.0) THEN + IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. + & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN + XVAL = X * 1.5D0 * (X**2+X1**2) + XGLU = 0D0 + XSEA = 0D0 + ELSE + XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 + + & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 + + & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) * + & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S) + XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) * + & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) * + & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL) + XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) * + & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) * + & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL + + & (2D0*X-1D0)*X*XL**2) + ENDIF + +C...Evaluate set 1D parton distributions below or above threshold. + ELSEIF(ISET.EQ.1) THEN + IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. + & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN + XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0 + XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0 + XSEA = 0.100D0 * X1**3.76D0 + ELSE + XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) * + & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S) + XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) * + & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 * + & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) * + & X**0.40D0 * X1**(1.76D0+3D0*S) + XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/ + & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) * + & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S)) + XSEA0 = 0.100D0 * X1**3.76D0 + ENDIF + +C...Evaluate set 1M parton distributions below or above threshold. + ELSEIF(ISET.EQ.2) THEN + IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. + & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN + XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0 + XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0 + XSEA = 0D0 + ELSE + XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) * + & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S) + XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) * + & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) * + & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 * + & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S) + XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) * + & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) * + & XL**(2.8D0*S) + XSEA0 = 0D0 + ENDIF + +C...Evaluate set 2D parton distributions below or above threshold. + ELSEIF(ISET.EQ.3) THEN + IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. + & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN + XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X + XGLU = 1.925D0 * X1**2 + XSEA = 0.242D0 * X1**4 + ELSE + XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) * + & X**(0.46D0+0.25D0*S) * + & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) + + & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S) + XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) * + & EXP(-18.67D0*S) * + & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2)) + & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) * + & XL**(9.3D0*S/(1D0+1.7D0*S)) + XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/ + & (1D0-0.607D0*S+21.95D0*S2) * + & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S + XSEA0 = 0.242D0 * X1**4 + ENDIF + +C...Evaluate set 2M parton distributions below or above threshold. + ELSEIF(ISET.EQ.4) THEN + IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR. + & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN + XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X + XGLU = 1.808D0 * X1**2 + XSEA = 0.209D0 * X1**4 + ELSE + XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) * + & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) * + & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) * + & XL**(5.15D0*S/(1D0+2D0*S)) + + & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S) + XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) * + & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) * + & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) * + & XL**(10.9D0*S/(1D0+2.5D0*S)) + XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) * + & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) * + & X1**(4D0+S) * XL**(0.45D0*S) + XSEA0 = 0.209D0 * X1**4 + ENDIF + ENDIF + +C...Threshold factors for c and b sea. + SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2)) + XCHM=0D0 + IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN + SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2))) + IF(ISET.EQ.0) THEN + XCHM=XSEA*(1D0-(SCH/SLL)**2) + ELSE + XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL) + ENDIF + ENDIF + XBOT=0D0 + IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN + SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2))) + IF(ISET.EQ.0) THEN + XBOT=XSEA*(1D0-(SBT/SLL)**2) + ELSE + XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL) + ENDIF + ENDIF + +C...Fill parton distributions. + XPGA(0)=XGLU + XPGA(1)=XSEA + XPGA(2)=XSEA + XPGA(3)=XSEA + XPGA(4)=XCHM + XPGA(5)=XBOT + XPGA(KFA)=XPGA(KFA)+XVAL + DO 110 KFL=1,5 + XPGA(-KFL)=XPGA(KFL) + 110 CONTINUE + VXPGA(KFA)=XVAL + VXPGA(-KFA)=XVAL + + RETURN + END + +C********************************************************************* + +C...PYGANO +C...Evaluates the parton distributions of the anomalous photon, +C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2. +C...KF=0 gives the sum over (up to) 5 flavours, +C...KF<0 limits to flavours up to abs(KF), +C...KF>0 is for flavour KF only. +C...ALAM is the 4-flavour Lambda, which is automatically converted +C...to 3- and 5-flavour equivalents as needed. +C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. + + SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Local arrays and data. + DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5) + DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/ + +C...Reset output. + DO 100 KFL=-6,6 + XPGA(KFL)=0D0 + VXPGA(KFL)=0D0 + 100 CONTINUE + IF(Q2.LE.P2) RETURN + KFA=IABS(KF) + +C...Calculate Lambda; protect against unphysical Q2 and P2 input. + ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2 + ALAMSQ(4)=ALAM**2 + ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2 + P2EFF=MAX(P2,1.2D0*ALAMSQ(3)) + IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2) + IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2) + Q2EFF=MAX(Q2,P2EFF) + XL=-LOG(X) + +C...Find number of flavours at lower and upper scale. + NFP=4 + IF(P2EFF.LT.PMC**2) NFP=3 + IF(P2EFF.GT.PMB**2) NFP=5 + NFQ=4 + IF(Q2EFF.LT.PMC**2) NFQ=3 + IF(Q2EFF.GT.PMB**2) NFQ=5 + +C...Define range of flavour loop. + IF(KF.EQ.0) THEN + KFLMN=1 + KFLMX=5 + ELSEIF(KF.LT.0) THEN + KFLMN=1 + KFLMX=KFA + ELSE + KFLMN=KFA + KFLMX=KFA + ENDIF + +C...Loop over flavours the photon can branch into. + DO 110 KFL=KFLMN,KFLMX + +C...Light flavours: calculate t range and (approximate) s range. + IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN + TDIFF=LOG(Q2EFF/P2EFF) + S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/ + & LOG(P2EFF/ALAMSQ(NFQ))) + IF(NFQ.GT.NFP) THEN + Q2DIV=PMB**2 + IF(NFQ.EQ.4) Q2DIV=PMC**2 + SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/ + & LOG(P2EFF/ALAMSQ(NFQ))) + SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/ + & LOG(P2EFF/ALAMSQ(NFQ-1))) + S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ) + ENDIF + IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN + Q2DIV=PMC**2 + SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/ + & LOG(P2EFF/ALAMSQ(4))) + SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/ + & LOG(P2EFF/ALAMSQ(3))) + S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4) + ENDIF + +C...u and s quark do not need a separate treatment when d has been done. + ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN + +C...Charm: as above, but only include range above c threshold. + ELSEIF(KFL.EQ.4) THEN + IF(Q2.LE.PMC**2) GOTO 110 + P2EFF=MAX(P2EFF,PMC**2) + Q2EFF=MAX(Q2EFF,P2EFF) + TDIFF=LOG(Q2EFF/P2EFF) + S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/ + & LOG(P2EFF/ALAMSQ(NFQ))) + IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN + Q2DIV=PMB**2 + SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/ + & LOG(P2EFF/ALAMSQ(NFQ))) + SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/ + & LOG(P2EFF/ALAMSQ(NFQ-1))) + S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ) + ENDIF + +C...Bottom: as above, but only include range above b threshold. + ELSEIF(KFL.EQ.5) THEN + IF(Q2.LE.PMB**2) GOTO 110 + P2EFF=MAX(P2EFF,PMB**2) + Q2EFF=MAX(Q2,P2EFF) + TDIFF=LOG(Q2EFF/P2EFF) + S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/ + & LOG(P2EFF/ALAMSQ(NFQ))) + ENDIF + +C...Evaluate flavour-dependent prefactor (charge^2 etc.). + CHSQ=1D0/9D0 + IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0 + FAC=AEM2PI*2D0*CHSQ*TDIFF + +C...Evaluate parton distributions (normalized to unit momentum sum). + IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN + XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 + + & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 + + & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) * + & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S)) + XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) * + & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) * + & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL) + XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) * + & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) * + & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 + + & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2) + +C...Threshold factors for c and b sea. + SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2)) + XCHM=0D0 + IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN + SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2))) + XCHM=XSEA*(1D0-(SCH/SLL)**3) + ENDIF + XBOT=0D0 + IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN + SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2))) + XBOT=XSEA*(1D0-(SBT/SLL)**3) + ENDIF + ENDIF + +C...Add contribution of each valence flavour. + XPGA(0)=XPGA(0)+FAC*XGLU + XPGA(1)=XPGA(1)+FAC*XSEA + XPGA(2)=XPGA(2)+FAC*XSEA + XPGA(3)=XPGA(3)+FAC*XSEA + XPGA(4)=XPGA(4)+FAC*XCHM + XPGA(5)=XPGA(5)+FAC*XBOT + XPGA(KFL)=XPGA(KFL)+FAC*XVAL + VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL + 110 CONTINUE + DO 120 KFL=1,5 + XPGA(-KFL)=XPGA(KFL) + VXPGA(-KFL)=VXPGA(KFL) + 120 CONTINUE + + RETURN + END + + +C********************************************************************* + +C...PYGBEH +C...Evaluates the Bethe-Heitler cross section for heavy flavour +C...production. +C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. + + SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local data. + DATA AEM2PI/0.0011614D0/ + +C...Reset output. + XPBH=0D0 + SIGBH=0D0 + +C...Check kinematics limits. + IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN + W2=Q2*(1D0-X)/X-P2 + BETA2=1D0-4D0*PM2/W2 + IF(BETA2.LT.1D-10) RETURN + BETA=SQRT(BETA2) + RMQ=4D0*PM2/Q2 + +C...Simple case: P2 = 0. + IF(P2.LT.1D-4) THEN + IF(BETA.LT.0.99D0) THEN + XBL=LOG((1D0+BETA)/(1D0-BETA)) + ELSE + XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2)) + ENDIF + SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+ + & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2) + +C...Complicated case: P2 > 0, based on approximation of +C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373 + ELSE + RPQ=1D0-4D0*X**2*P2/Q2 + IF(RPQ.GT.1D-10) THEN + RPBE=SQRT(RPQ*BETA2) + IF(RPBE.LT.0.99D0) THEN + XBL=LOG((1D0+RPBE)/(1D0-RPBE)) + XBI=2D0*RPBE/(1D0-RPBE**2) + ELSE + RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2 + XBL=LOG((1D0+RPBE)**2/RPBESN) + XBI=2D0*RPBE/RPBESN + ENDIF + SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+ + & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+ + & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X) + ENDIF + ENDIF + +C...Multiply by charge-squared etc. to get parton distribution. + CHSQ=1D0/9D0 + IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0 + XPBH=3D0*CHSQ*AEM2PI*X*SIGBH + + RETURN + END + +C********************************************************************* + +C...PYGDIR +C...Evaluates the direct contribution, i.e. the C^gamma term, +C...as needed in MSbar parametrizations. +C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand. + + SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Local array and data. + DIMENSION XPGA(-6:6) + DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/ + +C...Reset output. + DO 100 KFL=-6,6 + XPGA(KFL)=0D0 + 100 CONTINUE + +C...Evaluate common x-dependent expression. + XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0 + CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X)) + +C...d, u, s part by simple charge factor. + XPGA(1)=(1D0/9D0)*CGAM + XPGA(2)=(4D0/9D0)*CGAM + XPGA(3)=(1D0/9D0)*CGAM + +C...Also fill for antiquarks. + DO 110 KF=1,5 + XPGA(-KF)=XPGA(KF) + 110 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYPDPI +C...Gives pi+ parton distribution according to two different +C...parametrizations. + + SUBROUTINE PYPDPI(X,Q2,XPPI) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYDAT1/,/PYPARS/,/PYINT1/ +C...Local arrays. + DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6) + +C...The following data lines are coefficients needed in the +C...Owens pion parton distribution parametrizations, see below. +C...Expansion coefficients for up and down valence quark distributions. + DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/ + &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00, + &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00, + &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/ + DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/ + &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00, + &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00, + &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/ +C...Expansion coefficients for gluon distribution. + DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/ + &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00, + &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01, + &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/ + DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/ + &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00, + &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00, + &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/ +C...Expansion coefficients for (up+down+strange) quark sea distribution. + DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/ + &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00, + &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00, + &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/ + DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/ + &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00, + &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01, + &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/ +C...Expansion coefficients for charm quark sea distribution. + DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/ + &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00, + &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00, + &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/ + DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/ + &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00, + &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01, + &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/ + +C...Euler's beta function, requires ordinary Gamma function + EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y) + +C...Reset output array. + DO 100 KFL=-6,6 + XPPI(KFL)=0D0 + 100 CONTINUE + + IF(MSTP(53).LE.2) THEN +C...Pion parton distributions from Owens. +C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2. + +C...Determine set, Lambda and s expansion variable. + NSET=MSTP(53) + IF(NSET.EQ.1) ALAM=0.2D0 + IF(NSET.EQ.2) ALAM=0.4D0 + VINT(231)=4D0 + IF(MSTP(57).LE.0) THEN + SD=0D0 + ELSE + Q2IN=MIN(2D3,MAX(4D0,Q2)) + SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2)) + ENDIF + +C...Calculate parton distributions. + DO 120 KFL=1,4 + DO 110 IS=1,5 + TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+ + & COW(3,IS,KFL,NSET)*SD**2 + 110 CONTINUE + IF(KFL.EQ.1) THEN + XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0) + ELSE + XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+ + & TS(5)*X**2) + ENDIF + 120 CONTINUE + +C...Put into output array. + XPPI(0)=XQ(2) + XPPI(1)=XQ(3)/6D0 + XPPI(2)=XQ(1)+XQ(3)/6D0 + XPPI(3)=XQ(3)/6D0 + XPPI(4)=XQ(4) + XPPI(-1)=XQ(1)+XQ(3)/6D0 + XPPI(-2)=XQ(3)/6D0 + XPPI(-3)=XQ(3)/6D0 + XPPI(-4)=XQ(4) + +C...Leading order pion parton distributions from Glueck, Reya and Vogt. +C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and +C...10^-5 < x < 1. + ELSE + +C...Determine s expansion variable and some x expressions. + VINT(231)=0.25D0 + IF(MSTP(57).LE.0) THEN + SD=0D0 + ELSE + Q2IN=MIN(1D8,MAX(0.25D0,Q2)) + SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2)) + ENDIF + SD2=SD**2 + XL=-LOG(X) + XS=SQRT(X) + +C...Evaluate valence, gluon and sea distributions. + XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)* + & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD) + XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0* + & SD-0.175D0*SD2)+ + & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+ + & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0* + & XL)))* + & (1D0-X)**(0.390D0+1.053D0*SD) + XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0- + & X)**3.359D0* + & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0* + & XL))/ + & XL**(2.538D0-0.763D0*SD) + IF(SD.LE.0.888D0) THEN + XFCHM=0D0 + ELSE + XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+ + & 0.771D0*SD)* + & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0* + & XL)) + ENDIF + IF(SD.LE.1.351D0) THEN + XFBOT=0D0 + ELSE + XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)* + & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0* + & XL)) + ENDIF + +C...Put into output array. + XPPI(0)=XFGLU + XPPI(1)=XFSEA + XPPI(2)=XFSEA + XPPI(3)=XFSEA + XPPI(4)=XFCHM + XPPI(5)=XFBOT + DO 130 KFL=1,5 + XPPI(-KFL)=XPPI(KFL) + 130 CONTINUE + XPPI(2)=XPPI(2)+XFVAL + XPPI(-1)=XPPI(-1)+XFVAL + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYPDPR +C...Gives proton parton distributions according to a few different +C...parametrizations. + + SUBROUTINE PYPDPR(X,Q2,XPPR) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ +C...Arrays and data. + DIMENSION XPPR(-6:6),Q2MIN(16) + DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0, + &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/ + +C...Reset output array. + DO 100 KFL=-6,6 + XPPR(KFL)=0D0 + 100 CONTINUE + +C...Common preliminaries. + NSET=MAX(1,MIN(16,MSTP(51))) + IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6 + VINT(231)=Q2MIN(NSET) + IF(MSTP(57).EQ.0) THEN + Q2L=Q2MIN(NSET) + ELSE + Q2L=MAX(Q2MIN(NSET),Q2) + ENDIF + + IF(NSET.GE.1.AND.NSET.LE.3) THEN +C...Interface to the CTEQ 3 parton distributions. + QRT=SQRT(MAX(1D0,Q2L)) + +C...Loop over flavours. + DO 110 I=-6,6 + IF(I.LE.0) THEN + XPPR(I)=PYCTEQ(NSET,I,X,QRT) + ELSEIF(I.LE.2) THEN + XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I) + ELSE + XPPR(I)=XPPR(-I) + ENDIF + 110 CONTINUE + + ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN +C...Interface to the GRV 94 distributions. + IF(NSET.EQ.4) THEN + CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL) + ELSEIF(NSET.EQ.5) THEN + CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL) + ELSE + CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL) + ENDIF + +C...Put into output array. + XPPR(0)=GL + XPPR(-1)=0.5D0*(UDB+DEL) + XPPR(-2)=0.5D0*(UDB-DEL) + XPPR(-3)=SB + XPPR(-4)=CHM + XPPR(-5)=BOT + XPPR(1)=DV+XPPR(-1) + XPPR(2)=UV+XPPR(-2) + XPPR(3)=SB + XPPR(4)=CHM + XPPR(5)=BOT + + ELSEIF(NSET.EQ.7) THEN +C...Interface to the CTEQ 5L parton distributions. +C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by +C...freezing x*f(x,Q2) at borders. + QRT=SQRT(MAX(1D0,MIN(1D8,Q2L))) + XIN=MAX(1D-6,MIN(1D0,X)) + +C...Loop over flavours (with u <-> d notation mismatch). + SUMUDB=PYCT5L(-1,XIN,QRT) + RATUDB=PYCT5L(-2,XIN,QRT) + DO 120 I=-5,2 + IF(I.EQ.1) THEN + XPPR(I)=XIN*PYCT5L(2,XIN,QRT) + ELSEIF(I.EQ.2) THEN + XPPR(I)=XIN*PYCT5L(1,XIN,QRT) + ELSEIF(I.EQ.-1) THEN + XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB) + ELSEIF(I.EQ.-2) THEN + XPPR(I)=XIN*SUMUDB/(1D0+RATUDB) + ELSE + XPPR(I)=XIN*PYCT5L(I,XIN,QRT) + IF(I.LT.0) XPPR(-I)=XPPR(I) + ENDIF + 120 CONTINUE + + ELSEIF(NSET.EQ.8) THEN +C...Interface to the CTEQ 5M1 parton distributions. + QRT=SQRT(MAX(1D0,MIN(1D8,Q2L))) + XIN=MAX(1D-6,MIN(1D0,X)) + +C...Loop over flavours (with u <-> d notation mismatch). + SUMUDB=PYCT5M(-1,XIN,QRT) + RATUDB=PYCT5M(-2,XIN,QRT) + DO 130 I=-5,2 + IF(I.EQ.1) THEN + XPPR(I)=XIN*PYCT5M(2,XIN,QRT) + ELSEIF(I.EQ.2) THEN + XPPR(I)=XIN*PYCT5M(1,XIN,QRT) + ELSEIF(I.EQ.-1) THEN + XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB) + ELSEIF(I.EQ.-2) THEN + XPPR(I)=XIN*SUMUDB/(1D0+RATUDB) + ELSE + XPPR(I)=XIN*PYCT5M(I,XIN,QRT) + IF(I.LT.0) XPPR(-I)=XPPR(I) + ENDIF + 130 CONTINUE + + ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN +C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions: +C...obsolete but offers backwards compatibility. + CALL PYPDPO(X,Q2L,XPPR) + +C...Symmetric choice for debugging only + ELSEIF(NSET.EQ.16) THEN + XPPR(0)=.5D0/X + XPPR(1)=.05D0/X + XPPR(2)=.05D0/X + XPPR(3)=.05D0/X + XPPR(4)=.05D0/X + XPPR(5)=.05D0/X + XPPR(-1)=.05D0/X + XPPR(-2)=.05D0/X + XPPR(-3)=.05D0/X + XPPR(-4)=.05D0/X + XPPR(-5)=.05D0/X + + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYCTEQ +C...Gives the CTEQ 3 parton distribution function sets in +C...parametrized form, of October 24, 1994. +C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens, +C...J. Qiu, W.K. Tung and H. Weerts. + + FUNCTION PYCTEQ (ISET, IPRT, X, Q) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...Data on Lambda values of fits, minimum Q and quark masses. + DIMENSION ALM(3), QMS(4:6) + DATA ALM / 0.177D0, 0.239D0, 0.247D0 / + DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 / + +C....Check flavour thresholds. Set up QI for SB. + IP = IABS(IPRT) + IF(IP .GE. 4) THEN + IF(Q .LE. QMS(IP)) THEN + PYCTEQ = 0D0 + RETURN + ENDIF + QI = QMS(IP) + ELSE + QI = QMN + ENDIF + +C...Use "standard lambda" of parametrization program for expansion. + ALAM = ALM (ISET) + SBL = LOG(Q/ALAM) / LOG(QI/ALAM) + SB = LOG (SBL) + SB2 = SB*SB + SB3 = SB2*SB + +C...Expansion for CTEQ3L. + IF(ISET .EQ. 1) THEN + IF(IPRT .EQ. 2) THEN + A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2- + & 0.3171D+00*SB3) + A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3 + A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3 + A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3 + A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3 + A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3 + ELSEIF(IPRT .EQ. 1) THEN + A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+ + & 0.7728D+00*SB3) + A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3 + A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3 + A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3 + A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3 + A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3 + ELSEIF(IPRT .EQ. 0) THEN + A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+ + & 0.5343D+00*SB3) + A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3 + A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3 + A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3 + A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3 + A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3 + ELSEIF(IPRT .EQ. -1) THEN + A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2- + & 0.2031D+01*SB3) + A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3 + A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3 + A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3 + A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3 + A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3 + ELSEIF(IPRT .EQ. -2) THEN + A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2- + & 0.9872D-01*SB3) + A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3 + A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3 + A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3 + A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3 + A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3 + ELSEIF(IPRT .EQ. -3) THEN + A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+ + & 0.8390D+00*SB3) + A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3 + A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3 + A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3 + A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3 + A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3 + ELSEIF(IPRT .EQ. -4) THEN + A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB + + & 0.1651D-01*SB2) + A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3 + A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3 + A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3 + A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3 + A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3 + ELSEIF(IPRT .EQ. -5) THEN + A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB + + & 0.3702D+01*SB2) + A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3 + A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3 + A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3 + A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3 + A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3 + ELSEIF(IPRT .EQ. -6) THEN + A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB - + & 0.6943D+00*SB2) + A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3 + A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3 + A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3 + A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3 + A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3 + ENDIF + +C...Expansion for CTEQ3M. + ELSEIF(ISET .EQ. 2) THEN + IF(IPRT .EQ. 2) THEN + A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2- + & 0.2935D+00*SB3) + A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3 + A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3 + A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3 + A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3 + A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3 + ELSEIF(IPRT .EQ. 1) THEN + A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2- + & 0.4305D-01*SB3) + A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3 + A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3 + A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3 + A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3 + A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3 + ELSEIF(IPRT .EQ. 0) THEN + A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+ + & 0.1037D-01*SB3) + A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3 + A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3 + A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3 + A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3 + A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3 + ELSEIF(IPRT .EQ. -1) THEN + A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2- + & 0.1602D+01*SB3) + A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3 + A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3 + A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3 + A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3 + A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3 + ELSEIF(IPRT .EQ. -2) THEN + A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+ + & 0.2496D+00*SB3) + A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3 + A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3 + A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3 + A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3 + A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3 + ELSEIF(IPRT .EQ. -3) THEN + A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+ + & 0.1936D+01*SB3) + A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3 + A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3 + A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3 + A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3 + A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3 + ELSEIF(IPRT .EQ. -4) THEN + A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB + + & 0.5348D+00*SB2) + A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3 + A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3 + A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3 + A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3 + A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3 + ELSEIF(IPRT .EQ. -5) THEN + A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB + + & 0.1569D+01*SB2) + A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3 + A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3 + A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3 + A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3 + A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3 + ELSEIF(IPRT .EQ. -6) THEN + A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB + + & 0.8838D+01*SB2) + A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3 + A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3 + A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3 + A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3 + A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3 + ENDIF + +C...Expansion for CTEQ3D. + ELSEIF(ISET .EQ. 3) THEN + IF(IPRT .EQ. 2) THEN + A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2- + & 0.2902D+00*SB3) + A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3 + A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3 + A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3 + A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3 + A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3 + ELSEIF(IPRT .EQ. 1) THEN + A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+ + & 0.7257D+00*SB3) + A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3 + A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3 + A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3 + A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3 + A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3 + ELSEIF(IPRT .EQ. 0) THEN + A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2- + & 0.2734D-04*SB3) + A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3 + A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3 + A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3 + A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3 + A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3 + ELSEIF(IPRT .EQ. -1) THEN + A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2- + & 0.1671D+01*SB3) + A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3 + A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3 + A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3 + A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3 + A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3 + ELSEIF(IPRT .EQ. -2) THEN + A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+ + & 0.2223D+00*SB3) + A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3 + A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3 + A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3 + A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3 + A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3 + ELSEIF(IPRT .EQ. -3) THEN + A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+ + & 0.1937D+01*SB3) + A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3 + A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3 + A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3 + A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3 + A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3 + ELSEIF(IPRT .EQ. -4) THEN + A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB + + & 0.5137D+00*SB2) + A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3 + A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3 + A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3 + A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3 + A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3 + ELSEIF(IPRT .EQ. -5) THEN + A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB + + & 0.2143D+01*SB2) + A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3 + A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3 + A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3 + A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3 + A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3 + ELSEIF(IPRT .EQ. -6) THEN + A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB + + & 0.9998D+01*SB2) + A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3 + A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3 + A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3 + A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3 + A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3 + ENDIF + ENDIF + +C...Calculation of x * f(x, Q). + PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4)) + & *(LOG(1D0+1D0/X))**A5 ) + + RETURN + END + +C********************************************************************* + +C...PYGRVL +C...Gives the GRV 94 L (leading order) parton distribution function set +C...in parametrized form. +C...Authors: M. Glueck, E. Reya and A. Vogt. + + SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION (A - Z) + +C...Common expressions. + MU2 = 0.23D0 + LAM2 = 0.2322D0 * 0.2322D0 + S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2)) + DS = SQRT (S) + S2 = S * S + S3 = S2 * S + +C...uv : + NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2 + AKU = 0.590D0 - 0.024D0 * S + BKU = 0.131D0 + 0.063D0 * S + AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2 + BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2 + CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2 + DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2 + UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU) + +C...dv : + ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2 + AKD = 0.376D0 + BKD = 0.486D0 + 0.062D0 * S + AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2 + BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2 + CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2 + DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2 + DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD) + +C...del : + NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2 + AKE = 0.409D0 - 0.005D0 * S + BKE = 0.799D0 + 0.071D0 * S + AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2 + BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2 + CE = 0.0D0 + DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2 + DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE) + +C...udb : + ALX = 1.451D0 + BEX = 0.271D0 + AKX = 0.410D0 - 0.232D0 * S + BKX = 0.534D0 - 0.457D0 * S + AGX = 0.890D0 - 0.140D0 * S + BGX = -0.981D0 + CX = 0.320D0 + 0.683D0 * S + DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2 + EX = 4.119D0 + 1.713D0 * S + ESX = 0.682D0 + 2.978D0 * S + UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX, + & DX, EX, ESX) + +C...sb : + STS = 0D0 + ALS = 0.914D0 + BES = 0.577D0 + AKS = 1.798D0 - 0.596D0 * S + AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S + BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S + DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2 + EST = 3.981D0 + 1.638D0 * S + ESS = 6.402D0 + SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS) + +C...cb : + STC = 0.888D0 + ALC = 1.01D0 + BEC = 0.37D0 + AKC = 0D0 + AC = 0D0 + BC = 4.24D0 - 0.804D0 * S + DCT = 3.46D0 - 1.076D0 * S + ECT = 4.61D0 + 1.49D0 * S + ESC = 2.555D0 + 1.961D0 * S + CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC) + +C...bb : + STB = 1.351D0 + ALB = 1.00D0 + BEB = 0.51D0 + AKB = 0D0 + AB = 0D0 + BB = 1.848D0 + DBT = 2.929D0 + 1.396D0 * S + EBT = 4.71D0 + 1.514D0 * S + ESB = 4.02D0 + 1.239D0 * S + BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB) + +C...gl : + ALG = 0.524D0 + BEG = 1.088D0 + AKG = 1.742D0 - 0.930D0 * S + BKG = - 0.399D0 * S2 + AG = 7.486D0 - 2.185D0 * S + BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2 + CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2 + DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3 + EG = 0.807D0 + 2.005D0 * S + ESG = 3.841D0 + 0.316D0 * S + GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, + & DG, EG, ESG) + + RETURN + END + +C********************************************************************* + +C...PYGRVM +C...Gives the GRV 94 M (MSbar) parton distribution function set +C...in parametrized form. +C...Authors: M. Glueck, E. Reya and A. Vogt. + + SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION (A - Z) + +C...Common expressions. + MU2 = 0.34D0 + LAM2 = 0.248D0 * 0.248D0 + S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2)) + DS = SQRT (S) + S2 = S * S + S3 = S2 * S + +C...uv : + NU = 1.304D0 + 0.863D0 * S + AKU = 0.558D0 - 0.020D0 * S + BKU = 0.183D0 * S + AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2 + BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3 + CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2 + DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3 + UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU) + +C...dv : + ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2 + AKD = 0.270D0 - 0.019D0 * S + BKD = 0.260D0 + AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2 + BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3 + CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2 + DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3 + DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD) + +C...del : + NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3 + AKE = 0.409D0 - 0.007D0 * S + BKE = 0.782D0 + 0.082D0 * S + AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2 + BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2 + CE = 0.0D0 + DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3 + DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE) + +C...udb : + ALX = 0.877D0 + BEX = 0.561D0 + AKX = 0.275D0 + BKX = 0.0D0 + AGX = 0.997D0 + BGX = 3.210D0 - 1.866D0 * S + CX = 7.300D0 + DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2 + EX = 3.077D0 + 1.446D0 * S + ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S + UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX, + & DX, EX, ESX) + +C...sb : + STS = 0D0 + ALS = 0.756D0 + BES = 0.216D0 + AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S + AS = -4.329D0 + 1.131D0 * S + BS = 9.568D0 - 1.744D0 * S + DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2 + EST = 3.031D0 + 1.639D0 * S + ESS = 5.837D0 + 0.815D0 * S + SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS) + +C...cb : + STC = 0.820D0 + ALC = 0.98D0 + BEC = 0D0 + AKC = -0.625D0 - 0.523D0 * S + AC = 0D0 + BC = 1.896D0 + 1.616D0 * S + DCT = 4.12D0 + 0.683D0 * S + ECT = 4.36D0 + 1.328D0 * S + ESC = 0.677D0 + 0.679D0 * S + CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC) + +C...bb : + STB = 1.297D0 + ALB = 0.99D0 + BEB = 0D0 + AKB = - 0.193D0 * S + AB = 0D0 + BB = 0D0 + DBT = 3.447D0 + 0.927D0 * S + EBT = 4.68D0 + 1.259D0 * S + ESB = 1.892D0 + 2.199D0 * S + BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB) + +C...gl : + ALG = 1.014D0 + BEG = 1.738D0 + AKG = 1.724D0 + 0.157D0 * S + BKG = 0.800D0 + 1.016D0 * S + AG = 7.517D0 - 2.547D0 * S + BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S + CG = 4.039D0 + 1.491D0 * S + DG = 3.404D0 + 0.830D0 * S + EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2 + ESG = 3.256D0 - 0.436D0 * S + GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG) + + RETURN + END + +C********************************************************************* + +C...PYGRVD +C...Gives the GRV 94 D (DIS) parton distribution function set +C...in parametrized form. +C...Authors: M. Glueck, E. Reya and A. Vogt. + + SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION (A - Z) + +C...Common expressions. + MU2 = 0.34D0 + LAM2 = 0.248D0 * 0.248D0 + S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2)) + DS = SQRT (S) + S2 = S * S + S3 = S2 * S + +C...uv : + NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2 + AKU = 0.563D0 - 0.025D0 * S + BKU = 0.054D0 + 0.154D0 * S + AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2 + BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3 + CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2 + DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3 + UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU) + +C...dv : + ND = 0.156D0 - 0.017D0 * S + AKD = 0.299D0 - 0.022D0 * S + BKD = 0.259D0 - 0.015D0 * S + AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2 + BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3 + CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2 + DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3 + DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD) + +C...del : + NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2 + AKE = 0.419D0 - 0.013D0 * S + BKE = 1.064D0 - 0.038D0 * S + AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2 + BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3 + CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2 + DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2 + DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE) + +C...udb : + ALX = 1.215D0 + BEX = 0.466D0 + AKX = 0.326D0 + 0.150D0 * S + BKX = 0.956D0 + 0.405D0 * S + AGX = 0.272D0 + BGX = 3.794D0 - 2.359D0 * DS + CX = 2.014D0 + DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2 + EX = 3.049D0 + 1.597D0 * S + ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S + UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX, + & DX, EX, ESX) + +C...sb : + STS = 0D0 + ALS = 0.175D0 + BES = 0.344D0 + AKS = 1.415D0 - 0.641D0 * DS + AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2 + BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S + DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3 + EST = 4.546D0 + 0.372D0 * S2 + ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2 + SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS) + +C...cb : + STC = 0.820D0 + ALC = 0.98D0 + BEC = 0D0 + AKC = -0.625D0 - 0.523D0 * S + AC = 0D0 + BC = 1.896D0 + 1.616D0 * S + DCT = 4.12D0 + 0.683D0 * S + ECT = 4.36D0 + 1.328D0 * S + ESC = 0.677D0 + 0.679D0 * S + CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC) + +C...bb : + STB = 1.297D0 + ALB = 0.99D0 + BEB = 0D0 + AKB = - 0.193D0 * S + AB = 0D0 + BB = 0D0 + DBT = 3.447D0 + 0.927D0 * S + EBT = 4.68D0 + 1.259D0 * S + ESB = 1.892D0 + 2.199D0 * S + BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB) + +C...gl : + ALG = 1.258D0 + BEG = 1.846D0 + AKG = 2.423D0 + BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2 + AG = 25.09D0 - 7.935D0 * S + BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S + CG = 590.3D0 - 173.8D0 * S + DG = 5.196D0 + 1.857D0 * S + EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2 + ESG = 3.232D0 - 0.542D0 * S + GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG) + + RETURN + END + +C********************************************************************* + +C...PYGRVV +C...Auxiliary for the GRV 94 parton distribution functions +C...for u and d valence and d-u sea. +C...Authors: M. Glueck, E. Reya and A. Vogt. + + FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION (A - Z) + +C...Evaluation. + DX = SQRT (X) + PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) * + & (1D0- X)**D + + RETURN + END + +C********************************************************************* + +C...PYGRVW +C...Auxiliary for the GRV 94 parton distribution functions +C...for d+u sea and gluon. +C...Authors: M. Glueck, E. Reya and A. Vogt. + + FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION (A - Z) + +C...Evaluation. + LX = LOG (1D0/X) + PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL + & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D + + RETURN + END + +C********************************************************************* + +C...PYGRVS +C...Auxiliary for the GRV 94 parton distribution functions +C...for s, c and b sea. +C...Authors: M. Glueck, E. Reya and A. Vogt. + + FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION (A - Z) + +C...Evaluation. + IF(S.LE.STH) THEN + PYGRVS = 0D0 + ELSE + DX = SQRT (X) + LX = LOG (1D0/X) + PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) * + & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX)) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYCT5L +C...Auxiliary function for parametrization of CTEQ5L. +C...Author: J. Pumplin 9/99. + +C...CTEQ5M1 and CTEQ5L Parton Distribution Functions +C...in Parametrized Form +C... September 15, 1999 +C +C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON: +C... CTEQ5 PPARTON DISTRIBUTIONS" +C...hep-ph/9903282 + +C...The CTEQ5M1 set given here is an updated version of the original +C...CTEQ5M set posted, in the table version, on the Web page of CTEQ. +C...The differences between CTEQ5M and CTEQ5M1 are insignificant for +C...almost all applications. +C...The improvement is in the QCD evolution which is now more +C...accurate, and which agrees completely with the benchmark work +C...of the HERA 96/97 Workshop. +C...The differences between the parametrized and the corresponding +C...table versions (on which it is based) are of similar order as +C...between the two version. + +C...!! Because accurate parametrizations over a wide range of (x,Q) +C...is hard to obtain, only the most widely used sets CTEQ5M and +C...CTEQ5L are available in parametrized form for now. + +C...These parametrizations were obtained by Jon Pumplin. + +C Iset PDF Description Alpha_s(Mz) Lam4 Lam5 +C ------------------------------------------------------------------- +C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226 +C 3 CTEQ5L Leading Order 0.127 192 146 +C ------------------------------------------------------------------- +C...Note the Qcd-lambda values given for CTEQ5L is for the leading +C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute +C...calibration. + +C...The two Iset value are adopted to agree with the standard table +C...versions. + +C...Range of validity: +C...The range of (x, Q) covered by this parametrization of the QCD +C...evolved parton distributions is 1E-6 < x < 1 ; +C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by +C...data only in a subset of that region; and the assumed DGLAP +C...evolution is unlikely to be valid for all of it either. + +C...The range of (x, Q) used in the CTEQ5 round of global analysis is +C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for +C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and +C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data. + + FUNCTION PYCT5L(IFL,X,Q) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + + PARAMETER (NEX=8, NLF=2) + DIMENSION AM(0:NEX,0:NLF,-5:2) + DIMENSION ALFVEC(-5:2), QMAVEC(-5:2) + DIMENSION MEXVEC(-5:2), MLFVEC(-5:2) + DIMENSION UT1VEC(-5:2), UT2VEC(-5:2) + DIMENSION AF(0:NEX) + + DATA MEXVEC( 2) / 8 / + DATA MLFVEC( 2) / 2 / + DATA UT1VEC( 2) / 0.4971265E+01 / + DATA UT2VEC( 2) / -0.1105128E+01 / + DATA ALFVEC( 2) / 0.2987216E+00 / + DATA QMAVEC( 2) / 0.0000000E+00 / + DATA (AM( 0,K, 2),K=0, 2) + & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 / + DATA (AM( 1,K, 2),K=0, 2) + & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 / + DATA (AM( 2,K, 2),K=0, 2) + & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 / + DATA (AM( 3,K, 2),K=0, 2) + & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 / + DATA (AM( 4,K, 2),K=0, 2) + & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 / + DATA (AM( 5,K, 2),K=0, 2) + & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 / + DATA (AM( 6,K, 2),K=0, 2) + & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 / + DATA (AM( 7,K, 2),K=0, 2) + & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 / + DATA (AM( 8,K, 2),K=0, 2) + & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 / + + DATA MEXVEC( 1) / 8 / + DATA MLFVEC( 1) / 2 / + DATA UT1VEC( 1) / 0.2612618E+01 / + DATA UT2VEC( 1) / -0.1258304E+06 / + DATA ALFVEC( 1) / 0.3407552E+00 / + DATA QMAVEC( 1) / 0.0000000E+00 / + DATA (AM( 0,K, 1),K=0, 2) + & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 / + DATA (AM( 1,K, 1),K=0, 2) + & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 / + DATA (AM( 2,K, 1),K=0, 2) + & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 / + DATA (AM( 3,K, 1),K=0, 2) + & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 / + DATA (AM( 4,K, 1),K=0, 2) + & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 / + DATA (AM( 5,K, 1),K=0, 2) + & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 / + DATA (AM( 6,K, 1),K=0, 2) + & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 / + DATA (AM( 7,K, 1),K=0, 2) + & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 / + DATA (AM( 8,K, 1),K=0, 2) + & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 / + + DATA MEXVEC( 0) / 8 / + DATA MLFVEC( 0) / 2 / + DATA UT1VEC( 0) / -0.4656819E+00 / + DATA UT2VEC( 0) / -0.2742390E+03 / + DATA ALFVEC( 0) / 0.4491863E+00 / + DATA QMAVEC( 0) / 0.0000000E+00 / + DATA (AM( 0,K, 0),K=0, 2) + & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 / + DATA (AM( 1,K, 0),K=0, 2) + & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 / + DATA (AM( 2,K, 0),K=0, 2) + & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 / + DATA (AM( 3,K, 0),K=0, 2) + & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 / + DATA (AM( 4,K, 0),K=0, 2) + & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 / + DATA (AM( 5,K, 0),K=0, 2) + & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 / + DATA (AM( 6,K, 0),K=0, 2) + & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 / + DATA (AM( 7,K, 0),K=0, 2) + & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 / + DATA (AM( 8,K, 0),K=0, 2) + & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 / + + DATA MEXVEC(-1) / 8 / + DATA MLFVEC(-1) / 2 / + DATA UT1VEC(-1) / 0.3862583E+01 / + DATA UT2VEC(-1) / -0.1265969E+01 / + DATA ALFVEC(-1) / 0.2457668E+00 / + DATA QMAVEC(-1) / 0.0000000E+00 / + DATA (AM( 0,K,-1),K=0, 2) + & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 / + DATA (AM( 1,K,-1),K=0, 2) + & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 / + DATA (AM( 2,K,-1),K=0, 2) + & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 / + DATA (AM( 3,K,-1),K=0, 2) + & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 / + DATA (AM( 4,K,-1),K=0, 2) + & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 / + DATA (AM( 5,K,-1),K=0, 2) + & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 / + DATA (AM( 6,K,-1),K=0, 2) + & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 / + DATA (AM( 7,K,-1),K=0, 2) + & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 / + DATA (AM( 8,K,-1),K=0, 2) + & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 / + + DATA MEXVEC(-2) / 7 / + DATA MLFVEC(-2) / 2 / + DATA UT1VEC(-2) / 0.1895615E+00 / + DATA UT2VEC(-2) / -0.3069097E+01 / + DATA ALFVEC(-2) / 0.5293999E+00 / + DATA QMAVEC(-2) / 0.0000000E+00 / + DATA (AM( 0,K,-2),K=0, 2) + & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 / + DATA (AM( 1,K,-2),K=0, 2) + & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 / + DATA (AM( 2,K,-2),K=0, 2) + & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 / + DATA (AM( 3,K,-2),K=0, 2) + & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 / + DATA (AM( 4,K,-2),K=0, 2) + & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 / + DATA (AM( 5,K,-2),K=0, 2) + & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 / + DATA (AM( 6,K,-2),K=0, 2) + & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 / + DATA (AM( 7,K,-2),K=0, 2) + & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 / + + DATA MEXVEC(-3) / 7 / + DATA MLFVEC(-3) / 2 / + DATA UT1VEC(-3) / 0.3753257E+01 / + DATA UT2VEC(-3) / -0.1113085E+01 / + DATA ALFVEC(-3) / 0.3713141E+00 / + DATA QMAVEC(-3) / 0.0000000E+00 / + DATA (AM( 0,K,-3),K=0, 2) + & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 / + DATA (AM( 1,K,-3),K=0, 2) + & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 / + DATA (AM( 2,K,-3),K=0, 2) + & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 / + DATA (AM( 3,K,-3),K=0, 2) + & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 / + DATA (AM( 4,K,-3),K=0, 2) + & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 / + DATA (AM( 5,K,-3),K=0, 2) + & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 / + DATA (AM( 6,K,-3),K=0, 2) + & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 / + DATA (AM( 7,K,-3),K=0, 2) + & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 / + + DATA MEXVEC(-4) / 7 / + DATA MLFVEC(-4) / 2 / + DATA UT1VEC(-4) / 0.4400772E+01 / + DATA UT2VEC(-4) / -0.1356116E+01 / + DATA ALFVEC(-4) / 0.3712017E-01 / + DATA QMAVEC(-4) / 0.1300000E+01 / + DATA (AM( 0,K,-4),K=0, 2) + & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 / + DATA (AM( 1,K,-4),K=0, 2) + & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 / + DATA (AM( 2,K,-4),K=0, 2) + & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 / + DATA (AM( 3,K,-4),K=0, 2) + & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 / + DATA (AM( 4,K,-4),K=0, 2) + & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 / + DATA (AM( 5,K,-4),K=0, 2) + & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 / + DATA (AM( 6,K,-4),K=0, 2) + & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 / + DATA (AM( 7,K,-4),K=0, 2) + & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 / + + DATA MEXVEC(-5) / 6 / + DATA MLFVEC(-5) / 2 / + DATA UT1VEC(-5) / 0.5562568E+01 / + DATA UT2VEC(-5) / -0.1801317E+01 / + DATA ALFVEC(-5) / 0.4952010E-02 / + DATA QMAVEC(-5) / 0.4500000E+01 / + DATA (AM( 0,K,-5),K=0, 2) + & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 / + DATA (AM( 1,K,-5),K=0, 2) + & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 / + DATA (AM( 2,K,-5),K=0, 2) + & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 / + DATA (AM( 3,K,-5),K=0, 2) + & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 / + DATA (AM( 4,K,-5),K=0, 2) + & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 / + DATA (AM( 5,K,-5),K=0, 2) + & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 / + DATA (AM( 6,K,-5),K=0, 2) + & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 / + + IF(Q .LE. QMAVEC(IFL)) THEN + PYCT5L = 0.D0 + RETURN + ENDIF + + IF(X .GE. 1.D0) THEN + PYCT5L = 0.D0 + RETURN + ENDIF + + TMP = LOG(Q/ALFVEC(IFL)) + IF(TMP .LE. 0.D0) THEN + PYCT5L = 0.D0 + RETURN + ENDIF + + SB = LOG(TMP) + SB1 = SB - 1.2D0 + SB2 = SB1*SB1 + + DO 110 I = 0, NEX + AF(I) = 0.D0 + SBX = 1.D0 + DO 100 K = 0, MLFVEC(IFL) + AF(I) = AF(I) + SBX*AM(I,K,IFL) + SBX = SB1*SBX + 100 CONTINUE + 110 CONTINUE + + Y = -LOG(X) + U = LOG(X/0.00001D0) + + PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U) + PART2 = AF(0)*(1.D0 - X) + AF(3)*X + PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X)) + PART4 = UT1VEC(IFL)*LOG(1.D0-X) + + & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X) + + PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4) + +C...Include threshold factor. + PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q) + + RETURN + END + +C********************************************************************* + +C...PYCT5M +C...Auxiliary function for parametrization of CTEQ5M1. +C...Author: J. Pumplin 9/99. + + FUNCTION PYCT5M(IFL,X,Q) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + + PARAMETER (NEX=8, NLF=2) + DIMENSION AM(0:NEX,0:NLF,-5:2) + DIMENSION ALFVEC(-5:2), QMAVEC(-5:2) + DIMENSION MEXVEC(-5:2), MLFVEC(-5:2) + DIMENSION UT1VEC(-5:2), UT2VEC(-5:2) + DIMENSION AF(0:NEX) + + DATA MEXVEC( 2) / 8 / + DATA MLFVEC( 2) / 2 / + DATA UT1VEC( 2) / 0.5141718E+01 / + DATA UT2VEC( 2) / -0.1346944E+01 / + DATA ALFVEC( 2) / 0.5260555E+00 / + DATA QMAVEC( 2) / 0.0000000E+00 / + DATA (AM( 0,K, 2),K=0, 2) + & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 / + DATA (AM( 1,K, 2),K=0, 2) + & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 / + DATA (AM( 2,K, 2),K=0, 2) + & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 / + DATA (AM( 3,K, 2),K=0, 2) + & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 / + DATA (AM( 4,K, 2),K=0, 2) + & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 / + DATA (AM( 5,K, 2),K=0, 2) + & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 / + DATA (AM( 6,K, 2),K=0, 2) + & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 / + DATA (AM( 7,K, 2),K=0, 2) + & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 / + DATA (AM( 8,K, 2),K=0, 2) + & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 / + + DATA MEXVEC( 1) / 8 / + DATA MLFVEC( 1) / 2 / + DATA UT1VEC( 1) / 0.4138426E+01 / + DATA UT2VEC( 1) / -0.3221374E+01 / + DATA ALFVEC( 1) / 0.4960962E+00 / + DATA QMAVEC( 1) / 0.0000000E+00 / + DATA (AM( 0,K, 1),K=0, 2) + & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 / + DATA (AM( 1,K, 1),K=0, 2) + & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 / + DATA (AM( 2,K, 1),K=0, 2) + & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 / + DATA (AM( 3,K, 1),K=0, 2) + & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 / + DATA (AM( 4,K, 1),K=0, 2) + & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 / + DATA (AM( 5,K, 1),K=0, 2) + & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 / + DATA (AM( 6,K, 1),K=0, 2) + & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 / + DATA (AM( 7,K, 1),K=0, 2) + & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 / + DATA (AM( 8,K, 1),K=0, 2) + & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 / + + DATA MEXVEC( 0) / 8 / + DATA MLFVEC( 0) / 2 / + DATA UT1VEC( 0) / -0.1026789E+01 / + DATA UT2VEC( 0) / -0.9051707E+01 / + DATA ALFVEC( 0) / 0.9462977E+00 / + DATA QMAVEC( 0) / 0.0000000E+00 / + DATA (AM( 0,K, 0),K=0, 2) + & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 / + DATA (AM( 1,K, 0),K=0, 2) + & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 / + DATA (AM( 2,K, 0),K=0, 2) + & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 / + DATA (AM( 3,K, 0),K=0, 2) + & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 / + DATA (AM( 4,K, 0),K=0, 2) + & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 / + DATA (AM( 5,K, 0),K=0, 2) + & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 / + DATA (AM( 6,K, 0),K=0, 2) + & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 / + DATA (AM( 7,K, 0),K=0, 2) + & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 / + DATA (AM( 8,K, 0),K=0, 2) + & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 / + + DATA MEXVEC(-1) / 8 / + DATA MLFVEC(-1) / 2 / + DATA UT1VEC(-1) / 0.5243571E+01 / + DATA UT2VEC(-1) / -0.2870513E+01 / + DATA ALFVEC(-1) / 0.6701448E+00 / + DATA QMAVEC(-1) / 0.0000000E+00 / + DATA (AM( 0,K,-1),K=0, 2) + & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 / + DATA (AM( 1,K,-1),K=0, 2) + & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 / + DATA (AM( 2,K,-1),K=0, 2) + & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 / + DATA (AM( 3,K,-1),K=0, 2) + & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 / + DATA (AM( 4,K,-1),K=0, 2) + & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 / + DATA (AM( 5,K,-1),K=0, 2) + & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 / + DATA (AM( 6,K,-1),K=0, 2) + & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 / + DATA (AM( 7,K,-1),K=0, 2) + & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 / + DATA (AM( 8,K,-1),K=0, 2) + & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 / + + DATA MEXVEC(-2) / 7 / + DATA MLFVEC(-2) / 2 / + DATA UT1VEC(-2) / 0.4782210E+01 / + DATA UT2VEC(-2) / -0.1976856E+02 / + DATA ALFVEC(-2) / 0.7558374E+00 / + DATA QMAVEC(-2) / 0.0000000E+00 / + DATA (AM( 0,K,-2),K=0, 2) + & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 / + DATA (AM( 1,K,-2),K=0, 2) + & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 / + DATA (AM( 2,K,-2),K=0, 2) + & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 / + DATA (AM( 3,K,-2),K=0, 2) + & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 / + DATA (AM( 4,K,-2),K=0, 2) + & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 / + DATA (AM( 5,K,-2),K=0, 2) + & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 / + DATA (AM( 6,K,-2),K=0, 2) + & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 / + DATA (AM( 7,K,-2),K=0, 2) + & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 / + + DATA MEXVEC(-3) / 7 / + DATA MLFVEC(-3) / 2 / + DATA UT1VEC(-3) / 0.4518239E+01 / + DATA UT2VEC(-3) / -0.2690590E+01 / + DATA ALFVEC(-3) / 0.6124079E+00 / + DATA QMAVEC(-3) / 0.0000000E+00 / + DATA (AM( 0,K,-3),K=0, 2) + & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 / + DATA (AM( 1,K,-3),K=0, 2) + & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 / + DATA (AM( 2,K,-3),K=0, 2) + & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 / + DATA (AM( 3,K,-3),K=0, 2) + & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 / + DATA (AM( 4,K,-3),K=0, 2) + & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 / + DATA (AM( 5,K,-3),K=0, 2) + & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 / + DATA (AM( 6,K,-3),K=0, 2) + & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 / + DATA (AM( 7,K,-3),K=0, 2) + & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 / + + DATA MEXVEC(-4) / 7 / + DATA MLFVEC(-4) / 2 / + DATA UT1VEC(-4) / 0.2783230E+01 / + DATA UT2VEC(-4) / -0.1746328E+01 / + DATA ALFVEC(-4) / 0.1115653E+01 / + DATA QMAVEC(-4) / 0.1300000E+01 / + DATA (AM( 0,K,-4),K=0, 2) + & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 / + DATA (AM( 1,K,-4),K=0, 2) + & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 / + DATA (AM( 2,K,-4),K=0, 2) + & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 / + DATA (AM( 3,K,-4),K=0, 2) + & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 / + DATA (AM( 4,K,-4),K=0, 2) + & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 / + DATA (AM( 5,K,-4),K=0, 2) + & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 / + DATA (AM( 6,K,-4),K=0, 2) + & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 / + DATA (AM( 7,K,-4),K=0, 2) + & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 / + + DATA MEXVEC(-5) / 6 / + DATA MLFVEC(-5) / 2 / + DATA UT1VEC(-5) / 0.1619654E+02 / + DATA UT2VEC(-5) / -0.3367346E+01 / + DATA ALFVEC(-5) / 0.5109891E-02 / + DATA QMAVEC(-5) / 0.4500000E+01 / + DATA (AM( 0,K,-5),K=0, 2) + & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 / + DATA (AM( 1,K,-5),K=0, 2) + & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 / + DATA (AM( 2,K,-5),K=0, 2) + & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 / + DATA (AM( 3,K,-5),K=0, 2) + & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 / + DATA (AM( 4,K,-5),K=0, 2) + & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 / + DATA (AM( 5,K,-5),K=0, 2) + & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 / + DATA (AM( 6,K,-5),K=0, 2) + & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 / + + IF(Q .LE. QMAVEC(IFL)) THEN + PYCT5M = 0.D0 + RETURN + ENDIF + + IF(X .GE. 1.D0) THEN + PYCT5M = 0.D0 + RETURN + ENDIF + + TMP = LOG(Q/ALFVEC(IFL)) + IF(TMP .LE. 0.D0) THEN + PYCT5M = 0.D0 + RETURN + ENDIF + + SB = LOG(TMP) + SB1 = SB - 1.2D0 + SB2 = SB1*SB1 + + DO 110 I = 0, NEX + AF(I) = 0.D0 + SBX = 1.D0 + DO 100 K = 0, MLFVEC(IFL) + AF(I) = AF(I) + SBX*AM(I,K,IFL) + SBX = SB1*SBX + 100 CONTINUE + 110 CONTINUE + + Y = -LOG(X) + U = LOG(X/0.00001D0) + + PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U) + PART2 = AF(0)*(1.D0 - X) + AF(3)*X + PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X)) + PART4 = UT1VEC(IFL)*LOG(1.D0-X) + + & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X) + + PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4) + +C...Include threshold factor. + PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q) + + RETURN + END + +C********************************************************************* + +C...PYPDPO +C...Auxiliary to PYPDPR. Gives proton parton distributions according to +C...a few older parametrizations, now obsolete but convenient for +C...backwards checks. + + SUBROUTINE PYPDPO(X,Q2,XPPR) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ + DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2), + &CEHLQ(6,6,2,8,2),CDO(3,6,5,2) + + +C...The following data lines are coefficients needed in the +C...Eichten, Hinchliffe, Lane, Quigg proton structure function +C...parametrizations, see below. +C...Powers of 1-x in different cases. + DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/ +C...Expansion coefficients for up valence quark distribution. + DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/ + 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04, + 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03, + 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03, + 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03, + 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03, + 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04, + 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04, + 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03, + 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04, + 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04, + 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05, + 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/ + DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/ + 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04, + 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03, + 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03, + 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03, + 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03, + 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04, + 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04, + 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03, + 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04, + 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04, + 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05, + 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/ +C...Expansion coefficients for down valence quark distribution. + DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/ + 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04, + 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03, + 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03, + 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03, + 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04, + 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04, + 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04, + 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03, + 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04, + 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04, + 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05, + 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/ + DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/ + 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04, + 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03, + 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03, + 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03, + 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04, + 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04, + 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04, + 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03, + 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04, + 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04, + 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05, + 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/ +C...Expansion coefficients for up and down sea quark distributions. + DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/ + 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04, + 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03, + 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05, + 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04, + 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04, + 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05, + 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04, + 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03, + 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04, + 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05, + 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00, + 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/ + DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/ + 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04, + 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03, + 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04, + 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04, + 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04, + 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04, + 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03, + 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03, + 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04, + 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05, + 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05, + 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/ +C...Expansion coefficients for gluon distribution. + DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/ + 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02, + 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02, + 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02, + 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03, + 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04, + 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03, + 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02, + 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02, + 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02, + 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03, + 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03, + 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/ + DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/ + 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02, + 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02, + 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02, + 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02, + 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02, + 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02, + 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02, + 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01, + 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02, + 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03, + 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03, + 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/ +C...Expansion coefficients for strange sea quark distribution. + DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/ + 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04, + 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03, + 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04, + 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04, + 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04, + 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05, + 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04, + 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03, + 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04, + 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05, + 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00, + 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/ + DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/ + 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04, + 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03, + 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04, + 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04, + 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04, + 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04, + 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03, + 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03, + 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04, + 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05, + 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05, + 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/ +C...Expansion coefficients for charm sea quark distribution. + DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/ + 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03, + 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03, + 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04, + 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05, + 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05, + 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05, + 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04, + 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03, + 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04, + 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04, + 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05, + 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/ + DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/ + 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03, + 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03, + 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04, + 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05, + 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05, + 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05, + 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03, + 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03, + 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04, + 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04, + 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05, + 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/ +C...Expansion coefficients for bottom sea quark distribution. + DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/ + 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03, + 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04, + 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04, + 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05, + 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05, + 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05, + 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03, + 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03, + 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04, + 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05, + 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05, + 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/ + DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/ + 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03, + 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04, + 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04, + 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05, + 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00, + 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05, + 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03, + 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03, + 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04, + 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05, + 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05, + 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/ +C...Expansion coefficients for top sea quark distribution. + DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/ + 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04, + 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04, + 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04, + 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00, + 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05, + 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00, + 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03, + 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03, + 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04, + 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05, + 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00, + 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/ + DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/ + 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04, + 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04, + 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04, + 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00, + 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05, + 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00, + 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03, + 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03, + 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04, + 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05, + 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00, + 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/ + +C...The following data lines are coefficients needed in the +C...Duke, Owens proton structure function parametrizations, see below. +C...Expansion coefficients for (up+down) valence quark distribution. + DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/ + 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/ + DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/ + 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/ +C...Expansion coefficients for down valence quark distribution. + DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/ + 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00, + 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/ + DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/ + 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00, + 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/ +C...Expansion coefficients for (up+down+strange) sea quark distribution. + DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/ + 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01, + 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/ + DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/ + 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02, + 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/ +C...Expansion coefficients for charm sea quark distribution. + DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/ + 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01, + 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/ + DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/ + 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00, + 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01, + 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/ +C...Expansion coefficients for gluon distribution. + DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/ + 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00, + 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01, + 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/ + DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/ + 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00, + 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01, + 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/ + +C...Euler's beta function, requires ordinary Gamma function + EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y) + +C...Leading order proton parton distributions from Glueck, Reya and +C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and +C...10^-5 < x < 1. + IF(MSTP(51).EQ.11) THEN + +C...Determine s expansion variable and some x expressions. + Q2IN=MIN(1D8,MAX(0.25D0,Q2)) + SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2)) + SD2=SD**2 + XL=-LOG(X) + XS=SQRT(X) + +C...Evaluate valence, gluon and sea distributions. + XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)* + & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+ + & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)* + & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2) + XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)* + & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+ + & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2) + XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+ + & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD- + & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+ + & SQRT(4.066D0*SD**1.218D0*XL)))* + & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2) + XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+ + & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+ + & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0* + & XL)))*(1D0-X)**(4.696D0+2.109D0*SD) + XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+ + & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0* + & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)* + & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD) + IF(SD.LE.0.888D0) THEN + XFCHM=0D0 + ELSE + XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)* + & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+ + & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL)) + ENDIF + IF(SD.LE.1.351D0) THEN + XFBOT=0D0 + ELSE + XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+ + & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+ + & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL)) + ENDIF + +C...Put into output array. + XPPR(0)=XFGLU + XPPR(1)=XFVDD+XFSEA + XPPR(2)=XFVUD-XFVDD+XFSEA + XPPR(3)=XFSTR + XPPR(4)=XFCHM + XPPR(5)=XFBOT + XPPR(-1)=XFSEA + XPPR(-2)=XFSEA + XPPR(-3)=XFSTR + XPPR(-4)=XFCHM + XPPR(-5)=XFBOT + +C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg. +C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1 + ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN + +C...Determine set, Lambda and x and t expansion variables. + NSET=MSTP(51)-11 + IF(NSET.EQ.1) ALAM=0.2D0 + IF(NSET.EQ.2) ALAM=0.29D0 + TMIN=LOG(5D0/ALAM**2) + TMAX=LOG(1D8/ALAM**2) + T=LOG(MAX(1D0,Q2/ALAM**2)) + VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN))) + NX=1 + IF(X.LE.0.1D0) NX=2 + IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0 + IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0) + +C...Chebyshev polynomials for x and t expansion. + TX(1)=1D0 + TX(2)=VX + TX(3)=2D0*VX**2-1D0 + TX(4)=4D0*VX**3-3D0*VX + TX(5)=8D0*VX**4-8D0*VX**2+1D0 + TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX + TT(1)=1D0 + TT(2)=VT + TT(3)=2D0*VT**2-1D0 + TT(4)=4D0*VT**3-3D0*VT + TT(5)=8D0*VT**4-8D0*VT**2+1D0 + TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT + +C...Calculate structure functions. + DO 120 KFL=1,6 + XQSUM=0D0 + DO 110 IT=1,6 + DO 100 IX=1,6 + XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT) + 100 CONTINUE + 110 CONTINUE + XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET) + 120 CONTINUE + +C...Put into output array. + XPPR(0)=XQ(4) + XPPR(1)=XQ(2)+XQ(3) + XPPR(2)=XQ(1)+XQ(3) + XPPR(3)=XQ(5) + XPPR(4)=XQ(6) + XPPR(-1)=XQ(3) + XPPR(-2)=XQ(3) + XPPR(-3)=XQ(5) + XPPR(-4)=XQ(6) + +C...Special expansion for bottom (threshold effects). + IF(MSTP(58).GE.5) THEN + IF(NSET.EQ.1) TMIN=8.1905D0 + IF(NSET.EQ.2) TMIN=7.4474D0 + IF(T.GT.TMIN) THEN + VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN))) + TT(1)=1D0 + TT(2)=VT + TT(3)=2D0*VT**2-1D0 + TT(4)=4D0*VT**3-3D0*VT + TT(5)=8D0*VT**4-8D0*VT**2+1D0 + TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT + XQSUM=0D0 + DO 140 IT=1,6 + DO 130 IX=1,6 + XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT) + 130 CONTINUE + 140 CONTINUE + XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET) + XPPR(-5)=XPPR(5) + ENDIF + ENDIF + +C...Special expansion for top (threshold effects). + IF(MSTP(58).GE.6) THEN + IF(NSET.EQ.1) TMIN=11.5528D0 + IF(NSET.EQ.2) TMIN=10.8097D0 + TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0) + TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0) + IF(T.GT.TMIN) THEN + VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN))) + TT(1)=1D0 + TT(2)=VT + TT(3)=2D0*VT**2-1D0 + TT(4)=4D0*VT**3-3D0*VT + TT(5)=8D0*VT**4-8D0*VT**2+1D0 + TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT + XQSUM=0D0 + DO 160 IT=1,6 + DO 150 IX=1,6 + XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT) + 150 CONTINUE + 160 CONTINUE + XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET) + XPPR(-6)=XPPR(6) + ENDIF + ENDIF + +C...Proton parton distributions from Duke, Owens. +C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2. + ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN + +C...Determine set, Lambda and s expansion parameter. + NSET=MSTP(51)-13 + IF(NSET.EQ.1) ALAM=0.2D0 + IF(NSET.EQ.2) ALAM=0.4D0 + Q2IN=MIN(1D6,MAX(4D0,Q2)) + SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2)) + +C...Calculate structure functions. + DO 180 KFL=1,5 + DO 170 IS=1,6 + TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+ + & CDO(3,IS,KFL,NSET)*SD**2 + 170 CONTINUE + IF(KFL.LE.2) THEN + XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1), + & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0))) + ELSE + XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+ + & TS(5)*X**2+TS(6)*X**3) + ENDIF + 180 CONTINUE + +C...Put into output arrays. + XPPR(0)=XQ(5) + XPPR(1)=XQ(2)+XQ(3)/6D0 + XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0 + XPPR(3)=XQ(3)/6D0 + XPPR(4)=XQ(4) + XPPR(-1)=XQ(3)/6D0 + XPPR(-2)=XQ(3)/6D0 + XPPR(-3)=XQ(3)/6D0 + XPPR(-4)=XQ(4) + + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYHFTH +C...Gives threshold attractive/repulsive factor for heavy flavour +C...production. + + FUNCTION PYHFTH(SH,SQM,FRATT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYDAT1/,/PYPARS/,/PYINT1/ + +C...Value for alpha_strong. + IF(MSTP(35).LE.1) THEN + ALSSG=PARP(35) + ELSE + MST115=MSTU(115) + MSTU(115)=MSTP(36) + Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+ + & PARP(36)**2))) + ALSSG=PYALPS(Q2BN) + MSTU(115)=MST115 + ENDIF + +C...Evaluate attractive and repulsive factors. + XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH))) + FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR))) + XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH))) + FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0) + PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU + VINT(138)=PYHFTH + + RETURN + END + +C********************************************************************* + +C...PYSPLI +C...Splits a hadron remnant into two (partons or hadron + parton) +C...in case it is more complicated than just a quark or a diquark. + + SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. PYDAT1 temporary + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYPARS/,/PYINT1/,/PYDAT1/ +C...Local array. + DIMENSION KFL(3) + +C...Preliminaries. Parton composition. + KFA=IABS(KF) + KFS=ISIGN(1,KF) + KFL(1)=MOD(KFA/1000,10) + KFL(2)=MOD(KFA/100,10) + KFL(3)=MOD(KFA/10,10) + IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN + KFL(2)=INT(1.5D0+PYR(0)) + IF(MINT(105).EQ.333) KFL(2)=3 + IF(MINT(105).EQ.443) KFL(2)=4 + KFL(3)=KFL(2) + ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN + KFL(2)=2 + KFL(3)=2 + ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN + KFL(2)=1 + KFL(3)=1 + ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN + KFL(2)=MOD(KFA/10,10) + KFL(3)=MOD(KFA/100,10) + ENDIF + IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN + KFLR=KFLIN*KFS + ELSE + KFLR=KFLIN + ENDIF + KFLCH=0 + +C...Subdivide lepton. + IF(KFA.GE.11.AND.KFA.LE.18) THEN + IF(KFLR.EQ.KFA) THEN + KFLSP=KFS*22 + ELSEIF(KFLR.EQ.22) THEN + KFLSP=KFA + ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN + KFLSP=KFA+1 + ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN + KFLSP=KFA-1 + ELSEIF(KFLR.EQ.21) THEN + KFLSP=KFA + KFLCH=KFS*21 + ELSE + KFLSP=KFA + KFLCH=-KFLR + ENDIF + +C...Subdivide photon. + ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN + IF(KFLR.NE.21) THEN + KFLSP=-KFLR + ELSE + RAGR=0.75D0*PYR(0) + KFLSP=1 + IF(RAGR.GT.0.125D0) KFLSP=2 + IF(RAGR.GT.0.625D0) KFLSP=3 + IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP + KFLCH=-KFLSP + ENDIF + +C...Subdivide Reggeon or Pomeron. + ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN + IF(KFLIN.EQ.21) THEN + KFLSP=KFS*21 + ELSE + KFLSP=-KFLIN + ENDIF + +C...Subdivide meson. + ELSEIF(KFL(1).EQ.0) THEN + KFL(2)=KFL(2)*(-1)**KFL(2) + KFL(3)=-KFL(3)*(-1)**IABS(KFL(2)) + IF(KFLR.EQ.KFL(2)) THEN + KFLSP=KFL(3) + ELSEIF(KFLR.EQ.KFL(3)) THEN + KFLSP=KFL(2) + ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN + KFLSP=KFL(2) + KFLCH=KFL(3) + ELSEIF(KFLR.EQ.21) THEN + KFLSP=KFL(3) + KFLCH=KFL(2) + ELSEIF(KFLR*KFL(2).GT.0) THEN + NTRY=0 + 100 NTRY=NTRY+1 + CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH) + IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN + GOTO 100 + ELSEIF(KFLCH.EQ.0) THEN + CALL PYERRM(14,'(PYSPLI:) caught in infinite loop') + MINT(51)=1 + RETURN + ENDIF + KFLSP=KFL(3) + ELSE + NTRY=0 + 110 NTRY=NTRY+1 + CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH) + IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN + GOTO 110 + ELSEIF(KFLCH.EQ.0) THEN + CALL PYERRM(14,'(PYSPLI:) caught in infinite loop') + MINT(51)=1 + RETURN + ENDIF + KFLSP=KFL(2) + ENDIF + +C...Special case for extracting photon from baryon without splitting +C...the latter. (Currently only used by external programs.) + ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then + KFLSP=KFA + KFLCH=0 + +C...Subdivide baryon. + ELSE + NAGR=0 + DO 120 J=1,3 + IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1 + 120 CONTINUE + IF(NAGR.GE.1) THEN + RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0) + IAGR=0 + DO 130 J=1,3 + IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0 + IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J + 130 CONTINUE + ELSE + IAGR=1.00001D0+2.99998D0*PYR(0) + ENDIF + ID1=1 + IF(IAGR.EQ.1) ID1=2 + IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3 + ID2=6-IAGR-ID1 + KSP=3 + IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN + IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1 + ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN + IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1 + ELSEIF(MOD(KFA,10).EQ.2) THEN + IF(IAGR.EQ.1) KSP=1 + IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1 + ENDIF + KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP + IF(KFLR.EQ.21) THEN + KFLCH=KFL(IAGR) + ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN + NTRY=0 + 140 NTRY=NTRY+1 + CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH) + IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN + GOTO 140 + ELSEIF(KFLCH.EQ.0) THEN + CALL PYERRM(14,'(PYSPLI:) caught in infinite loop') + MINT(51)=1 + RETURN + ENDIF + ELSEIF(NAGR.EQ.0) THEN + NTRY=0 + 150 NTRY=NTRY+1 + CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH) + IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN + GOTO 150 + ELSEIF(KFLCH.EQ.0) THEN + CALL PYERRM(14,'(PYSPLI:) caught in infinite loop') + MINT(51)=1 + RETURN + ENDIF + KFLSP=KFL(IAGR) + ENDIF + ENDIF + +C...Add on correct sign for result. + KFLCH=KFLCH*KFS + KFLSP=KFLSP*KFS + + RETURN + END + +C********************************************************************* + +C...PYGAMM +C...Gives ordinary Gamma function Gamma(x) for positive, real arguments; +C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions +C...(Dover, 1965) 6.1.36. + + FUNCTION PYGAMM(X) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Local array and data. + DIMENSION B(8) + DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0, + &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/ + + NX=INT(X) + DX=X-NX + + PYGAMM=1D0 + DXP=1D0 + DO 100 I=1,8 + DXP=DXP*DX + PYGAMM=PYGAMM+B(I)*DXP + 100 CONTINUE + IF(X.LT.1D0) THEN + PYGAMM=PYGAMM/X + ELSE + DO 110 IX=1,NX-1 + PYGAMM=(X-IX)*PYGAMM + 110 CONTINUE + ENDIF + + RETURN + END + +C*********************************************************************** + +C...PYWAUX +C...Calculates real and imaginary parts of the auxiliary functions W1 +C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van +C...der Bij, Nucl. Phys. B297 (1988) 221. + + SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + + ASINH(X)=LOG(X+SQRT(X**2+1D0)) + ACOSH(X)=LOG(X+SQRT(X**2-1D0)) + + IF(EPS.LT.0D0) THEN + IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS)) + IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2 + WIM=0D0 + ELSEIF(EPS.LT.1D0) THEN + IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS)) + IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2 + IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS) + IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS)) + ELSE + IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS)) + IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2 + WIM=0D0 + ENDIF + + RETURN + END + +C*********************************************************************** + +C...PYI3AU +C...Calculates real and imaginary parts of the auxiliary function I3; +C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij, +C...Nucl. Phys. B297 (1988) 221. + + SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + + BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS)) + IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS)) + + IF(EPS.LT.0D0) THEN + IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN + F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)- + & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+ + & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)- + & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2- + & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)* + & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+ + & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)* + & EPS)) + ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN + F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)- + & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+ + & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)- + & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+ + & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+ + & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+ + & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS)) + ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN + F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)- + & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+ + & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)- + & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+ + & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+ + & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+ + & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS)) + ELSE + F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)- + & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)- + & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2- + & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+ + & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0)) + ENDIF + F3IM=0D0 + ELSEIF(EPS.LT.1D0) THEN + IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN + F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)- + & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+ + & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)- + & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/ + & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/ + & (0.25D0*(RAT+1D0)*EPS)) + F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/ + & (0.25D0*(RAT+1D0)*EPS)) + ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN + F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)- + & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+ + & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)- + & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+ + & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))* + & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS)) + F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS)) + ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN + F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)- + & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+ + & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)- + & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+ + & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/ + & (1D0+0.25D0*RAT*EPS-GA)) + F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/ + & (1D0+0.25D0*RAT*EPS-GA)) + ELSE + F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)- + & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)- + & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))* + & LOG((GA+BE-1D0)/(BE-GA)) + F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA)) + ENDIF + ELSE + RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2) + RCTHE=RSQ*(1D0-2D0*BE/EPS) + RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2)) + RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS) + RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2)) + R=SQRT(RSQ) + THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R))) + PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R))) + F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)- + & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+ + & (PHI-THE)*(PHI+THE-PARU(1)) + F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)- + & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2) + ENDIF + + Y3RE=2D0/(2D0*BE-1D0)*F3RE + Y3IM=2D0/(2D0*BE-1D0)*F3IM + + RETURN + END + +C*********************************************************************** + +C...PYSPEN +C...Calculates real and imaginary part of Spence function; see +C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365. + + FUNCTION PYSPEN(XREIN,XIMIN,IREIM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ +C...Local array and data. + DIMENSION B(0:14) + DATA B/ + &1.000000D+00, -5.000000D-01, 1.666667D-01, + &0.000000D+00, -3.333333D-02, 0.000000D+00, + &2.380952D-02, 0.000000D+00, -3.333333D-02, + &0.000000D+00, 7.575757D-02, 0.000000D+00, + &-2.531135D-01, 0.000000D+00, 1.166667D+00/ + + XRE=XREIN + XIM=XIMIN + IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN + IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0 + IF(IREIM.EQ.2) PYSPEN=0D0 + RETURN + ENDIF + + XMOD=SQRT(XRE**2+XIM**2) + IF(XMOD.LT.1D-6) THEN + IF(IREIM.EQ.1) PYSPEN=0D0 + IF(IREIM.EQ.2) PYSPEN=0D0 + RETURN + ENDIF + + XARG=SIGN(ACOS(XRE/XMOD),XIM) + SP0RE=0D0 + SP0IM=0D0 + SGN=1D0 + IF(XMOD.GT.1D0) THEN + ALGXRE=LOG(XMOD) + ALGXIM=XARG-SIGN(PARU(1),XARG) + SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0 + SP0IM=-ALGXRE*ALGXIM + SGN=-1D0 + XMOD=1D0/XMOD + XARG=-XARG + XRE=XMOD*COS(XARG) + XIM=XMOD*SIN(XARG) + ENDIF + IF(XRE.GT.0.5D0) THEN + ALGXRE=LOG(XMOD) + ALGXIM=XARG + XRE=1D0-XRE + XIM=-XIM + XMOD=SQRT(XRE**2+XIM**2) + XARG=SIGN(ACOS(XRE/XMOD),XIM) + ALGYRE=LOG(XMOD) + ALGYIM=XARG + SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM)) + SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE) + SGN=-SGN + ENDIF + + XRE=1D0-XRE + XIM=-XIM + XMOD=SQRT(XRE**2+XIM**2) + XARG=SIGN(ACOS(XRE/XMOD),XIM) + ZRE=-LOG(XMOD) + ZIM=-XARG + + SPRE=0D0 + SPIM=0D0 + SAVERE=1D0 + SAVEIM=0D0 + DO 100 I=0,14 + IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110 + TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1) + TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1) + SAVERE=TERMRE + SAVEIM=TERMIM + SPRE=SPRE+B(I)*TERMRE + SPIM=SPIM+B(I)*TERMIM + 100 CONTINUE + + 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE + IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM + + RETURN + END + +C*********************************************************************** + +C...PYQQBH +C...Calculates the matrix element for the processes +C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t). +C...REDUCE output and part of the rest courtesy Z. Kunszt, see +C...Z. Kunszt, Nucl. Phys. B247 (1984) 339. + + SUBROUTINE PYQQBH(WTQQBH) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/ +C...Local arrays and function. + DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8) + DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)- + &PP(I,3)*PP(J,3) + +C...Mass parameters. + WTQQBH=0D0 + ISUB=MINT(1) + SHPR=SQRT(VINT(26))*VINT(1) + PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1) + PH=SQRT(VINT(21))*VINT(1) + SPQ=PQ**2 + SPH=PH**2 + +C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H. + DO 100 I=1,2 + PT=SQRT(MAX(0D0,VINT(197+5*I))) + PP(I,1)=PT*COS(VINT(198+5*I)) + PP(I,2)=PT*SIN(VINT(198+5*I)) + 100 CONTINUE + PP(3,1)=-PP(1,1)-PP(2,1) + PP(3,2)=-PP(1,2)-PP(2,2) + PMS1=SPQ+PP(1,1)**2+PP(1,2)**2 + PMS2=SPQ+PP(2,1)**2+PP(2,2)**2 + PMS3=SPH+PP(3,1)**2+PP(3,2)**2 + PMT3=SQRT(PMS3) + PP(3,3)=PMT3*SINH(VINT(211)) + PP(3,4)=PMT3*COSH(VINT(211)) + PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2 + PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+ + &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12) + PP(2,3)=-PP(1,3)-PP(3,3) + PP(1,4)=SQRT(PMS1+PP(1,3)**2) + PP(2,4)=SQRT(PMS2+PP(2,3)**2) + +C...Set up incoming kinematics and derived momentum combinations. + DO 110 I=4,5 + PP(I,1)=0D0 + PP(I,2)=0D0 + PP(I,3)=-0.5D0*SHPR*(-1)**I + PP(I,4)=-0.5D0*SHPR + 110 CONTINUE + DO 120 J=1,4 + PP(6,J)=PP(1,J)+PP(2,J) + PP(7,J)=PP(1,J)+PP(3,J) + PP(8,J)=PP(1,J)+PP(4,J) + PP(9,J)=PP(1,J)+PP(5,J) + PP(10,J)=-PP(2,J)-PP(3,J) + PP(11,J)=-PP(2,J)-PP(4,J) + PP(12,J)=-PP(2,J)-PP(5,J) + PP(13,J)=-PP(4,J)-PP(5,J) + 120 CONTINUE + +C...Derived kinematics invariants. + X1=DOT(1,2) + X2=DOT(1,3) + X3=DOT(1,4) + X4=DOT(1,5) + X5=DOT(2,3) + X6=DOT(2,4) + X7=DOT(2,5) + X8=DOT(3,4) + X9=DOT(3,5) + X10=DOT(4,5) + +C...Propagators. + SS1=DOT(7,7)-SPQ + SS2=DOT(8,8)-SPQ + SS3=DOT(9,9)-SPQ + SS4=DOT(10,10)-SPQ + SS5=DOT(11,11)-SPQ + SS6=DOT(12,12)-SPQ + SS7=DOT(13,13) + DX(1)=SS1*SS6 + DX(2)=SS2*SS6 + DX(3)=SS2*SS4 + DX(4)=SS1*SS5 + DX(5)=SS3*SS5 + DX(6)=SS3*SS4 + DX(7)=SS7*SS1 + DX(8)=SS7*SS4 + +C...Define colour coefficients for g + g -> Q + Qbar + H. + IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN + DO 140 I=1,3 + DO 130 J=1,3 + CLR(I,J)=16D0/3D0 + CLR(I+3,J+3)=16D0/3D0 + CLR(I,J+3)=-2D0/3D0 + CLR(I+3,J)=-2D0/3D0 + 130 CONTINUE + 140 CONTINUE + DO 160 L=1,2 + DO 150 I=1,3 + CLR(I,6+L)=-6D0 + CLR(I+3,6+L)=6D0 + CLR(6+L,I)=-6D0 + CLR(6+L,I+3)=6D0 + 150 CONTINUE + 160 CONTINUE + DO 180 K1=1,2 + DO 170 K2=1,2 + CLR(6+K1,6+K2)=12D0 + 170 CONTINUE + 180 CONTINUE + +C...Evaluate matrix elements for g + g -> Q + Qbar + H. + FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2* + & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2* + & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7 + FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2 + & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2* + & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+ + & X10) + FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4* + & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10 + & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2 + & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7 + & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+ + & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6) + FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10- + & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6 + & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+ + & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2* + & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6) + FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1* + & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1* + & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4 + & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1** + & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4* + & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7 + & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5- + & X4*X6*X5) + FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4- + & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3* + & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2 + & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5 + & +X4*X9*X5+X4*X5**2) + FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2* + & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1* + & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3* + & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7* + & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7- + & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5) + FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2* + & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+ + & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8* + & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6 + & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8* + & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4* + & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2* + & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+ + & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2) + FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*( + & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7 + FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2 + & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3* + & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+ + & X6) + FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1* + & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1* + & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4 + & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1 + & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4 + & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3* + & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6* + & X5+X4*X6*X5) + FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1 + & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3- + & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4- + & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1* + & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3 + & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4* + & X6**2) + FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1* + & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1* + & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4* + & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1** + & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4* + & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7 + & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5- + & X4*X6*X5) + FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3- + & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2* + & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3* + & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2 + & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5 + & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*( + & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1* + & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1* + & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3* + & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3 + & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5) + FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3- + & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2* + & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2* + & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4 + & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5- + & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*( + & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9- + & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9 + & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10* + & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3* + & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5) + FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6 + & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3* + & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5 + FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3- + & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3* + & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2 + & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5 + & +X3*X8*X5+X3*X5**2) + FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1* + & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1* + & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3 + & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1 + & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3 + & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3* + & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7* + & X5+X4*X6*X5) + FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+ + & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6 + & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2* + & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2* + & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10) + FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2* + & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4* + & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+ + & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4* + & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+ + & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3* + & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2 + & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7 + & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5) + FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2* + & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+ + & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7 + & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9* + & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4 + & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8) + FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2* + & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2* + & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6 + FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4 + & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+ + & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+ + & X10) + FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2* + & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10 + & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2 + & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7 + & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+ + & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7) + FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2 + & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1* + & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3* + & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7* + & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2* + & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5) + FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2 + & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9 + & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4 + & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4* + & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2 + & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3 + & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2 + & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9* + & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2) + FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*( + & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6 + FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2 + & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4* + & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+ + & X7) + FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+ + & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2* + & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+ + & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+ + & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+ + & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(- + & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3 + & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10* + & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2* + & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4 + & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5) + FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+ + & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2* + & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+ + & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2* + & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+ + & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*( + & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3* + & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9 + & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10* + & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+ + & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5) + FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7 + & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4* + & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5 + FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2 + & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4 + & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9 + & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+ + & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9 + & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4 + & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2 + & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+ + & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5) + FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2 + & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1* + & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12* + & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9 + & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2* + & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8) + FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9* + & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7* + & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2 + & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8 + & *X6) + FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+ + & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4* + & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9* + & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3* + & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2 + & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+ + & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5) + FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2 + & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4 + & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2* + & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4* + & X8) + FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+ + & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6 + & )+2*X2*(-X10*X5+X9*X6+X8*X7) + FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2* + & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2 + & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3* + & X9*X5) + FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2* + & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2 + & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4* + & X8*X5) + FM(9,10)=0.5D0*(FMXX+FM(9,10)) + FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+ + & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6 + & )+2*X5*(-X10*X2+X9*X3+X8*X4) + +C...Repackage matrix elements. + DO 200 I=1,8 + DO 190 J=I,8 + RM(I,J)=FM(I,J) + 190 CONTINUE + 200 CONTINUE + RM(7,7)=FM(7,7)-2D0*FM(9,9) + RM(7,8)=FM(7,8)-2D0*FM(9,10) + RM(8,8)=FM(8,8)-2D0*FM(10,10) + +C...Produce final result: matrix elements * colours * propagators. + DO 220 I=1,8 + DO 210 J=I,8 + FAC=8D0 + IF(I.EQ.J)FAC=4D0 + WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J)) + 210 CONTINUE + 220 CONTINUE + WTQQBH=-WTQQBH/256D0 + + ELSE +C...Evaluate matrix elements for q + qbar -> Q + Qbar + H. + A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3 + & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9 + & *X6+X8*X7) + A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8- + & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7 + & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8* + & X5) + A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3* + & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3 + & *X9+X4*X8) + +C...Produce final result: matrix elements * propagators. + A11=A11/DX(7)**2 + A12=A12/(DX(7)*DX(8)) + A22=A22/DX(8)**2 + WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0 + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSTBH (and auxiliaries) +C.. Evaluates the matrix elements for t + b + H production. + + SUBROUTINE PYSTBH(WTTBH) + +C...DOUBLE PRECISION AND INTEGER DECLARATIONS + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...COMMONBLOCKS + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A + DOUBLE PRECISION MW2 + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/, + &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/ + +C...LOCAL ARRAYS AND COMPLEX VARIABLES + DIMENSION QQ(4,2),PP(4,3) + DATA QQ/8*0D0/ + + WTTBH=0D0 + +C...KINEMATIC PARAMETERS. + SHPR=SQRT(VINT(26))*VINT(1) + PH=SQRT(VINT(21))*VINT(1) + SPH=PH**2 + +C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H. + DO 100 I=1,2 + PT=SQRT(MAX(0D0,VINT(197+5*I))) + PP(1,I)=PT*COS(VINT(198+5*I)) + PP(2,I)=PT*SIN(VINT(198+5*I)) + 100 CONTINUE + PP(1,3)=-PP(1,1)-PP(1,2) + PP(2,3)=-PP(2,1)-PP(2,2) + PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2 + PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2 + PMS3=SPH+PP(1,3)**2+PP(2,3)**2 + PMT3=SQRT(PMS3) + PP(3,3)=PMT3*SINH(VINT(211)) + PP(4,3)=PMT3*COSH(VINT(211)) + PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2 + PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+ + &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12) + PP(3,2)=-PP(3,1)-PP(3,3) + PP(4,1)=SQRT(PMS1+PP(3,1)**2) + PP(4,2)=SQRT(PMS2+PP(3,2)**2) + +C...CM SYSTEM, INGOING QUARKS/GLUONS + QQ(3,1) = SHPR/2.D0 + QQ(4,1) = QQ(3,1) + QQ(3,2) = -QQ(3,1) + QQ(4,2) = QQ(4,1) + +C...PARAMETERS FOR AMPLITUDE METHOD + ALPHA = AEM + ALPHAS = AS + SW2 = PARU(102) + MW2 = PMAS(24,1)**2 + TANB = PARU(141) + VTB = VCKM(3,3) + RMB=PYMRUN(5,VINT(52)) + + ISUB=MINT(1) + + IF (ISUB.EQ.401) THEN + CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3), + & VINT(201),VINT(206),RMB,VINT(43),WTTBH) + ELSE IF (ISUB.EQ.402) THEN + CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3), + & VINT(201),VINT(206),RMB,VINT(43),WTTBH) + END IF + + RETURN + END +C------------------------------------------------------------------ + SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT) +C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+ + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN + COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A + SAVE /PYCTBH/ + +C TOP WIDTH CALCULATION +C VTB = 0.99 + MW=DSQRT(MW2) + XB=(MB/MT)**2 + XW=(MW/MT)**2 + XH =(MHP/MT)**2 + GAMTBH = 0D0 + IF (MT .LT. (MHP+MB)) THEN +C T ->B W ONLY + BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2) + GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW* + & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) ) + GAMT = GAMTBW + ELSE +C T ->BW +T ->B H^+ + BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2) + GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW* + & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) ) +C + KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2 + & -4.D0*(MHP*MB/MT**2)**2 ) + GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT * + & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2)) + GAMT = GAMTBW+GAMTBH + ENDIF +C THUS BR IS + BR=GAMTBH/GAMT + RETURN + END + +C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES: +C GG->TBH^+, QQBAR->TBH^+ +C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE +C (FOR INSTANCE WITH PYTHIA) +C------------------------------------------------------------ +C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443, +C PHYS REV. D 60 (1999) 115011 +C (THESE FILES PREPARED BY J.-L. KNEUR) +C------------------------------------------------------------ +C 1) GG->TBH^+ + SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2) +C +C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS: +C +C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS; +C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA; +C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA. +C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT) +C "PHYSICAL PARAMETERS" INPUT: +C MT,MB TOP AND BOTTOM MASSES; +C MHP CHARGED HIGGS MASS +C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW) +C +C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+ +C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY +C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING +C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL +C CROSS-SECTION SHOULD BE (SYMBOLICALLY): +C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL +C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ] +C + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + DOUBLE PRECISION MW2,MT,MB,MHP,MW + DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + + COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/ +C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION +C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES: +C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA +C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB +C (TAN BETA) VALUES +C +C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH +C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..). + + PI = 4*DATAN(1.D0) + MW = DSQRT(MW2) +C +C COLLECTING THE RELEVANT OVERALL FACTORS: +C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE + PS=1.D0/(8.D0*8.D0 *2.D0*2.D0) +C COUPLING CONSTANT (OVERALL NORMALIZATION) + FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0 +C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI: +C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI +C ALPHAS IS ALPHA_STRONG; +C SW2 IS SIN(THETA_W)**2. +C +C VTB=.998D0 +C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE) +C + V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0 + A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0 +C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS +C +C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION +C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS) + DO 100 KK=1,4 + P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK) + 100 CONTINUE +C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS: + S = 2*PYTBHS(Q1,Q2) + P1Q1=PYTBHS(Q1,P1) + P1Q2=PYTBHS(P1,Q2) + P2Q1=PYTBHS(P2,Q1) + P2Q2=PYTBHS(P2,Q2) + P1P2=PYTBHS(P1,P2) +C +C TOP WIDTH CALCULATION + CALL PYTBHB(MT,MB,MHP,BR,GAMT) +C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+ +C THEN DEFINE TOP (RESONANT) PROPAGATOR: + A1INV= S -2*P1Q1 -2*P1Q2 + A1 =A1INV/(A1INV**2+ (GAMT*MT)**2) +C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE) +C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF +C THE TOP WIDTH + A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2) + A2 =1.D0/(S +2*P2Q1 +2*P2Q2) +C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH +C NOW COMES THE AMP**2: +C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN +C THE EXPRESSIONS BELOW + V18=0.D0 + A18=0.D0 + V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT- + &512*A1*A2*MB*MT/3- + &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+ + &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+ + &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+ + &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+ + &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+ + &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+ + &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+ + &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+ + &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)- + &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1- + &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+ + &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+ + &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+ + &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+ + &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2) + V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+ + &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+ + &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+ + &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)- + &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2- + &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+ + &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)- + &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+ + &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)- + &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)- + &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+ + &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2- + &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+ + &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+ + &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)- + &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)- + &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1 + V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1- + &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+ + &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+ + &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+ + &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)- + &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)- + &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)- + &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+ + &64*MB**3*MT/(3*P1Q2*P2Q1**2)+ + &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+ + &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+ + &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+ + &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+ + &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)- + &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1- + &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+ + &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1) + V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+ + &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)- + &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1- + &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)- + &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)- + &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)- + &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+ + &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+ + &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)- + &64*MB*MT**3/(3*P1Q2**2*P2Q1)- + &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)- + &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+ + &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)- + &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)- + &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)- + &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+ + &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1) + V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)- + &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)- + &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)- + &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)- + &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+ + &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+ + &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)- + &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+ + &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)- + &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+ + &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)- + &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+ + &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)- + &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+ + &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+ + &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+ + &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1) + V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+ + &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+ + &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+ + &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+ + &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+ + &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+ + &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)- + &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)- + &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)- + &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+ + &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+ + &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+ + &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+ + &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+ + &256*A12*MT**4*P2Q1/(3*P1Q2**2)+ + &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+ + &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2) + V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+ + &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+ + &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+ + &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+ + &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)- + &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)- + &256*A2**2*MB**4*P1P2/(3*P2Q2**2)- + &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)- + &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+ + &64*MB**3*MT/(3*P1Q1*P2Q2**2)+ + &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+ + &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)- + &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)- + &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)- + &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+ + &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+ + &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2) + V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)- + &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+ + &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+ + &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)- + &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)- + &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)- + &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+ + &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)- + &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)- + &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+ + &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)- + &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2- + &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)- + &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+ + &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)- + &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)- + &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2) + V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)- + &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)- + &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)- + &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)- + &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)- + &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+ + &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+ + &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+ + &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+ + &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)- + &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)- + &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)- + &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)- + &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)- + &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+ + &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)- + &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2) + V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+ + &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)- + &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)- + &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)- + &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+ + &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+ + &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+ + &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)- + &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)- + &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)- + &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)- + &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+ + &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)- + &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+ + &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2) + V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+ + &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)- + &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+ + &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+ + &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+ + &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)- + &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+ + &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)- + &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)- + &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+ + &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)- + &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+ + &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)- + &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+ + &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2) + V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)- + &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)- + &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+ + &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2- + &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)- + &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+ + &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+ + &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)- + &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+ + &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+ + &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)- + &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)- + &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)- + &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)- + &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)- + &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2) + V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+ + &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+ + &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)- + &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+ + &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)- + &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+ + &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+ + &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)- + &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)- + &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)- + &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)- + &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)- + &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)- + &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)- + &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2) + V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+ + &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+ + &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+ + &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+ + &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+ + &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+ + &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+ + &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+ + &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+ + &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+ + &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+ + &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+ + &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)- + &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+ + &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+ + &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)- + &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2) + V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)- + &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)- + &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+ + &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+ + &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1- + &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)- + &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+ + &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+ + &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+ + &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+ + &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)- + &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+ + &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+ + &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)- + &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+ + &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+ + &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1) + V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)- + &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)- + &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)- + &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+ + &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)- + &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)- + &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)- + &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)- + &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)- + &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)- + &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+ + &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)- + &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)- + &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+ + &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+ + &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+ + &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1) + V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+ + &384*A12*MB*MT*P1Q1**2/S**2+ + &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+ + &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+ + &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+ + &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+ + &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2- + &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+ + &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+ + &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2- + &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+ + &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+ + &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+ + &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2- + &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+ + &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+ + &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+ + &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2 + V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2- + &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S- + &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S- + &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S- + &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S- + &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)- + &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S- + &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S- + &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S- + &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S- + &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)- + &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)- + &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)- + &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)- + &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+ + &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)- + &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S) + V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+ + &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+ + &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S- + &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S- + &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S- + &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S- + &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)- + &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)- + &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+ + &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S- + &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)- + &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)- + &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+ + &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+ + &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+ + &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+ + &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+ + &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S) + V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+ + &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+ + &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+ + &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+ + &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+ + &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+ + &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+ + &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+ + &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+ + &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+ + &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)- + &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)- + &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S- + &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+ + &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+ + &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+ + &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S) + V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+ + &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+ + &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)- + &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+ + &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)- + &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)- + &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)- + &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)- + &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)- + &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)- + &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)- + &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S- + &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+ + &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)- + &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)- + &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+ + &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)- + &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S) + V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S- + &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+ + &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+ + &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+ + &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+ + &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)- + &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)- + &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+ + &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+ + &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+ + &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+ + &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+ + &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+ + &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+ + &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+ + &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+ + &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S) + V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+ + &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+ + &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)- + &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+ + &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+ + &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)- + &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)- + &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)- + &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)- + &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+ + &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+ + &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+ + &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+ + &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)- + &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+ + &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+ + &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S) + V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)- + &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+ + &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+ + &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)- + &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)- + &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)- + &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+ + &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)- + &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+ + &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)- + &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)- + &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+ + &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+ + &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+ + &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+ + &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)- + &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S) + V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+ + &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+ + &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S- + &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+ + &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+ + &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+ + &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)- + &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)- + &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S- + &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+ + &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+ + &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+ + &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+ + &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)- + &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)- + &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+ + &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S) + V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)- + &192*A12*P1Q1**2*P2Q2/(P1Q2*S)- + &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S- + &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)- + &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)- + &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)- + &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)- + &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+ + &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)- + &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+ + &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+ + &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)- + &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+ + &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+ + &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+ + &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)- + &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S) + V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)- + &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)- + &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)- + &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+ + &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S) + + V18BIS= + &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+ + &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+ + &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+ + &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+ + &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+ + &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+ + &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)- + &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)- + &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+ + &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)- + &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)- + &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S) + V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)- + &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+ + &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+ + &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+ + &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+ + &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+ + &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)- + &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3- + &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)- + &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+ + &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)- + &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)- + &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)- + &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+ + &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)- + &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)- + &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2) + V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+ + &272*A1*A2*P1Q1*S/(3*P1Q2)+ + &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)- + &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+ + &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)- + &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)- + &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)- + &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)- + &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+ + &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)- + &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)- + &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+ + &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+ + &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+ + &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)- + &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+ + &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1) + V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+ + &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)- + &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+ + &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+ + &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+ + &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+ + &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)- + &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+ + &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)- + &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)- + &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)- + &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+ + &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)- + &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)- + &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)- + &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)- + &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1) + V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)- + &32*A12*P2Q1*S/(3*P1Q1)- + &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)- + &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+ + &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)- + &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)- + &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)- + &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+ + &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)- + &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)- + &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)- + &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+ + &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+ + &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+ + &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+ + &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+ + &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2) + V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)- + &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)- + &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+ + &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)- + &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)- + &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)- + &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+ + &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+ + &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+ + &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)- + &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+ + &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+ + &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+ + &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+ + &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)- + &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+ + &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2) + V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)- + &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)- + &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)- + &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+ + &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)- + &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)- + &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+ + &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)- + &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+ + &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ + &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ + &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ + &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2) + V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+ + &272*A1*A2*P2Q1*S/(3*P2Q2)- + &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+ + &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+ + &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+ + &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)- + &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+ + &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+ + &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)- + &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)- + &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)- + &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)- + &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+ + &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+ + &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+ + &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+ + &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1) + V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+ + &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)- + &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)- + &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+ + &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)- + &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)- + &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+ + &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2) +C + + A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+ + &512*A1*A2*MB*MT/3+ + &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+ + &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+ + &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+ + &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+ + &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+ + &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1- + &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+ + &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1- + &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)- + &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1- + &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+ + &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+ + &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+ + &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+ + &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2) + A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2- + &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+ + &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2- + &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)- + &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+ + &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)- + &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)- + &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+ + &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)- + &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+ + &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+ + &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2- + &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+ + &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+ + &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)- + &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+ + &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1 + A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1- + &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)- + &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+ + &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+ + &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+ + &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)- + &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)- + &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)- + &64*MB**3*MT/(3*P1Q2*P2Q1**2)- + &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+ + &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)- + &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+ + &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+ + &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)- + &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1- + &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1- + &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1) + A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+ + &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+ + &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1- + &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+ + &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+ + &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)- + &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+ + &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)- + &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+ + &64*MB*MT**3/(3*P1Q2**2*P2Q1)+ + &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)- + &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+ + &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)- + &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+ + &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)- + &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)- + &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1) + A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)- + &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)- + &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+ + &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)- + &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)- + &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+ + &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)- + &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)- + &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)- + &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+ + &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)- + &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)- + &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)- + &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+ + &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)- + &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+ + &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1) + A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+ + &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)- + &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+ + &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+ + &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)- + &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+ + &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)- + &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+ + &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)- + &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+ + &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+ + &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)- + &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+ + &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+ + &256*A12*MT**4*P2Q1/(3*P1Q2**2)+ + &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)- + &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2) + A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+ + &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+ + &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+ + &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+ + &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+ + &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)- + &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+ + &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)- + &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)- + &64*MB**3*MT/(3*P1Q1*P2Q2**2)- + &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+ + &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)- + &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)- + &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)- + &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)- + &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+ + &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2) + A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)- + &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+ + &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+ + &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+ + &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)- + &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)- + &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+ + &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)- + &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)- + &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)- + &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+ + &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2- + &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)- + &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+ + &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+ + &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)- + &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2) + A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)- + &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)- + &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)- + &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+ + &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)- + &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)- + &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+ + &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+ + &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)- + &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)- + &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+ + &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+ + &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)- + &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)- + &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)- + &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)- + &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2) + A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+ + &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)- + &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+ + &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)- + &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+ + &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)- + &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+ + &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)- + &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+ + &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)- + &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)- + &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)- + &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)- + &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)- + &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+ + &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2) + A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)- + &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+ + &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+ + &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+ + &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+ + &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)- + &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+ + &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+ + &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)- + &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)- + &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+ + &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+ + &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+ + &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)- + &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)- + &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2) + A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)- + &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)- + &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+ + &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+ + &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)- + &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+ + &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+ + &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+ + &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+ + &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+ + &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+ + &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)- + &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)- + &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)- + &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)- + &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2) + A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+ + &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+ + &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)- + &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+ + &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)- + &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+ + &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+ + &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)- + &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+ + &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)- + &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)- + &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)- + &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)- + &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)- + &272*A1*P2Q1**2/(3*P1Q1*P2Q2)- + &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+ + &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2) + A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+ + &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+ + &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+ + &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+ + &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+ + &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+ + &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)- + &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+ + &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+ + &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+ + &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+ + &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+ + &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)- + &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+ + &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+ + &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+ + &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2) + A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)- + &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)- + &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+ + &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+ + &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+ + &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)- + &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+ + &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)- + &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+ + &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+ + &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)- + &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+ + &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+ + &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+ + &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+ + &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+ + &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1) + A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)- + &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)- + &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)- + &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+ + &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)- + &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+ + &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)- + &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)- + &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)- + &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)- + &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+ + &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)- + &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)- + &272*A1*P2Q2**2/(3*P1Q2*P2Q1)- + &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+ + &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+ + &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1) + A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)- + &384*A12*MB*MT*P1Q1**2/S**2+ + &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+ + &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+ + &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+ + &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+ + &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2- + &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+ + &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+ + &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2- + &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+ + &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+ + &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+ + &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2- + &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+ + &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+ + &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2 + A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2- + &384*A2**2*MB*MT*P2Q2**2/S**2+ + &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2- + &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+ + &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S- + &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S- + &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+ + &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)- + &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S- + &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+ + &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S- + &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+ + &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)- + &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+ + &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)- + &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)- + &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S) + A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)- + &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+ + &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+ + &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S- + &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+ + &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S- + &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+ + &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)- + &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)- + &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+ + &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S- + &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)- + &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+ + &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+ + &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+ + &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+ + &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S) + A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)- + &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+ + &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+ + &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)- + &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+ + &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)- + &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+ + &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+ + &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+ + &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)- + &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+ + &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+ + &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)- + &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)- + &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+ + &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+ + &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S + A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S- + &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+ + &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+ + &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)- + &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+ + &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+ + &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)- + &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+ + &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)- + &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)- + &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)- + &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)- + &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S- + &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+ + &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+ + &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)- + &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S) + A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)- + &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)- + &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S- + &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+ + &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+ + &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+ + &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+ + &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)- + &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)- + &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+ + &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)- + &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+ + &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)- + &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+ + &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)- + &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+ + &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S) + A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+ + &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)- + &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+ + &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)- + &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)- + &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)- + &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+ + &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+ + &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+ + &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)- + &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)- + &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+ + &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+ + &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)- + &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+ + &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)- + &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S) + A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)- + &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+ + &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)- + &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)- + &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)- + &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)- + &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)- + &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)- + &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+ + &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)- + &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+ + &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+ + &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)- + &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)- + &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+ + &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+ + &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S) + A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)- + &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)- + &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)- + &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+ + &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+ + &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+ + &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+ + &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+ + &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+ + &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)- + &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S- + &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S- + &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+ + &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+ + &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+ + &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+ + &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S) + A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+ + &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)- + &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)- + &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S- + &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)- + &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)- + &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)- + &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)- + &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)- + &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)- + &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)- + &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+ + &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)- + &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+ + &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)- + &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+ + &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S) + A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+ + &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)- + &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)- + &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)- + &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)- + &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+ + &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+ + &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)- + &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+ + &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+ + &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+ + &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S) + A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)- + &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+ + &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+ + &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)- + &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)- + &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)- + &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+ + &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+ + &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+ + &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+ + &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)- + &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3- + &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)- + &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)- + &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)- + &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)- + &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2) + A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)- + &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)- + &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+ + &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)- + &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+ + &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+ + &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+ + &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2) + + A18BIS= + &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)- + &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)- + &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)- + &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+ + &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)- + &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+ + &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+ + &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+ + &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)- + &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)- + &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)- + &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+ + &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+ + &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)- + &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)- + &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1) + A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)- + &12*S/(P1Q2*P2Q1)+ + &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+ + &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+ + &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+ + &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+ + &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)- + &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)- + &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)- + &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)- + &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)- + &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+ + &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)- + &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+ + &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)- + &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)- + &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2) + A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+ + &32*MB**2*S/(3*P1Q1*P2Q2**2)+ + &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)- + &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)- + &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+ + &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)- + &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)- + &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+ + &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+ + &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+ + &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)- + &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+ + &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+ + &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+ + &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+ + &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+ + &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2) + A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)- + &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)- + &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)- + &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+ + &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)- + &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)- + &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)- + &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+ + &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+ + &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)- + &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)- + &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+ + &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+ + &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+ + &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)- + &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)- + &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2) + A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+ + &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+ + &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+ + &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+ + &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)- + &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ + &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ + &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)- + &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+ + &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+ + &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)- + &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)- + &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+ + &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2) + A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)- + &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+ + &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+ + &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)- + &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)- + &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)- + &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)- + &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)- + &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+ + &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+ + &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+ + &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+ + &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)- + &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)- + &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)- + &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)- + &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2) + A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)- + &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+ + &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2) +C + V18=V18+V18BIS + A18=A18+A18BIS + V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2- + &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2- + &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+ + &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2- + &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+ + &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2- + &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2- + &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+ + &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2- + &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2- + &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2- + &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+ + &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+ + &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+ + &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S- + &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+ + &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S + V910=V910+96*A1*A2*P1P2*P2Q1/S- + &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+ + &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+ + &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+ + &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+ + &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S +C + A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+ + &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+ + &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+ + &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2- + &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+ + &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+ + &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2- + &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+ + &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+ + &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2- + &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2- + &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+ + &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2- + &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+ + &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+ + &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S- + &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S + A910=A910+96*A1*A2*P1P2*P2Q1/S- + &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+ + &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S- + &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+ + &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+ + &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S +C +C FINAL RESULT; +C + AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) ) + + END +C--------------------------------------------------------- +C 2) Q QBAR ->TBH^+ + SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2) +C +C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+ +C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE) + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + DOUBLE PRECISION MW2,MT,MB,MHP,MW + DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/ +C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION +C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES: +C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA +C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES +C +C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH +C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..). +C + DIMENSION YY(2,2) + + PI = 4*DATAN(1.D0) + MW = DSQRT(MW2) + +C COLLECTING THE RELEVANT OVERALL FACTORS: +C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE + PS=1.D0/(3.D0*3.D0 *2.D0*2.D0) +C COUPLING CONSTANT (OVERALL NORMALIZATION) + FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0 +C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI: +C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI +C ALPHAS IS ALPHA_STRONG; +C SW2 IS SIN(THETA_W)**2. +C +C VTB=.998D0 +C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE) +C + V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0 + A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0 +C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS +C +C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION +C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS) + DO 100 KK=1,4 + P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK) + 100 CONTINUE +C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS: + S = 2*PYTBHS(Q1,Q2) + P1Q1=PYTBHS(Q1,P1) + P1Q2=PYTBHS(P1,Q2) + P2Q1=PYTBHS(P2,Q1) + P2Q2=PYTBHS(P2,Q2) + P1P2=PYTBHS(P1,P2) +C +C TOP WIDTH CALCULATION + CALL PYTBHB(MT,MB,MHP,BR,GAMT) +C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+ +C THEN DEFINE TOP (RESONANT) PROPAGATOR: + A1INV= S -2*P1Q1 -2*P1Q2 + A1 =A1INV/(A1INV**2+ (GAMT*MT)**2) +C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE) +C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT + A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2) + A2 =1.D0/(S +2*P2Q1 +2*P2Q2) +C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH +C NOW COMES THE AMP**2: +C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN +C THE EXPRESSIONS BELOW + YY(1, 1) = -16*A**2*A2**2*MB*MT+ + &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+ + &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2- + &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2- + &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2- + &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+ + &64*A**2*A2**2*P1Q1*P2Q2**2/S**2- + &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+ + &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S- + &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S- + &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+ + &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2- + &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2- + &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2- + &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2- + &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+ + &64*A2**2*P1Q1*P2Q2**2*V**2/S**2 + YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+ + &32*A2**2*MB**2*P1P2*V**2/S+ + &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S- + &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S- + &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S + YY(1, 1)=2*YY(1, 1) + + YY(1, 2) = -32*A**2*A1*A2*MB*MT+ + &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2- + &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+ + &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2- + &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+ + &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+ + &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2- + &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2- + &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+ + &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2- + &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2- + &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+ + &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2- + &64*A**2*A1*A2*MB*MT*P1P2/S+ + &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+ + &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+ + &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S + YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S- + &64*A**2*A1*A2*P1Q1*P2Q1/S- + &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S- + &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2- + &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 - + &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+ + &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2- + &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+ + &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2- + &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2- + &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2- + &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+ + &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2- + &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2- + &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+ + &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+ + &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S + YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+ + &32*A1*A2*P1P2*P1Q1*V**2/S+ + &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S- + &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S- + &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S- + &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S + + + YY(2, 2) =-16*A**2*A12*MB*MT+ + &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2- + &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+ + &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2- + &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+ + &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+ + &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+ + &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S- + &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S- + &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2- + &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2- + &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+ + &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2- + &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+ + &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+ + &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+ + &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S + YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S- + &32*A12*MT**2*P2Q2*V**2/S- + &32*A12*P1Q2*P2Q2*V**2/S + YY(2, 2)=2*YY(2, 2) + + RES=YY(1,1)+2*YY(1,2)+YY(2,2) + AMP2= FACT*PS*VTB**2*RES + + END +C===================================================================== +C ************* FUNCTION SCALAR PRODUCTS ************************* + DOUBLE PRECISION FUNCTION PYTBHS(A,B) + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + DIMENSION A(4),B(4) + DUM=A(4)*B(4) + DO 100 ID=1,3 + DUM=DUM-A(ID)*B(ID) + 100 CONTINUE + PYTBHS=DUM + RETURN + END + +C********************************************************************* + +C...PYMSIN +C...Initializes supersymmetry: finds sparticle masses and +C...branching ratios and stores this information. +C...AUTHOR: STEPHEN MRENNA +C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM) + + SUBROUTINE PYMSIN + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYDAT4/CHAF(500,2) + CHARACTER CHAF*16 + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYHTRI/HHH(7) + COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/, + &/PYMSSM/,/PYMSRV/,/PYSSMT/ + +C...Local variables. + DOUBLE PRECISION ALFA,BETA + DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW + INTEGER I,J,J1,I1,K1 + INTEGER KC,LKNT,IDLAM(400,3) + DOUBLE PRECISION XLAM(0:400) + DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5) + DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2 + DOUBLE PRECISION DELM,XMDIF + DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2 + DOUBLE PRECISION ARG,SGNMU,R + INTEGER IMSSM + INTEGER IRPRTY + INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36) + SAVE MWIDSU,MDCYSU + DATA KFSUSY/ + &1000001,2000001,1000002,2000002,1000003,2000003, + &1000004,2000004,1000005,2000005,1000006,2000006, + &1000011,2000011,1000012,2000012,1000013,2000013, + &1000014,2000014,1000015,2000015,1000016,2000016, + &1000021,1000022,1000023,1000025,1000035,1000024, + &1000037,1000039, 25, 35, 36, 37, + & 6, 24, 45, 46,1000045, 9*0/ + DATA INIT/0/ + +C...Automatically read QNUMBERS, MASS, and DECAY tables + IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN + NQNUM=0 + CALL PYSLHA(0,0,IFAIL) + CALL PYSLHA(5,0,IFAIL) + ENDIF + IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL) + +C...Do nothing further if SUSY not requested + IMSSM=IMSS(1) + IF(IMSSM.EQ.0) RETURN + +C...Save copy of MWID(KC) and MDCY(KC,1) values before +C...they are set to zero for the LSP. + IF(INIT.EQ.0) THEN + INIT=1 + DO 100 I=1,36 + KF=KFSUSY(I) + KC=PYCOMP(KF) + MWIDSU(I)=MWID(KC) + MDCYSU(I)=MDCY(KC,1) + 100 CONTINUE + ENDIF + +C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP. + DO 110 I=1,36 + KF=KFSUSY(I) + KC=PYCOMP(KF) + IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN + MWID(KC)=MWIDSU(I) + MDCY(KC,1)=MDCYSU(I) + ENDIF + 110 CONTINUE + +C...First part of routine: set masses and couplings. + +C...Reset mixing values in sfermion sector to pure left/right. + DO 120 I=1,16 + SFMIX(I,1)=1D0 + SFMIX(I,4)=1D0 + SFMIX(I,2)=0D0 + SFMIX(I,3)=0D0 + 120 CONTINUE + +C...Add NMSSM states if NMSSM switched on, and change old names. + IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN +C... Switch on NMSSM + WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM' + + KFN=25 + KCN=KFN + CHAF(KCN,1)='h_10' + CHAF(KCN,2)=' ' + + KFN=35 + KCN=KFN + CHAF(KCN,1)='h_20' + CHAF(KCN,2)=' ' + + KFN=45 + KCN=KFN + CHAF(KCN,1)='h_30' + CHAF(KCN,2)=' ' + + KFN=36 + KCN=KFN + CHAF(KCN,1)='A_10' + CHAF(KCN,2)=' ' + + KFN=46 + KCN=KFN + CHAF(KCN,1)='A_20' + CHAF(KCN,2)=' ' + + KFN=1000045 + KCN=PYCOMP(KFN) + IF (KCN.EQ.0) THEN + DO 123 KCT=100,MSTU(6) + IF(KCHG(KCT,4).GT.100) KCN=KCT + 123 CONTINUE + KCN=KCN+1 + KCHG(KCN,4)=KFN + MSTU(20)=0 + ENDIF +C... Set stable for now + PMAS(KCN,2)=1D-6 + MWID(KCN)=0 + MDCY(KCN,1)=0 + MDCY(KCN,2)=0 + MDCY(KCN,3)=0 + CHAF(KCN,1)='~chi_50' + CHAF(KCN,2)=' ' + ENDIF + +C...Read spectrum from SLHA file. + IF (IMSSM.EQ.11) THEN + CALL PYSLHA(1,0,IFAIL) + ENDIF + +C...Common couplings. + TANB=RMSS(5) + BETA=ATAN(TANB) + COSB=COS(BETA) + SINB=TANB*COSB + COS2B=COS(2D0*BETA) + ALFA=RMSS(18) + XMW2=PMAS(24,1)**2 + XMZ2=PMAS(23,1)**2 + XW=PARU(102) + +C...Define sparticle masses for a general MSSM simulation. + IF(IMSSM.EQ.1) THEN + IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9) + DO 130 I=1,5,2 + KC=PYCOMP(KSUSY1+I) + PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0) + KC=PYCOMP(KSUSY2+I) + PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0) + KC=PYCOMP(KSUSY1+I+1) + PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0) + KC=PYCOMP(KSUSY2+I+1) + PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0) + 130 CONTINUE + XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA)) + IF(XARG.LT.0D0) THEN + WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'// + & ' FROM THE SUM RULE. ' + WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). ' + RETURN + ELSE + XARG=SQRT(XARG) + ENDIF + DO 140 I=11,15,2 + PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6) + PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7) + PMAS(PYCOMP(KSUSY1+I+1),1)=XARG + PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0 + 140 CONTINUE + IF(IMSS(8).EQ.1) THEN + RMSS(13)=RMSS(6) + RMSS(14)=RMSS(7) + ENDIF + +C...Alternatively derive masses from SUGRA relations. + ELSEIF(IMSSM.EQ.2) THEN + RMSS(36)=RMSS(16) + CALL PYAPPS +C...Or use ISASUSY + ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN + RMSS(36)=RMSS(16) + CALL PYSUGI + ALFA=RMSS(18) + GOTO 170 + ELSE + GOTO 170 + ENDIF + +C...Add in extra D-term contributions. + IF(IMSS(7).EQ.1) THEN + R=0.43D0 + DX=RMSS(23) + DY=RMSS(24) + DS=RMSS(25) + WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' + WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES ' + WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY ' + WRITE(MSTU(11),*) 'C DX = ',DX + WRITE(MSTU(11),*) 'C DY = ',DY + WRITE(MSTU(11),*) 'C DS = ',DS + WRITE(MSTU(11),*) 'C ' + DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS + WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY + WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' + DQ2=DY/6D0-DX/3D0-DS/3D0 + DU2=-2D0*DY/3D0-DX/3D0-DS/3D0 + DD2=DY/3D0+DX-2D0*DS/3D0 + DL2=-DY/2D0+DX-2D0*DS/3D0 + DE2=DY-DX/3D0-DS/3D0 + DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0 + DHD2=-DY/2D0-2D0*DX/3D0+DS + DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS) + & /ABS(COS2B) + DMA2 = 2D0*DMU2+DHU2+DHD2 + DO 150 I=1,5,2 + KC=PYCOMP(KSUSY1+I) + PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2) + KC=PYCOMP(KSUSY2+I) + PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2) + KC=PYCOMP(KSUSY1+I+1) + PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2) + KC=PYCOMP(KSUSY2+I+1) + PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2) + 150 CONTINUE + DO 160 I=11,15,2 + KC=PYCOMP(KSUSY1+I) + PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2) + KC=PYCOMP(KSUSY2+I) + PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2) + KC=PYCOMP(KSUSY1+I+1) + PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2) + 160 CONTINUE + IF(RMSS(4)**2+DMU2.LT.0D0) THEN + WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE ' + CALL PYSTOP(104) + ENDIF + SGNMU=SIGN(1D0,RMSS(4)) + RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2) + ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2 + RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG) + ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2 + RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG) + ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2 + RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG) + ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2 + RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG) + ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2 + RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG) + IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN + WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW ' + CALL PYSTOP(104) + ENDIF + RMSS(19)=SQRT(RMSS(19)**2+DMA2) + RMSS(6)=SQRT(RMSS(6)**2+DL2) + RMSS(7)=SQRT(RMSS(7)**2+DE2) + WRITE(MSTU(11),*) ' MTL = ',RMSS(10) + WRITE(MSTU(11),*) ' MBR = ',RMSS(11) + WRITE(MSTU(11),*) ' MTR = ',RMSS(12) + WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13) + WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14) + ENDIF + +C...Fix the third generation sfermions. + CALL PYTHRG + +C...Fix the neutralino--chargino--gluino sector. + CALL PYINOM + +C...Fix the Higgs sector. + CALL PYHGGM(ALFA) + +C...Choose the Gunion-Haber convention. + ALFA=-ALFA + RMSS(18)=ALFA + +C...Print information on mass parameters. + IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN + WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' + WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS ' + WRITE(MSTU(11),*) ' M0 = ',RMSS(8) + WRITE(MSTU(11),*) ' M1/2=',RMSS(1) + WRITE(MSTU(11),*) ' TANB=',RMSS(5) + WRITE(MSTU(11),*) ' MU = ',RMSS(4) + WRITE(MSTU(11),*) ' AT = ',RMSS(16) + WRITE(MSTU(11),*) ' MA = ',RMSS(19) + WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1) + WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' + ENDIF + IF(IMSS(20).EQ.1) THEN + WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' + WRITE(MSTU(11),*) ' DEBUG MODE ' + WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2), + & UMIX(2,1),UMIX(2,2) + WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2), + & UMIXI(2,1),UMIXI(2,2) + WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2), + & VMIX(2,1),VMIX(2,2) + WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2), + & VMIXI(2,1),VMIXI(2,2) + WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4) + WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4) + WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4) + WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4) + WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4) + WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4) + WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4) + WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4) + WRITE(MSTU(11),*) ' ALFA = ',ALFA + WRITE(MSTU(11),*) ' BETA = ',BETA + WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4) + WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4) + WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' + ENDIF + +C...Set up the Higgs couplings - needed here since initialization +C...in PYINRE did not yet occur when PYWIDT is called below. + 170 AL=ALFA + BE=BETA + SINA=SIN(AL) + COSA=COS(AL) + COSB=COS(BE) + SINB=TANB*COSB + SBMA=SIN(BE-AL) + SAPB=SIN(AL+BE) + CAPB=COS(AL+BE) + CBMA=COS(BE-AL) + C2A=COS(2D0*AL) + C2B=COSB**2-SINB**2 +C...tanb (used for H+) + PARU(141)=TANB + +C...Firstly: h +C...Coupling to d-type quarks + PARU(161)=SINA/COSB +C...Coupling to u-type quarks + PARU(162)=-COSA/SINB +C...Coupling to leptons + PARU(163)=PARU(161) +C...Coupling to Z + PARU(164)=SBMA +C...Coupling to W + PARU(165)=PARU(164) + +C...Secondly: H +C...Coupling to d-type quarks + PARU(171)=-COSA/COSB +C...Coupling to u-type quarks + PARU(172)=-SINA/SINB +C...Coupling to leptons + PARU(173)=PARU(171) +C...Coupling to Z + PARU(174)=CBMA +C...Coupling to W + PARU(175)=PARU(174) +C...Coupling to h + IF(IMSS(4).GE.2) THEN + PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL) + ELSE + HHH(3)=HHH(3)+HHH(4)+HHH(5) + PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+ + 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB- + 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+ + 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB)) + ENDIF +C...Coupling to H+ +C...Define later + IF(IMSS(4).GE.2) THEN + PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW) + ELSE + PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA- + 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+ + 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)- + 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA) + ENDIF +C...Coupling to A + IF(IMSS(4).GE.2) THEN + PARU(177)=COS(2D0*BE)*COS(BE+AL) + ELSE + PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+ + 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)- + 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+ + 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B)) + ENDIF +C...Coupling to H+ + IF(IMSS(4).GE.2) THEN + PARU(178)=PARU(177) + ELSE + PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA + ENDIF +C...Thirdly, A +C...Coupling to d-type quarks + PARU(181)=TANB +C...Coupling to u-type quarks + PARU(182)=1D0/PARU(181) +C...Coupling to leptons + PARU(183)=PARU(181) + PARU(184)=0D0 + PARU(185)=0D0 +C...Coupling to Z h + PARU(186)=COS(BE-AL) +C...Coupling to Z H + PARU(187)=SIN(BE-AL) + PARU(188)=0D0 + PARU(189)=0D0 + PARU(190)=0D0 + +C...Finally: H+ +C...Coupling to W h + PARU(195)=COS(BE-AL) + +C...Tell that all Higgs couplings have been set. + MSTP(4)=1 + +C...Set R-Violating couplings. +C...Set lambda couplings to common value or "natural values". + IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN + VIR3=1D0/(126D0)**3 + DO 200 IRK=1,3 + DO 190 IRI=1,3 + DO 180 IRJ=1,3 + IF (IRI.NE.IRJ) THEN + IF (IRI.LT.IRJ) THEN + RVLAM(IRI,IRJ,IRK)=RMSS(51) + IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)* + & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)* + & PMAS(9+2*IRK,1)*VIR3) + ELSE + RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK) + ENDIF + ELSE + RVLAM(IRI,IRJ,IRK)=0D0 + ENDIF + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + ENDIF +C...Set lambda' couplings to common value or "natural values". + IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN + VIR3=1D0/(126D0)**3 + DO 230 IRI=1,3 + DO 220 IRJ=1,3 + DO 210 IRK=1,3 + RVLAMP(IRI,IRJ,IRK)=RMSS(52) + IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)* + & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+ + & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3) + 210 CONTINUE + 220 CONTINUE + 230 CONTINUE + ENDIF +C...Set lambda'' couplings to common value or "natural values". + IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN + VIR3=1D0/(126D0)**3 + DO 260 IRI=1,3 + DO 250 IRJ=1,3 + DO 240 IRK=1,3 + IF (IRJ.NE.IRK) THEN + IF (IRJ.LT.IRK) THEN + RVLAMB(IRI,IRJ,IRK)=RMSS(53) + IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)= + & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)* + & PMAS(2*IRK-1,1)*VIR3) + ELSE + RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ) + ENDIF + ELSE + RVLAMB(IRI,IRJ,IRK) = 0D0 + ENDIF + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + ENDIF + +C...Antisymmetrize couplings set by user + IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN + DO 290 IRI=1,3 + DO 280 IRJ=1,3 + DO 270 IRK=1,3 + IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN + RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK) + IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0 + ENDIF + IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN + RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK) + IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0 + ENDIF + 270 CONTINUE + 280 CONTINUE + 290 CONTINUE + ENDIF + +C...Write spectrum to SLHA file + IF (IMSS(23).NE.0) THEN + IFAIL=0 + CALL PYSLHA(3,0,IFAIL) + ENDIF + +C...Second part of routine: set decay modes and branching ratios. + +C...Allow chi10 -> gravitino + gamma or not. + KC=PYCOMP(KSUSY1+39) + IF( IMSS(11) .NE. 0 ) THEN + PMAS(KC,1)=RMSS(21)/1D9 + PMAS(KC,2)=0D0 + IRPRTY=0 + WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS ' + ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN + IRPRTY=0 + IF (IMSS(51).GE.1) WRITE(MSTU(11),*) + & ' ALLOWING SUSY LLE DECAYS' + IF (IMSS(52).GE.1) WRITE(MSTU(11),*) + & ' ALLOWING SUSY LQD DECAYS' + IF (IMSS(53).GE.1) WRITE(MSTU(11),*) + & ' ALLOWING SUSY UDD DECAYS' + IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*) + & ' --- Warning: R-Violating couplings possibly', + & ' incompatible with proton decay' + ELSE + PMAS(KC,1)=9999D0 + IRPRTY=1 + ENDIF + +C...Loop over sparticle and Higgs species. + PMCHI1=PMAS(PYCOMP(KSUSY1+22),1) +C...Find the LSP or NLSP for a gravitino LSP + ILSP=0 + PMLSP=1D20 + DO 300 I=1,36 + KF=KFSUSY(I) + IF(KF.EQ.1000039) GOTO 300 + KC=PYCOMP(KF) + IF(PMAS(KC,1).LT.PMLSP) THEN + ILSP=I + PMLSP=PMAS(KC,1) + ENDIF + 300 CONTINUE + DO 370 I=1,50 + IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370 + KF=KFSUSY(I) + IF (KF.EQ.0) GOTO 370 + KC=PYCOMP(KF) + LKNT=0 + +C...Check if there are any decays listed for this sparticle +C...in a file + IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN + IFAIL=0 + CALL PYSLHA(2,KF,IFAIL) + IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370 + ELSEIF (I.GE.37) THEN + GOTO 370 + ENDIF + +C...Sfermion decays. + IF(I.LE.24) THEN +C...First check to see if sneutrino is lighter than chi10. + IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND. + & PMAS(KC,1).LT.PMCHI1) THEN + ELSE + CALL PYSFDC(KF,XLAM,IDLAM,LKNT) + ENDIF + +C...Gluino decays. + ELSEIF(I.EQ.25) THEN + CALL PYGLUI(KF,XLAM,IDLAM,LKNT) + IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0 + +C...Neutralino decays. + ELSEIF(I.GE.26.AND.I.LE.29) THEN + CALL PYNJDC(KF,XLAM,IDLAM,LKNT) +C...chi10 stable or chi10 -> gravitino + gamma. + IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN + PMAS(KC,2)=1D-6 + MDCY(KC,1)=0 + MWID(KC)=0 + ENDIF + +C...Chargino decays. + ELSEIF(I.GE.30.AND.I.LE.31) THEN + CALL PYCJDC(KF,XLAM,IDLAM,LKNT) + +C...Gravitino is stable. + ELSEIF(I.EQ.32) THEN + MDCY(KC,1)=0 + MWID(KC)=0 + +C...Higgs decays. + ELSEIF(I.GE.33.AND.I.LE.36) THEN +C...Calculate decays to non-SUSY particles. + CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE) + LKNT=0 + DO 310 I1=0,100 + XLAM(I1)=0D0 + 310 CONTINUE + DO 330 I1=1,MDCY(KC,3) + K1=MDCY(KC,2)+I1-1 + IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR. + & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330 + XLAM(I1)=WDTP(I1) + XLAM(0)=XLAM(0)+XLAM(I1) + DO 320 J1=1,3 + IDLAM(I1,J1)=KFDP(K1,J1) + 320 CONTINUE + LKNT=LKNT+1 + 330 CONTINUE +C...Add the decays to SUSY particles. + CALL PYHEXT(KF,XLAM,IDLAM,LKNT) + ENDIF +C...Zero the branching ratios for use in loop mode +C...thanks to K. Matchev (FNAL) + DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + BRAT(IDC)=0D0 + 340 CONTINUE + +C...Set stable particles. + IF(LKNT.EQ.0) THEN + MDCY(KC,1)=0 + MWID(KC)=0 + PMAS(KC,2)=1D-6 + PMAS(KC,3)=1D-5 + PMAS(KC,4)=0D0 + +C...Store branching ratios in the standard tables. + ELSE + IDC=MDCY(KC,2)+MDCY(KC,3)-1 + DELM=1D6 + DO 360 IL=1,LKNT + IDCSV=IDC + 350 IDC=IDC+1 + BRAT(IDC)=0D0 + IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2) + IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ. + & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN + BRAT(IDC)=XLAM(IL)/XLAM(0) + XMDIF=PMAS(KC,1) + IF(MDME(IDC,1).GE.1) THEN + XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)- + & PMAS(PYCOMP(KFDP(IDC,2)),1) + IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF- + & PMAS(PYCOMP(KFDP(IDC,3)),1) + ENDIF + IF(I.LE.32) THEN + IF(XMDIF.GE.0D0) THEN + DELM=MIN(DELM,XMDIF) + ELSE + WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF + WRITE(MSTU(11),*) ' KF = ',KF + WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3) + ENDIF + ENDIF + GOTO 360 + ELSEIF(IDC.EQ.IDCSV) THEN + WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ', + & 'channel not recognized:' + WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3) + GOTO 360 + ELSE + GOTO 350 + ENDIF + 360 CONTINUE + +C...Store width, cutoff and lifetime. + PMAS(KC,2)=XLAM(0) + IF(PMAS(KC,2).LT.0.1D0*DELM) THEN + PMAS(KC,3)=PMAS(KC,2)*10D0 + ELSE + PMAS(KC,3)=0.95D0*DELM + ENDIF + IF(PMAS(KC,2).NE.0D0) THEN + PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12 + ENDIF +C...Write decays to SLHA file + IF (IMSS(24).NE.0) THEN + IFAIL=0 + CALL PYSLHA(4,KF,IFAIL) + ENDIF + + ENDIF + 370 CONTINUE + + RETURN + END +C********************************************************************* + +C...PYSLHA +C...Read/write spectrum or decay data from SLHA standard file(s). +C...P. Skands +C...DECAY TABLE writeout by Nils-Erik Bomark (2010) + +C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21) +C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21) +C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22) +C... (KFORIG=0 : read all decay tables) +C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23) +C...MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24) +C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY +C... (KFORIG=0 : read all MASS entries) + + SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYDAT4/CHAF(500,2) + CHARACTER CHAF*16 + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + CHARACTER*40 ISAVER,VISAJE + COMMON/PYINT4/MWID(500),WIDS(500,5) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/ +C...SUSY blocks + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) + SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/ + +C...Local arrays, character variables and data. + COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100), + & AU(3,3),AD(3,3),AE(3,3) + COMMON/PYLH3C/CPRO(2),CVER(2) +C...The common block of new states (QNUMBERS / PARTICLE) + COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9) +C...- NQNUM : Number of QNUMBERS blocks that have been read in +C...- KQNUM(I,0) : KF of new state +C...- KQNUM(I,1) : 3 times electric charge +C...- KQNUM(I,2) : Number of spin states: (2S + 1) +C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet) +C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti) +C...- KQNUM(I,5:9) : space available for further quantum numbers + DIMENSION MMOD(100),MSPC(100),KFDEC(100) + SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC +C...MMOD: flags to set for each block read in. +C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS +C...MSPC: Flags to set for each block read in. +C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX +C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU +C...11: AD 12: AE 13: YU 14: YD 15: YE +C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS + CHARACTER CPRO*12,CVER*12,CHNLIN*6 + CHARACTER DOC*11, CHDUM*120, CHBLCK*60 + CHARACTER CHINL*120,CHKF*9,CHTMP*16 + INTEGER VERBOS + SAVE VERBOS +C...Date of last Change + PARAMETER (DOC='10 Jun 2010') +C...Local arrays and initial values + DIMENSION IDC(5),KFSUSY(50) + SAVE KFSUSY + DATA NQNUM /0/ + DATA NDECAY /0/ + DATA VERBOS /1/ + DATA NHELLO /0/ + DATA MLHEF /0/ + DATA MLHEFD /0/ + DATA KFSUSY/ + &1000001,1000002,1000003,1000004,1000005,1000006, + &2000001,2000002,2000003,2000004,2000005,2000006, + &1000011,1000012,1000013,1000014,1000015,1000016, + &2000011,2000012,2000013,2000014,2000015,2000016, + &1000021,1000022,1000023,1000025,1000035,1000024, + &1000037,1000039, 25, 35, 36, 37, + & 6, 24, 45, 46,1000045, 9*0/ + DATA KFDEC/100*0/ + RMFUN(IP)=PMAS(PYCOMP(IP),1) + +C...Shorthand for spectrum and decay table unit numbers + IMSS21=IMSS(21) + IMSS22=IMSS(22) + +C...Default for LHEF input: read header information + IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161) + IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161) + IF (IMSS21.EQ.MSTP(161).AND.IMSS21.NE.0) MLHEF=1 + IF (IMSS22.EQ.MSTP(161).AND.IMSS22.NE.0) MLHEFD=1 + +C...Hello World + IF (NHELLO.EQ.0) THEN + IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN + WRITE(MSTU(11),5000) DOC + NHELLO=1 + ENDIF + ENDIF + +C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20 +C...+MUPDA). + LFN=IMSS21 + IF (MUPDA.EQ.2) LFN=IMSS22 + IF (MUPDA.EQ.3) LFN=IMSS(23) + IF (MUPDA.EQ.4) LFN=IMSS(24) +C...Flag that we have not yet found whatever we were asked to find. + IRETRN=1 +C...Flag that we are skipping until tag found (if LHEF) + ISKIP=0 + IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) ISKIP=1 + +C...STOP IF LFN IS ZERO (i.e. if no LFN was given). + IF (LFN.EQ.0) THEN + WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS' + GOTO 9999 + ENDIF + +C...If reading LHEF header, start by rewinding file + IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN) + +C...If told to read spectrum, first zero all previous information. + IF (MUPDA.EQ.1) THEN +C...Zero all block read flags + DO 100 M=1,100 + MMOD(M)=0 + MSPC(M)=0 + 100 CONTINUE +C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA + DO 110 ISUSY=1,36 + KC=PYCOMP(KFSUSY(ISUSY)) + PMAS(KC,1)=0D0 + 110 CONTINUE +C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices. + DO 130 J=1,4 + SFMIX(5,J) =0D0 + SFMIX(6,J) =0D0 + SFMIX(15,J)=0D0 + DO 120 L=1,4 + ZMIX(L,J) =0D0 + ZMIXI(L,J)=0D0 + IF (J.LE.2.AND.L.LE.2) THEN + UMIX(L,J) =0D0 + UMIXI(L,J)=0D0 + VMIX(L,J) =0D0 + VMIXI(L,J)=0D0 + ENDIF + 120 CONTINUE +C...Zero signed masses. + SMZ(J)=0D0 + IF (J.LE.2) SMW(J)=0D0 + 130 CONTINUE + +C...If reading decays, reset PYTHIA decay counters. + ELSEIF (MUPDA.EQ.2) THEN +C...Check if DECAY for this KF already read + IF (KFORIG.NE.0) THEN + DO 140 IDEC=1,NDECAY + IF (KFORIG.EQ.KFDEC(IDEC)) THEN + IRETRN=0 + RETURN + ENDIF + 140 CONTINUE + ENDIF + KCC=100 + NDC=0 + BRSUM=0D0 + DO 150 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) + 150 CONTINUE + ELSEIF (MUPDA.EQ.5) THEN +C...Zero block read flags + DO 160 M=1,100 + MSPC(M)=0 + 160 CONTINUE + ENDIF + +C............READ +C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG) + IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN +C...Initialize program and version strings + IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN + CPRO(MUPDA)=' ' + CVER(MUPDA)=' ' + ENDIF + +C...Initialize read loop + MERR=0 + NLINE=0 + CHBLCK=' ' +C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE. + 170 CHINL=' ' + READ(LFN,'(A120)',END=400) CHINL +C...Count which line number we're at. + NLINE=NLINE+1 + WRITE(CHNLIN,'(I6)') NLINE + +C...Skip comment and empty lines without processing. + IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170 + +C...We assume all upper case below. Rewrite CHINL to all upper case. + INL=0 + IGOOD=0 + 180 INL=INL+1 + IF (CHINL(INL:INL).NE.'#') THEN + DO 190 ICH=97,122 + IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32) + 190 CONTINUE +C...Extra safety. Chek for sensible input on line + IF (IGOOD.EQ.0) THEN + DO 200 ICH=48,90 + IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1 + 200 CONTINUE + ENDIF + IF (INL.LT.120) GOTO 180 + ENDIF + IF (IGOOD.EQ.0) GOTO 170 + +C...If reading from LHEF file, skip until begin tag found + IF (ISKIP.NE.0) THEN + DO 205 I1=1,10 + IF (CHINL(I1:I1+4).EQ.', , or first tag reached in LHEF file + DO 210 I1=1,10 + IF (CHINL(I1:I1+5).EQ.'h/H/A cross section'// + & ' is proportional to the h/H/A->gg width' + ELSEIF (KF.EQ.23.OR.KF.EQ.24.OR.KF.EQ.6.OR.KF.EQ.32 + & .OR.KF.EQ.33.OR.KF.EQ.34) THEN + WRITE(MSTU(11),'(1x,A,A16)') + & '* Warning: will use DECAY table (fixed-width,'// + & ' flat PS) for ',CHAF(KC,1)(1:16) + ENDIF + PMAS(KC,3)=0D0 + PMAS(KC,4)=PARU(3)*1D-12/WIDTH + MWID(KC)=2 + MDCY(KC,1)=1 + MDCY(KC,2)=NDC + MDCY(KC,3)=0 +C...Add to list of DECAY blocks currently read + NDECAY=NDECAY+1 + KFDEC(NDECAY)=KF +C...Return ok + IRETRN=0 + ENDIF +C... Count up number of decay modes for this particle + MDCY(KC,3)=MDCY(KC,3)+1 +C... Read in decay daughters. + READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA) +C... Flip sign if reading antiparticle decays (if antipartner exists) + DO 340 IDA=1,NDA + IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0) + & IDC(IDA)=MPSIGN*IDC(IDA) + 340 CONTINUE +C...Switch on decay channel, with products ordered in decreasing ABS(KF) + MDME(NDC,1)=1 + IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0 + BRSUM=BRSUM+ABS(BRAT(NDC)) + BRAT(NDC)=ABS(BRAT(NDC)) + 350 IFLIP=0 + DO 360 IDA=1,NDA-1 + IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN + ITMP=IDC(IDA) + IDC(IDA)=IDC(IDA+1) + IDC(IDA+1)=ITMP + IFLIP=IFLIP+1 + ENDIF + 360 CONTINUE + IF (IFLIP.GT.0) GOTO 350 +C...Treat as ordinary decay, no fancy stuff. + MDME(NDC,2)=0 + DO 370 IDA=1,5 + IF (IDA.LE.NDA) THEN + KFDP(NDC,IDA)=IDC(IDA) + ELSE + KFDP(NDC,IDA)=0 + ENDIF + 370 CONTINUE +C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA, +C & (KFDP(NDC,J),J=1,NDA) + ELSE + CALL PYERRM(7,'(PYSLHA:) Too many daughters on line '// + & CHNLIN) + MERR=11 + NDC=NDC-1 + ENDIF + ELSEIF(CHINL(1:1).EQ.'+') THEN + MERR=11 + ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN + MERR=16 + ELSE + MERR=16 + ENDIF + ENDIF +C... Error check. + 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN + WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': ' + & //CHINL(1:40) + MERR=0 + ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN + WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '// + & CHBLCK(1:MIN(INL,40))//'... on line '//CHNLIN + ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN + WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK ' + & //CHBLCK(1:INL)//'... on line'//CHNLIN + ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND. + & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN + WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL) + & //'... on line'//CHNLIN + ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN + WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/ + & /CHBLCK(1:INL)//'... on line'//CHNLIN + ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN + WRITE (CHTMP,*) KF + WRITE(MSTU(11),*) + & '* (PYSLHA:) Ignoring extra MASS entry for KF='// + & CHTMP(1:9)//' on line'//CHNLIN + ENDIF +C...Iterate read loop + GOTO 170 +C...Error catching + 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE, + & ', ignoring subsequent lines.' + WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46) + CHBLCK=' ' + GOTO 170 +C...End of read loop + 400 CONTINUE +C...Set flag that KC codes have been rearranged. + MSTU(20)=0 + VERBOS=0 + +C...Perform possible tests that new information is consistent. + IF (MUPDA.EQ.1) THEN + MSTU23=MSTU(23) + MSTU27=MSTU(27) +C...Check masses + DO 410 ISUSY=1,37 + KF=KFSUSY(ISUSY) +C...Don't complain about right-handed neutrinos + IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2 + & +16) GOTO 410 +C...Only check gravitino in GMSB scenarios + IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410 + KC=PYCOMP(KF) + IF (PMAS(KC,1).EQ.0D0) THEN + WRITE(CHTMP,*) KF + CALL PYERRM(9 + & ,'(PYSLHA:) No mass information found for KF =' + & //CHTMP) + ENDIF + 410 CONTINUE +C...Check mixing matrices (MSSM only) + IF (IMSS(13).EQ.0) THEN + IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9 + & ,'(PYSLHA:) Inconsistent # of elements in NMIX') + IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9 + & ,'(PYSLHA:) Inconsistent # of elements in UMIX') + IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9 + & ,'(PYSLHA:) Inconsistent # of elements in VMIX') + IF (MSPC(5).NE.4) CALL PYERRM(9 + & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX') + IF (MSPC(6).NE.4) CALL PYERRM(9 + & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX') + IF (MSPC(7).NE.4) CALL PYERRM(9 + & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX') + IF (MSPC(8).LT.1) CALL PYERRM(9 + & ,'(PYSLHA:) Too few elements in HMIX') + IF (MSPC(10).EQ.0) CALL PYERRM(9 + & ,'(PYSLHA:) Missing A_b trilinear coupling') + IF (MSPC(11).EQ.0) CALL PYERRM(9 + & ,'(PYSLHA:) Missing A_t trilinear coupling') + IF (MSPC(12).EQ.0) CALL PYERRM(9 + & ,'(PYSLHA:) Missing A_tau trilinear coupling') + IF (MSPC(17).LT.1) CALL PYERRM(9 + & ,'(PYSLHA:) Missing Higgs mixing angle alpha') + ENDIF +C...Check wavefunction normalizations. +C...Sfermions + DO 420 ISPC=5,7 + IF (MSPC(ISPC).EQ.4) THEN + KFSM=ISPC + IF (ISPC.EQ.7) KFSM=15 + CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2) + & *SFMIX(KFSM,3)) + IF (ABS(1D0-CHECK).GT.1D-3) THEN + KCSM=PYCOMP(KFSM) + CALL PYERRM(17 + & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~' + & //CHAF(KCSM,1)) + ENDIF +C...Bug fix 30/09 2008: PS +C...Translate to Pythia's internal convention: (1,1) same sign as (2,2) + IF (SFMIX(KFSM,1)*SFMIX(KFSM,4).LT.0D0) THEN + SFMIX(KFSM,3) = -SFMIX(KFSM,3) + SFMIX(KFSM,4) = -SFMIX(KFSM,4) + ENDIF + ENDIF + 420 CONTINUE +C...Neutralinos + charginos + DO 440 J=1,4 + CN1=0D0 + CN2=0D0 + CU1=0D0 + CU2=0D0 + CV1=0D0 + CV2=0D0 + DO 430 L=1,4 + CN1=CN1+ZMIX(J,L)**2 + CN2=CN2+ZMIX(L,J)**2 + IF (J.LE.2.AND.L.LE.2) THEN + CU1=CU1+UMIX(J,L)**2 + CU2=CU2+UMIX(L,J)**2 + CV1=CV1+VMIX(J,L)**2 + CV2=CV2+VMIX(L,J)**2 + ENDIF + 430 CONTINUE +C...NMIX normalization + IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2) + & .GT.1D-3).AND.IMSS(13).EQ.0) THEN + CALL PYERRM(19, + & '(PYSLHA:) NMIX: Inconsistent normalization.') + WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2 + ENDIF +C...UMIX, VMIX normalizations + IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN + IF (J.LE.2) THEN + IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN + CALL PYERRM(19 + & ,'(PYSLHA:) UMIX: Inconsistent normalization.') + WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1, + & CU2 + ENDIF + IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN + CALL PYERRM(19, + & '(PYSLHA:) VMIX: Inconsistent normalization.') + WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1, + & CV2 + ENDIF + ENDIF + ENDIF + 440 CONTINUE + IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN + WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")') + & '* (PYSLHA:) No spectrum inconsistencies were found.' + ELSE + WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)') + & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.' + & ,' Warning: one or more (serious)'// + & ' inconsistencies were found in the spectrum !' + & ,' Read the error messages above and check your'// + & ' input file.' + ENDIF +C...Increase precision in Higgs sector using FeynHiggs + IF (IMSS(4).EQ.3) THEN +C...FeynHiggs needs MSOFT. + IERR=0 + IF (MSPC(18).EQ.0) THEN + WRITE(MSTU(11),'(1x,"*"/1x,A/)') + & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'// + & ' Cannot call FeynHiggs.' + IERR=-1 + ELSE + WRITE(MSTU(11),'(1x,/1x,A/)') + & '* (PYSLHA:) Now calling FeynHiggs.' + CALL PYFEYN(IERR) + IF (IERR.NE.0) IMSS(4)=2 + ENDIF + ENDIF + ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN + IBEG=1 + IF (KFORIG.NE.0) IBEG=NDECAY + DO 490 IDECAY=IBEG,NDECAY + KF = KFDEC(IDECAY) + KC = PYCOMP(KF) + WRITE(CHKF,8300) KF + IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3 + $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3) + $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17 + $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF=' + $ //CHKF) + BRSUM=0D0 + BROPN=0D0 + DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + IF(MDME(IDA,2).GT.80) GOTO 460 + KQ=KCHG(KC,1) + PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64) + MERR=0 + DO 450 J=1,5 + KP=KFDP(IDA,J) + IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN + IF(KP.EQ.81) KQ=0 + ELSEIF(PYCOMP(KP).EQ.0) THEN + MERR=3 + ELSE + KQ=KQ-PYCHGE(KP) + KPC=PYCOMP(KP) + PMS=PMS-PMAS(KPC,1) + IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2), + & PMAS(KPC,3)) + ENDIF + 450 CONTINUE + IF(KQ.NE.0) MERR=MAX(2,MERR) + IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0) + & MERR=MAX(1,MERR) + IF(MERR.EQ.3) CALL PYERRM(17, + & '(PYSLHA:) Unknown particle code in decay of KF =' + $ //CHKF) + IF(MERR.EQ.2) CALL PYERRM(17, + & '(PYSLHA:) Charge not conserved in decay of KF =' + $ //CHKF) + IF(MERR.EQ.1) CALL PYERRM(7, + & '(PYSLHA:) Kinematically unallowed decay of KF =' + $ //CHKF) + BRSUM=BRSUM+BRAT(IDA) + IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA) + 460 CONTINUE +C...Check branching ratio sum. + IF (BROPN.LE.0D0) THEN +C...If zero, set stable. + WRITE(CHTMP,8500) BROPN + CALL PYERRM(7 + & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '// + & CHTMP(9:16)//'. Changed to stable.') + PMAS(KC,2)=1D-6 + MWID(KC)=0 +C...If BR's > 1, rescale. + ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN + WRITE(CHTMP,8500) BRSUM + IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7 + & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF// + & ' ; sum was'//CHTMP(9:16)//'.') + FAC=1D0/BRSUM + DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + IF(MDME(IDA,2).GT.80) GOTO 470 + BRAT(IDA)=FAC*BRAT(IDA) + 470 CONTINUE + ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN +C...If BR's < 1, insert dummy mode for proper cross section rescaling. + WRITE(CHTMP,8500) BRSUM + IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7 + & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '// + & CHTMP(9:16)//'. Dummy mode will be inserted.') +C...Move table and insert dummy mode + DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + NDC=NDC+1 + BRAT(NDC)=BRAT(IDA) + KFDP(NDC,1)=KFDP(IDA,1) + KFDP(NDC,2)=KFDP(IDA,2) + KFDP(NDC,3)=KFDP(IDA,3) + KFDP(NDC,4)=KFDP(IDA,4) + KFDP(NDC,5)=KFDP(IDA,5) + MDME(NDC,1)=MDME(IDA,1) + 480 CONTINUE + NDC=NDC+1 + BRAT(NDC)=1D0-BRSUM + KFDP(NDC,1)=0 + KFDP(NDC,2)=0 + KFDP(NDC,3)=0 + KFDP(NDC,4)=0 + KFDP(NDC,5)=0 + MDME(NDC,1)=0 + BRSUM=1D0 +C...Update MDCY + MDCY(KC,3)=MDCY(KC,3)+1 + MDCY(KC,2)=NDC-MDCY(KC,3)+1 + ENDIF + 490 CONTINUE + ENDIF + + +C...WRITE SPECTRUM ON SLHA FILE + ELSEIF(MUPDA.EQ.3) THEN +C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN. + IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN + MODSEL(1)=1 + PARMIN(1)=RMSS(8) + PARMIN(2)=RMSS(1) + PARMIN(3)=RMSS(5) + PARMIN(4)=SIGN(1D0,RMSS(4)) + PARMIN(5)=RMSS(36) + ENDIF +C...Write spectrum + WRITE(LFN,7000) 'SLHA MSSM spectrum' + WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,' + & // ' P. Skands.' + WRITE(LFN,7010) 'MODSEL', 'Model selection' + WRITE(LFN,7110) 1, MODSEL(1) + WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.' + IF (MODSEL(1).EQ.1) THEN + WRITE(LFN,7210) 1, PARMIN(1), 'm0' + WRITE(LFN,7210) 2, PARMIN(2), 'm12' + WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)' + WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)' + WRITE(LFN,7210) 5, PARMIN(5), 'a0' + ELSEIF(MODSEL(2).EQ.2) THEN + WRITE(LFN,7210) 1, PARMIN(1), 'Lambda' + WRITE(LFN,7210) 2, PARMIN(2), 'M' + WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)' + WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)' + WRITE(LFN,7210) 5, PARMIN(5), 'N5' + WRITE(LFN,7210) 6, PARMIN(6), 'c_grav' + ENDIF + WRITE(LFN,7000) ' ' + WRITE(LFN,7010) 'MASS', 'Mass spectrum' + DO 500 I=1,36 + KF=KFSUSY(I) + KC=PYCOMP(KF) + IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500 + KFSM=KF-KSUSY1 + IF (KFSM.GE.22.AND.KFSM.LE.37) THEN + IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1) + IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1) + IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1) + IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1) + IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1) + IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1) + ELSE + WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1) + ENDIF + 500 CONTINUE +C...SUSY scale + RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1)) + WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters' + WRITE(LFN,7210) 1, RMSS(4),'mu' + WRITE(LFN,7010) 'ALPHA',' ' +C WRITE(LFN,7210) 1, RMSS(18), 'alpha' + WRITE(LFN,7200) RMSS(18), 'alpha' + WRITE(LFN,7020) 'AU',RMSUSY + WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t' + WRITE(LFN,7020) 'AD',RMSUSY + WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b' + WRITE(LFN,7020) 'AE',RMSUSY + WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau' + WRITE(LFN,7010) 'STOPMIX','~t mixing matrix' + WRITE(LFN,7410) 1, 1, SFMIX(6,1) + WRITE(LFN,7410) 1, 2, SFMIX(6,2) + WRITE(LFN,7410) 2, 1, SFMIX(6,3) + WRITE(LFN,7410) 2, 2, SFMIX(6,4) + WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix' + WRITE(LFN,7410) 1, 1, SFMIX(5,1) + WRITE(LFN,7410) 1, 2, SFMIX(5,2) + WRITE(LFN,7410) 2, 1, SFMIX(5,3) + WRITE(LFN,7410) 2, 2, SFMIX(5,4) + WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix' + WRITE(LFN,7410) 1, 1, SFMIX(15,1) + WRITE(LFN,7410) 1, 2, SFMIX(15,2) + WRITE(LFN,7410) 2, 1, SFMIX(15,3) + WRITE(LFN,7410) 2, 2, SFMIX(15,4) + WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix' + DO 520 I1=1,4 + DO 510 I2=1,4 + WRITE(LFN,7410) I1, I2, ZMIX(I1,I2) + 510 CONTINUE + 520 CONTINUE + WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix' + DO 540 I1=1,2 + DO 530 I2=1,2 + WRITE(LFN,7410) I1, I2, UMIX(I1,I2) + 530 CONTINUE + 540 CONTINUE + WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix' + DO 560 I1=1,2 + DO 550 I2=1,2 + WRITE(LFN,7410) I1, I2, VMIX(I1,I2) + 550 CONTINUE + 560 CONTINUE + WRITE(LFN,7010) 'SPINFO' + IF (IMSS(1).EQ.2) THEN + CPRO(1)='PYTHIA' + CVER(1)='6.4' + ELSEIF (IMSS(1).EQ.12) THEN + ISAVER=VISAJE() + CPRO(1)='ISASUSY' + CVER(1)=ISAVER(1:12) + ENDIF + WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator' + WRITE(LFN,7310) 2, CVER(1), 'Version number' + ENDIF + +C...Print user information about spectrum + IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN + IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ') + & WRITE(MSTU(11),5030) CPRO(1), CVER(1) + IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040) + IF (MUPDA.EQ.1) THEN + WRITE(MSTU(11),5020) LFN + ELSE + WRITE(MSTU(11),5010) LFN + ENDIF + + WRITE(MSTU(11),5400) + WRITE(MSTU(11),5500) 'Pole masses' + WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6) + $ ,(RMFUN(KSUSY2+IP),IP=1,6) + WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16) + $ ,(RMFUN(KSUSY2+IP),IP=11,16) + IF (IMSS(13).EQ.0) THEN + WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22) + $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35), + $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37) + WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1), + & CHAF(37,1), ' ', ' ',' ',' ', + & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37) + ELSEIF (IMSS(13).EQ.1) THEN + KF1=KSUSY1+21 + KF2=KSUSY1+22 + KF3=KSUSY1+23 + KF4=KSUSY1+25 + KF5=KSUSY1+35 + KF6=KSUSY1+45 + KF7=KSUSY1+24 + KF8=KSUSY1+37 + WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1), + & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1), + & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1), + & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1), + & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4), + & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8) + WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1), + & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ', + & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46), + & RMFUN(37) + ENDIF + WRITE(MSTU(11),5400) + WRITE(MSTU(11),5500) 'Mixing structure' + WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4) + WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2) + & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2) + WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2) + & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4 + & ),(SFMIX(15,J),J=3,4) + WRITE(MSTU(11),5400) + WRITE(MSTU(11),5500) 'Couplings' + WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17) + WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4) + WRITE(MSTU(11),5400) + WRITE(MSTU(11),6500) + +C...DECAY TABLES writeout +C...Write decay information by Nils-Erik Bomark 3/29/2010 + ELSEIF (MUPDA.EQ.4) THEN + KF = KFORIG + KC = PYCOMP(KF) + IF (KC.NE.0) THEN + WRITE(LFN,7000) '' + WRITE(LFN,7000) ' PDG Width' + WRITE(LFN,7500) KF,PMAS(KC,2), CHAF(KC,1) + WRITE(LFN,7000) + & ' BR NDA ID1 ID2 ID3' + DO 575 I=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + NDA = 0 + DO 570 J=1,5 + IF (KFDP(I,J).NE.0) NDA = NDA+1 + 570 CONTINUE + IF (NDA.EQ.2) + & WRITE(LFN,7512) BRAT(I),NDA,(KFDP(I,K),K=1,NDA), + & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)), + & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA) + IF (NDA.EQ.3) + & WRITE(LFN,7513) BRAT(I),NDA,(KFDP(I,K),K=1,NDA), + & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)), + & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA) + IF (NDA.EQ.4) + & WRITE(LFN,7514) BRAT(I),NDA,(KFDP(I,K),K=1,NDA), + & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)), + & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA) + IF (NDA.EQ.5) + & WRITE(LFN,7515) BRAT(I),NDA,(KFDP(I,K),K=1,NDA), + & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)), + & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA) + 575 CONTINUE + ENDIF +C....End of DECAY TABLES writeout + + ENDIF + +C...Only rewind when reading + IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN) + + 9999 RETURN + +C...Serious error catching + 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE + write(*,*) CHINL(1:80) + CALL PYSTOP(106) + 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE + WRITE(*,*) CHINL(1:72) + CALL PYSTOP(106) + 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE + WRITE(*,*) CHINL(1:80) + CALL PYSTOP(106) + 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE + WRITE(*,*) CHINL(1:80) + 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK + CALL PYSTOP(106) + 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':' + WRITE(*,*) CHINL(1:80) + CALL PYSTOP(106) + + 8300 FORMAT(I9) + 8500 FORMAT(F16.5) + +C...Formats for user information printout. + 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.14: SUSY/BSM SPECTRUM ' + & ,'INTERFACE',1x,17('*')/1x,'*',1x + & ,'(PYSLHA:) Last Change',1x,A,1x,'-',1x,'P.Z. Skands') + 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3) + 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3) + 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A) + 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs') + 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------') + 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)', + & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2) + 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x + & ,'----------------') + 5400 FORMAT(1x,'*',1x,A) + 5500 FORMAT(1x,'*',1x,A,':') + 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/ + & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2) + 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x, + & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x + & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x)) + 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x + & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x + & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x)) + 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20' + & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x + & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x)) + 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x)) + 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x + & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|' + & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|' + & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|' + & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|' + & ,1x,F6.3,1x),'|') + 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|' + & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x + & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x + & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x + & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|') + 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x + & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x + & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/ + & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|' + & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/ + & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|' + & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|') + 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x + & ,'A_tau = ',F8.2) + 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x + & ,' mu = ',F8.2) + 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*')) + +C...Format to use for comments + 7000 FORMAT('# ',A) +C...Format to use for block statements + 7010 FORMAT('Block',1x,A,3x,'#',1x,A) + 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A) +C...Indexed Int + 7110 FORMAT(1x,I4,1x,I4,3x,'#') +C...Non-Indexed Double + 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A) +C...Indexed Double + 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A) +C...Long Indexed Double (PDG + double) + 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A) +C...Indexed Char(12) + 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A) +C...Single matrix + 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A) +C...Double Matrix + 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A) +C...Write Decay Table + 7500 FORMAT('Decay',1x,I9,1x,1P,E16.8,0P,3x,'#',1x,A) + 7510 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),3x,'#',1x,A) + 7512 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,2(1x,I9),13x, + & '#',1x,'BR(',A10,1x,'->',2(1x,A10),')') + 7513 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,3(1x,I9),3x, + & '#',1x,'BR(',A10,1x,'->',3(1x,A10),')') + 7514 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,4(1x,I9),3x, + & '#',1x,'BR(',A10,1x,'->',4(1x,A10),')') + 7515 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,5(1x,I9),3x, + & '#',1x,'BR(',A10,1x,'->',5(1x,A10),')') + + END + + +C********************************************************************* + +C...PYAPPS +C...Uses approximate analytical formulae to determine the full set of +C...MSSM parameters from SUGRA input. +C...See M. Drees and S.P. Martin, hep-ph/9504124 + + SUBROUTINE PYAPPS + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/ + + WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'// + &' not intended for serious physics studies' + IMSS(5)=0 + IMSS(8)=0 + XMT=PMAS(6,1) + XMZ2=PMAS(23,1)**2 + XMW2=PMAS(24,1)**2 + TANB=RMSS(5) + BETA=ATAN(TANB) + XW=PARU(102) + XMG=RMSS(1) + XMG2=XMG*XMG + XM0=RMSS(8) + XM02=XM0*XM0 +C...Temporary sign change for AT. Others unchanged. + AT=-RMSS(16) + RMSS(15)=RMSS(16) + RMSS(17)=RMSS(16) + SINB=TANB/SQRT(TANB**2+1D0) + COSB=SINB/TANB + + DTERM=XMZ2*COS(2D0*BETA) + XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM) + XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM) + RMSS(6)=XMEL + RMSS(7)=XMER + XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM)) + XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM)) + XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM)) + XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM)) + DO 100 I=1,5,2 + PMAS(PYCOMP(KSUSY1+I),1)=XMDL + PMAS(PYCOMP(KSUSY2+I),1)=XMDR + PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL + PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR + 100 CONTINUE + XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA)) + IF(XARG.LT.0D0) THEN + WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'// + & ' FROM THE SUM RULE. ' + WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). ' + RETURN + ELSE + XARG=SQRT(XARG) + ENDIF + DO 110 I=11,15,2 + PMAS(PYCOMP(KSUSY1+I),1)=XMEL + PMAS(PYCOMP(KSUSY2+I),1)=XMER + PMAS(PYCOMP(KSUSY1+I+1),1)=XARG + PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0 + 110 CONTINUE + RMT=PYMRUN(6,PMAS(6,1)**2) + XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+ + &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG)) + RMB=PYMRUN(5,PMAS(6,1)**2) + XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+ + &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG)) + XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0) + ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/ + &SINB)**2) + RMSS(16)=-ATP + XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)- + &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2) + XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0 + XMU=SIGN(SQRT(XMU2),RMSS(4)) + RMSS(4)=XMU + IF(XMA2.GT.0D0) THEN + RMSS(19)=SQRT(XMA2) + ELSE + WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 ' + CALL PYSTOP(102) + ENDIF + ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM + IF(ARG.GT.0D0) THEN + RMSS(14)=SQRT(ARG) + ELSE + WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 ' + CALL PYSTOP(102) + ENDIF + ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM + IF(ARG.GT.0D0) THEN + RMSS(13)=SQRT(ARG) + ELSE + WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 ' + CALL PYSTOP(102) + ENDIF + ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0) + IF(ARG.GT.0D0) THEN + RMSS(10)=SQRT(ARG) + ELSE + RMSS(10)=-SQRT(-ARG) + ENDIF + ARG=PYRNMQ(2,-2D0*XTOP/3D0) + IF(ARG.GT.0D0) THEN + RMSS(12)=SQRT(ARG) + ELSE + RMSS(12)=-SQRT(-ARG) + ENDIF + ARG=PYRNMQ(3,-2D0*XBOT/3D0) + IF(ARG.GT.0D0) THEN + RMSS(11)=SQRT(ARG) + ELSE + RMSS(11)=-SQRT(-ARG) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSUGI +C...Interface to ISASUSY version 7.71. +C...Warning: this interface should not be used with earlier versions +C...of ISASUSY, since common block incompatibilities may then arise. +C...Calls SUGRA (in ISAJET) to perform RGE evolution. +C...Then converts to Gunion-Haber conventions. + + SUBROUTINE PYSUGI + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + + INTEGER PYK,PYCHGE,PYCOMP + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) + +C...Date of Change + CHARACTER DOC*11 + PARAMETER (DOC='01 May 2006') + +C...ISASUGRA Input: + REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP +C...XISAIN contains the MSSMi inputs in natural order. + COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4), + $XAMIN(7) + REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN + SAVE /SUGXIN/ +C...ISASUGRA Output + CHARACTER*40 ISAVER,VISAJE + REAL SUPER + COMMON /SSPAR/ SUPER(72) + COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT, + $FBGUT,FTAGUT,FNGUT + REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT + COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW, + $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ, + $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3, + $VUMT,VDMT,ASMTP,ASMSS,M3Q + REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW, + $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ, + $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q + INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG + INTEGER IALLOW + SAVE /SUGMG/,/SSPAR/ +C SUPER: Filled by ISASUGRA. +C SUPER(1) = mass of ~g +C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L +C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2 +C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1 +C ,~tau_2 +C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau +C SUPER(29) = Higgsino mass = - mu +C SUPER(30) = ratio v2/v1 of vev's +C SUPER(31:34) = Signed neutralino masses +C SUPER(35:50) = Neutralino mixing matrix +C SUPER(51:52) = Signed chargino masses +C SUPER(53:54) = Chargino left, right mixing angles +C SUPER(55:58) = mass of h0, H0, A0, H+ +C SUPER(59) = Higgs mixing angle alpha +C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau +C SUPER(66) = Gravitino mass +C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used) +C SUPER(70) = b-Yukawa at mA scale (not used) +C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used) +C GSS: Filled by ISASUGRA +C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3 +C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t +C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3 +C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t +C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2 +C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2 +C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2 +C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2 +C GSS(25) = mu GSS(26) = B GSS(27) = Y_N +C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq) +C GSS(31) = log(vuq) +C MSS: Filled by ISASUGRA +C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr +C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl +C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr +C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1 +C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl +C MSS(16) = nutl MSS(17) = el- MSS(18) = er- +C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1 +C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss +C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss +C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0 +C MSS(31) = ha0 MSS(32) = h+ +C Unification, filled by ISASUGRA if applicable. +C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC + +C...SPYTHIA Input/Output + INTEGER IMSS + DOUBLE PRECISION RMSS + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) +C...SLHA Input/Output + COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100), + & AU(3,3),AD(3,3),AE(3,3) +C...PYTHIA common blocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + + SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/ +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + INTEGER IMODEL + REAL M0,MHF,A0,MT + CHARACTER*20 CHMOD(5) + CHARACTER*32 FNAME + + COMMON /SUGNU/ XNUSUG(18) + REAL XNUSUG + SAVE /SUGNU/ + + DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA', + & 'truly unified SUGRA', 'non-minimal GMSB'/ + +C...Start by checking for incompatibilities/inconsistencies: + DO 100 ICHK=2,9 + IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN + WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK) + & ,' option not used by PYSUGI' + ENDIF + 100 CONTINUE +C...ISAJET works with REAL numbers. + MZERO=REAL(RMSS(8)) + MHLF=REAL(RMSS(1)) + AZERO=REAL(RMSS(16)) + TANB=REAL(RMSS(5)) + SGNMU=REAL(RMSS(4)) + MTOP=REAL(PMAS(6,1)) + IMODEL=0 + IF (IMSS(1).EQ.12) THEN + IMODEL=1 + GOTO 130 + ELSEIF(IMSS(1).EQ.13) THEN +C...Read from isajet par file in IMSS(20) + LFN=IMSS(20) +C...STOP IF LFN IS ZERO (i.e. if no LFN was given). + IF (LFN.EQ.0) THEN + WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)' + GOTO 9999 + ENDIF + WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...' +CMrenna change to allow any susy model + WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:' + WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:' + WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:' + WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'// + & ' gauge couplings:' + WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:' + READ(LFN,*) IMODEL + IF (IMODEL.EQ.4) THEN + IAL3UN=1 + IMODEL=1 + ENDIF + IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN + WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),' + & //' sgn(mu), M_t:' + READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT + IF (IMODEL.EQ.3) THEN + IMODEL=1 + 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;' + & //' 0 to continue:' + WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses' + WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms' + WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses' + WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd' + & //' generation masses' + WRITE(MSTU(11),*) + & ' NUSUG5 = GUT scale 3rd generation masses' + READ(LFN,*) INUSUG + IF (INUSUG.EQ.0) THEN + GOTO 120 + ELSEIF (INUSUG.EQ.1) THEN + WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:' + READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3) + IF (XNUSUG(3).LE.0.) THEN + WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED' + CALL PYSTOP(109) + END IF + ELSEIF (INUSUG.EQ.2) THEN + WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:' + READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4) + ELSEIF (INUSUG.EQ.3) THEN + WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:' + READ(LFN,*) XNUSUG(7),XNUSUG(8) + ELSEIF (INUSUG.EQ.4) THEN + WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),' + & //' M(ur), M(el), M(er):' + READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12), + & XNUSUG(10),XNUSUG(9) + ELSEIF (INUSUG.EQ.5) THEN + WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),' + & //' M(Ll), M(Lr):' + READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17), + & XNUSUG(15),XNUSUG(14) + ENDIF + GOTO 110 + ENDIF + ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN + IMSS(11)=1 + WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),' + & ,' sgn(mu), M_t, C_gv:' + READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV + XGMIN(7)=XCMGV + XGMIN(8)=1. +C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2} + AMPL=2.4D18 + AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL + IF (IMODEL.EQ.5) THEN + IMODEL=2 + WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino' + & ,' masses at M_mes' + WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2' + & ,' shifts at M_mes' + WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to', + & ' Y at M_mes' + WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),' + & ,'SU(2),SU(3)' + WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,' + & ,' n5_2, n5_3' + READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12), + $ XGMIN(13),XGMIN(14) + ENDIF + ELSE + WRITE(MSTU(11),*) 'Invalid model choice.' + GOTO 9999 + ENDIF + ENDIF + + 120 MZERO=M0 + MHLF=MHF + AZERO=A0 +C TANB=REAL(RMSS(5)) +C SGNMU=REAL(RMSS(4)) + MTOP=MT + +C...Initialize MSSM parameter array + 130 DO 140 IPAR=1,72 + SUPER(IPAR)=0.0 + 140 CONTINUE +C...Call ISASUGRA + CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL) +C...Check whether ISASUSY thought the model was OK. + IF (NOGOOD.NE.0) THEN + IF (NOGOOD.EQ.1) CALL PYERRM(26 + & ,'(PYSUGI:) SUSY parameters give tachyonic particles.') + IF (NOGOOD.EQ.2) CALL PYERRM(26 + & ,'(PYSUGI:) SUSY parameters give no EWSB.') + IF (NOGOOD.EQ.3) CALL PYERRM(26 + & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.') + IF (NOGOOD.EQ.4) CALL PYERRM(26 + & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.') + IF (NOGOOD.EQ.7) CALL PYERRM(26 + & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.') + IF (NOGOOD.EQ.8) CALL PYERRM(26 + & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.') +C...Give warning, but don't stop, if LSP not ~chi_10. + IF (NOGOOD.EQ.5) CALL PYERRM(16 + & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.') + ENDIF +C...Warn about possible GUT scale tachyons. + IF (ITACHY.NE.0) CALL PYERRM(16, + & '(PYSUGI:) Tachyonic sleptons at GUT scale.') +C...Finalize spectrum (last iteration) +C...(Thanks to A. Raklev for pointing this out.) +C...NB: SSMSSM also calculates decays, but these are not used by Pythia. + CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3), + $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9), + $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14), + $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19), + $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24), + $ MTOP,IALLOW,1) + +C...M1, M2, M3. + RMSS(1)=dble(GSS(7)) + RMSS(2)=dble(GSS(8)) + RMSS(3)=dble(GSS(9)) + RMSOFT(1)=dble(GSS(7)) + RMSOFT(2)=dble(GSS(8)) + RMSOFT(3)=dble(GSS(9)) +C...Mu = - Higgsino mass. + RMSS(4)=-SUPER(29) + RMSS(5)=TANB +C...Slepton and squark masses. 2 first generations. + RMSS(6)=0.5*(SUPER(18)+SUPER(20)) + RMSS(7)=0.5*(SUPER(19)+SUPER(21)) + RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8)) + RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9)) +C...Third generation. + RMSS(10)=0.5*(SUPER(14)+SUPER(10)) + RMSS(11)=SUPER(11) + RMSS(12)=SUPER(15) + RMSS(13)=SUPER(22) + RMSS(14)=SUPER(23) +C...SLHA: store exact soft spectrum in RMSOFT + RMSOFT(31)=SUPER(18) + RMSOFT(32)=SUPER(20) + RMSOFT(33)=SUPER(22) + RMSOFT(34)=SUPER(19) + RMSOFT(35)=SUPER(21) + RMSOFT(36)=SUPER(23) + RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4)) + RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8)) + RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14)) + RMSOFT(44)=SUPER(3) + RMSOFT(45)=SUPER(9) + RMSOFT(46)=SUPER(15) + RMSOFT(47)=SUPER(5) + RMSOFT(48)=SUPER(7) + RMSOFT(49)=SUPER(11) + +C...~b, ~t, and ~tau trilinear couplings and mixing angles. + RMSS(15)=SUPER(62) + RMSS(16)=SUPER(60) + RMSS(17)=SUPER(64) + RMSS(26)=SUPER(63) + RMSS(27)=SUPER(61) + RMSS(28)=SUPER(65) +C...SLHA trilinears + DO 142 K1=1,3 + DO 141 K2=1,3 + AE(K1,K2)=0D0 + AU(K1,K2)=0D0 + AD(K1,K2)=0D0 + 141 CONTINUE + 142 CONTINUE + AE(3,3)=SUPER(64) + AU(3,3)=SUPER(60) + AD(3,3)=SUPER(62) +C...Higgs mixing angle alpha (Gunion-Haber convention). + RMSS(18)=-SUPER(59) +C...A0 mass. + RMSS(19)=SUPER(57) +C...GUT scale coupling + RMSS(20)=AGUTSS +C...Gravitino mass (for future compatibility) + RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66))) + +C...Now we're done with RMSS. Time to fill PMAS (m > 0 required). +C...Higgs sector. + PMAS(PYCOMP(25),1)=ABS(SUPER(55)) + PMAS(PYCOMP(35),1)=ABS(SUPER(56)) + PMAS(PYCOMP(36),1)=ABS(SUPER(57)) + PMAS(PYCOMP(37),1)=ABS(SUPER(58)) +C...Gluino. + PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1)) +C...Squarks and Sleptons. + DO 150 ILR=1,2 + ILRM=ILR-1 + PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM)) + PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM)) + PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM)) + PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM)) + PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM)) + PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM)) + PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM)) + PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM)) + PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM)) + 150 CONTINUE + PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26)) + PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27)) + PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28)) +C...Neutralinos. + PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31)) + PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32)) + PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33)) + PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34)) +C...Signed masses (extra minus from going to G-H convention). + SMZ(1)=-SUPER(31) + SMZ(2)=-SUPER(32) + SMZ(3)=-SUPER(33) + SMZ(4)=-SUPER(34) +C...Charginos + PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51)) + PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52)) +C...Signed masses (extra minus from going to G-H convention). + SMW(1)=-SUPER(51) + SMW(2)=-SUPER(52) + +C... Neutralino Mixing. + DO 160 IN=1,4 + ZMIX(IN,1)= SUPER(38+4*(IN-1)) + ZMIX(IN,2)= SUPER(37+4*(IN-1)) + ZMIX(IN,3)=-SUPER(36+4*(IN-1)) + ZMIX(IN,4)=-SUPER(35+4*(IN-1)) + 160 CONTINUE +C...Chargino Mixing (PYTHIA same angle as HERWIG). + THX=1D0 + THY=1D0 + IF (SUPER(53).GT.0) THX=-1D0 + IF (SUPER(54).GT.0) THY=-1D0 + UMIX(1,1) = -SIN(SUPER(53)) + UMIX(1,2) = -COS(SUPER(53)) + UMIX(2,1) = -THX*COS(SUPER(53)) + UMIX(2,2) = THX*SIN(SUPER(53)) + VMIX(1,1) = -SIN(SUPER(54)) + VMIX(1,2) = -COS(SUPER(54)) + VMIX(2,1) = -THY*COS(SUPER(54)) + VMIX(2,2) = THY*SIN(SUPER(54)) +C...Sfermion mixing (PYTHIA same angle as ISAJET) + SFMIX(5,1)=COS(SUPER(63)) + SFMIX(5,2)=SIN(SUPER(63)) + SFMIX(5,3)=-SIN(SUPER(63)) + SFMIX(5,4)=COS(SUPER(63)) + SFMIX(6,1)=COS(SUPER(61)) + SFMIX(6,2)=SIN(SUPER(61)) + SFMIX(6,3)=-SIN(SUPER(61)) + SFMIX(6,4)=COS(SUPER(61)) + SFMIX(15,1)=COS(SUPER(65)) + SFMIX(15,2)=SIN(SUPER(65)) + SFMIX(15,3)=-SIN(SUPER(65)) + SFMIX(15,4)=COS(SUPER(65)) + + IF (MSTP(122).NE.0) THEN +C...Print a few lines to make the user know what's happening + ISAVER=VISAJE() + WRITE(MSTU(11),5000) DOC, ISAVER + WRITE(MSTU(11),5100) + IF (IMODEL.EQ.1) THEN + WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU), + & MTOP + WRITE(MSTU(11),5300) + ENDIF + WRITE(MSTU(11),5500) 'Pole masses' + WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2) + WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28) + & ,(SUPER(IP),IP=19,25,2) + WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP) + & ,IP=1,2) + WRITE(MSTU(11),5400) + WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58) + WRITE(MSTU(11),5400) + WRITE(MSTU(11),5500) 'EW scale mixing structure' + WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4) + WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2) + & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2) + WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2) + & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4 + & ),(SFMIX(15,J),J=3,4) + WRITE(MSTU(11),5400) + WRITE(MSTU(11),6450) RMSS(18) + WRITE(MSTU(11),5400) + WRITE(MSTU(11),5500) 'Couplings' + WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20) + WRITE(MSTU(11),5400) + ENDIF + +C...Call FeynHiggs to improve Higgs sector if requested + IF (IMSS(4).EQ.3) THEN + IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)') + & ' (PYSUGI:) Now calling FeynHiggs.' + CALL PYFEYN(IERR) + IF (IERR.EQ.0) THEN + IMSS(4)=2 + IF (MSTP(122).NE.0) THEN + WRITE(MSTU(11),5400) + WRITE(MSTU(11),5500) + & 'Corrected Higgs masses and mixing' + WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1), + & PMAS(37,1) + WRITE(MSTU(11),6450) RMSS(18) + WRITE(MSTU(11),5400) + ENDIF + ENDIF + ENDIF + + IF (MSTP(122).NE.0) WRITE(MSTU(11),6500) + +C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle +C...output by ISASUSY. + IMSS(4)=MAX(2,IMSS(4)) + + 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY ' + & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A + & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*') + 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------') + 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)', + & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2) + 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x + & ,'----------------') + 5400 FORMAT(1x,'*',1x,A) + 5500 FORMAT(1x,'*',1x,A,':') + 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/ + & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2) + 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x, + & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x, + & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2 + & ,1x)) + 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x + & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x + & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8 + & .2,1x)) + 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20' + & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x + & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x)) + 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x + & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x)) + 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x + & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)') + 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x + & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|' + & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|' + & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|' + & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|' + & ,1x,F6.3,1x),'|') + 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|' + & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x + & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x + & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x + & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|') + 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x + & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x + & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/ + & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|' + & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/ + & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|' + & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|') + 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2 + & ,4x,'Alpha_GUT = ',F8.2) + 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4) + 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*')) + + 9999 RETURN + END + +C********************************************************************* + +C...PYFEYN +C...Interface to FeynHiggs for MSSM Higgs sector. +C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX +C...P. Skands + + SUBROUTINE PYFEYN(IERR) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) +C...SUSY blocks + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) +C...FeynHiggs variables + DOUBLE PRECISION RMHIGG(4) + DOUBLE COMPLEX SAEFF, UHIGGS(3,3) + DOUBLE COMPLEX DMU, + & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11, + & DM1, DM2, DM3 +C...SLHA Common Block + COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100), + & AU(3,3),AD(3,3),AE(3,3) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/ + + IERR=0 + CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1) + IF (IERR.NE.0) THEN + CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.' + & //'Will not use FeynHiggs for this run.') + RETURN + ENDIF + Q=RMSOFT(0) + DMB=PMAS(5,1) + DMT=PMAS(6,1) + DMZ=PMAS(23,1) + DMW=PMAS(24,1) + DMA=PMAS(36,1) + DM1=RMSOFT(1) + DM2=RMSOFT(2) + DM3=RMSOFT(3) + DTANB=RMSS(5) + DMU=RMSS(4) + DM3SL=RMSOFT(33) + DM3SE=RMSOFT(36) + DM3SQ=RMSOFT(43) + DM3SU=RMSOFT(46) + DM3SD=RMSOFT(49) + DM2SL=RMSOFT(32) + DM2SE=RMSOFT(35) + DM2SQ=RMSOFT(42) + DM2SU=RMSOFT(45) + DM2SD=RMSOFT(48) + DM1SL=RMSOFT(31) + DM1SE=RMSOFT(34) + DM1SQ=RMSOFT(41) + DM1SU=RMSOFT(44) + DM1SD=RMSOFT(47) + AE33=AE(3,3) + AE22=AE(2,2) + AE11=AE(1,1) + AU33=AU(3,3) + AU22=AU(2,2) + AU11=AU(1,1) + AD33=AD(3,3) + AD22=AD(2,2) + AD11=AD(1,1) + CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB, + & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD, + & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD, + & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU, + & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11, + & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q) + IF (IERR.NE.0) THEN + CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.' + & //' Will not use FeynHiggs for this run.') + RETURN + ENDIF +C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV) + SAEFF=0D0 + CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS) + IF (IERR.NE.0) THEN + CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'// + & 'GSCORR. Will not use FeynHiggs for this run.') + RETURN + ENDIF + ALPHA = ASIN(DBLE(SAEFF)) + R=RMSS(18)/ALPHA + IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN + CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.') + WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18) + WRITE(MSTU(11),*) ' New Alpha:', ALPHA + ENDIF + IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT. + & 1.15D0*PMAS(25,1)) THEN + CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.') + WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1) + WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1) + ENDIF + RMSS(18)=ALPHA + PMAS(25,1)=RMHIGG(1) + PMAS(35,1)=RMHIGG(2) + PMAS(36,1)=RMHIGG(3) + PMAS(37,1)=RMHIGG(4) + + RETURN + END + +C********************************************************************* + +C...PYRNMQ +C...Determines the running mass of Squarks. + + FUNCTION PYRNMQ(ID,DTERM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblock. + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + SAVE /PYMSSM/ + +C...Local variables. + DOUBLE PRECISION PI,R + DOUBLE PRECISION TOL + DOUBLE PRECISION CI(3) + EXTERNAL PYALPS + DOUBLE PRECISION PYALPS + DATA TOL/0.001D0/ + DATA PI,R/3.141592654D0,.61803399D0/ + DATA CI/0.47D0,0.07D0,0.02D0/ + + C=1D0-R + CA=CI(ID) + AG=(0.71D0)**2/4D0/PI + AG=RMSS(20) + XM0=RMSS(8) + XMG=RMSS(1) + XM02=XM0*XM0 + XMG2=XMG*XMG + + AS=PYALPS(XM02+6D0*XMG2) + CG=8D0/9D0*((AS/AG)**2-1D0) + BX=XM02+(CA+CG)*XMG2+DTERM + AX=MIN(50D0**2,0.5D0*BX) + CX=MAX(2000D0**2,2D0*BX) + + X0=AX + X3=CX + IF(ABS(CX-BX).GT.ABS(BX-AX))THEN + X1=BX + X2=BX+C*(CX-BX) + ELSE + X2=BX + X1=BX-C*(BX-AX) + ENDIF + AS1=PYALPS(X1) + CG=8D0/9D0*((AS1/AG)**2-1D0) + F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1) + AS2=PYALPS(X2) + CG=8D0/9D0*((AS2/AG)**2-1D0) + F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2) + 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN + IF(F2.LT.F1) THEN + X0=X1 + X1=X2 + X2=R*X1+C*X3 + F1=F2 + AS2=PYALPS(X2) + CG=8D0/9D0*((AS2/AG)**2-1D0) + F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2) + ELSE + X3=X2 + X2=X1 + X1=R*X2+C*X0 + F2=F1 + AS1=PYALPS(X1) + CG=8D0/9D0*((AS1/AG)**2-1D0) + F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1) + ENDIF + GOTO 100 + ENDIF + IF(F1.LT.F2) THEN + PYRNMQ=X1 + XMIN=X1 + ELSE + PYRNMQ=X2 + XMIN=X2 + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYTHRG +C...Calculates the mass eigenstates of the third generation sfermions. +C...Created: 5-31-96 + + SUBROUTINE PYTHRG + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ + +C...Local variables. + DOUBLE PRECISION BETA + DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2) + DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2 + DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL + DOUBLE PRECISION ATR,AMQR,AMQL + INTEGER ID1(3),ID2(3),ID3(3),ID4(3) + INTEGER IF,I,J,II,JJ,IT,L + LOGICAL DTERM + DATA SMALL/1D-3/ + DATA ID1/10,10,13/ + DATA ID2/5,6,15/ + DATA ID3/15,16,17/ + DATA ID4/11,12,14/ + DATA DTERM/.TRUE./ + + XMZ2=PMAS(23,1)**2 + XMW2=PMAS(24,1)**2 + TANB=RMSS(5) + XMU=-RMSS(4) + BETA=ATAN(TANB) + COS2B=COS(2D0*BETA) + +C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS + + IOPT=IMSS(5) + IF(IOPT.EQ.1) THEN + CTT=DCOS(RMSS(27)) + CTT2=CTT**2 + STT=DSIN(RMSS(27)) + STT2=STT**2 + XM12=RMSS(10)**2 + XM22=RMSS(12)**2 + XMQL2=CTT2*XM12+STT2*XM22 + XMQR2=STT2*XM12+CTT2*XM22 + XMF2=PYMRUN(6,PMAS(6,1)**2)**2 + ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2) + RMSS(16)=ATOP +C......SUBTRACT OUT D-TERM AND FERMION MASS + XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0 + XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0 + IF(XMQL2.GE.0D0) THEN + RMSS(10)=SQRT(XMQL2) + ELSE + RMSS(10)=-SQRT(-XMQL2) + ENDIF + IF(XMQR2.GE.0D0) THEN + RMSS(12)=SQRT(XMQR2) + ELSE + RMSS(12)=-SQRT(-XMQR2) + ENDIF + +C SAME FOR BOTTOM SQUARK + CTT=DCOS(RMSS(26)) + CTT2=CTT**2 + STT=DSIN(RMSS(26)) + STT2=STT**2 + XM22=RMSS(11)**2 + XMF2=PYMRUN(5,PMAS(6,1)**2)**2 + XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2 + IF(ABS(CTT).GE..9999D0) THEN + ABOT=-XMU*TANB + XMQR2=RMSS(11)**2 + ELSEIF(ABS(CTT).LE.1D-4) THEN + ABOT=-XMU*TANB + XMQR2=RMSS(11)**2 + ELSE + XM12=(XMQL2-STT2*XM22)/CTT2 + XMQR2=STT2*XM12+CTT2*XM22 + ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2) + ENDIF + RMSS(15)=ABOT +C......SUBTRACT OUT D-TERM AND FERMION MASS + XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2 + IF(XMQR2.GE.0D0) THEN + RMSS(11)=SQRT(XMQR2) + ELSE + RMSS(11)=-SQRT(-XMQR2) + ENDIF +C SAME FOR TAU SLEPTON + CTT=DCOS(RMSS(28)) + CTT2=CTT**2 + STT=DSIN(RMSS(28)) + STT2=STT**2 + XM12=RMSS(13)**2 + XM22=RMSS(14)**2 + XMQL2=CTT2*XM12+STT2*XM22 + XMQR2=STT2*XM12+CTT2*XM22 + XMFR=PMAS(15,1) + XMF2=XMFR**2 + ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2) + RMSS(17)=ATAU +C......SUBTRACT OUT D-TERM AND FERMION MASS + XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B + XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B + IF(XMQL2.GE.0D0) THEN + RMSS(13)=SQRT(XMQL2) + ELSE + RMSS(13)=-SQRT(-XMQL2) + ENDIF + IF(XMQR2.GE.0D0) THEN + RMSS(14)=SQRT(XMQR2) + ELSE + RMSS(14)=-SQRT(-XMQR2) + ENDIF + ENDIF + DO 170 L=1,3 + AMQL=RMSS(ID1(L)) + IF(AMQL.LT.0D0) THEN + XMQL2=-AMQL**2 + ELSE + XMQL2=AMQL**2 + ENDIF + ATR=RMSS(ID3(L)) + AMQR=RMSS(ID4(L)) + IF(AMQR.LT.0D0) THEN + XMQR2=-AMQR**2 + ELSE + XMQR2=AMQR**2 + ENDIF + IF=ID2(L) + XMF=PYMRUN(IF,PMAS(6,1)**2) + XMF2=XMF**2 + AM2(1,1)=XMQL2+XMF2 + AM2(2,2)=XMQR2+XMF2 + IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0 + IF(DTERM) THEN + IF(L.EQ.1) THEN + AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0 + AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0 + AM2(1,2)=XMF*(ATR+XMU*TANB) + ELSEIF(L.EQ.2) THEN + AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0 + AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0 + AM2(1,2)=XMF*(ATR+XMU/TANB) + ELSEIF(L.EQ.3) THEN + IF(IMSS(8).EQ.1) THEN + AM2(1,1)=RMSS(6)**2 + AM2(2,2)=RMSS(7)**2 + AM2(1,2)=0D0 + RMSS(13)=RMSS(6) + RMSS(14)=RMSS(7) + ELSE + AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B + AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B + AM2(1,2)=XMF*(ATR+XMU*TANB) + ENDIF + ENDIF + ENDIF + AM2(2,1)=AM2(1,2) + DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2 + IF(DETM.LT.0D0) THEN + WRITE(MSTU(11),*) ID2(L),DETM,AM2 + CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ') + ENDIF + SAME=0.5D0*(AM2(1,1)+AM2(2,2)) + DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1)) + XMF12=SAME-DIFF + XMF22=SAME+DIFF + IT=0 + IF(XMF22-XMF12.GT.0D0) THEN + RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12))) + RT(2,2) = RT(1,1) + RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)), + & AM2(1,2)/(XMF22-XMF12)) + RT(2,1) = -RT(1,2) + ELSE + RT(1,1) = 1D0 + RT(2,2) = RT(1,1) + RT(1,2) = 0D0 + RT(2,1) = -RT(1,2) + ENDIF + 100 CONTINUE + IT=IT+1 + + DO 140 I=1,2 + DO 130 JJ=1,2 + DI(I,JJ)=0D0 + DO 120 II=1,2 + DO 110 J=1,2 + DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II) + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + + IF(DI(1,1).GT.DI(2,2)) THEN + WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION ' + WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22) + WRITE(MSTU(11),*) AM2 + WRITE(MSTU(11),*) DI + WRITE(MSTU(11),*) RT + DI(1,1)=-RT(2,1) + DI(2,2)=RT(1,2) + DI(1,2)=-RT(2,2) + DI(2,1)=RT(1,1) + DO 160 I=1,2 + DO 150 J=1,2 + RT(I,J)=DI(I,J) + 150 CONTINUE + 160 CONTINUE + GOTO 100 + ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN + WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'// + & ' OFF DIAGONAL ELEMENTS ' + WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22) + WRITE(MSTU(11),*) DI + WRITE(MSTU(11),*) ' ROTATION = ',RT +C...STOP + ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN + WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'// + & ' NEGATIVE MASSES ' + CALL PYSTOP(111) + ENDIF + PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12) + PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22) + SFMIX(IF,1)=RT(1,1) + SFMIX(IF,2)=RT(1,2) + SFMIX(IF,3)=RT(2,1) + SFMIX(IF,4)=RT(2,2) + 170 CONTINUE + +C.....TAU SNEUTRINO MASS...L=3 + + XARG=AM2(1,1)+XMW2*COS2B + IF(XARG.LT.0D0) THEN + WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'// + & ' FROM THE SUM RULE. ' + WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). ' + RETURN + ELSE + PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG) + ENDIF + + RETURN + END +C********************************************************************* + +C...PYINOM +C...Finds the mass eigenstates and mixing matrices for neutralinos +C...and charginos. + + SUBROUTINE PYINOM + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ + +C...Local variables. + DOUBLE PRECISION XMW,XMZ,XM(4) + DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5) + DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5) + DOUBLE PRECISION COSW,SINW + DOUBLE PRECISION XMU + DOUBLE PRECISION TANB,COSB,SINB + DOUBLE PRECISION XM1,XM2,XM3,BETA + DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2 + DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT + DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1 + DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1 + DOUBLE PRECISION PYALPS,PYALEM + DOUBLE PRECISION PYRNM3 + COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2 + INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4) + DATA KFNCHI/1000022,1000023,1000025,1000035/ + + IOPT=IMSS(2) + IF(IMSS(1).EQ.2) THEN + IOPT=1 + ENDIF +C...M1, M2, AND M3 ARE INDEPENDENT + IF(IOPT.EQ.0) THEN + XM1=RMSS(1) + XM2=RMSS(2) + XM3=RMSS(3) + ELSEIF(IOPT.GE.1) THEN + Q2=PMAS(23,1)**2 + AEM=PYALEM(Q2) + A2=AEM/PARU(102) + A1=AEM/(1D0-PARU(102)) + XM1=RMSS(1) + XM2=RMSS(2) + IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0 + IF(IOPT.EQ.1) THEN + XM2=XM1*A2/A1*3D0/5D0 + RMSS(2)=XM2 + ELSEIF(IOPT.EQ.3) THEN + XM1=XM2*5D0/3D0*A1/A2 + RMSS(1)=XM1 + ENDIF + XM3=PYRNM3(XM2/A2) + RMSS(3)=XM3 + IF(XM3.LE.0D0) THEN + WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3 + CALL PYSTOP(105) + ENDIF + ENDIF + +C...GLUINO MASS + IF(IMSS(3).EQ.1) THEN + PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3) + ELSE + AQ=0D0 + DO 110 I=1,4 + DO 100 ILR=1,2 + RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2 + AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0) + & +(1D0-RM1)**2*LOG(ABS(1D0-RM1))) + 100 CONTINUE + 110 CONTINUE + + DO 130 I=5,6 + DO 120 ILR=1,2 + RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2 + RM2=PMAS(I,1)**2/XM3**2 + ARG=(RM1-RM2-1D0)**2-4D0*RM2**2 + IF(ARG.GE.0D0) THEN + X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG)) + AX0=ABS(X0) + X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG)) + AX1=ABS(X1) + IF(X0.EQ.1D0) THEN + AT=-1D0 + BT=0.25D0 + ELSEIF(X0.EQ.0D0) THEN + AT=0D0 + BT=-0.25D0 + ELSE + AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+ + & 0.5D0*X0**2*LOG(AX0) + BT=(-1D0-2D0*X0)/4D0 + ENDIF + IF(X1.EQ.1D0) THEN + AT=-1D0+AT + BT=0.25D0+BT + ELSEIF(X1.EQ.0D0) THEN + AT=0D0+AT + BT=-0.25D0+BT + ELSE + AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0* + & X1**2*LOG(AX1)+AT + BT=(-1D0-2D0*X1)/4D0+BT + ENDIF + AQ=AQ+AT+BT + ELSE + X0=0.5D0*(1D0+RM2-RM1) + Y0=-0.5D0*SQRT(-ARG) + AMGX0=SQRT(X0**2+Y0**2) + AM1X0=SQRT((1D0-X0)**2+Y0**2) + ARGX0=ATAN2(-X0,-Y0) + AR1X0=ATAN2(1D0-X0,Y0) + X1=X0 + Y1=-Y0 + AMGX1=AMGX0 + AM1X1=AM1X0 + ARGX1=ATAN2(-X1,-Y1) + AR1X1=ATAN2(1D0-X1,Y1) + AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2) + & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0) + BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 ) + AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2) + & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1) + BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 ) + AQ=AQ+AT+BT + ENDIF + 120 CONTINUE + 130 CONTINUE + PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2) + & /(2D0*PARU(2))*(15D0+AQ)) + ENDIF + +C...NEUTRALINO MASSES + DO 150 I=1,4 + DO 140 J=1,4 + AI(I,J)=0D0 + 140 CONTINUE + 150 CONTINUE + XMZ=PMAS(23,1)/100D0 + XMW=PMAS(24,1)/100D0 + XMU=RMSS(4)/100D0 + SINW=SQRT(PARU(102)) + COSW=SQRT(1D0-PARU(102)) + TANB=RMSS(5) + BETA=ATAN(TANB) + COSB=COS(BETA) + SINB=TANB*COSB + + XM2=XM2/100D0 + XM1=XM1/100D0 + + +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(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR) + IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '// + & 'PROBLEM WITH PYEICG IN PYINOM ') + 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)*100D0 + 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^* + DO I=1,4 + DO J=1,4 + AR(I,J)=0D0 + AI(I,J)=0D0 + ENDDO + ENDDO + 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(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR) + IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '// + & 'PROBLEM WITH PYEICG IN PYINOM ') + 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))*100D0 + S=0D0 + DO 220 J=1,2 + S=S+ZR(J,K)**2+ZI(J,K)**2 + 220 CONTINUE + DO 230 J=1,2 + UMIX(I,J)=ZR(J,K)/SQRT(S) + UMIXI(I,J)=-ZI(J,K)/SQRT(S) + IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0 + IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0 + 230 CONTINUE + 240 CONTINUE +C...Force chargino mass > neutralino mass + IFRC=0 + IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN + CALL PYERRM(8,'(PYINOM:) '// + & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)') + SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1)) + IFRC=1 + ENDIF + PMAS(PYCOMP(KSUSY1+24),1)=SMW(1) + PMAS(PYCOMP(KSUSY1+37),1)=SMW(2) + +C.....Find eigenvectors of X^* X + DO I=1,4 + DO J=1,4 + AR(I,J)=0D0 + AI(I,J)=0D0 + ZR(I,J)=0D0 + ZI(I,J)=0D0 + ENDDO + ENDDO + 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(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR) + IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '// + & 'PROBLEM WITH PYEICG IN PYINOM ') + INDEX(1)=1 + INDEX(2)=2 + IF(WR(2).LT.WR(1)) THEN + INDEX(1)=2 + INDEX(2)=1 + ENDIF + + SIMAG=0D0 + 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 + SIMAG=SIMAG+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 + +C.....Simplify if no phases + IF(SIMAG.LT.1D-6) THEN + AR(1,1) = XM2*COS(RMSS(31)) + AR(2,2) = XMU*COS(RMSS(33)) + AR(1,2) = SQRT(2D0)*XMW*SINB + AR(2,1) = SQRT(2D0)*XMW*COSB + IKNT=0 + 300 CONTINUE + DO I=1,2 + DO J=1,2 + ZR(I,J)=0D0 + ENDDO + ENDDO + + DO I=1,2 + DO J=1,2 + DO K=1,2 + DO L=1,2 + ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L) + ENDDO + ENDDO + ENDDO + ENDDO + VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0 + VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0 + VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0 + VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0 + IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN + CALL PYERRM(18,'(PYINOM:) Problem with Charginos') + ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN + IKNT=IKNT+1 + GOTO 300 + ENDIF +C.....Must deal with phases + ELSE + CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31))) + CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33))) + CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0) + CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0) + + IKNT=0 + 310 CONTINUE + DO I=1,2 + DO J=1,2 + CAI(I,J)=CMPLX(0D0,0D0) + ENDDO + ENDDO + + DO I=1,2 + DO J=1,2 + DO K=1,2 + DO L=1,2 + CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)* + & CMPLX(VMIX(J,L),VMIXI(J,L)) + ENDDO + ENDDO + ENDDO + ENDDO + + CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0 + CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0 + TEMPR=VMIX(1,1) + TEMPI=VMIXI(1,1) + VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1) + VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1) + TEMPR=VMIX(1,2) + TEMPI=VMIXI(1,2) + VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1) + VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1) + TEMPR=VMIX(2,1) + TEMPI=VMIXI(2,1) + VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2) + VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2) + TEMPR=VMIX(2,2) + TEMPI=VMIXI(2,2) + VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2) + VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2) + IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN + CALL PYERRM(18,'(PYINOM:) Problem with Charginos') + ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR. + & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN + IKNT=IKNT+1 + GOTO 310 + ENDIF + ENDIF + RETURN + END + +C********************************************************************* + +C...PYRNM3 +C...Calculates the running of M3, the SU(3) gluino mass parameter. + + FUNCTION PYRNM3(RGUT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local variables. + DOUBLE PRECISION R + DOUBLE PRECISION TOL + EXTERNAL PYALPS + DOUBLE PRECISION PYALPS + DATA TOL/0.001D0/ + DATA R/0.61803399D0/ + + C=1D0-R + + BX=RGUT*PYALPS(RGUT**2) + AX=MIN(50D0,BX*0.5D0) + CX=MAX(2000D0,2D0*BX) + + X0=AX + X3=CX + IF(ABS(CX-BX).GT.ABS(BX-AX))THEN + X1=BX + X2=BX+C*(CX-BX) + ELSE + X2=BX + X1=BX-C*(BX-AX) + ENDIF + AS1=PYALPS(X1**2) + F1=ABS(X1-RGUT*AS1) + AS2=PYALPS(X2**2) + F2=ABS(X2-RGUT*AS2) + 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN + IF(F2.LT.F1) THEN + X0=X1 + X1=X2 + X2=R*X1+C*X3 + F1=F2 + AS2=PYALPS(X2**2) + F2=ABS(X2-RGUT*AS2) + ELSE + X3=X2 + X2=X1 + X1=R*X2+C*X0 + F2=F1 + AS1=PYALPS(X1**2) + F1=ABS(X1-RGUT*AS1) + ENDIF + GOTO 100 + ENDIF + IF(F1.LT.F2) THEN + PYRNM3=X1 + XMIN=X1 + ELSE + PYRNM3=X2 + XMIN=X2 + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYEIG4 +C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix. +C...Specific application: mixing in neutralino sector. + + SUBROUTINE PYEIG4(A,W,Z) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Arrays: in call and local. + DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4) + +C...Coefficients of fourth-degree equation from matrix. +C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0. + B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4)) + B2=0D0 + DO 110 I=1,3 + DO 100 J=I+1,4 + B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I) + 100 CONTINUE + 110 CONTINUE + B1=0D0 + B0=0D0 + DO 120 I=1,4 + I1=MOD(I,4)+1 + I2=MOD(I+1,4)+1 + I3=MOD(I+2,4)+1 + B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+ + & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))- + & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I) + B0=B0+(-1D0)**(I+1)*A(1,I)*( + & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+ + & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+ + & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1))) + 120 CONTINUE + +C...Coefficients of third-degree equation needed for +C...separation into two second-degree equations. +C...u**3 + c2 * u**2 + c1 * u + c0 = 0. + C2=-B2 + C1=B1*B3-4D0*B0 + C0=-B1**2-B0*B3**2+4D0*B0*B2 + CQ=C1/3D0-C2**2/9D0 + CR=C1*C2/6D0-C0/2D0-C2**3/27D0 + CQR=CQ**3+CR**2 + +C...Cases with one or three real roots. + IF(CQR.GE.0D0) THEN + S1=(CR+SQRT(CQR))**(1D0/3D0) + S2=(CR-SQRT(CQR))**(1D0/3D0) + U=S1+S2-C2/3D0 + ELSE + SABS=SQRT(-CQ) + THE=ACOS(CR/SABS**3)/3D0 + SRE=SABS*COS(THE) + U=2D0*SRE-C2/3D0 + ENDIF + +C...Find and solve two second-degree equations. + P1=B3/2D0-SQRT(B3**2/4D0+U-B2) + P2=B3/2D0+SQRT(B3**2/4D0+U-B2) + Q1=U/2D0+SQRT(U**2/4D0-B0) + Q2=U/2D0-SQRT(U**2/4D0-B0) + IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN + QSAV=Q1 + Q1=Q2 + Q2=QSAV + ENDIF + X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1) + X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1) + X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2) + X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2) + +C...Order eigenvalues in asceding mass. + W(1)=X(1) + DO 150 I1=2,4 + DO 130 I2=I1-1,1,-1 + IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140 + W(I2+1)=W(I2) + 130 CONTINUE + 140 W(I2+1)=X(I1) + 150 CONTINUE + +C...Find equation system for eigenvectors. + DO 250 I=1,4 + DO 170 J1=1,4 + D(J1,J1)=A(J1,J1)-W(I) + DO 160 J2=J1+1,4 + D(J1,J2)=A(J1,J2) + D(J2,J1)=A(J2,J1) + 160 CONTINUE + 170 CONTINUE + +C...Find largest element in matrix. + DAMAX=0D0 + DO 190 J1=1,4 + DO 180 J2=1,4 + IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180 + JA=J1 + JB=J2 + DAMAX=ABS(D(J1,J2)) + 180 CONTINUE + 190 CONTINUE + +C...Subtract others by multiple of row selected above. + DAMAX=0D0 + DO 210 J3=JA+1,JA+3 + J1=J3-4*((J3-1)/4) + RL=D(J1,JB)/D(JA,JB) + DO 200 J2=1,4 + D(J1,J2)=D(J1,J2)-RL*D(JA,J2) + IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200 + JC=J1 + JD=J2 + DAMAX=ABS(D(J1,J2)) + 200 CONTINUE + 210 CONTINUE + +C...Do one more subtraction of a row. + DAMAX=0D0 + DO 230 J3=JC+1,JC+3 + J1=J3-4*((J3-1)/4) + IF(J1.EQ.JA) GOTO 230 + RL=D(J1,JD)/D(JC,JD) + DO 220 J2=1,4 + IF(J2.EQ.JB) GOTO 220 + D(J1,J2)=D(J1,J2)-RL*D(JC,J2) + IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220 + JE=J1 + DAMAX=ABS(D(J1,J2)) + 220 CONTINUE + 230 CONTINUE + +C...Construct unnormalized eigenvector. + JF1=JD+1-4*(JD/4) + JF2=JD+2-4*((JD+1)/4) + IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4) + IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4) + E(JF1)=-D(JE,JF2) + E(JF2)=D(JE,JF1) + E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD) + E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/ + & D(JA,JB) + +C...Normalize and fill in final array. + EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2) + SGN=(-1D0)**INT(PYR(0)+0.5D0) + DO 240 J=1,4 + Z(I,J)=SGN*E(J)/EA + 240 CONTINUE + 250 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYHGGM +C...Determines the Higgs boson mass spectrum using several inputs. + + SUBROUTINE PYHGGM(ALPHA) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/ + +C...Local variables. + DOUBLE PRECISION AT,AB,XMU,TANB + DOUBLE PRECISION ALPHA + INTEGER IHOPT + DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD + DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA + DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP + DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2 + + IHOPT=IMSS(4) + IF(IHOPT.EQ.2) THEN + ALPHA=RMSS(18) + RETURN + ENDIF + AT=RMSS(16) + AB=RMSS(15) + DMGL=RMSS(3) + XMU=RMSS(4) + TANB=RMSS(5) + + DMA=RMSS(19) + DTANB=TANB + DMQ=RMSS(10) + DMUR=RMSS(12) + DMDR=RMSS(11) + DMTOP=PMAS(6,1) + DMC=PMAS(PYCOMP(KSUSY1+37),1) + DAU=AT + DAD=AB + DMU=XMU + RMSS(40)=0D0 + RMSS(41)=0D0 + + IF(IHOPT.EQ.0) THEN + CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM, + & DMHCH,DSA,DCA,DTANBA) + ELSEIF(IHOPT.EQ.1) THEN + CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM, + & DMHCH,DSA,DCA,DTANBA) + CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU, + & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA, + & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB) + RMSS(40)=DDT + RMSS(41)=DDB + DMH=DMHP + DHM=DHMP + DMA=DAMP + IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN + WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM ' + WRITE(MSTU(11),*) ' STOP1 MASSES = ', + & PMAS(PYCOMP(1000006),1),DSTOP2 + ENDIF + IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN + WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM ' + WRITE(MSTU(11),*) ' STOP2 MASSES = ', + & PMAS(PYCOMP(2000006),1),DSTOP1 + ENDIF + IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN + WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM ' + WRITE(MSTU(11),*) ' SBOT1 MASSES = ', + & PMAS(PYCOMP(1000005),1),DSBOT2 + ENDIF + IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN + WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM ' + WRITE(MSTU(11),*) ' SBOT2 MASSES = ', + & PMAS(PYCOMP(2000005),1),DSBOT1 + ENDIF + + ELSEIF (IHOPT.EQ.3) THEN +c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de) +C...Currently only available for SLHA spectrum read-in. + IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN + CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY' + & //' spectrum, change IMSS(1) or IMSS(4) option.') + ENDIF + ALPHA=RMSS(18) + RETURN + ENDIF + + ALPHA=ACOS(DCA) + + PMAS(25,1)=DMH + PMAS(35,1)=DHM + PMAS(36,1)=DMA + PMAS(37,1)=DMHCH + + RETURN + END + +C********************************************************************* + +C...PYSUBH +C...This routine computes the renormalization group improved +C...values of Higgs masses and couplings in the MSSM. + +C...Program based on the work by M. Carena, J.R. Espinosa, +c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45 + +C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU +C...All masses in GeV units. MA is the CP-odd Higgs mass, +C...MTOP is the physical top mass, MQ and MUR are the soft +C...supersymmetry breaking mass parameters of left handed +C...and right handed stops respectively, AU and AD are the +C...stop and sbottom trilinear soft breaking terms, +C...respectively, and MU is the supersymmetric +C...Higgs mass parameter. We use the conventions from +C...the physics report of Haber and Kane: left right +C...stop mixing term proportional to (AU - MU/TANB) +C...We use as input TANB defined at the scale MTOP + +C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA +C...where MH and HM are the lightest and heaviest CP-even +C...Higgs masses, MHCH is the charged Higgs mass and +C...ALPHA is the Higgs mixing angle +C...TANBA is the angle TANB at the CP-odd Higgs mass scale + +C...Range of validity: +C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5 +C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5 +C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and +C...are the sbottom mass eigenvalues, respectively. This +C...range automatically excludes the existence of tachyons. +C...For the charged Higgs mass computation, the method is +C...valid if +C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2 +C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2 +C...where M_SUSY**2 is the average of the squared stop mass +C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom +C...masses have been assumed to be of order of the stop ones +C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2 + + SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM, + &XMHCH,SA,CA,TANBA) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYHTRI/HHH(7) + SAVE /PYDAT1/,/PYDAT2/ + +C...Local variables. + DOUBLE PRECISION PYALEM,PYALPS + DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM + DOUBLE PRECISION XMHCH,SA,CA + DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI + DOUBLE PRECISION Q02 + DOUBLE PRECISION TANBA,TANBT,XMB,ALP3 + DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB + DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6 + DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2 + DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT + DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2 + DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2 + DOUBLE PRECISION AU2,XMU2,XMZ,XMS3 + + XMZ = PMAS(23,1) + Q02=XMZ**2 + AEM=PYALEM(Q02) + ALP1=AEM/(1D0-PARU(102)) + ALP2=AEM/PARU(102) + ALPH3Z=PYALPS(Q02) + + ALP1 = 0.0101D0 + ALP2 = 0.0337D0 + ALPH3Z = 0.12D0 + + V = 174.1D0 + PI = PARU(1) + TANBA = TANB + TANBT = TANB + +C...MBOTTOM(MTOP) = 3. GEV + XMB = PYMRUN(5,XMTOP**2) + ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z* + &LOG(XMTOP**2/XMZ**2)) + +C...RMTOP= RUNNING TOP QUARK MASS + RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI) + XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0 + T = LOG(XMS**2/XMTOP**2) + SINB = TANB/((1D0 + TANB**2)**0.5D0) + COSB = SINB/TANB +C...IF(MA.LE.XMTOP) TANBA = TANBT + IF(XMA.GT.XMTOP) + &TANBA = TANBT*(1D0-3D0/32D0/PI**2* + &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)* + &LOG(XMA**2/XMTOP**2)) + + SINBT = TANBT/SQRT(1D0 + TANBT**2) + COSBT = 1D0/SQRT(1D0 + TANBT**2) +C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0) + G1 = SQRT(ALP1*4D0*PI) + G2 = SQRT(ALP2*4D0*PI) + G3 = SQRT(ALP3*4D0*PI) + HU = RMTOP/V/SINBT + HD = XMB/V/COSBT + HU2=HU*HU + HD2=HD*HD + HU4=HU2*HU2 + HD4=HD2*HD2 + AU2=AU**2 + AD2=AD**2 + XMS2=XMS**2 + XMS3=XMS**3 + XMS4=XMS2*XMS2 + XMU2=XMU*XMU + PI2=PI*PI + + XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2) + XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2) + AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4 + &+ 3D0*(AU + AD)**2/XMS2)/6D0 + XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2) + &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0 + &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2) + &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2 + &- 16D0*G3**2) *T/16D0/PI2) + XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2) + &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0 + &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2) + &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2 + &- 16D0*G3**2) *T/16D0/PI2) + XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0* + &(HU2 + HD2)*T/16D0/PI2) + &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2 + &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2) + &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/ + &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0 + &- 16D0*G3**2) *T/16D0/PI2) + &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/ + &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2 + &- 16D0*G3**2) *T/16D0/PI2) + XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2) + &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2 + &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2) + &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/ + &XMS4)* + &(1+ (6D0*HU2 -2D0* HD2 + &- 16D0*G3**2) *T/16D0/PI2) + &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/ + &XMS4)* + &(1+ (6D0*HD2 -2D0* HU2/2D0 + &- 16D0*G3**2) *T/16D0/PI2) + XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) * + &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2) + &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) * + &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2) + XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) * + &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2) + &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) * + &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2) + XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) * + &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2) + &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) * + &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2) + HHH(1)=XLAM1 + HHH(2)=XLAM2 + HHH(3)=XLAM3 + HHH(4)=XLAM4 + HHH(5)=XLAM5 + HHH(6)=XLAM6 + HHH(7)=XLAM7 + TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 + + &2D0* XLAM6*SINBT*COSBT + &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT + &+ XLAM5*COSBT**2) + DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) + + &XLAM6*COSBT**2 + &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 + + &2D0* XLAM6* COSBT*SINBT + &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 * + &((XLAM1* COSBT**2 +2D0* + &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 + + &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2) + &*SINBT**2 + &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3 + &+ XLAM4) + XLAM6*COSBT**2 + &+ XLAM7* SINBT**2)) + + XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0 + XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0 + XHM = SQRT(XHM2) + XMH = SQRT(XMH2) + XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2 + XMHCH = SQRT(XMHCH2) + + SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) - + &((2D0*V**2*(XLAM1* COSBT**2 + 2D0* + &XLAM6* COSBT*SINBT + &+ XLAM5*SINBT**2) + XMA**2*SINBT**2) + &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/ + &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0 + + COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) + + &XLAM6*COSBT**2 + XLAM7* SINBT**2) - + &XMA**2*SINBT*COSBT))/2D0**0.5D0/ + &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)* + &(((TRM2**2 - 4D0* DETM2)**0.5D0) - + &((2D0*V**2*(XLAM1* COSBT**2 + 2D0* + &XLAM6* COSBT*SINBT + &+ XLAM5*SINBT**2) + XMA**2*SINBT**2) + &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))) + + SA = -SINALP + CA = -COSALP + + 100 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYPOLE +C...This subroutine computes the CP-even higgs and CP-odd pole +c...Higgs masses and mixing angles. + +C...Program based on the work by M. Carena, M. Quiros +C...and C.E.M. Wagner, "Effective potential methods and +C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157 + +C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP, +C...AT,AB,MU +C...where MCHI is the largest chargino mass, MA is the running +C...CP-odd higgs mass, TANB is the value of the ratio of vacuum +C...expectaion values at the scale MTOP, MQ is the third generation +C...left handed squark mass parameter, MUR is the third generation +C...right handed stop mass parameter, MDR is the third generation +C...right handed sbottom mass parameter, MTOP is the pole top quark +C...mass; AT,AB are the soft supersymmetry breaking trilinear +C...couplings of the stop and sbottoms, respectively, and MU is the +C...supersymmetric mass parameter + +C...The parameter IHIGGS=0,1,2,3 corresponds to the number of +C...Higgses whose pole mass is computed. If IHIGGS=0 only running +C...masses are given, what makes the running of the program +c...much faster and it is quite generally a good approximation +c...(for a theoretical discussion see ref. above). If IHIGGS=1, +C...only the pole mass for H is computed. If IHIGGS=2, then h and H, +c...and if IHIGGS=3, then h,H,A polarizations are computed + +C...Output: MH and MHP which are the lightest CP-even Higgs running +C...and pole masses, respectively; HM and HMP are the heaviest CP-even +C...Higgs running and pole masses, repectively; SA and CA are the +C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle +C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2 +C...are the stop and sbottom mass eigenvalues. Finally, TANBA is +C...the value of TANB at the CP-odd Higgs mass scale + +C...This subroutine makes use of CERN library subroutine +C...integration package, which makes the computation of the +C...pole Higgs masses somewhat faster. We thank P. Janot for this +C...improvement. Those who are not able to call the CERN +C...libraries, please use the subroutine SUBHPOLE2.F, which +C...although somewhat slower, gives identical results + + SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU, + &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...Parameters. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + INTEGER PYK,PYCHGE,PYCOMP + +C...Local variables. + DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2), + &SSBOT2(2),B(2,2),COUPB(2,2), + &HCOUPT(2,2),HCOUPB(2,2), + &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3) + + DELTA(1,1) = 1D0 + DELTA(2,2) = 1D0 + DELTA(1,2) = 0D0 + DELTA(2,1) = 0D0 + V = 174.1D0 + XMZ=91.18D0 + PI=PARU(1) + RXMT=PYMRUN(6,XMT**2) + CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB, + &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB) + + SINB = TANB/(TANB**2+1D0)**0.5D0 + COSB = 1D0/(TANB**2+1D0)**0.5D0 + COS2B = SINB**2 - COSB**2 + SINBPA = SINB*CA + COSB*SA + COSBPA = COSB*CA - SINB*SA + RMBOT = PYMRUN(5,XMT**2) + XMQ2 = XMQ**2 + XMUR2 = XMUR**2 + IF(XMUR.LT.0D0) XMUR2=-XMUR2 + XMDR2 = XMDR**2 + XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B + XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B + IF(XMST11.LT.0D0) GOTO 500 + IF(XMST22.LT.0D0) GOTO 500 + XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B + XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B + IF(XMSB11.LT.0D0) GOTO 500 + IF(XMSB22.LT.0D0) GOTO 500 +C WMST11 = RXMT**2 + XMQ2 +C WMST22 = RXMT**2 + XMUR2 + XMST12 = RXMT*(AT - XMU/TANB) + XMSB12 = RMBOT*(AB - XMU*TANB) + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C...STOP EIGENVALUES CALCULATION +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + STOP12 = 0.5D0*(XMST11+XMST22) + + &0.5D0*((XMST11+XMST22)**2 - + &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0 + STOP22 = 0.5D0*(XMST11+XMST22) - + &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 - + &XMST12**2))**0.5D0 + + IF(STOP22.LT.0D0) GOTO 500 + SSTOP2(1) = STOP12 + SSTOP2(2) = STOP22 + STOP1 = STOP12**0.5D0 + STOP2 = STOP22**0.5D0 +C STOP1W = STOP1 +C STOP2W = STOP2 + + IF(XMST12.EQ.0D0) XST11 = 1D0 + IF(XMST12.EQ.0D0) XST12 = 0D0 + IF(XMST12.EQ.0D0) XST21 = 0D0 + IF(XMST12.EQ.0D0) XST22 = 1D0 + + IF(XMST12.EQ.0D0) GOTO 110 + + 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0 + XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0 + XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0 + XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0 + + 110 T(1,1) = XST11 + T(2,2) = XST22 + T(1,2) = XST12 + T(2,1) = XST21 + + SBOT12 = 0.5D0*(XMSB11+XMSB22) + + &0.5D0*((XMSB11+XMSB22)**2 - + &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0 + SBOT22 = 0.5D0*(XMSB11+XMSB22) - + &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 - + &XMSB12**2))**0.5D0 + IF(SBOT22.LT.0D0) GOTO 500 + SBOT1 = SBOT12**0.5D0 + SBOT2 = SBOT22**0.5D0 + + SSBOT2(1) = SBOT12 + SSBOT2(2) = SBOT22 + + IF(XMSB12.EQ.0D0) XSB11 = 1D0 + IF(XMSB12.EQ.0D0) XSB12 = 0D0 + IF(XMSB12.EQ.0D0) XSB21 = 0D0 + IF(XMSB12.EQ.0D0) XSB22 = 1D0 + + IF(XMSB12.EQ.0D0) GOTO 130 + + 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0 + XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0 + XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0 + XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0 + + 130 B(1,1) = XSB11 + B(2,2) = XSB22 + B(1,2) = XSB12 + B(2,1) = XSB21 + + + SINT = 0.2320D0 + SQR = DSQRT(2D0) + VP = 174.1D0*SQR + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C...STARTING OF LIGHT HIGGS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + IF(IHIGGS.EQ.0) GOTO 490 + + DO 150 I = 1,2 + DO 140 J = 1,2 + COUPT(I,J) = + & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) + + & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J)) + & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J) + & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) + + & T(1,J)*T(2,I)) + 140 CONTINUE + 150 CONTINUE + + + DO 170 I = 1,2 + DO 160 J = 1,2 + COUPB(I,J) = + & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) + + & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J)) + & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J) + & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) + + & B(1,J)*B(2,I)) + 160 CONTINUE + 170 CONTINUE + + PRUN = XMH + EPS = 1D-4*PRUN + ITER = 0 + 180 ITER = ITER + 1 + DO 230 I3 = 1,3 + + PR(I3)=PRUN+(I3-2)*EPS/2 + P2=PR(I3)**2 + POLT = 0D0 + DO 200 I = 1,2 + DO 190 J = 1,2 + POLT = POLT + COUPT(I,J)**2*3D0* + & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2 + 190 CONTINUE + 200 CONTINUE + + POLB = 0D0 + DO 220 I = 1,2 + DO 210 J = 1,2 + POLB = POLB + COUPB(I,J)**2*3D0* + & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2 + 210 CONTINUE + 220 CONTINUE +C RXMT2 = RXMT**2 + XMT2=XMT**2 + + POLTT = + & 3D0*RXMT**2/8D0/PI**2/ V **2* + & CA**2/SINB**2 * + & (-2D0*XMT**2+0.5D0*P2)* + & PYFINT(P2,XMT2,XMT2) + + POL = POLT + POLB + POLTT + POLAR(I3) = P2 - XMH**2 - POL + 230 CONTINUE + DERIV = (POLAR(3)-POLAR(1))/EPS + DRUN = - POLAR(2)/DERIV + PRUN = PRUN + DRUN + P2 = PRUN**2 + IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240 + GOTO 180 + 240 CONTINUE + + XMHP = DSQRT(P2) + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C...END OF LIGHT HIGGS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + 250 IF(IHIGGS.EQ.1) GOTO 490 + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C... STARTING OF HEAVY HIGGS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + DO 270 I = 1,2 + DO 260 J = 1,2 + HCOUPT(I,J) = + & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) + + & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J)) + & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J) + & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) + + & T(1,J)*T(2,I)) + 260 CONTINUE + 270 CONTINUE + + DO 290 I = 1,2 + DO 280 J = 1,2 + HCOUPB(I,J) = + & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) + + & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J)) + & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J) + & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) + + & B(1,J)*B(2,I)) + HCOUPB(I,J)=0D0 + 280 CONTINUE + 290 CONTINUE + + PRUN = HM + EPS = 1D-4*PRUN + ITER = 0 + 300 ITER = ITER + 1 + DO 350 I3 = 1,3 + PR(I3)=PRUN+(I3-2)*EPS/2 + HP2=PR(I3)**2 + + HPOLT = 0D0 + DO 320 I = 1,2 + DO 310 J = 1,2 + HPOLT = HPOLT + HCOUPT(I,J)**2*3D0* + & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2 + 310 CONTINUE + 320 CONTINUE + + HPOLB = 0D0 + DO 340 I = 1,2 + DO 330 J = 1,2 + HPOLB = HPOLB + HCOUPB(I,J)**2*3D0* + & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2 + 330 CONTINUE + 340 CONTINUE + +C RXMT2 = RXMT**2 + XMT2 = XMT**2 + + HPOLTT = + & 3D0*RXMT**2/8D0/PI**2/ V **2* + & SA**2/SINB**2 * + & (-2D0*XMT**2+0.5D0*HP2)* + & PYFINT(HP2,XMT2,XMT2) + + HPOL = HPOLT + HPOLB + HPOLTT + POLAR(I3) =HP2-HM**2-HPOL + 350 CONTINUE + DERIV = (POLAR(3)-POLAR(1))/EPS + DRUN = - POLAR(2)/DERIV + PRUN = PRUN + DRUN + HP2 = PRUN**2 + IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360 + GOTO 300 + 360 CONTINUE + + + 370 CONTINUE + HMP = HP2**0.5D0 + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C... END OF HEAVY HIGGS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + IF(IHIGGS.EQ.2) GOTO 490 + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C...BEGINNING OF PSEUDOSCALAR HIGGS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + DO 390 I = 1,2 + DO 380 J = 1,2 + ACOUPT(I,J) = + & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)* + & (T(1,I)*T(2,J) -T(1,J)*T(2,I)) + 380 CONTINUE + 390 CONTINUE + DO 410 I = 1,2 + DO 400 J = 1,2 + ACOUPB(I,J) = + & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)* + & (B(1,I)*B(2,J) -B(1,J)*B(2,I)) + 400 CONTINUE + 410 CONTINUE + + PRUN = XMA + EPS = 1D-4*PRUN + ITER = 0 + 420 ITER = ITER + 1 + DO 470 I3 = 1,3 + PR(I3)=PRUN+(I3-2)*EPS/2 + AP2=PR(I3)**2 + APOLT = 0D0 + DO 440 I = 1,2 + DO 430 J = 1,2 + APOLT = APOLT + ACOUPT(I,J)**2*3D0* + & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2 + 430 CONTINUE + 440 CONTINUE + APOLB = 0D0 + DO 460 I = 1,2 + DO 450 J = 1,2 + APOLB = APOLB + ACOUPB(I,J)**2*3D0* + & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2 + 450 CONTINUE + 460 CONTINUE +C RXMT2 = RXMT**2 + XMT2=XMT**2 + APOLTT = + & 3D0*RXMT**2/8D0/PI**2/ V **2* + & COSB**2/SINB**2 * + & (-0.5D0*AP2)* + & PYFINT(AP2,XMT2,XMT2) + APOL = APOLT + APOLB + APOLTT + POLAR(I3) = AP2 - XMA**2 -APOL + 470 CONTINUE + DERIV = (POLAR(3)-POLAR(1))/EPS + DRUN = - POLAR(2)/DERIV + PRUN = PRUN + DRUN + AP2 = PRUN**2 + IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480 + GOTO 420 + 480 CONTINUE + + AMP = DSQRT(AP2) + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C...END OF PSEUDOSCALAR HIGGS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + IF(IHIGGS.EQ.3) GOTO 490 + + 490 CONTINUE + RETURN + 500 CONTINUE + WRITE(MSTU(11),*) ' EXITING IN PYPOLE ' + WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22 + WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22 + WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22 + CALL PYSTOP(107) + END + +C********************************************************************* + +C...PYRGHM +C...Auxiliary to PYPOLE. + + SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU, + * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB) + IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z) + DIMENSION VH(2,2),M2(2,2),M2P(2,2) +C...Parameters. + INTEGER MSTU,MSTJ + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + + MZ = 91.18D0 + PI = PARU(1) + V = 174.1D0 + ALPHA1 = 0.0101D0 + ALPHA2 = 0.0337D0 + ALPHA3Z = 0.12D0 + TANBA = TANB + TANBT = TANB +C MBOTTOM(MTOP) = 3. GEV + MB = PYMRUN(5,MTOP**2) + ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z* + *LOG(MTOP**2/MZ**2)) +C RMTOP= RUNNING TOP QUARK MASS + RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI) + TQ = LOG((MQ**2+MTOP**2)/MTOP**2) + TU = LOG((MUR**2 + MTOP**2)/MTOP**2) + TD = LOG((MD**2 + MTOP**2)/MTOP**2) +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C NEW DEFINITION, TGLU. +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + TGLU = LOG(MGLU**2/MTOP**2) + SINB = TANB/DSQRT(1D0 + TANB**2) + COSB = SINB/TANB + IF(MA.GT.MTOP) + *TANBA = TANB*(1D0-3D0/32D0/PI**2* + *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)* + *LOG(MA**2/MTOP**2)) + IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA + SINB = TANBT/SQRT(1D0 + TANBT**2) + COSB = 1D0/DSQRT(1D0 + TANBT**2) + G1 = SQRT(ALPHA1*4D0*PI) + G2 = SQRT(ALPHA2*4D0*PI) + G3 = SQRT(ALPHA3*4D0*PI) + HU = RMTOP/V/SINB + HD = MB/V/COSB + CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2, + *SBOT1,SBOT2,DELTAMT,DELTAMB) + IF(MQ.GT.MUR) TP = TQ - TU + IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ + IF(MQ.GT.MUR) TDP = TU + IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ + IF(MQ.GT.MD) TPD = TQ - TD + IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ + IF(MQ.GT.MD) TDPD = TD + IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ + + IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD + IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2* + * HD**2*(G1**2/3D0+G2**2)*TPD + + IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP + IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2* + * HU**2*(-G1**2/3D0+G2**2)*TP + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO +C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL, +C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE +C TWO STOPS. +C +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + DLAMBDAP2 = 0D0 + IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN + IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN + DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2) + ENDIF + + IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN + DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2) + ENDIF + + IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN + DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2) + ENDIF + + IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN + DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2) + ENDIF + + IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN + DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2) + ENDIF + + IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN + DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2) + ENDIF + ENDIF + DLAMBDA3 = 0D0 + DLAMBDA4 = 0D0 + IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD + IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2* + *(G2**2-G1**2/3D0)*TPD + IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 - + *1D0/16D0/PI**2*G1**2*HU**2*TP + IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 + + * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP + IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP + IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2* + *HD**2*TPD + LAMBDA1 = ((G1**2 + G2**2)/4D0)* + * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2) + *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0 + *+ (3D0*HD**2/2D0 + HU**2/2D0 + *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2) + *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0 + *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1 + LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2* + *(TP + TDP)/8D0/PI**2) + *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0 + *+ (3D0*HU**2/2D0 + HD**2/2D0 + *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2) + *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0 + *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2 + LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0* + *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0* + *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3 + LAMBDA4 = (- G2**2/2D0)*(1D0 + *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2 + *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4 + + LAMBDA5 = 0D0 + LAMBDA6 = 0D0 + LAMBDA7 = 0D0 + + M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6* + *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2 + + M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7* + *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2 + M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)* + *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB + + M2(2,1) = M2(1,2) +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2) + + IF(MCHI.GT.MSSUSY) GOTO 100 + IF(MCHI.LT.MTOP) MCHI=MTOP + + TCHAR=LOG(MSSUSY**2/MCHI**2) + + DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR + DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4 + *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR + + DELTAM112=2D0*DELTAL12*V**2*COSB**2 + DELTAM222=2D0*DELTAL12*V**2*SINB**2 + DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB + + M2(1,1)=M2(1,1)+DELTAM112 + M2(2,2)=M2(2,2)+DELTAM222 + M2(1,2)=M2(1,2)+DELTAM122 + M2(2,1)=M2(2,1)+DELTAM122 + + 100 CONTINUE + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCC END OF CHARGINOS/NEUTRALINOS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + DO 120 I = 1,2 + DO 110 J = 1,2 + M2P(I,J) = M2(I,J) + VH(I,J) + 110 CONTINUE + 120 CONTINUE + TRM2P = M2P(1,1) + M2P(2,2) + DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1) + MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0 + HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0 + HMP = DSQRT(HM2P) + MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2 + MCH=DSQRT(MCH2) + IF(MH2P.LT.0.) GOTO 130 + MHP = SQRT(MH2P) + SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P) + COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P) + IF(COS2ALPHA.GE.0.) THEN + ALPHA = ASIN(SIN2ALPHA)/2D0 + ELSE + ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0 + ENDIF + SA = SIN(ALPHA) + CA = COS(ALPHA) +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER +C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND +C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK. +C +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB)) + CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB)) + 130 CONTINUE + RETURN + END + +C********************************************************************* + +C...PYGFXX +C...Auxiliary to PYRGHM. + + SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH, + * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB) + IMPLICIT DOUBLE PRECISION(A-H,M,O-Z) + DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2) +C...Commonblocks. + INTEGER MSTU,MSTJ,KCHG + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ + + G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y) + + T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2) + * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2)) + + IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0 + MQ2 = MQ**2 + MUR2 = MUR**2 + MD2 = MD**2 + TANBA = TANB + SINBA = TANBA/DSQRT(TANBA**2+1D0) + COSBA = SINBA/TANBA + + SINB = TANB/DSQRT(TANB**2+1D0) + COSB = SINB/TANB + + PI = PARU(1) + MZ = PMAS(23,1) + MW = PMAS(24,1) + SW = 1D0-MW**2/MZ**2 + V = 174.1D0 + + ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2)) + G2 = DSQRT(0.0336D0*4D0*PI) + G1 = DSQRT(0.0101D0*4D0*PI) + + IF(MQ.GT.MUR) MST = MQ + IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR + + MSUSYT = DSQRT(MST**2 + MTOP**2) + + IF(MQ.GT.MD) MSB = MQ + IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD + + MB = PYMRUN(5,MSB**2) + MSUSYB = DSQRT(MSB**2 + MB**2) + TT = LOG(MSUSYT**2/MTOP**2) + TB = LOG(MSUSYB**2/MTOP**2) + + RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI) + HT = RMTOP/(V*SINB) + HTST = RMTOP/V + HB = MB/V/COSB + G32 = ALPHA3*4D0*PI + BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2 + BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2 + AL2 = 3D0/8D0/PI**2*HT**2 +C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2 +C ALST = 3./8./PI**2*HTST**2 + AL1 = 3D0/8D0/PI**2*HB**2 + + AL(1,1) = AL1 + AL(1,2) = (AL2+AL1)/2D0 + AL(2,1) = (AL2+AL1)/2D0 + AL(2,2) = AL2 + + IF(MA.GT.MTOP) THEN + VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2* + * LOG(MTOP**2/MA**2)) + H1I = VI* COSBA + H2I = VI*SINBA + H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0 + H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0 + H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0 + H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0 + ELSE + VI = V + H1I = VI*COSB + H2I = VI*SINB + H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0 + H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0 + H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0 + H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0 + ENDIF + + TANBST = H2T/H1T + SINBT = TANBST/DSQRT(1D0+TANBST**2) + + TANBSB = H2B/H1B + SINBB = TANBSB/DSQRT(1D0+TANBSB**2) + COSBB = SINBB/TANBSB + + DELTAMT = 0D0 + DELTAMB = 0D0 + + MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT) + MTOP2 = DSQRT(MTOP4) + MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB) + * /(1D0+DELTAMB)**4 + MBOT2 = DSQRT(MBOT4) + + STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2 + * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) + * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + + * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2) + STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2 + * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) + * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + + * MQ2 - MUR2)**2*0.25D0 + * + MTOP2*(AT-XMU/TANBST)**2) + IF(STOP22.LT.0.) GOTO 120 + SBOT12 = (MQ2 + MD2)*.5D0 + * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) + * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + + * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2) + SBOT22 = (MQ2 + MD2)*.5D0 + * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) + * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + + * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2) + IF(SBOT22.LT.0.) SBOT22 = 10000D0 + + STOP1 = DSQRT(STOP12) + STOP2 = DSQRT(STOP22) + SBOT1 = DSQRT(SBOT12) + SBOT2 = DSQRT(SBOT22) + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH +C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK +C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING +C INDUCED CORRECTIONS. +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + X=SBOT1 + Y=SBOT2 + Z=XMGL + IF(X.EQ.Y) X = X - 0.00001D0 + IF(X.EQ.Z) X = X - 0.00002D0 + IF(Y.EQ.Z) Y = Y - 0.00003D0 + + T1=T(X,Y,Z) + X=STOP1 + Y=STOP2 + Z=XMU + IF(X.EQ.Y) X = X - 0.00001D0 + IF(X.EQ.Z) X = X - 0.00002D0 + IF(Y.EQ.Z) Y = Y - 0.00003D0 + T2=T(X,Y,Z) + DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1 + * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2 + X=STOP1 + Y=STOP2 + Z=XMGL + IF(X.EQ.Y) X = X - 0.00001D0 + IF(X.EQ.Z) X = X - 0.00002D0 + IF(Y.EQ.Z) Y = Y - 0.00003D0 + T3=T(X,Y,Z) + DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3 + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT +C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE +C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT +C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB. +C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED +C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA, +C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA, +C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP +C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE +C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE +C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES ! +C +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT) + MTOP2 = DSQRT(MTOP4) + MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB) + * /(1D0+DELTAMB)**4 + MBOT2 = DSQRT(MBOT4) + + STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2 + * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) + * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + + * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2) + STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2 + * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2) + * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) + + * MQ2 - MUR2)**2*0.25D0 + * + MTOP2*(AT-XMU/TANBST)**2) + + IF(STOP22.LT.0.) GOTO 120 + SBOT12 = (MQ2 + MD2)*.5D0 + * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) + * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + + * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2) + SBOT22 = (MQ2 + MD2)*.5D0 + * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2) + * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) + + * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2) + IF(SBOT22.LT.0.) GOTO 120 + + + STOP1 = DSQRT(STOP12) + STOP2 = DSQRT(STOP22) + SBOT1 = DSQRT(SBOT12) + SBOT2 = DSQRT(SBOT22) + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +CCC D-TERMS +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + STW=SW + + F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)* + * LOG(STOP1/STOP2) + * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2)) + * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2)) + + F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)* + * LOG(SBOT1/SBOT2) + * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2)) + * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2)) + + F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)* + * (-.5D0*LOG(STOP12/STOP22) + * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)* + * G(STOP12,STOP22)) + + F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)* + * (.5D0*LOG(SBOT12/SBOT22) + * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)* + * G(SBOT12,SBOT22)) + + VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/ + * (MQ2+MBOT2)/(MD2+MBOT2)) + * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))* + * LOG(SBOT1**2/SBOT2**2)) + + * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/ + * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22) + + VH3T(1,1) = + * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2 + * -STOP2**2))**2*G(STOP12,STOP22) + + VH3B(1,1)=VH3B(1,1)+ + * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B) + + VH3T(1,1) = VH3T(1,1) + + * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T) + + VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/ + * (MQ2+MTOP2)/(MUR2+MTOP2)) + * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))* + * LOG(STOP1**2/STOP2**2)) + + * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/ + * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22) + + VH3B(2,2) = + * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2 + * -SBOT2**2))**2*G(SBOT12,SBOT22) + + VH3T(2,2)=VH3T(2,2)+ + * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T) + VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B + VH3T(1,2) = - + * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/ + * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT* + * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22)) + + VH3B(1,2) = + * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/ + * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB* + * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22)) + + + VH3T(1,2)=VH3T(1,2) + + *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T) + + VH3B(1,2)=VH3B(1,2) + + *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B) + + VH3T(2,1) = VH3T(1,2) + VH3B(2,1) = VH3B(1,2) + +C TQ = LOG((MQ2 + MTOP2)/MTOP2) +C TU = LOG((MUR2+MTOP2)/MTOP2) +C TQD = LOG((MQ2 + MB**2)/MB**2) +C TD = LOG((MD2+MB**2)/MB**2) + + DO 110 I = 1,2 + DO 100 J = 1,2 + VH(I,J) = + * 6D0/(8D0*PI**2*(H1T**2+H2T**2)) + * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) + + * 6D0/(8D0*PI**2*(H1B**2+H2B**2)) + * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0) + 100 CONTINUE + 110 CONTINUE + + GOTO 150 + 120 DO 140 I =1,2 + DO 130 J = 1,2 + VH(I,J) = -1D15 + 130 CONTINUE + 140 CONTINUE + + + 150 RETURN + END + + + + + +C********************************************************************* + +C...PYFINT +C...Auxiliary routine to PYPOLE for SUSY Higgs calculations. + + FUNCTION PYFINT(A,B,C) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblock. + COMMON/PYINTS/XXM(20) + SAVE/PYINTS/ + +C...Local variables. + EXTERNAL PYFISB + DOUBLE PRECISION PYFISB + + XXM(1)=A + XXM(2)=B + XXM(3)=C + XLO=0D0 + XHI=1D0 + PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3) + + RETURN + END + +C********************************************************************* + +C...PYFISB +C...Auxiliary routine to PYFINT for SUSY Higgs calculations. + + FUNCTION PYFISB(X) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblock. + COMMON/PYINTS/XXM(20) + SAVE/PYINTS/ + + PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/ + &(X*(XXM(2)-XXM(3))+XXM(3))) + + RETURN + END + +C********************************************************************* + +C...PYSFDC +C...Calculates decays of sfermions. + + SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ + +C...Local variables. + COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2) + COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB + INTEGER KFIN,KCIN + DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ + DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP + DOUBLE PRECISION PYLAMF,XL + DOUBLE PRECISION TANW,XW,AEM,C1,AS + DOUBLE PRECISION AL,AR,BL,BR + DOUBLE PRECISION CH1,CH2,CH3,CH4 + DOUBLE PRECISION XMBOT,XMTOP + DOUBLE PRECISION XLAM(0:400) + INTEGER IDLAM(400,3) + INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II + DOUBLE PRECISION SR2 + DOUBLE PRECISION CBETA,SBETA + DOUBLE PRECISION CW + DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL + DOUBLE PRECISION COSA,SINA,TANB + DOUBLE PRECISION PYALEM,PI,PYALPS,EI + DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR + INTEGER IG,KF1,KF2 + INTEGER IGG(4),KFNCHI(4),KFCCHI(2) + DATA IGG/23,25,35,36/ + DATA PI/3.141592654D0/ + DATA SR2/1.4142136D0/ + DATA KFNCHI/1000022,1000023,1000025,1000035/ + DATA KFCCHI/1000024,1000037/ + +C...COUNT THE NUMBER OF DECAY MODES + LKNT=0 + +C...NO NU_R DECAYS + IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR. + &KFIN.EQ.KSUSY2+16) RETURN + + XMW=PMAS(24,1) + XMW2=XMW**2 + XMZ=PMAS(23,1) + XW=PARU(102) + TANW = SQRT(XW/(1D0-XW)) + CW=SQRT(1D0-XW) + + DO 110 I=1,4 + DO 100 J=1,4 + ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I)) + 100 CONTINUE + 110 CONTINUE + DO 130 I=1,2 + DO 120 J=1,2 + VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I)) + UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I)) + 120 CONTINUE + 130 CONTINUE + +C...KCIN + KCIN=PYCOMP(KFIN) +C...ILR is 1 for left and 2 for right. + ILR=KFIN/KSUSY1 +C...IFL is matching non-SUSY flavour. + IFL=MOD(KFIN,KSUSY1) +C...IDU is weak isospin, 1 for down and 2 for up. + IDU=2-MOD(IFL,2) + + XMI=PMAS(KCIN,1) + XMI2=XMI**2 + AEM=PYALEM(XMI2) + AS =PYALPS(XMI2) + C1=AEM/XW + XMI3=XMI**3 + EI=KCHG(IFL,1)/3D0 + + XMBOT=PYMRUN(5,XMI2) + XMTOP=PYMRUN(6,XMI2) + + TANB=RMSS(5) + BETA=ATAN(TANB) + ALFA=RMSS(18) + CBETA=COS(BETA) + SBETA=TANB*CBETA + SINA=SIN(ALFA) + COSA=COS(ALFA) + XMU=-RMSS(4) + ATRIT=RMSS(16) + ATRIB=RMSS(15) + ATRIL=RMSS(17) + +C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION + + IF(IMSS(11).EQ.1) THEN + XMP=RMSS(29) + IDG=39+KSUSY1 + XMGR=PMAS(PYCOMP(IDG),1) + XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI + IF(IFL.EQ.5) THEN + XMF=XMBOT + ELSEIF(IFL.EQ.6) THEN + XMF=XMTOP + ELSE + XMF=PMAS(IFL,1) + ENDIF + IF(XMI.GT.XMGR+XMF) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=IFL + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4 + ENDIF + ENDIF + +C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO + +C...CHARGED DECAYS: + DO 140 IX=1,2 +C...DI -> U CHI1-,CHI2- + IF(IDU.EQ.1) THEN + XMFP=PMAS(IFL+1,1) + XMF =PMAS(IFL,1) +C...UI -> D CHI1+,CHI2+ + ELSE + XMFP=PMAS(IFL-1,1) + XMF =PMAS(IFL,1) + ENDIF + XMJ=SMW(IX) + AXMJ=ABS(XMJ) + IF(XMI.GE.AXMJ+XMFP) THEN + XMA2=XMJ**2 + XMB2=XMFP**2 + IF(IDU.EQ.2) THEN + IF(IFL.EQ.6) THEN + XMFP=XMBOT + XMF =XMTOP + ELSEIF(IFL.LT.6) THEN + XMF=0D0 + XMFP=0D0 + ENDIF + CBL=VMIXC(IX,1) + CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA + CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA + CAR=0D0 + ELSE + IF(IFL.EQ.5) THEN + XMF =XMBOT + XMFP=XMTOP + ELSEIF(IFL.LT.5) THEN + XMF=0D0 + XMFP=0D0 + ENDIF + CBL=UMIXC(IX,1) + CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA + CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA + CAR=0D0 + ENDIF + + CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR + CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR + CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL + CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL + CAL=CALP + CBL=CBLP + CAR=CARP + CBR=CBRP + +C...F1 -> F` CHI + IF(ILR.EQ.1) THEN + CA=CAL + CB=CBL +C...F2 -> F` CHI + ELSE + CA=CAR + CB=CBR + ENDIF + LKNT=LKNT+1 + XL=PYLAMF(XMI2,XMA2,XMB2) +C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT + XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)* + & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP) + IDLAM(LKNT,3)=0 + IF(IDU.EQ.1) THEN + IDLAM(LKNT,1)=-KFCCHI(IX) + IDLAM(LKNT,2)=IFL+1 + ELSE + IDLAM(LKNT,1)=KFCCHI(IX) + IDLAM(LKNT,2)=IFL-1 + ENDIF + ENDIF + 140 CONTINUE + +C...NEUTRAL DECAYS + DO 150 IX=1,4 +C...DI -> D CHI10 + XMF=PMAS(IFL,1) + XMJ=SMZ(IX) + AXMJ=ABS(XMJ) + IF(XMI.GE.AXMJ+XMF) THEN + XMA2=XMJ**2 + XMB2=XMF**2 + IF(IDU.EQ.1) THEN + IF(IFL.EQ.5) THEN + XMF=XMBOT + ELSEIF(IFL.LT.5) THEN + XMF=0D0 + ENDIF + CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1) + CAL=XMF*ZMIXC(IX,3)/XMW/CBETA + CAR=-2D0*EI*TANW*ZMIXC(IX,1) + CBR=CAL + ELSE + IF(IFL.EQ.6) THEN + XMF=XMTOP + ELSEIF(IFL.LT.5) THEN + XMF=0D0 + ENDIF + CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1) + CAL=XMF*ZMIXC(IX,4)/XMW/SBETA + CAR=-2D0*EI*TANW*ZMIXC(IX,1) + CBR=CAL + ENDIF + + CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR + CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR + CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL + CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL + CAL=CALP + CBL=CBLP + CAR=CARP + CBR=CBRP + +C...F1 -> F CHI + IF(ILR.EQ.1) THEN + CA=CAL + CB=CBL +C...F2 -> F CHI + ELSE + CA=CAR + CB=CBR + ENDIF + LKNT=LKNT+1 + XL=PYLAMF(XMI2,XMA2,XMB2) +C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT + XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)* + & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF) + IDLAM(LKNT,1)=KFNCHI(IX) + IDLAM(LKNT,2)=IFL + IDLAM(LKNT,3)=0 + ENDIF + 150 CONTINUE + +C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS +C...IG=23,25,35,36 + DO 160 II=1,4 + IG=IGG(II) + IF(ILR.EQ.1) GOTO 160 + XMB=PMAS(IG,1) + XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1) + IF(XMI.LT.XMSF1+XMB) GOTO 160 + IF(IG.EQ.23) THEN + BL=-SIGN(.5D0,EI)/CW+EI*XW/CW + BR=EI*XW/CW + BLR=0D0 + ELSEIF(IG.EQ.25) THEN + IF(IFL.EQ.5) THEN + XMF=XMBOT + ELSEIF(IFL.EQ.6) THEN + XMF=XMTOP + ELSEIF(IFL.LT.5) THEN + XMF=0D0 + ELSE + XMF=PMAS(IFL,1) + ENDIF + IF(IDU.EQ.2) THEN + GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+ + & XMF**2/XMW*COSA/SBETA + GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+ + & XMF**2/XMW*COSA/SBETA + ELSE + GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+ + & XMF**2/XMW*(-SINA)/CBETA + GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+ + & XMF**2/XMW*(-SINA)/CBETA + ENDIF + IF(IFL.EQ.5) THEN + AT=ATRIB + ELSEIF(IFL.EQ.6) THEN + AT=ATRIT + ELSEIF(IFL.EQ.15) THEN + AT=ATRIL + ELSE + AT=0D0 + ENDIF +C.........need to complexify + IF(IDU.EQ.2) THEN + GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+ + & AT*COSA) + ELSE + GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA- + & AT*SINA) + ENDIF + BL=GHLL + BR=GHRR + BLR=-GHLR + ELSEIF(IG.EQ.35) THEN + IF(IFL.EQ.5) THEN + XMF=XMBOT + ELSEIF(IFL.EQ.6) THEN + XMF=XMTOP + ELSEIF(IFL.LT.5) THEN + XMF=0D0 + ELSE + XMF=PMAS(IFL,1) + ENDIF + IF(IDU.EQ.2) THEN + GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+ + & XMF**2/XMW*SINA/SBETA + GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+ + & XMF**2/XMW*SINA/SBETA + ELSE + GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+ + & XMF**2/XMW*COSA/CBETA + GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+ + & XMF**2/XMW*COSA/CBETA + ENDIF + IF(IFL.EQ.5) THEN + AT=ATRIB + ELSEIF(IFL.EQ.6) THEN + AT=ATRIT + ELSEIF(IFL.EQ.15) THEN + AT=ATRIL + ELSE + AT=0D0 + ENDIF +C.........Need to complexify + IF(IDU.EQ.2) THEN + GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+ + & AT*SINA) + ELSE + GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+ + & AT*COSA) + ENDIF + BL=GHLL + BR=GHRR + BLR=GHLR + ELSEIF(IG.EQ.36) THEN + GHLL=0D0 + GHRR=0D0 + IF(IFL.EQ.5) THEN + XMF=XMBOT + ELSEIF(IFL.EQ.6) THEN + XMF=XMTOP + ELSEIF(IFL.LT.5) THEN + XMF=0D0 + ELSE + XMF=PMAS(IFL,1) + ENDIF + IF(IFL.EQ.5) THEN + AT=ATRIB + ELSEIF(IFL.EQ.6) THEN + AT=ATRIT + ELSEIF(IFL.EQ.15) THEN + AT=ATRIL + ELSE + AT=0D0 + ENDIF +C.........Need to complexify + IF(IDU.EQ.2) THEN + GHLR=XMF/2D0/XMW*(-XMU+AT/TANB) + ELSE + GHLR=XMF/2D0/XMW/(-XMU+AT*TANB) + ENDIF + BL=GHLL + BR=GHRR + BLR=GHLR + ENDIF + AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+ + & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+ + & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR + XL=PYLAMF(XMI2,XMSF1**2,XMB**2) + LKNT=LKNT+1 + IF(IG.EQ.23) THEN + XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2 + ELSE + XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2 + ENDIF + IDLAM(LKNT,3)=0 + IDLAM(LKNT,1)=KFIN-KSUSY1 + IDLAM(LKNT,2)=IG + 160 CONTINUE + +C...SF -> SF' + W + XMB=PMAS(24,1) + IF(MOD(IFL,2).EQ.0) THEN + KF1=KSUSY1+IFL-1 + ELSE + KF1=KSUSY1+IFL+1 + ENDIF + KF2=KF1+KSUSY1 + XMSF1=PMAS(PYCOMP(KF1),1) + XMSF2=PMAS(PYCOMP(KF2),1) + IF(XMI.GT.XMB+XMSF1) THEN + IF(MOD(IFL,2).EQ.0) THEN + IF(ILR.EQ.1) THEN + AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1) + ELSE + AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1) + ENDIF + ELSE + IF(ILR.EQ.1) THEN + AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1) + ELSE + AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1) + ENDIF + ENDIF + XL=PYLAMF(XMI2,XMSF1**2,XMB**2) + LKNT=LKNT+1 + XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2 + IDLAM(LKNT,3)=0 + IDLAM(LKNT,1)=KF1 + IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1)) + ENDIF + IF(XMI.GT.XMB+XMSF2) THEN + IF(MOD(IFL,2).EQ.0) THEN + IF(ILR.EQ.1) THEN + AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3) + ELSE + AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3) + ENDIF + ELSE + IF(ILR.EQ.1) THEN + AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3) + ELSE + AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3) + ENDIF + ENDIF + XL=PYLAMF(XMI2,XMSF2**2,XMB**2) + LKNT=LKNT+1 + XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2 + IDLAM(LKNT,3)=0 + IDLAM(LKNT,1)=KF2 + IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1)) + ENDIF + +C...SF -> SF' + HC + XMB=PMAS(37,1) + IF(MOD(IFL,2).EQ.0) THEN + KF1=KSUSY1+IFL-1 + ELSE + KF1=KSUSY1+IFL+1 + ENDIF + KF2=KF1+KSUSY1 + XMSF1=PMAS(PYCOMP(KF1),1) + XMSF2=PMAS(PYCOMP(KF2),1) + IF(XMI.GT.XMB+XMSF1) THEN + XMF=0D0 + XMFP=0D0 + AT=0D0 + AB=0D0 + IF(MOD(IFL,2).EQ.0) THEN +C...T1-> B1 HC + IF(ILR.EQ.1) THEN + CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1) + CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2) + CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2) + CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1) +C...T2-> B1 HC + ELSE + CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1) + CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2) + CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2) + CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1) + ENDIF + IF(IFL.EQ.6) THEN + XMF=XMTOP + XMFP=XMBOT + AT=ATRIT + AB=ATRIB + ENDIF + ELSE +C...B1 -> T1 HC + IF(ILR.EQ.1) THEN + CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1) + CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2) + CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2) + CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1) +C...B2-> T1 HC + ELSE + CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1) + CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2) + CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1) + CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2) + ENDIF + IF(IFL.EQ.5) THEN + XMF=XMTOP + XMFP=XMBOT + AT=ATRIT + AB=ATRIB + ENDIF + ENDIF + XL=PYLAMF(XMI2,XMSF1**2,XMB**2) + LKNT=LKNT+1 +C.......Need to complexify + AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+ + & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+ + & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB) + XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2 + IDLAM(LKNT,3)=0 + IDLAM(LKNT,1)=KF1 + IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1)) + ENDIF + IF(XMI.GT.XMB+XMSF2) THEN + XMF=0D0 + XMFP=0D0 + AT=0D0 + AB=0D0 + IF(MOD(IFL,2).EQ.0) THEN +C...T1-> B2 HC + IF(ILR.EQ.1) THEN + CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1) + CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2) + CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1) + CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2) +C...T2-> B2 HC + ELSE + CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3) + CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4) + CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4) + CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3) + ENDIF + IF(IFL.EQ.6) THEN + XMF=XMTOP + XMFP=XMBOT + AT=ATRIT + AB=ATRIB + ENDIF + ELSE +C...B1 -> T2 HC + IF(ILR.EQ.1) THEN + CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1) + CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2) + CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2) + CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1) +C...B2-> T2 HC + ELSE + CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3) + CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4) + CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4) + CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3) + ENDIF + IF(IFL.EQ.5) THEN + XMF=XMTOP + XMFP=XMBOT + AT=ATRIT + AB=ATRIB + ENDIF + ENDIF + XL=PYLAMF(XMI2,XMSF1**2,XMB**2) + LKNT=LKNT+1 +C.......Need to complexify + AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+ + & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+ + & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB) + XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2 + IDLAM(LKNT,3)=0 + IDLAM(LKNT,1)=KF2 + IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1)) + ENDIF + +C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO + + IF(IFL.LE.6) THEN + XMFP=0D0 + XMF=0D0 + IF(IFL.EQ.6) XMF=PMAS(6,1) + IF(IFL.EQ.5) XMF=PMAS(5,1) + XMJ=PMAS(PYCOMP(KSUSY1+21),1) + AXMJ=ABS(XMJ) + IF(XMI.GE.AXMJ+XMF) THEN + AL=-SFMIX(IFL,3) + BL=SFMIX(IFL,1) + AR=-SFMIX(IFL,4) + BR=SFMIX(IFL,2) +C...F1 -> F CHI + IF(ILR.EQ.1) THEN + XCA=AL + XCB=BL +C...F2 -> F CHI + ELSE + XCA=AR + XCB=BR + ENDIF + LKNT=LKNT+1 + XMA2=XMJ**2 + XMB2=XMF**2 + XL=PYLAMF(XMI2,XMA2,XMB2) + XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)* + & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF) + IDLAM(LKNT,1)=KSUSY1+21 + IDLAM(LKNT,2)=IFL + IDLAM(LKNT,3)=0 + ENDIF + ENDIF + +C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0 + IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT. + &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN +C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE +C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI) +C...M*M = C1**2 * G**2/(16PI**2) +C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3) + LKNT=LKNT+1 + XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2) + XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL) + IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3 + IDLAM(LKNT,1)=KSUSY1+22 + IDLAM(LKNT,2)=4 + IDLAM(LKNT,3)=0 + ENDIF + +C...R-violating sfermion decays (SKANDS). + CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT) + + IKNT=LKNT + XLAM(0)=0D0 + DO 170 I=1,IKNT + IF(XLAM(I).LT.0D0) XLAM(I)=0D0 + XLAM(0)=XLAM(0)+XLAM(I) + 170 CONTINUE + IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3 + + RETURN + END + +C********************************************************************* + +C...PYGLUI +C...Calculates gluino decay modes. + + SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) +CC &SFMIX(16,4), +C COMMON/PYINTS/XXM(20) + COMPLEX*16 CXC + COMMON/PYINTC/XXC(10),CXC(8) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/ + +C...Local variables + COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ + DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI + DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP + DOUBLE PRECISION PYLAMF,XL + DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN + DOUBLE PRECISION CA,CB,AL,AR,BL,BR + DOUBLE PRECISION XLAM(0:400) + INTEGER IDLAM(400,3) + INTEGER LKNT,IX,ILR,I,IKNT,IFL + DOUBLE PRECISION SR2 + DOUBLE PRECISION GAM + DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I + EXTERNAL PYGAUS,PYXXZ6 + DOUBLE PRECISION PYGAUS,PYXXZ6 + DOUBLE PRECISION PREC + INTEGER KFNCHI(4),KFCCHI(2) + DATA PI/3.141592654D0/ + DATA SR2/1.4142136D0/ + DATA PREC/1D-2/ + DATA KFNCHI/1000022,1000023,1000025,1000035/ + DATA KFCCHI/1000024,1000037/ + +C...COUNT THE NUMBER OF DECAY MODES + LKNT=0 + IF(KFIN.NE.KSUSY1+21) RETURN + KCIN=PYCOMP(KFIN) + + XW=PARU(102) + TANW = SQRT(XW/(1D0-XW)) + + XMI=PMAS(KCIN,1) + AXMI=ABS(XMI) + XMI2=XMI**2 + AEM=PYALEM(XMI2) + AS =PYALPS(XMI2) + C1=AEM/XW + XMI3=AXMI**3 + + XMI=SIGN(XMI,RMSS(3)) + +C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON + + IF(IMSS(11).EQ.1) THEN + XMP=RMSS(29) + IDG=39+KSUSY1 + XMGR=PMAS(PYCOMP(IDG),1) + XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI + IF(AXMI.GT.XMGR) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=21 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC + ENDIF + ENDIF + +C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK + + DO 110 IFL=1,6 + DO 100 ILR=1,2 + XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1) + AXMJ=ABS(XMJ) + XMF=PMAS(IFL,1) + IF(AXMI.GE.AXMJ+XMF) THEN +C...Minus sign difference from gluino-quark-squark feynman rules + AL=SFMIX(IFL,1) + BL=-SFMIX(IFL,3) + AR=SFMIX(IFL,2) + BR=-SFMIX(IFL,4) +C...F1 -> F CHI + IF(ILR.EQ.1) THEN + CA=AL + CB=BL +C...F2 -> F CHI + ELSE + CA=AR + CB=BR + ENDIF + LKNT=LKNT+1 + XMA2=XMJ**2 + XMB2=XMF**2 + XL=PYLAMF(XMI2,XMA2,XMB2) + XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)* + & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF) + IDLAM(LKNT,1)=ILR*KSUSY1+IFL + IDLAM(LKNT,2)=-IFL + IDLAM(LKNT,3)=0 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=0 + ENDIF + 100 CONTINUE + 110 CONTINUE + +C...3-BODY DECAYS TO GAUGINO FERMION-FERMION +C...GLUINO -> NI Q QBAR + DO 170 IX=1,4 + XMJ=SMZ(IX) + AXMJ=ABS(XMJ) + IF(AXMI.GE.AXMJ) THEN + DO 120 I=1,4 + ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I)) + 120 CONTINUE + OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2 + ORPP=DCONJG(OLPP) + XXC(1)=0D0 + XXC(2)=XMJ + XXC(3)=0D0 + XXC(4)=XMI + IA=1 + XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1) + XXC(7)=XXC(5) + XXC(8)=XXC(6) + XXC(9)=1D6 + XXC(10)=0D0 + EI=KCHG(IA,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP + GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP + CXC(1)=0D0 + CXC(2)=-GLIJ + CXC(3)=0D0 + CXC(4)=DCONJG(GLIJ) + CXC(5)=0D0 + CXC(6)=GRIJ + CXC(7)=0D0 + CXC(8)=-DCONJG(GRIJ) + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130 + IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2) + IDLAM(LKNT,1)=KFNCHI(IX) + IDLAM(LKNT,2)=1 + IDLAM(LKNT,3)=-1 + ENDIF + IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFNCHI(IX) + IDLAM(LKNT,2)=3 + IDLAM(LKNT,3)=-3 + ENDIF + 130 CONTINUE + IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN + PMOLD=PMAS(PYCOMP(KSUSY1+5),1) + IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN + GOTO 140 + ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN + PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI + ENDIF + CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM) + LKNT=LKNT+1 + XLAM(LKNT)=GAM + IDLAM(LKNT,1)=KFNCHI(IX) + IDLAM(LKNT,2)=5 + IDLAM(LKNT,3)=-5 + PMAS(PYCOMP(KSUSY1+5),1)=PMOLD + ENDIF +C...U-TYPE QUARKS + 140 CONTINUE + IA=2 + XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1) +C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290 + XXC(7)=XXC(5) + XXC(8)=XXC(6) + EI=KCHG(IA,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP + GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP + CXC(2)=-GLIJ + CXC(4)=DCONJG(GLIJ) + CXC(6)=GRIJ + CXC(8)=-DCONJG(GRIJ) + IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150 + IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2) + IDLAM(LKNT,1)=KFNCHI(IX) + IDLAM(LKNT,2)=2 + IDLAM(LKNT,3)=-2 + ENDIF + IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFNCHI(IX) + IDLAM(LKNT,2)=4 + IDLAM(LKNT,3)=-4 + ENDIF + 150 CONTINUE +C...INCLUDE THE DECAY GLUINO -> NJ + T + T~ +C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR + XMF=PMAS(6,1) + IF(AXMI.GE.AXMJ+2D0*XMF) THEN + PMOLD=PMAS(PYCOMP(KSUSY1+6),1) + IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN + GOTO 160 + ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN + PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI + ENDIF + CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM) + LKNT=LKNT+1 + XLAM(LKNT)=GAM + IDLAM(LKNT,1)=KFNCHI(IX) + IDLAM(LKNT,2)=6 + IDLAM(LKNT,3)=-6 + PMAS(PYCOMP(KSUSY1+6),1)=PMOLD + ENDIF + 160 CONTINUE + ENDIF + 170 CONTINUE + +C...GLUINO -> CI Q QBAR' + DO 210 IX=1,2 + XMJ=SMW(IX) + AXMJ=ABS(XMJ) + IF(AXMI.GE.AXMJ) THEN + DO 180 I=1,2 + VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I)) + UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I)) + 180 CONTINUE + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + XXC(1)=0D0 + XXC(2)=XMJ + XXC(3)=0D0 + XXC(4)=XMI + XXC(5)=PMAS(PYCOMP(KSUSY1+1),1) + XXC(6)=PMAS(PYCOMP(KSUSY1+2),1) + XXC(9)=1D6 + XXC(10)=0D0 + OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32))) + ORPP=DCONJG(OLPP) + CXC(1)=DCMPLX(0D0,0D0) + CXC(3)=DCMPLX(0D0,0D0) + CXC(5)=DCMPLX(0D0,0D0) + CXC(7)=DCMPLX(0D0,0D0) + CXC(2)=UMIXC(IX,1)*OLPP/SR2 + CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2 + CXC(6)=DCMPLX(0D0,0D0) + CXC(8)=DCMPLX(0D0,0D0) + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ELSEIF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(6) + XXC(8)=XXC(5) + IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190 + IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(IX) + IDLAM(LKNT,2)=1 + IDLAM(LKNT,3)=-2 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + ENDIF + IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(IX) + IDLAM(LKNT,2)=3 + IDLAM(LKNT,3)=-4 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + ENDIF + 190 CONTINUE + + XMF=PMAS(6,1) + XMFP=PMAS(5,1) + IF(AXMI.GE.AXMJ+XMF+XMFP) THEN + IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP, + $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200 + PMOLT2=PMAS(PYCOMP(KSUSY2+6),1) + PMOLB2=PMAS(PYCOMP(KSUSY2+5),1) + PMOLT1=PMAS(PYCOMP(KSUSY1+6),1) + PMOLB1=PMAS(PYCOMP(KSUSY1+5),1) + IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI + IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI + IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI + IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI + CALL PYTBBC(IX,100,XMI,GAM) + LKNT=LKNT+1 + XLAM(LKNT)=GAM + IDLAM(LKNT,1)=KFCCHI(IX) + IDLAM(LKNT,2)=5 + IDLAM(LKNT,3)=-6 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2 + PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2 + PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1 + PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1 + ENDIF + 200 CONTINUE + ENDIF + 210 CONTINUE + +C...R-parity violating (3-body) decays. + CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT) + + IKNT=LKNT + XLAM(0)=0D0 + DO 220 I=1,IKNT + IF(XLAM(I).LT.0D0) XLAM(I)=0D0 + XLAM(0)=XLAM(0)+XLAM(I) + 220 CONTINUE + IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6 + + RETURN + END + + +C********************************************************************* + +C...PYTBBN +C...Calculates the three-body decay of gluinos into +C...neutralinos and third generation fermions. + + SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ + +C...Local variables. + EXTERNAL PYSIMP,PYLAMF + DOUBLE PRECISION PYSIMP,PYLAMF + INTEGER LIN,NN + DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D + DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2 + DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2 + DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100) + DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24 + DOUBLE PRECISION XLN1,XLN2,B1,B2 + DOUBLE PRECISION E,XMGLU,GAM + DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4) + SAVE HRB,HLB,FLB,FRB + DOUBLE PRECISION ALPHAW,ALPHAS + DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4) + SAVE HLT,HRT,FLT,FRT + DOUBLE PRECISION AMN(4),AN(4,4),ZN(3) + SAVE AMN,AN,ZN + DOUBLE PRECISION AMBOT,SINC,COSC + DOUBLE PRECISION AMTOP,SINA,COSA + DOUBLE PRECISION SINW,COSW,TANW + DOUBLE PRECISION ROT1(4,4) + LOGICAL IFIRST + SAVE IFIRST + DATA IFIRST/.TRUE./ + + TANB=RMSS(5) + SINB=TANB/SQRT(1D0+TANB**2) + COSB=SINB/TANB + XW=PARU(102) + SINW=SQRT(XW) + COSW=SQRT(1D0-XW) + TANW=SINW/COSW + AMW=PMAS(24,1) + COSC=SFMIX(5,1) + SINC=SFMIX(5,3) + COSA=SFMIX(6,1) + SINA=SFMIX(6,3) + AMBOT=PYMRUN(5,XMGLU**2) + AMTOP=PYMRUN(6,XMGLU**2) + W2=SQRT(2D0) + FAKT1=AMBOT/W2/AMW/COSB + FAKT2=AMTOP/W2/AMW/SINB + IF(IFIRST) THEN + DO 110 II=1,4 + AMN(II)=SMZ(II) + DO 100 J=1,4 + ROT1(II,J)=0D0 + AN(II,J)=0D0 + 100 CONTINUE + 110 CONTINUE + ROT1(1,1)=COSW + ROT1(1,2)=-SINW + ROT1(2,1)=-ROT1(1,2) + ROT1(2,2)=ROT1(1,1) + ROT1(3,3)=COSB + ROT1(3,4)=SINB + ROT1(4,3)=-ROT1(3,4) + ROT1(4,4)=ROT1(3,3) + DO 140 II=1,4 + DO 130 J=1,4 + DO 120 JJ=1,4 + AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J) + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + DO 150 J=1,4 + ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4)) + ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1)) + ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0* + & XW)*AN(J,2)/COSW + HRT(J)=ZN(1)*COSA-ZN(3)*SINA + HLT(J)=ZN(1)*COSA+ZN(2)*SINA + FLT(J)=ZN(3)*COSA+ZN(1)*SINA + FRT(J)=ZN(2)*COSA-ZN(1)*SINA +C FLU(J)=ZN(3) +C FRU(J)=ZN(2) + ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4)) + ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1)) + ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW + HRB(J)=ZN(1)*COSC-ZN(3)*SINC + HLB(J)=ZN(1)*COSC+ZN(2)*SINC + FLB(J)=ZN(3)*COSC+ZN(1)*SINC + FRB(J)=ZN(2)*COSC-ZN(1)*SINC +C FLD(J)=ZN(3) +C FRD(J)=ZN(2) + 150 CONTINUE +C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1) +C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1) +C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1) +C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1) + IFIRST=.FALSE. + ENDIF + + IF(NINT(3D0*E).EQ.2) THEN + HL=HLT(I) + HR=HRT(I) + FL=FLT(I) + FR=FRT(I) + COSD=SFMIX(6,1) + SIND=SFMIX(6,3) + XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2 + XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2 + XM=PMAS(6,1) + ELSE + HL=HLB(I) + HR=HRB(I) + FL=FLB(I) + FR=FRB(I) + COSD=SFMIX(5,1) + SIND=SFMIX(5,3) + XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2 + XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2 + XM=PMAS(5,1) + ENDIF + COSD2=COSD*COSD + SIND2=SIND*SIND + COS2D=COSD2-SIND2 + SIN2D=SIND*COSD*2D0 + HL2=HL*HL + HR2=HR*HR + FL2=FL*FL + FR2=FR*FR + FF=FL*FR + HH=HL*HR + HFL=HL*FL + HFR=HR*FR + HRFL=HR*FL + HLFR=HL*FR + XM2=XM*XM + XMG=XMGLU + XMG2=XMG*XMG + ALPHAW=PYALEM(XMG2) + ALPHAS=PYALPS(XMG2) + XMR=AMN(I) + XMR2=XMR*XMR + XMQ4=XMG*XM2*XMR + XM24=(XMG2+XM2)*(XM2+XMR2) + SMIN=4D0*XM2 + SMAX=(XMG-ABS(XMR))**2 + XMQA=XMG2+2D0*XM2+XMR2 + DO 170 LIN=1,NN-1 + SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN) + GRS=SBAR-XMQA + W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR) + W=DSQRT(W) + XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W))) + XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W))) + B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W) + B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W) + G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D + & +2D0*(FF*SIND2-HH*COSD2))*W + G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D) + & +4D0*HFL*XM*XMR)*XLN1 + & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24 + & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D) + & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1)) + & +8D0*HFL*XMQ4*SIN2D)*B1 + G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D) + & +4D0*HFR*XMR*XM)*XLN2 + & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24 + & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2)) + & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2) + & -8D0*HFR*XMQ4*SIN2D)*B2 + G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2) + & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR + & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2) + & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2) + & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1 + G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))* + & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2) + & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1)) + G(5)=(2D0*(HH*COSD2-FF*SIND2) + & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2 + & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1) + & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR) + & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2) + & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2) + & +COS2D*XM*(SBAR+XMG2-XMR2)) + & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2)) + & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2)) + G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2) + & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR + & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2) + & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2) + & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2 + SUMME(LIN)=0D0 + DO 160 J=0,6 + SUMME(LIN)=SUMME(LIN)+G(J) + 160 CONTINUE + 170 CONTINUE + SUMME(0)=0D0 + SUMME(NN)=0D0 + GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN) + &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3) + + RETURN + END + +C********************************************************************* + +C...PYTBBC +C...Calculates the three-body decay of gluinos into +C...charginos and third generation fermions. + + SUBROUTINE PYTBBC(I,NN,XMGLU,GAM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/ + +C...Local variables. + EXTERNAL PYSIMP,PYLAMF + DOUBLE PRECISION PYSIMP,PYLAMF + INTEGER I,NN,LIN + DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2 + DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4) + DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX + DOUBLE PRECISION SUMME(0:100),A(4,8) + DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C + DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2 + DOUBLE PRECISION XMGLU,GAM + DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2), + &DDD(2),EEE(2),FFF(2) + SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF + DOUBLE PRECISION ALPHAW,ALPHAS + DOUBLE PRECISION AMC(2) + SAVE AMC + DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC + DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA + SAVE AMSB,AMST + LOGICAL IFIRST + SAVE IFIRST + DATA IFIRST/.TRUE./ + + TANB=RMSS(5) + SINB=TANB/SQRT(1D0+TANB**2) + COSB=SINB/TANB + XW=PARU(102) + AMW=PMAS(24,1) + COSC=SFMIX(5,1) + SINC=SFMIX(5,3) + COSA=SFMIX(6,1) + SINA=SFMIX(6,3) + AMBOT=PYMRUN(5,XMGLU**2) + AMTOP=PYMRUN(6,XMGLU**2) + W2=SQRT(2D0) + AMW=PMAS(24,1) + FAKT1=AMBOT/W2/AMW/COSB + FAKT2=AMTOP/W2/AMW/SINB + IF(IFIRST) THEN + AMC(1)=SMW(1) + AMC(2)=SMW(2) + DO 100 JJ=1,2 + CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC + EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC + DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC + FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC + XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA + AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA + XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA + BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA + 100 CONTINUE + AMST(1)=PMAS(PYCOMP(KSUSY1+6),1) + AMST(2)=PMAS(PYCOMP(KSUSY2+6),1) + AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1) + AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1) + IFIRST=.FALSE. + ENDIF + + ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I) + ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I) + VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I) + VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I) + + COS2A=COSA**2-SINA**2 + SIN2A=SINA*COSA*2D0 + COS2C=COSC**2-SINC**2 + SIN2C=SINC*COSC*2D0 + + XMG=XMGLU + XMT=PMAS(6,1) + XMB=PMAS(5,1) + XMR=AMC(I) + XMG2=XMG*XMG + ALPHAW=PYALEM(XMG2) + ALPHAS=PYALPS(XMG2) + XMT2=XMT*XMT + XMB2=XMB*XMB + XMR2=XMR*XMR + XMQ2=XMG2+XMT2+XMB2+XMR2 + XMQ4=XMG*XMT*XMB*XMR + XMQ3=XMG2*XMR2+XMT2*XMB2 + XMGBTR=(XMG2+XMB2)*(XMT2+XMR2) + XMGTBR=(XMG2+XMT2)*(XMB2+XMR2) + + XMST(1)=AMST(1)*AMST(1) + XMST(2)=AMST(1)*AMST(1) + XMST(3)=AMST(2)*AMST(2) + XMST(4)=AMST(2)*AMST(2) + XMSB(1)=AMSB(1)*AMSB(1) + XMSB(2)=AMSB(2)*AMSB(2) + XMSB(3)=AMSB(1)*AMSB(1) + XMSB(4)=AMSB(2)*AMSB(2) + + A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I) + A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I)) + A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I)) + A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I)) + A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I)) + A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I)) + A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I)) + A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I)) + + A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I) + A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I)) + A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I)) + A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I)) + A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I)) + A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I)) + A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I)) + A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I)) + + A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I) + A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I)) + A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I)) + A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I)) + A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I)) + A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I)) + A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I)) + A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I)) + + A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I) + A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I)) + A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I)) + A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I)) + A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I)) + A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I)) + A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I)) + A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I)) + + SMAX=(XMG-ABS(XMR))**2 + SMIN=(XMB+XMT)**2+0.1D0 + + DO 120 LIN=0,NN-1 + SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN) + AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR + GRS=SBAR-XMQ2 + W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2) + W=DSQRT(W)/2D0/SBAR + ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W))) + ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W))) + ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W))) + ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W))) + SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A) + & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1 + & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR + & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2)) + & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2) + & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4) + & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W)) + SUMME(LIN)=SUMME(LIN)-ULR(2)*W + & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A) + & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2 + & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR + & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2)) + & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2) + & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4) + & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W)) + SUMME(LIN)=SUMME(LIN)-VLR(1)*W + & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C) + & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1 + & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR + & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2)) + & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2) + & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4) + & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W)) + SUMME(LIN)=SUMME(LIN)-VLR(2)*W + & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C) + & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2 + & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR + & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2)) + & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2) + & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4) + & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W)) + SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1)) + & *((AAA(I)*BBB(I)-XX1(I)*XX2(I)) + & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1) + & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1)) + SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1)) + & *((EEE(I)*FFF(I)-CCC(I)*DDD(I)) + & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1) + & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1)) + DO 110 J=1,4 + SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W + & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3) + & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2) + & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2) + & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR) + & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8)) + & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W))) + & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3) + & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2) + & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2) + & -A(J,6)*(XMG2+XMR2-SBAR) + & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8)) + & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W)))) + & /(GRS+XMSB(J)+XMST(J)) + 110 CONTINUE + 120 CONTINUE + SUMME(NN)=0D0 + GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN) + &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3) + + RETURN + END + +C********************************************************************* + +C...PYNJDC +C...Calculates decay widths for the neutralinos (admixtures of +C...Bino, W3-ino, Higgs1-ino, Higgs2-ino) + +C...Input: KCIN = KF code for particle +C...Output: XLAM = widths +C... IDLAM = KF codes for decay particles +C... IKNT = number of decay channels defined +C...AUTHOR: STEPHEN MRENNA +C...Last change: +C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma +C...when CHIGAMMA .NE. 0 +C...10 FEB 96: Calculate this decay for small tan(beta) + + SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) +c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), +c &SFMIX(16,4) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) +C COMMON/PYINTS/XXM(20) + COMPLEX*16 CXC + COMMON/PYINTC/XXC(10),CXC(8) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/ + +C...Local variables. + COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ + COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB + INTEGER KFIN + DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2, + &XMZ,XMZ2,AXMJ,AXMI + DOUBLE PRECISION S12MIN,S12MAX + DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2 + DOUBLE PRECISION PYLAMF,XL + DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I + DOUBLE PRECISION PYX2XH,PYX2XG + DOUBLE PRECISION XLAM(0:400) + INTEGER IDLAM(400,3) + INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID + INTEGER ITH(3),KF1,KF2 + INTEGER ITHC + DOUBLE PRECISION DH(3),EH(3) + DOUBLE PRECISION SR2 + DOUBLE PRECISION CBETA,SBETA + DOUBLE PRECISION GAMCON,XMT1,XMT2 + DOUBLE PRECISION PYALEM,PI,PYALPS + DOUBLE PRECISION RAT1,RAT2 + DOUBLE PRECISION T3T,FCOL + DOUBLE PRECISION ALFA,BETA,TANB + DOUBLE PRECISION PYXXGA + EXTERNAL PYGAUS,PYXXZ6 + DOUBLE PRECISION PYGAUS,PYXXZ6 + DOUBLE PRECISION PREC + INTEGER KFNCHI(4),KFCCHI(2) + DATA ITH/25,35,36/ + DATA ITHC/37/ + DATA PREC/1D-2/ + DATA PI/3.141592654D0/ + DATA SR2/1.4142136D0/ + DATA KFNCHI/1000022,1000023,1000025,1000035/ + DATA KFCCHI/1000024,1000037/ + +C...COUNT THE NUMBER OF DECAY MODES + LKNT=0 + + XMW=PMAS(24,1) + XMW2=XMW**2 + XMZ=PMAS(23,1) + XMZ2=XMZ**2 + XW=1D0-XMW2/XMZ2 + XW1=1D0-XW + TANW = SQRT(XW/XW1) + +C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER + IX=1 + IF(KFIN.EQ.KFNCHI(2)) IX=2 + IF(KFIN.EQ.KFNCHI(3)) IX=3 + IF(KFIN.EQ.KFNCHI(4)) IX=4 + + XMI=SMZ(IX) + XMI2=XMI**2 + AXMI=ABS(XMI) + AEM=PYALEM(XMI2) + AS =PYALPS(XMI2) + C1=AEM/XW + XMI3=ABS(XMI**3) + + TANB=RMSS(5) + BETA=ATAN(TANB) + ALFA=RMSS(18) + CBETA=COS(BETA) + SBETA=TANB*CBETA + CALFA=COS(ALFA) + SALFA=SIN(ALFA) + + DO 110 I=1,4 + DO 100 J=1,4 + ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I)) + 100 CONTINUE + 110 CONTINUE + DO 130 I=1,2 + DO 120 J=1,2 + VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I)) + UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I)) + 120 CONTINUE + 130 CONTINUE + +C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS + IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300 + +C...FORCE CHI0_2 -> CHI0_1 + GAMMA + IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN + XMJ=SMZ(1) + AXMJ=ABS(XMJ) + LKNT=LKNT+1 + GAMCON=AEM**3/8D0/PI/XMW2/XW + XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2 + XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2 + XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2) + IDLAM(LKNT,1)=KSUSY1+22 + IDLAM(LKNT,2)=22 + IDLAM(LKNT,3)=0 + WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT) + GOTO 340 + ENDIF + +C...GRAVITINO DECAY MODES + + IF(IMSS(11).EQ.1) THEN + XMP=RMSS(29) + IDG=39+KSUSY1 + XMGR=PMAS(PYCOMP(IDG),1) + SINW=SQRT(XW) + COSW=SQRT(1D0-XW) + XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI + IF(AXMI.GT.XMGR+PMAS(22,1)) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=22 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2 + ENDIF + IF(AXMI.GT.XMGR+XMZ) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=23 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 + + $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)* + & (1D0-XMZ2/XMI2)**4 + ENDIF + IF(AXMI.GT.XMGR+PMAS(25,1)) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=25 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)* + $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4 + ENDIF + IF(AXMI.GT.XMGR+PMAS(35,1)) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=35 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)* + $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4 + ENDIF + IF(AXMI.GT.XMGR+PMAS(36,1)) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=36 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)* + $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4 + ENDIF + IF(IX.EQ.1) GOTO 300 + ENDIF + + DO 220 IJ=1,IX-1 + XMJ=SMZ(IJ) + AXMJ=ABS(XMJ) + XMJ2=XMJ**2 + +C...CHI0_I -> CHI0_J + GAMMA + IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN + RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2 + RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 ) + RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2 + RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 ) + IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR. + & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=22 + IDLAM(LKNT,3)=0 + GAMCON=AEM**3/8D0/PI/XMW2/XW + XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2 + XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2 + XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2) + ENDIF + ENDIF + +C...CHI0_I -> CHI0_J + Z0 + IF(AXMI.GE.AXMJ+XMZ) THEN + LKNT=LKNT+1 + OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))- + & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0 + ORPP=-DCONJG(OLPP) + GX2=ABS(OLPP)**2+ABS(ORPP)**2 + GLR=DBLE(OLPP*DCONJG(ORPP)) + XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=23 + IDLAM(LKNT,3)=0 + ELSEIF(AXMI.GE.AXMJ) THEN + XXC(1)=0D0 + XXC(2)=XMJ + XXC(3)=0D0 + XXC(4)=XMI + XXC(9)=XMZ + XXC(10)=PMAS(23,2) + OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))- + & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0 + ORPP=DCONJG(OLPP) +C...CHARGED LEPTONS + FID=11 + XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) + EI=KCHG(FID,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))* + & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1)) + GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2 + CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP + CXC(2)=-GLIJ + CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP + CXC(4)=DCONJG(GLIJ) + CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP + CXC(6)=GRIJ + CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP + CXC(8)=-DCONJG(GRIJ) + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + IF(XXC(6).LT.AXMI ) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + + IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=FID + IDLAM(LKNT,3)=-FID + IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=13 + IDLAM(LKNT,3)=-13 + ENDIF + ENDIF + 140 CONTINUE + IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN + XXC(5)=PMAS(PYCOMP(KSUSY1+15),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+15),1) + ELSE + XXC(6)=PMAS(PYCOMP(KSUSY1+15),1) + XXC(5)=PMAS(PYCOMP(KSUSY2+15),1) + ENDIF + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + IF(XXC(6).LT.AXMI ) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + + IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=15 + IDLAM(LKNT,3)=-15 + ENDIF + +C...NEUTRINOS + 150 CONTINUE + FID=12 + XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) + EI=KCHG(FID,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))* + & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1)) + GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2 + CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP + CXC(2)=-GLIJ + CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP + CXC(4)=DCONJG(GLIJ) + CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP + CXC(6)=GRIJ + CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP + CXC(8)=-DCONJG(GRIJ) + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + IF( XXC(6).LT.AXMI ) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=12 + IDLAM(LKNT,3)=-12 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=14 + IDLAM(LKNT,3)=-14 + 160 CONTINUE + + IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1)) + & THEN + XXC(5)=PMAS(PYCOMP(KSUSY1+16),1) + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + XXC(7)=XXC(5) + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) + ELSE + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + ENDIF + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=16 + IDLAM(LKNT,3)=-16 +C...D-TYPE QUARKS + 170 CONTINUE + FID=1 + XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) + EI=KCHG(FID,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))* + & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1)) + GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2 + CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP + CXC(2)=-GLIJ + CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP + CXC(4)=DCONJG(GLIJ) + CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP + CXC(6)=GRIJ + CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP + CXC(8)=-DCONJG(GRIJ) + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + IF( XXC(6).LT.AXMI ) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + + IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0 + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=1 + IDLAM(LKNT,3)=-1 + IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=3 + IDLAM(LKNT,3)=-3 + ENDIF + ENDIF + 180 CONTINUE + IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN + XXC(5)=PMAS(PYCOMP(KSUSY1+5),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+5),1) + ELSE + XXC(6)=PMAS(PYCOMP(KSUSY1+5),1) + XXC(5)=PMAS(PYCOMP(KSUSY2+5),1) + ENDIF + IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190 + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ELSEIF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0 + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=5 + IDLAM(LKNT,3)=-5 + ENDIF + +C...U-TYPE QUARKS + 190 CONTINUE + FID=2 + XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) + EI=KCHG(FID,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))* + & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1)) + GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2 + CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP + CXC(2)=-GLIJ + CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP + CXC(4)=DCONJG(GLIJ) + CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP + CXC(6)=GRIJ + CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP + CXC(8)=-DCONJG(GRIJ) + + IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200 + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ELSEIF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + + IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0 + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=2 + IDLAM(LKNT,3)=-2 + IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=4 + IDLAM(LKNT,3)=-4 + ENDIF + ENDIF + 200 CONTINUE + ENDIF + +C...CHI0_I -> CHI0_J + H0_K + EH(1)=SIN(ALFA) + EH(2)=COS(ALFA) + EH(3)=-SIN(BETA) + DH(1)=COS(ALFA) + DH(2)=-SIN(ALFA) + DH(3)=COS(BETA) + QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+ + & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)- + & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+ + & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1)) + RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+ + & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))- + & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+ + & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1))) + DO 210 IH=1,3 + XMH=PMAS(ITH(IH),1) + XMH2=XMH**2 + IF(AXMI.GE.AXMJ+XMH) THEN + LKNT=LKNT+1 + XL=PYLAMF(XMI2,XMJ2,XMH2) + F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH)) + F12K=F21K +C...SIGN OF MASSES I,J + XMK=XMJ + IF(IH.EQ.3) XMK=-XMK + GX2=ABS(F21K)**2+ABS(F12K)**2 + GLR=DBLE(F21K*DCONJG(F12K)) + XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=ITH(IH) + IDLAM(LKNT,3)=0 + ENDIF + 210 CONTINUE + 220 CONTINUE + +C...CHI0_I -> CHI+_J + W- + DO 260 IJ=1,2 + XMJ=SMW(IJ) + AXMJ=ABS(XMJ) + XMJ2=XMJ**2 + IF(AXMI.GE.AXMJ+XMW) THEN + LKNT=LKNT+1 + CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)- + & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2) + CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+ + & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2) + GX2=ABS(CXC(1))**2+ABS(CXC(3))**2 + GLR=DBLE(CXC(1)*DCONJG(CXC(3))) + XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR) + IDLAM(LKNT,1)=KFCCHI(IJ) + IDLAM(LKNT,2)=-24 + IDLAM(LKNT,3)=0 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-KFCCHI(IJ) + IDLAM(LKNT,2)=24 + IDLAM(LKNT,3)=0 + ELSEIF(AXMI.GE.AXMJ) THEN + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + RT2I = 1D0/SQRT(2D0) + CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)- + & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I + CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+ + & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I + CXC(5)=DCMPLX(0D0,0D0) + CXC(7)=DCMPLX(0D0,0D0) + IA=11 + JA=12 + EI=KCHG(IA,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + EJ=KCHG(JA,1)/3D0 + T3J=SIGN(1D0,EJ+1D-6)/2D0 + CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)* + & TANW+ZMIXC(IX,2)*T3J)*RT2I + CXC(4)=-DCONJG(UMIXC(IJ,1))*( + & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I + CXC(6)=DCMPLX(0D0,0D0) + CXC(8)=DCMPLX(0D0,0D0) + XXC(1)=0D0 + XXC(2)=XMJ + XXC(3)=0D0 + XXC(4)=XMI + XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) + XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1) + XXC(9)=PMAS(24,1) + XXC(10)=PMAS(24,2) + IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230 + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ELSEIF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(6) + XXC(8)=XXC(5) + IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(IJ) + IDLAM(LKNT,2)=11 + IDLAM(LKNT,3)=-12 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(IJ) + IDLAM(LKNT,2)=13 + IDLAM(LKNT,3)=-14 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + ENDIF + ENDIF + 230 CONTINUE + IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN + XXC(5)=PMAS(PYCOMP(KSUSY1+15),1) + XXC(6)=PMAS(PYCOMP(KSUSY1+16),1) + ELSE + XXC(5)=PMAS(PYCOMP(KSUSY2+15),1) + XXC(6)=PMAS(PYCOMP(KSUSY1+16),1) + ENDIF + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ENDIF + IF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(6) + XXC(8)=XXC(5) + IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(IJ) + IDLAM(LKNT,2)=15 + IDLAM(LKNT,3)=-16 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + ENDIF + +C...NOW, DO THE QUARKS + 240 CONTINUE + IA=1 + JA=2 + EI=KCHG(IA,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + EJ=KCHG(JA,1)/3D0 + T3J=SIGN(1D0,EJ+1D-6)/2D0 + CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)* + & TANW+ZMIXC(IX,2)*T3J) + CXC(4)=-DCONJG(UMIXC(IJ,1))*( + & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I) + XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1) + XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1) + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ENDIF + IF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(6) + XXC(8)=XXC(5) + IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(IJ) + IDLAM(LKNT,2)=1 + IDLAM(LKNT,3)=-2 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(IJ) + IDLAM(LKNT,2)=3 + IDLAM(LKNT,3)=-4 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + ENDIF + ENDIF + 250 CONTINUE + ENDIF + 260 CONTINUE + 270 CONTINUE + +C...CHI0_I -> CHI+_I + H- + DO 280 IJ=1,2 + XMJ=SMW(IJ) + AXMJ=ABS(XMJ) + XMJ2=XMJ**2 + XMHP=PMAS(ITHC,1) + IF(AXMI.GE.AXMJ+XMHP) THEN + LKNT=LKNT+1 + OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+ + & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2) + ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)- + & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)* + & UMIXC(IJ,2)/SR2) + GX2=ABS(OLPP)**2+ABS(ORPP)**2 + GLR=DBLE(OLPP*DCONJG(ORPP)) + XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR) + IDLAM(LKNT,1)=KFCCHI(IJ) + IDLAM(LKNT,2)=-ITHC + IDLAM(LKNT,3)=0 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + ELSE + + ENDIF + 280 CONTINUE + +C...2-BODY DECAYS TO FERMION SFERMION + DO 290 J=1,16 + IF(J.GE.7.AND.J.LE.10) GOTO 290 + KF1=KSUSY1+J + KF2=KSUSY2+J + XMSF1=PMAS(PYCOMP(KF1),1) + XMSF2=PMAS(PYCOMP(KF2),1) + XMF=PMAS(J,1) + IF(J.LE.6) THEN + FCOL=3D0 + ELSE + FCOL=1D0 + ENDIF + + EI=KCHG(J,1)/3D0 + T3T=SIGN(1D0,EI) + IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0 + IF(MOD(J,2).EQ.0) THEN + CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T) + CAL=XMF*ZMIXC(IX,4)/XMW/SBETA + CAR=-2D0*EI*TANW*ZMIXC(IX,1) + CBR=CAL + ELSE + CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T) + CAL=XMF*ZMIXC(IX,3)/XMW/CBETA + CAR=-2D0*EI*TANW*ZMIXC(IX,1) + CBR=CAL + ENDIF + +C...D~ D_L + IF(AXMI.GE.XMF+XMSF1) THEN + LKNT=LKNT+1 + XMA2=XMSF1**2 + XMB2=XMF**2 + XL=PYLAMF(XMI2,XMA2,XMB2) + CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2) + CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2) + XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* + & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI) + IDLAM(LKNT,1)=KF1 + IDLAM(LKNT,2)=-J + IDLAM(LKNT,3)=0 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=0 + ENDIF + +C...D~ D_R + IF(AXMI.GE.XMF+XMSF2) THEN + LKNT=LKNT+1 + XMA2=XMSF2**2 + XMB2=XMF**2 + CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4) + CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4) + XL=PYLAMF(XMI2,XMA2,XMB2) + XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* + & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI) + IDLAM(LKNT,1)=KF2 + IDLAM(LKNT,2)=-J + IDLAM(LKNT,3)=0 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=0 + ENDIF + 290 CONTINUE + 300 CONTINUE +C...3-BODY DECAY TO Q Q~ GLUINO + XMJ=PMAS(PYCOMP(KSUSY1+21),1) + IF(AXMI.GE.XMJ) THEN + RT2I = 1D0/SQRT(2D0) + OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I + ORPP=DCONJG(OLPP) + AXMJ=ABS(XMJ) + XXC(1)=0D0 + XXC(2)=XMJ + XXC(3)=0D0 + XXC(4)=XMI + FID=1 + XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) + 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 +CMRENNA.This statement must be here to define S12MAX + IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310 +C...ALL QUARKS BUT T + IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) + IDLAM(LKNT,1)=KSUSY1+21 + IDLAM(LKNT,2)=1 + IDLAM(LKNT,3)=-1 + IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KSUSY1+21 + IDLAM(LKNT,2)=3 + IDLAM(LKNT,3)=-3 + ENDIF + ENDIF + 310 CONTINUE + IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN + XXC(5)=PMAS(PYCOMP(KSUSY1+5),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+5),1) + ELSE + XXC(6)=PMAS(PYCOMP(KSUSY1+5),1) + XXC(5)=PMAS(PYCOMP(KSUSY2+5),1) + ENDIF + IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320 + XXC(7)=XXC(5) + XXC(8)=XXC(6) + IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) + IDLAM(LKNT,1)=KSUSY1+21 + IDLAM(LKNT,2)=5 + IDLAM(LKNT,3)=-5 + ENDIF +C...U-TYPE QUARKS + 320 CONTINUE + FID=2 + XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1) + XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1) + IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330 + XXC(7)=XXC(5) + XXC(8)=XXC(6) + EI=KCHG(FID,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP + GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP + CXC(2)=-GLIJ + CXC(4)=DCONJG(GLIJ) + CXC(6)=GRIJ + CXC(8)=-DCONJG(GRIJ) + IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3) + IDLAM(LKNT,1)=KSUSY1+21 + IDLAM(LKNT,2)=2 + IDLAM(LKNT,3)=-2 + IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KSUSY1+21 + IDLAM(LKNT,2)=4 + IDLAM(LKNT,3)=-4 + ENDIF + ENDIF + 330 CONTINUE + ENDIF + +C...R-violating decay modes (SKANDS). + CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT) + + 340 IKNT=LKNT + XLAM(0)=0D0 + DO 350 I=1,IKNT + IF(XLAM(I).LT.0D0) XLAM(I)=0D0 + XLAM(0)=XLAM(0)+XLAM(I) + 350 CONTINUE + IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6 + + RETURN + END + +C********************************************************************* + +C...PYCJDC +C...Calculate decay widths for the charginos (admixtures of +C...charged Wino and charged Higgsino. + +C...Input: KCIN = KF code for particle +C...Output: XLAM = widths +C... IDLAM = KF codes for decay particles +C... IKNT = number of decay channels defined +C...AUTHOR: STEPHEN MRENNA +C...Last change: +C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e +C...when CHIENU .NE. 0 + + SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) +CC &SFMIX(16,4), +C COMMON/PYINTS/XXM(20) + COMPLEX*16 CXC + COMMON/PYINTC/XXC(10),CXC(8) + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/ + +C...Local variables + COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP + COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB + INTEGER KFIN,KCIN + DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2, + &XMZ,XMZ2,AXMJ,AXMI + DOUBLE PRECISION S12MIN,S12MAX + DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK + DOUBLE PRECISION PYLAMF,XL + DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA + DOUBLE PRECISION PYX2XH,PYX2XG + DOUBLE PRECISION XLAM(0:400) + INTEGER IDLAM(400,3) + INTEGER LKNT,IX,IH,J,IJ,I,IKNT + INTEGER ITH(3) + INTEGER ITHC + DOUBLE PRECISION ETAH(3),DH(3),EH(3) + DOUBLE PRECISION SR2 + DOUBLE PRECISION CBETA,SBETA,TANB + + DOUBLE PRECISION PYALEM,PI,PYALPS + DOUBLE PRECISION FCOL + INTEGER KF1,KF2,ISF + INTEGER KFNCHI(4),KFCCHI(2) + + DOUBLE PRECISION TEMP + EXTERNAL PYGAUS,PYXXZ6 + DOUBLE PRECISION PYGAUS,PYXXZ6 + DOUBLE PRECISION PREC + DATA ITH/25,35,36/ + DATA ITHC/37/ + DATA ETAH/1D0,1D0,-1D0/ + DATA SR2/1.4142136D0/ + DATA PI/3.141592654D0/ + DATA PREC/1D-2/ + DATA KFNCHI/1000022,1000023,1000025,1000035/ + DATA KFCCHI/1000024,1000037/ + +C...COUNT THE NUMBER OF DECAY MODES + LKNT=0 + XMW=PMAS(24,1) + XMW2=XMW**2 + XMZ=PMAS(23,1) + XMZ2=XMZ**2 + XW=1D0-XMW2/XMZ2 + XW1=1D0-XW + TANW = SQRT(XW/XW1) + +C...1 OR 2 DEPENDING ON CHARGINO TYPE + IX=1 + IF(KFIN.EQ.KFCCHI(2)) IX=2 + KCIN=PYCOMP(KFIN) + + XMI=SMW(IX) + XMI2=XMI**2 + AXMI=ABS(XMI) + AEM=PYALEM(XMI2) + AS =PYALPS(XMI2) + C1=AEM/XW + XMI3=ABS(XMI**3) + TANB=RMSS(5) + BETA=ATAN(TANB) + CBETA=COS(BETA) + SBETA=TANB*CBETA + ALFA=RMSS(18) + + DO 110 I=1,2 + DO 100 J=1,2 + VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I)) + UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I)) + 100 CONTINUE + 110 CONTINUE + +C...GRAVITINO DECAY MODES + + IF(IMSS(11).EQ.1) THEN + XMP=RMSS(29) + IDG=39+KSUSY1 + XMGR=PMAS(PYCOMP(IDG),1) +C SINW=SQRT(XW) +C COSW=SQRT(1D0-XW) + XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI + IF(AXMI.GT.XMGR+XMW) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=24 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC*( + & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+ + & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))* + & (1D0-XMW2/XMI2)**4 + ENDIF + IF(AXMI.GT.XMGR+PMAS(37,1)) THEN + LKNT=LKNT+1 + IDLAM(LKNT,1)=IDG + IDLAM(LKNT,2)=37 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+ + & (ABS(UMIXC(IX,2))*SBETA)**2)) + & *(1D0-PMAS(37,1)**2/XMI2)**4 + ENDIF + ENDIF + +C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS + IF(IX.EQ.1) GOTO 170 + XMJ=SMW(1) + AXMJ=ABS(XMJ) + XMJ2=XMJ**2 + +C...CHI_2+ -> CHI_1+ + Z0 + IF(AXMI.GE.AXMJ+XMZ) THEN + LKNT=LKNT+1 + IJ=1 + OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))- + & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0 + ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))- + & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0 + GX2=ABS(OLPP)**2+ABS(ORPP)**2 + GLR=DBLE(OLPP*DCONJG(ORPP)) + XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=23 + IDLAM(LKNT,3)=0 + +C...CHARGED LEPTONS + ELSEIF(AXMI.GE.AXMJ) THEN + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + IA=11 + JA=12 + EI=KCHG(IABS(IA),1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + XXC(1)=0D0 + XXC(2)=XMJ + XXC(3)=0D0 + XXC(4)=XMI + XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) + XXC(6)=1D6 + XXC(9)=PMAS(23,1) + XXC(10)=PMAS(23,2) + IJ=1 + OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))- + & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0 + ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))- + & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0 + CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP + CXC(2)=DCMPLX(0D0,0D0) + CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP + CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW) + CXC(5)=-DCMPLX(EI/XW1)*ORPP + CXC(6)=DCMPLX(0D0,0D0) + CXC(7)=-DCMPLX(EI/XW1)*OLPP + CXC(8)=DCMPLX(0D0,0D0) + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=11 + IDLAM(LKNT,3)=-11 + IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=13 + IDLAM(LKNT,3)=-13 + ENDIF + IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=15 + IDLAM(LKNT,3)=-15 + ENDIF + ENDIF + +C...NEUTRINOS + 120 CONTINUE + IA=12 + JA=11 + EI=KCHG(IABS(IA),1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) + XXC(6)=1D6 + CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP + CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP + CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW) + CXC(5)=-DCMPLX(EI/XW1)*ORPP + CXC(7)=-DCMPLX(EI/XW1)*OLPP + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=12 + IDLAM(LKNT,3)=-12 + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=14 + IDLAM(LKNT,3)=-14 + ENDIF + IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN + IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN + XXC(5)=PMAS(PYCOMP(KSUSY1+15),1) + ELSE + XXC(5)=PMAS(PYCOMP(KSUSY2+15),1) + ENDIF + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + XXC(7)=XXC(5) + LKNT=LKNT+1 + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=16 + IDLAM(LKNT,3)=-16 + ENDIF + +C...D-TYPE QUARKS + 130 CONTINUE + IA=1 + JA=2 + EI=KCHG(IABS(IA),1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) + XXC(6)=1D6 + CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP + CXC(2)=DCMPLX(0D0,0D0) + CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP + CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW) + CXC(5)=-DCMPLX(EI/XW1)*ORPP + CXC(6)=DCMPLX(0D0,0D0) + CXC(7)=-DCMPLX(EI/XW1)*OLPP + CXC(8)=DCMPLX(0D0,0D0) + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=1 + IDLAM(LKNT,3)=-1 + IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=3 + IDLAM(LKNT,3)=-3 + ENDIF + ENDIF + IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN + IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN + XXC(5)=PMAS(PYCOMP(KSUSY1+5),1) + ELSE + XXC(5)=PMAS(PYCOMP(KSUSY2+5),1) + ENDIF + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + XXC(7)=XXC(5) + LKNT=LKNT+1 + XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=5 + IDLAM(LKNT,3)=-5 + ENDIF + +C...U-TYPE QUARKS + 140 CONTINUE + IA=2 + JA=1 + EI=KCHG(IABS(IA),1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) + XXC(6)=1D6 + CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP + CXC(2)=DCMPLX(0D0,0D0) + CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP + CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW) + CXC(5)=-DCMPLX(EI/XW1)*ORPP + CXC(6)=DCMPLX(0D0,0D0) + CXC(7)=-DCMPLX(EI/XW1)*OLPP + CXC(8)=DCMPLX(0D0,0D0) + IF( XXC(5).LT.AXMI ) THEN + XXC(5)=1D6 + ENDIF + XXC(7)=XXC(5) + XXC(8)=XXC(6) + IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=2 + IDLAM(LKNT,3)=-2 + IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=4 + IDLAM(LKNT,3)=-4 + ENDIF + ENDIF + 150 CONTINUE + ENDIF + +C...CHI_2+ -> CHI_1+ + H0_K + EH(2)=COS(ALFA) + EH(1)=SIN(ALFA) + EH(3)=-SBETA + DH(2)=-SIN(ALFA) + DH(1)=COS(ALFA) + DH(3)=COS(BETA) + DO 160 IH=1,3 + XMH=PMAS(ITH(IH),1) + XMH2=XMH**2 +C...NO 3-BODY OPTION + IF(AXMI.GE.AXMJ+XMH) THEN + LKNT=LKNT+1 + XL=PYLAMF(XMI2,XMJ2,XMH2) + OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) - + & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2 + ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) - + & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2 + XMK=XMJ*ETAH(IH) + GX2=ABS(OLPP)**2+ABS(ORPP)**2 + GLR=DBLE(OLPP*DCONJG(ORPP)) + XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR) + IDLAM(LKNT,1)=KFCCHI(1) + IDLAM(LKNT,2)=ITH(IH) + IDLAM(LKNT,3)=0 + ENDIF + 160 CONTINUE + +C...CHI1 JUMPS TO HERE + 170 CONTINUE + +C...CHI+_I -> CHI0_J + W+ + DO 220 IJ=1,4 + XMJ=SMZ(IJ) + AXMJ=ABS(XMJ) + XMJ2=XMJ**2 + IF(AXMI.GE.AXMJ+XMW) THEN + LKNT=LKNT+1 + DO 180 I=1,4 + ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I)) + 180 CONTINUE + CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)- + & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2) + CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+ + & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2) + GX2=ABS(CXC(1))**2+ABS(CXC(3))**2 + GLR=DBLE(CXC(1)*DCONJG(CXC(3))) + XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=24 + IDLAM(LKNT,3)=0 +C...LEPTONS + ELSEIF(AXMI.GE.AXMJ) THEN + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + DO 190 I=1,4 + ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I)) + 190 CONTINUE + CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)- + & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2 + CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+ + & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2 + CXC(5)=DCMPLX(0D0,0D0) + CXC(7)=DCMPLX(0D0,0D0) + IA=11 + JA=12 + EI=KCHG(IA,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + EJ=KCHG(JA,1)/3D0 + T3J=SIGN(1D0,EJ+1D-6)/2D0 + CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)* + & TANW+ZMIXC(IJ,2)*T3J)/SR2 + CXC(4)=-DCONJG(UMIXC(IX,1))*( + & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2 + CXC(6)=DCMPLX(0D0,0D0) + CXC(8)=DCMPLX(0D0,0D0) + XXC(1)=0D0 + XXC(2)=XMJ + XXC(3)=0D0 + XXC(4)=XMI + XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) + XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1) + XXC(9)=PMAS(24,1) + XXC(10)=PMAS(24,2) +CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190 + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ELSEIF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(6) + XXC(8)=XXC(5) +C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW, +C...--> 1/(16PI)/M**3*(AEM/XW)**2 + IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN + LKNT=LKNT+1 + TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=-11 + IDLAM(LKNT,3)=12 +C...ONLY DECAY CHI+1 -> E+ NU_E + IF( IMSS(12).NE. 0 ) GOTO 260 + IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=-13 + IDLAM(LKNT,3)=14 + ENDIF + ENDIF + IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN + LKNT=LKNT+1 + IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN + XXC(6)=PMAS(PYCOMP(KSUSY1+15),1) + ELSE + XXC(6)=PMAS(PYCOMP(KSUSY2+15),1) + ENDIF + XXC(5)=PMAS(PYCOMP(KSUSY1+16),1) + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ELSEIF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(6) + XXC(8)=XXC(5) + TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=-15 + IDLAM(LKNT,3)=16 + ENDIF + +C...NOW, DO THE QUARKS + 200 CONTINUE + IA=1 + JA=2 + EI=KCHG(IA,1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + EJ=KCHG(JA,1)/3D0 + T3J=SIGN(1D0,EJ+1D-6)/2D0 + CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)* + & TANW+ZMIXC(IJ,2)*T3J) + CXC(4)=-DCONJG(UMIXC(IX,1))*( + & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I) + XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1) + XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1) + IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210 + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ENDIF + IF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(6) + XXC(8)=XXC(5) + IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=-1 + IDLAM(LKNT,3)=2 + IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=-3 + IDLAM(LKNT,3)=4 + ENDIF + ENDIF + 210 CONTINUE + ENDIF + 220 CONTINUE + +C...CHI+_I -> CHI0_J + H+ + DO 230 IJ=1,4 + XMJ=SMZ(IJ) + AXMJ=ABS(XMJ) + XMJ2=XMJ**2 + XMHP=PMAS(ITHC,1) + IF(AXMI.GE.AXMJ+XMHP) THEN + LKNT=LKNT+1 + OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+ + & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2) + ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)- + & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)* + & UMIXC(IX,2)/SR2) + GX2=ABS(OLPP)**2+ABS(ORPP)**2 + GLR=DBLE(OLPP*DCONJG(ORPP)) + XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=ITHC + IDLAM(LKNT,3)=0 + ELSE + + ENDIF + 230 CONTINUE + +C...2-BODY DECAYS TO FERMION SFERMION + DO 240 J=1,16 + IF(J.GE.7.AND.J.LE.10) GOTO 240 + IF(MOD(J,2).EQ.0) THEN + KF1=KSUSY1+J-1 + ELSE + KF1=KSUSY1+J+1 + ENDIF + KF2=KF1+KSUSY1 + XMSF1=PMAS(PYCOMP(KF1),1) + XMSF2=PMAS(PYCOMP(KF2),1) + XMF=PMAS(J,1) + IF(J.LE.6) THEN + FCOL=3D0 + ELSE + FCOL=1D0 + ENDIF + +C...U~ D_L + IF(MOD(J,2).EQ.0) THEN + XMFP=PMAS(J-1,1) + CAL=UMIXC(IX,1) + CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2 + CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2 + CBR=0D0 + ISF=J-1 + ELSE + XMFP=PMAS(J+1,1) + CAL=VMIXC(IX,1) + CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2 + CBR=0D0 + CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2 + ISF=J+1 + ENDIF + +C...~U_L D + IF(AXMI.GE.XMF+XMSF1) THEN + LKNT=LKNT+1 + XMA2=XMSF1**2 + XMB2=XMF**2 + XL=PYLAMF(XMI2,XMA2,XMB2) + CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2) + CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2) + XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* + & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI) + IDLAM(LKNT,3)=0 + IF(MOD(J,2).EQ.0) THEN + IDLAM(LKNT,1)=-KF1 + IDLAM(LKNT,2)=J + ELSE + IDLAM(LKNT,1)=KF1 + IDLAM(LKNT,2)=-J + ENDIF + ENDIF + +C...U~ D_R + IF(AXMI.GE.XMF+XMSF2) THEN + LKNT=LKNT+1 + XMA2=XMSF2**2 + XMB2=XMF**2 + CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4) + CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4) + XL=PYLAMF(XMI2,XMA2,XMB2) + XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)* + & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI) + IDLAM(LKNT,3)=0 + IF(MOD(J,2).EQ.0) THEN + IDLAM(LKNT,1)=-KF2 + IDLAM(LKNT,2)=J + ELSE + IDLAM(LKNT,1)=KF2 + IDLAM(LKNT,2)=-J + ENDIF + ENDIF + 240 CONTINUE + +C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH +C...A 2-BODY -- 2-BODY CHAIN + XMJ=PMAS(PYCOMP(KSUSY1+21),1) + IF(AXMI.GE.XMJ) THEN + AXMJ=ABS(XMJ) + S12MIN=0D0 + S12MAX=(AXMI-AXMJ)**2 + XXC(1)=0D0 + XXC(2)=XMJ + XXC(3)=0D0 + XXC(4)=XMI + XXC(5)=PMAS(PYCOMP(KSUSY1+1),1) + XXC(6)=PMAS(PYCOMP(KSUSY1+2),1) + XXC(9)=1D6 + XXC(10)=0D0 + OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32))) + ORPP=DCONJG(OLPP) + CXC(1)=DCMPLX(0D0,0D0) + CXC(3)=DCMPLX(0D0,0D0) + CXC(5)=DCMPLX(0D0,0D0) + CXC(7)=DCMPLX(0D0,0D0) + CXC(2)=UMIXC(IX,1)*OLPP/SR2 + CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2 + CXC(6)=DCMPLX(0D0,0D0) + CXC(8)=DCMPLX(0D0,0D0) + IF(XXC(5).LT.AXMI) THEN + XXC(5)=1D6 + ELSEIF(XXC(6).LT.AXMI) THEN + XXC(6)=1D6 + ENDIF + XXC(7)=XXC(6) + XXC(8)=XXC(5) + IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250 + IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)* + & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC) + IDLAM(LKNT,1)=KSUSY1+21 + IDLAM(LKNT,2)=-1 + IDLAM(LKNT,3)=2 + IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN + LKNT=LKNT+1 + XLAM(LKNT)=XLAM(LKNT-1) + IDLAM(LKNT,1)=KSUSY1+21 + IDLAM(LKNT,2)=-3 + IDLAM(LKNT,3)=4 + ENDIF + ENDIF + 250 CONTINUE + ENDIF + +C...R-violating decay modes (SKANDS). + CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT) + + 260 IKNT=LKNT + XLAM(0)=0D0 + DO 270 I=1,IKNT + XLAM(0)=XLAM(0)+XLAM(I) + IF(XLAM(I).LT.0D0) THEN + WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN, + & (IDLAM(I,J),J=1,3) + XLAM(I)=0D0 + ENDIF + 270 CONTINUE + IF(XLAM(0).EQ.0D0) THEN + XLAM(0)=1D-6 + WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0) + WRITE(MSTU(11),*) LKNT + WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYXXZ6 +C...Used in the calculation of inoi -> inoj + f + ~f. + + FUNCTION PYXXZ6(X) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) +C COMMON/PYINTS/XXM(20) + COMPLEX*16 CXC + COMMON/PYINTC/XXC(10),CXC(8) + SAVE /PYDAT1/,/PYINTC/ + +C...Local variables. + COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT + DOUBLE PRECISION PYXXZ6,X + DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2 + DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2 + DOUBLE PRECISION SIJ + DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2 + DOUBLE PRECISION OL2 + DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL + INTEGER I + +C...Statement functions. +C...Integral from x to y of (t-a)(b-t) dt. + TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B) +C...Integral from x to y of (t-a)(b-t)/(t-c) dt. + TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))- + &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A) +C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt. + TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+ + &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C))) +C...Integral from x to y of (t-a)/(b-t) dt. + UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A) +C...Integral from x to y of 1/(t-a) dt. + TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A))) + + XM12=XXC(1)**2 + XM22=XXC(2)**2 + XM32=XXC(3)**2 + S=XXC(4)**2 + S13=X + + S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S) + S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)* + &( (X-XM22-S)**2 -4D0*XM22*S ) ) + + S23MIN=(S23AVE-S23DEL) + S23MAX=(S23AVE+S23DEL) + + XMSD1=XXC(5)**2 + XMSD2=XXC(7)**2 + XMSU1=XXC(6)**2 + XMSU2=XXC(8)**2 + + XMV=XXC(9) + XMG=XXC(10) + QLLS=CXC(1) + QLLU=CXC(2) + QLRS=CXC(3) + QLRT=CXC(4) + QRLS=CXC(5) + QRLT=CXC(6) + QRRS=CXC(7) + QRRU=CXC(8) + WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2 + SIJ=2D0*XXC(2)*XXC(4)*S13 + IF(XMV.LE.1000D0) THEN + OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2 + OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS)) + WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S) + & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2 + IF(XXC(5).LE.10000D0) THEN + WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))* + & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)- + & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+ + & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)- + & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1)) + & *(S13-XMV**2)/WPROP2 + ELSE + WFL1=0D0 + ENDIF + + IF(XXC(6).LE.10000D0) THEN + WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))* + & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)- + & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+ + & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)- + & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1)) + & *(S13-XMV**2)/WPROP2 + ELSE + WFL2=0D0 + ENDIF + ELSE + WW=0D0 + WFL1=0D0 + WFL2=0D0 + ENDIF + IF(XXC(5).LE.10000D0) THEN + WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1) + & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2) + & - 2D0*DBLE(QLRT*DCONJG(QLLU))* + & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2) + ELSE + WF1=0D0 + ENDIF + IF(XXC(6).LE.10000D0) THEN + WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1) + & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2) + & - 2D0*DBLE(QRLT*DCONJG(QRRU))* + & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2) + ELSE + WF2=0D0 + ENDIF + + PYXXZ6=(WW+WF1+WF2+WFL1+WFL2) + + IF(PYXXZ6.LT.0D0) THEN + WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 ' + WRITE(MSTU(11),*) (XXC(I),I=1,5) + WRITE(MSTU(11),*) (XXC(I),I=6,10) + WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2 + WRITE(MSTU(11),*) S23MIN,S23MAX + PYXXZ6=0D0 + ENDIF + + RETURN + END + + +C********************************************************************* + +C...PYXXGA +C...Calculates chi0_i -> chi0_j + gamma. + + FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local variables. + DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL + DOUBLE PRECISION F1,F2 + + F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR) + F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL) + PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3 + PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2 + + RETURN + END + +C********************************************************************* + +C...PYX2XG +C...Calculates the decay rate for ino -> ino + gauge boson. + + FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local variables. + DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR + DOUBLE PRECISION XL,PYLAMF,C1 + DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3 + + XMI2=XM1**2 + XMI3=ABS(XM1**3) + XMJ2=XM2**2 + XMV2=XM3**2 + XL=PYLAMF(XMI2,XMJ2,XMV2) + PYX2XG=C1/8D0/XMI3*SQRT(XL) + &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))- + &12D0*GLR*XM1*XM2*XMV2) + + RETURN + END + +C********************************************************************* + +C...PYX2XH +C...Calculates the decay rate for ino -> ino + H. + + FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local variables. + DOUBLE PRECISION PYX2XH,XM1,XM2,XM3 + DOUBLE PRECISION XL,PYLAMF,C1 + DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3 + + XMI2=XM1**2 + XMI3=ABS(XM1**3) + XMJ2=XM2**2 + XMV2=XM3**2 + XL=PYLAMF(XMI2,XMJ2,XMV2) + PYX2XH=C1/8D0/XMI3*SQRT(XL) + &*(GX2*(XMI2+XMJ2-XMV2)+ + &4D0*GLR*XM1*XM2) + + RETURN + END + +C********************************************************************* + +C...PYHEXT +C...Calculates the non-standard decay modes of the Higgs boson. +C... +C...Author: Stephen Mrenna +C...Last Update: April 2001 +C......Allow complex values for Z,U, and V + + SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/ + +C...Local variables. + COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP + COMPLEX*16 QIJ,RIJ,F21K,F12K + INTEGER KFIN + DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI + DOUBLE PRECISION XMI2,XMI3,XMJ2 + DOUBLE PRECISION PYLAMF,XL,CF,EI + INTEGER IDU,IFL + DOUBLE PRECISION TANW,XW,AEM,C1,AS + DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR + DOUBLE PRECISION XLAM(0:400) + INTEGER IDLAM(400,3) + INTEGER LKNT,IH,J,IJ,I,IKNT,IK + INTEGER ITH(4) + INTEGER KFNCHI(4),KFCCHI(2) + DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3) + DOUBLE PRECISION SR2 + DOUBLE PRECISION BETA,ALFA + DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB + DOUBLE PRECISION PYALEM + DOUBLE PRECISION AL,AR,ALR + DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML + DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL + DOUBLE PRECISION XMJL,XMJR,XM1,XM2 + DATA ITH/25,35,36,37/ + DATA ETAH/1D0,1D0,-1D0/ + DATA SR2/1.4142136D0/ + DATA KFNCHI/1000022,1000023,1000025,1000035/ + DATA KFCCHI/1000024,1000037/ + +C...COUNT THE NUMBER OF DECAY MODES + LKNT=IKNT + + XMW=PMAS(24,1) + XMW2=XMW**2 + XMZ=PMAS(23,1) + XW=PARU(102) + TANW = SQRT(XW/(1D0-XW)) + CW=SQRT(1D0-XW) + +C...1 - 4 DEPENDING ON Higgs species. + IH=1 + IF(KFIN.EQ.ITH(2)) IH=2 + IF(KFIN.EQ.ITH(3)) IH=3 + IF(KFIN.EQ.ITH(4)) IH=4 + + XMI=PMAS(KFIN,1) + XMI2=XMI**2 + AXMI=ABS(XMI) + AEM=PYALEM(XMI2) + C1=AEM/XW + XMI3=ABS(XMI**3) + + TANB=RMSS(5) + BETA=ATAN(TANB) + CBETA=COS(BETA) + SBETA=TANB*CBETA + ALFA=RMSS(18) + COSA=COS(ALFA) + SINA=SIN(ALFA) + ATRIT=RMSS(16) + ATRIB=RMSS(15) + ATRIL=RMSS(17) + XMUZ=-RMSS(4) + + DO 110 I=1,4 + DO 100 J=1,4 + ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I)) + 100 CONTINUE + 110 CONTINUE + DO 130 I=1,2 + DO 120 J=1,2 + VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I)) + UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I)) + 120 CONTINUE + 130 CONTINUE + + + IF(IH.EQ.4) GOTO 220 + +C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS +C...H0_K -> CHI0_I + CHI0_J + EH(2)=SINA + EH(1)=COSA + EH(3)=CBETA + DH(2)=COSA + DH(1)=-SINA + DH(3)=SBETA + DO 150 IJ=1,4 + XMJ=SMZ(IJ) + AXMJ=ABS(XMJ) + DO 140 IK=1,IJ + XMK=SMZ(IK) + AXMK=ABS(XMK) + IF(AXMI.GE.AXMJ+AXMK) THEN + LKNT=LKNT+1 + QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+ + & ZMIXC(IJ,3)*ZMIXC(IK,2)- + & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+ + & ZMIXC(IJ,3)*ZMIXC(IK,1)) + RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+ + & ZMIXC(IJ,4)*ZMIXC(IK,2)- + & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+ + & ZMIXC(IJ,4)*ZMIXC(IK,1)) + F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH)) + F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH)) +C...SIGN OF MASSES I,J + XML=XMK*ETAH(IH) + GX2=ABS(F12K)**2+ABS(F21K)**2 + GLR=DBLE(F12K*DCONJG(F21K)) + XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR) + IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0 + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=KFNCHI(IK) + IDLAM(LKNT,3)=0 + ENDIF + 140 CONTINUE + 150 CONTINUE + +C...H0_K -> CHI+_I CHI-_J + DO 170 IJ=1,2 + XMJ=SMW(IJ) + AXMJ=ABS(XMJ) + DO 160 IK=1,2 + XMK=SMW(IK) + AXMK=ABS(XMK) + IF(AXMI.GE.AXMJ+AXMK) THEN + LKNT=LKNT+1 + OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) + + & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2 + ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) + + & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2 + GX2=ABS(OLPP)**2+ABS(ORPP)**2 + GLR=DBLE(OLPP*DCONJG(ORPP)) + XML=XMK*ETAH(IH) + XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR) + IDLAM(LKNT,1)=KFCCHI(IJ) + IDLAM(LKNT,2)=-KFCCHI(IK) + IDLAM(LKNT,3)=0 + ENDIF + 160 CONTINUE + 170 CONTINUE + +C...HIGGS TO SFERMION SFERMION + DO 200 IFL=1,16 + IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200 + IJ=KSUSY1+IFL + XMJL=PMAS(PYCOMP(IJ),1) + XMJR=PMAS(PYCOMP(IJ+KSUSY1),1) + IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN + XMJ=XMJL + XMJ2=XMJ**2 + XL=PYLAMF(XMI2,XMJ2,XMJ2) + XMF=PMAS(IFL,1) + EI=KCHG(IFL,1)/3D0 + IDU=2-MOD(IFL,2) + + IF(IH.EQ.1) THEN + IF(IDU.EQ.1) THEN + GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+ + & XMF**2/XMW*SINA/CBETA + GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+ + & XMF**2/XMW*SINA/CBETA + IF(IFL.EQ.5) THEN + GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA- + & ATRIB*SINA) + ELSEIF(IFL.EQ.15) THEN + GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA- + & ATRIL*SINA) + ELSE + GHLR=0D0 + ENDIF + ELSE + GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)- + & XMF**2/XMW*COSA/SBETA + GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)- + & XMF**2/XMW*COSA/SBETA + IF(IFL.EQ.6) THEN + GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA- + & ATRIT*COSA) + ELSE + GHLR=0D0 + ENDIF + ENDIF + + ELSEIF(IH.EQ.2) THEN + IF(IDU.EQ.1) THEN + GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)- + & XMF**2/XMW*COSA/CBETA + GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)- + & XMF**2/XMW*COSA/CBETA + IF(IFL.EQ.5) THEN + GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+ + & ATRIB*COSA) + ELSEIF(IFL.EQ.15) THEN + GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+ + & ATRIL*COSA) + ELSE + GHLR=0D0 + ENDIF + ELSE + GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)- + & XMF**2/XMW*SINA/SBETA + GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)- + & XMF**2/XMW*SINA/SBETA + IF(IFL.EQ.6) THEN + GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+ + & ATRIT*SINA) + ELSE + GHLR=0D0 + ENDIF + ENDIF + + ELSEIF(IH.EQ.3) THEN + GHLL=0D0 + GHRR=0D0 + GHLR=0D0 + IF(IDU.EQ.1) THEN + IF(IFL.EQ.5) THEN + GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ) + ELSEIF(IFL.EQ.15) THEN + GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ) + ENDIF + ELSE + IF(IFL.EQ.6) THEN + GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ) + ENDIF + ENDIF + ENDIF + IF(IH.EQ.3) GOTO 180 + + AL=SFMIX(IFL,1)**2 + AR=SFMIX(IFL,2)**2 + ALR=SFMIX(IFL,1)*SFMIX(IFL,2) + IF(IFL.LE.6) THEN + CF=3D0 + ELSE + CF=1D0 + ENDIF + + IF(AXMI.GE.2D0*XMJ) THEN + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* + & (GHLL*AL+GHRR*AR + & +2D0*GHLR*ALR)**2 + IDLAM(LKNT,1)=IJ + IDLAM(LKNT,2)=-IJ + IDLAM(LKNT,3)=0 + ENDIF + + IF(AXMI.GE.2D0*XMJR) THEN + LKNT=LKNT+1 + AL=SFMIX(IFL,3)**2 + AR=SFMIX(IFL,4)**2 + ALR=SFMIX(IFL,3)*SFMIX(IFL,4) + XMJ=XMJR + XMJ2=XMJ**2 + XL=PYLAMF(XMI2,XMJ2,XMJ2) + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* + & (GHLL*AL+GHRR*AR + & +2D0*GHLR*ALR)**2 + IDLAM(LKNT,1)=IJ+KSUSY1 + IDLAM(LKNT,2)=-(IJ+KSUSY1) + IDLAM(LKNT,3)=0 + ENDIF + 180 CONTINUE + + IF(AXMI.GE.XMJL+XMJR) THEN + LKNT=LKNT+1 + AL=SFMIX(IFL,1)*SFMIX(IFL,3) + AR=SFMIX(IFL,2)*SFMIX(IFL,4) + ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3) + XMJ=XMJR + XMJ2=XMJ**2 + XL=PYLAMF(XMI2,XMJ2,XMJL**2) + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* + & (GHLL*AL+GHRR*AR)**2 + IDLAM(LKNT,1)=IJ + IDLAM(LKNT,2)=-(IJ+KSUSY1) + IDLAM(LKNT,3)=0 + LKNT=LKNT+1 + IDLAM(LKNT,1)=-IJ + IDLAM(LKNT,2)=IJ+KSUSY1 + IDLAM(LKNT,3)=0 + XLAM(LKNT)=XLAM(LKNT-1) + ENDIF + ENDIF + 190 CONTINUE + 200 CONTINUE + 210 CONTINUE + + GOTO 270 + 220 CONTINUE + +C...H+ -> CHI+_I + CHI0_J + DO 240 IJ=1,4 + XMJ=SMZ(IJ) + AXMJ=ABS(XMJ) + XMJ2=XMJ**2 + DO 230 IK=1,2 + XMK=SMW(IK) + AXMK=ABS(XMK) + IF(AXMI.GE.AXMJ+AXMK) THEN + LKNT=LKNT+1 + OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+ + & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2) + ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)- + & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2) + GX2=ABS(OLPP)**2+ABS(ORPP)**2 + GLR=DBLE(OLPP*DCONJG(ORPP)) + XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR) + IDLAM(LKNT,1)=KFNCHI(IJ) + IDLAM(LKNT,2)=KFCCHI(IK) + IDLAM(LKNT,3)=0 + ENDIF + 230 CONTINUE + 240 CONTINUE + + GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2) + GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB) + AL=0D0 + AR=0D0 + CF=3D0 + +C...H+ -> T_1 B_1~ + XM1=PMAS(PYCOMP(KSUSY1+6),1) + XM2=PMAS(PYCOMP(KSUSY1+5),1) + IF(XMI.GE.XM1+XM2) THEN + XL=PYLAMF(XMI2,XM1**2,XM2**2) + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* + & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2 + IDLAM(LKNT,1)=KSUSY1+6 + IDLAM(LKNT,2)=-(KSUSY1+5) + IDLAM(LKNT,3)=0 + ENDIF + +C...H+ -> T_2 B_1~ + XM1=PMAS(PYCOMP(KSUSY2+6),1) + XM2=PMAS(PYCOMP(KSUSY1+5),1) + IF(XMI.GE.XM1+XM2) THEN + XL=PYLAMF(XMI2,XM1**2,XM2**2) + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* + & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2 + IDLAM(LKNT,1)=KSUSY2+6 + IDLAM(LKNT,2)=-(KSUSY1+5) + IDLAM(LKNT,3)=0 + ENDIF + +C...H+ -> T_1 B_2~ + XM1=PMAS(PYCOMP(KSUSY1+6),1) + XM2=PMAS(PYCOMP(KSUSY2+5),1) + IF(XMI.GE.XM1+XM2) THEN + XL=PYLAMF(XMI2,XM1**2,XM2**2) + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* + & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2 + IDLAM(LKNT,1)=KSUSY1+6 + IDLAM(LKNT,2)=-(KSUSY2+5) + IDLAM(LKNT,3)=0 + ENDIF + +C...H+ -> T_2 B_2~ + XM1=PMAS(PYCOMP(KSUSY2+6),1) + XM2=PMAS(PYCOMP(KSUSY2+5),1) + IF(XMI.GE.XM1+XM2) THEN + XL=PYLAMF(XMI2,XM1**2,XM2**2) + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3* + & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2 + IDLAM(LKNT,1)=KSUSY2+6 + IDLAM(LKNT,2)=-(KSUSY2+5) + IDLAM(LKNT,3)=0 + ENDIF + +C...H+ -> UL DL~ + GL=-XMW/SR2*SIN(2D0*BETA) + DO 250 IJ=1,3,2 + XM1=PMAS(PYCOMP(KSUSY1+IJ),1) + XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1) + IF(XMI.GE.XM1+XM2) THEN + XL=PYLAMF(XMI2,XM1**2,XM2**2) + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2 + IDLAM(LKNT,1)=-(KSUSY1+IJ) + IDLAM(LKNT,2)=KSUSY1+IJ+1 + IDLAM(LKNT,3)=0 + ENDIF + 250 CONTINUE + +C...H+ -> EL~ NUL + CF=1D0 + DO 260 IJ=11,13,2 + XM1=PMAS(PYCOMP(KSUSY1+IJ),1) + XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1) + IF(XMI.GE.XM1+XM2) THEN + XL=PYLAMF(XMI2,XM1**2,XM2**2) + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2 + IDLAM(LKNT,1)=-(KSUSY1+IJ) + IDLAM(LKNT,2)=KSUSY1+IJ+1 + IDLAM(LKNT,3)=0 + ENDIF + 260 CONTINUE + +C...H+ -> TAU1 NUTAUL + XM1=PMAS(PYCOMP(KSUSY1+15),1) + XM2=PMAS(PYCOMP(KSUSY1+16),1) + IF(XMI.GE.XM1+XM2) THEN + XL=PYLAMF(XMI2,XM1**2,XM2**2) + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2 + IDLAM(LKNT,1)=-(KSUSY1+15) + IDLAM(LKNT,2)= KSUSY1+16 + IDLAM(LKNT,3)=0 + ENDIF + +C...H+ -> TAU2 NUTAUL + XM1=PMAS(PYCOMP(KSUSY2+15),1) + XM2=PMAS(PYCOMP(KSUSY1+16),1) + IF(XMI.GE.XM1+XM2) THEN + XL=PYLAMF(XMI2,XM1**2,XM2**2) + LKNT=LKNT+1 + XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2 + IDLAM(LKNT,1)=-(KSUSY2+15) + IDLAM(LKNT,2)= KSUSY1+16 + IDLAM(LKNT,3)=0 + ENDIF + + 270 CONTINUE + IKNT=LKNT + XLAM(0)=0D0 + DO 280 I=1,IKNT + IF(XLAM(I).LE.0D0) XLAM(I)=0D0 + XLAM(0)=XLAM(0)+XLAM(I) + 280 CONTINUE + IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6 + + RETURN + END + +C********************************************************************* + +C...PYH2XX +C...Calculates the decay rate for a Higgs to an ino pair. + + FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + +C...Local variables. + DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR + DOUBLE PRECISION XL,PYLAMF,C1 + DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3 + + XMI2=XM1**2 + XMI3=ABS(XM1**3) + XMJ2=XM2**2 + XMK2=XM3**2 + XL=PYLAMF(XMI2,XMJ2,XMK2) + PYH2XX=C1/4D0/XMI3*SQRT(XL) + &*(GX2*(XMI2-XMJ2-XMK2)- + &4D0*GLR*XM3*XM2) + IF(PYH2XX.LT.0D0) PYH2XX=0D0 + + RETURN + END + +C********************************************************************* + +C...PYGAUS +C...Integration by adaptive Gaussian quadrature. +C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig. + + FUNCTION PYGAUS(F, A, B, EPS) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local declarations. + EXTERNAL F + DOUBLE PRECISION F,W(12), X(12) + DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/ + DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/ + DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/ + DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/ + DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/ + DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/ + DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/ + DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/ + DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/ + DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/ + DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/ + DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/ + +C...The Gaussian quadrature algorithm. + H = 0D0 + IF(B .EQ. A) GOTO 140 + CONST = 5D-3 / ABS(B-A) + BB = A + 100 CONTINUE + AA = BB + BB = B + 110 CONTINUE + C1 = 0.5D0*(BB+AA) + C2 = 0.5D0*(BB-AA) + S8 = 0D0 + DO 120 I = 1, 4 + U = C2*X(I) + S8 = S8 + W(I) * (F(C1+U) + F(C1-U)) + 120 CONTINUE + S16 = 0D0 + DO 130 I = 5, 12 + U = C2*X(I) + S16 = S16 + W(I) * (F(C1+U) + F(C1-U)) + 130 CONTINUE + S16 = C2*S16 + IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN + H = H + S16 + IF(BB .NE. B) GOTO 100 + ELSE + BB = C1 + IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110 + H = 0D0 + CALL PYERRM(18,'(PYGAUS:) too high accuracy required') + GOTO 140 + ENDIF + 140 CONTINUE + PYGAUS = H + + RETURN + END + +C********************************************************************* + +C...PYGAU2 +C...Integration by adaptive Gaussian quadrature. +C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig. +C...Carbon copy of PYGAUS, but avoids having to use it recursively. + + FUNCTION PYGAU2(F, A, B, EPS) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local declarations. + EXTERNAL F + DOUBLE PRECISION F,W(12), X(12) + DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/ + DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/ + DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/ + DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/ + DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/ + DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/ + DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/ + DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/ + DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/ + DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/ + DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/ + DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/ + +C...The Gaussian quadrature algorithm. + H = 0D0 + IF(B .EQ. A) GOTO 140 + CONST = 5D-3 / ABS(B-A) + BB = A + 100 CONTINUE + AA = BB + BB = B + 110 CONTINUE + C1 = 0.5D0*(BB+AA) + C2 = 0.5D0*(BB-AA) + S8 = 0D0 + DO 120 I = 1, 4 + U = C2*X(I) + S8 = S8 + W(I) * (F(C1+U) + F(C1-U)) + 120 CONTINUE + S16 = 0D0 + DO 130 I = 5, 12 + U = C2*X(I) + S16 = S16 + W(I) * (F(C1+U) + F(C1-U)) + 130 CONTINUE + S16 = C2*S16 + IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN + H = H + S16 + IF(BB .NE. B) GOTO 100 + ELSE + BB = C1 + IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110 + H = 0D0 + CALL PYERRM(18,'(PYGAU2:) too high accuracy required') + GOTO 140 + ENDIF + 140 CONTINUE + PYGAU2 = H + + RETURN + END + +C********************************************************************* + +C...PYSIMP +C...Simpson formula for an integral. + + FUNCTION PYSIMP(Y,X0,X1,N) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local variables. + DOUBLE PRECISION Y,X0,X1,H,S + DIMENSION Y(0:N) + + S=0D0 + H=(X1-X0)/N + DO 100 I=0,N-2,2 + S=S+Y(I)+4D0*Y(I+1)+Y(I+2) + 100 CONTINUE + PYSIMP=S*H/3D0 + + RETURN + END + +C********************************************************************* + +C...PYLAMF +C...The standard lambda function. + + FUNCTION PYLAMF(X,Y,Z) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + +C...Local variables. + DOUBLE PRECISION PYLAMF,X,Y,Z + + PYLAMF=(X-(Y+Z))**2-4D0*Y*Z + IF(PYLAMF.LT.0D0) PYLAMF=0D0 + + RETURN + END + +C********************************************************************* + +C...PYTBDY +C...Generates 3-body decays of gauginos. + + SUBROUTINE PYTBDY(IDIN) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,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) + 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/,/PYPARS/,/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 + + IA=K(N+2,2) + JA=K(N+3,2) + +C...Mrenna: check that we are indeed decaying a SUSY particle + IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN + + ELSE + 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 + ZM12=XM(5)**2 + ZM22=XM(1)**2 + EI=KCHG(PYCOMP(IABS(IA)),1)/3D0 + T3I=SIGN(1D0,EI+1D-6)/2D0 + ENDIF + + IF(MSTP(47).EQ.0) THEN + ISKIP=0 + ELSEIF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN + ISKIP=0 + ELSEIF(IZID1*IZID2.NE.0) THEN + SQMZ=PMAS(23,1)**2 + GMMZ=PMAS(23,1)*PMAS(23,2) + DO 110 I=1,4 + ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I)) + ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I)) + 110 CONTINUE + OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))- + & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0 + ORPP=DCONJG(OLPP) + XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2 + XLR2=XLL2 + XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2 + XRL2=XRR2 + GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))* + & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1)) + GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2 + XM1M2=SMZ(IZID1)*SMZ(IZID2) + QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP + QLLU=-GLIJ + QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP + QLRT=DCONJG(GLIJ) + QRLS=-DCMPLX((EI*XW)/XW1)*OLPP + QRLT=GRIJ + QRRS=DCMPLX((EI*XW)/XW1)*ORPP + QRRU=-DCONJG(GRIJ) + ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN + IF(IZID1.NE.0) THEN + XM1M2=SMZ(IZID1)*SMW(IWID2) + IZID1=IWID2 + IZID2=IZID1 + ELSE + XM1M2=SMZ(IZID2)*SMW(IWID1) + IZID1=IWID1 + ENDIF + RT2I = 1D0/SQRT(2D0) + SQMZ=PMAS(24,1)**2 + GMMZ=PMAS(24,1)*PMAS(24,2) + DO 120 I=1,2 + VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I)) + UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I)) + 120 CONTINUE + DO 130 I=1,4 + ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I)) + 130 CONTINUE + QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)- + & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I) + QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+ + & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I) + EJ=KCHG(IABS(JA),1)/3D0 + T3J=SIGN(1D0,EJ+1D-6)/2D0 + QRLS=DCMPLX(0D0,0D0) + QRLT=QRLS + QRRS=QRLS + QRRU=QRLS + XRR2=1D6**2 + XRL2=XRR2 + XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2 + XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2 + IF(MOD(IA,2).EQ.0) THEN + QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)* + & TANW+ZMIXC(IZID2,2)*T3I) + QLRT=-DCONJG(UMIXC(IZID1,1))*( + & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J) + ELSE + QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)* + & TANW+ZMIXC(IZID2,2)*T3J) + QLRT=-DCONJG(UMIXC(IZID1,1))*( + & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I) + ENDIF + ELSEIF(IWID1*IWID2.NE.0) THEN + IZID1=IWID1 + IZID2=IWID2 + XM1M2=SMW(IWID1)*SMW(IWID2) + SQMZ=PMAS(23,1)**2 + GMMZ=PMAS(23,1)*PMAS(23,2) + DO 140 I=1,2 + VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I)) + UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I)) + VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I)) + UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I)) + 140 CONTINUE + OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))- + & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0 + ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))- + & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0 + QRLS=-DCMPLX(EI/XW1)*ORPP + QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP + QRRS=-DCMPLX(EI/XW1)*OLPP + QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP + IF(MOD(IA,2).EQ.0) THEN + XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2 + QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW) + ELSE + XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2 + QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW) + ENDIF + ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21) + &THEN + ISKIP=0 + ELSE + ISKIP=0 + ENDIF + + IF(ISKIP.NE.0) THEN + WTMAX=0D0 + DO 160 KT=1,100 + S12=S12MIN+YJACO1*(KT-1)/99 + S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2) + & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12) + S23DF1=(S12-XM(2)**2-XM(1)**2)**2 + & -(2D0*XM(1)*XM(2))**2 + S23DF2=(S12-XM(3)**2-XM(5)**2)**2 + & -(2D0*XM(3)*XM(5))**2 + S23DF1=S23DF1*EPS + S23DF2=S23DF2*EPS + S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12) + S23DEL=S23DEL/EPS + S23MIN=S23AVE-S23DEL + S23MAX=S23AVE+S23DEL + YJACO2=S23MAX-S23MIN + TH=S12 + DO 150 KS=1,100 + S23=S23MIN+YJACO2*(KS-1)/99 + SH=S23 + UH=ZM12+ZM22-SH-TH + WU2 = (UH-ZM12)*(UH-ZM22) + WT2 = (TH-ZM12)*(TH-ZM22) + WS2 = XM1M2*SH + PROPZ2 = (SH-SQMZ)**2 + GMMZ**2 + PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2) + QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2) + QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2) + QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2) + QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2) + WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+ + & (ABS(QRL)**2+ABS(QLR)**2)*WT2+ + & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2) + IF(WT0.GT.WTMAX) WTMAX=WT0 + 150 CONTINUE + 160 CONTINUE + + WTMAX=WTMAX*1.05D0 + ENDIF + +C...FIND S12* + AX=S12MIN + CX=S12MAX + BX=S12MIN+0.5D0*YJACO1 + X0=AX + X3=CX + IF(ABS(CX-BX).GT.ABS(BX-AX))THEN + X1=BX + X2=BX+C*(CX-BX) + ELSE + X2=BX + X1=BX-C*(BX-AX) + ENDIF + +C...SOLVE FOR F1 AND F2 + S23DF1=(X1-XM(2)**2-XM(1)**2)**2 + &-(2D0*XM(1)*XM(2))**2 + S23DF2=(X1-XM(3)**2-XM(5)**2)**2 + &-(2D0*XM(3)*XM(5))**2 + S23DF1=S23DF1*EPS + S23DF2=S23DF2*EPS + S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1) + F1=-2D0*S23DEL/EPS + S23DF1=(X2-XM(2)**2-XM(1)**2)**2 + &-(2D0*XM(1)*XM(2))**2 + S23DF2=(X2-XM(3)**2-XM(5)**2)**2 + &-(2D0*XM(3)*XM(5))**2 + S23DF1=S23DF1*EPS + S23DF2=S23DF2*EPS + S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2) + F2=-2D0*S23DEL/EPS + + 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN +C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS) + IF(F2.LE.F1)THEN + X0=X1 + X1=X2 + X2=R*X1+C*X3 + F1=F2 + S23DF1=(X2-XM(2)**2-XM(1)**2)**2 + & -(2D0*XM(1)*XM(2))**2 + S23DF2=(X2-XM(3)**2-XM(5)**2)**2 + & -(2D0*XM(3)*XM(5))**2 + S23DF1=S23DF1*EPS + S23DF2=S23DF2*EPS + S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2) + F2=-2D0*S23DEL/EPS + ELSE + X3=X2 + X2=X1 + X1=R*X2+C*X0 + F2=F1 + S23DF1=(X1-XM(2)**2-XM(1)**2)**2 + & -(2D0*XM(1)*XM(2))**2 + S23DF2=(X1-XM(3)**2-XM(5)**2)**2 + & -(2D0*XM(3)*XM(5))**2 + S23DF1=S23DF1*EPS + S23DF2=S23DF2*EPS + S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1) + F1=-2D0*S23DEL/EPS + ENDIF + GOTO 170 + ENDIF +C...WE WANT THE MAXIMUM, NOT THE MINIMUM + IF(F1.LT.F2)THEN + GOLDEN=-F1 + XMIN=X1 + ELSE + GOLDEN=-F2 + XMIN=X2 + ENDIF + + IKNT=0 + 180 S12=S12MIN+PYR(0)*YJACO1 + IKNT=IKNT+1 +C...GENERATE S23 + S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2) + &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12) + S23DF1=(S12-XM(2)**2-XM(1)**2)**2 + &-(2D0*XM(1)*XM(2))**2 + S23DF2=(S12-XM(3)**2-XM(5)**2)**2 + &-(2D0*XM(3)*XM(5))**2 + S23DF1=S23DF1*EPS + S23DF2=S23DF2*EPS + S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12) + S23DEL=S23DEL/EPS + S23MIN=S23AVE-S23DEL + S23MAX=S23AVE+S23DEL + YJACO2=S23MAX-S23MIN + S23=S23MIN+PYR(0)*YJACO2 + +C...CHECK THE SAMPLING + IF(IKNT.GT.100) THEN + WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY ' + GOTO 190 + ENDIF + IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180 + + IF(ISKIP.EQ.0) GOTO 190 + + SH=S23 + TH=S12 + UH=ZM12+ZM22-SH-TH + + WU2 = (UH-ZM12)*(UH-ZM22) + WT2 = (TH-ZM12)*(TH-ZM22) + WS2 = XM1M2*SH + PROPZ2 = (SH-SQMZ)**2 + GMMZ**2 + PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2) + + QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2) + QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2) + QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2) + QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2) +c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2) +c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ) +c &/DCMPLX(TH-XML2) +c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2) +c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ +c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2) + WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+ + &(ABS(QRL)**2+ABS(QLR)**2)*WT2+ + &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2) + + IF(WT.LT.PYR(0)*WTMAX) GOTO 180 + IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX + + 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5)) + D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5)) + D2=XM(5)-D1-D3 + P1=SQRT(D1*D1-XM(1)**2) + P2=SQRT(D2*D2-XM(2)**2) + P3=SQRT(D3*D3-XM(3)**2) + CTHE1=2D0*PYR(0)-1D0 + ANG1=2D0*PYR(0)*PARU(1) + CPHI1=COS(ANG1) + SPHI1=SIN(ANG1) + ARG=1D0-CTHE1**2 + IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0 + STHE1=SQRT(ARG) + P(N+1,1)=P1*STHE1*CPHI1 + P(N+1,2)=P1*STHE1*SPHI1 + P(N+1,3)=P1*CTHE1 + P(N+1,4)=D1 + +C...GET CPHI3 + ANG3=2D0*PYR(0)*PARU(1) + CPHI3=COS(ANG3) + SPHI3=SIN(ANG3) + CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3 + ARG=1D0-CTHE3**2 + IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0 + STHE3=SQRT(ARG) + P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1 + &+P3*STHE3*SPHI3*SPHI1 + &+P3*CTHE3*STHE1*CPHI1 + P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1 + &-P3*STHE3*SPHI3*CPHI1 + &+P3*CTHE3*STHE1*SPHI1 + P(N+3,3)=P3*STHE3*CPHI3*STHE1 + &+P3*CTHE3*CTHE1 + P(N+3,4)=D3 + + DO 200 I=1,3 + P(N+2,I)=-P(N+1,I)-P(N+3,I) + 200 CONTINUE + P(N+2,4)=D2 + + RETURN + END + + +C********************************************************************* + +C...PYTECM +C...Finds the s-hat dependent eigenvalues of the inverse propagator +C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the +C...phase space generation. Extended to include techni-a meson, and +C...to return the width. + + SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/ + +C...Local variables. + DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12), + &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT, + &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5) + INTEGER i,j,ierr + + SH=SMIN + SHR=SQRT(SH) + AEM=PYALEM(SH) + + SINW=MIN(SQRT(PARU(102)),1D0) + COSW=SQRT(1D0-SINW**2) + TANW=SINW/COSW + CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW) + QUPD=2D0*RTCM(2)-1D0 + + ALPRHT=2.16D0*(3D0/DBLE(ITCM(1))) + FAR=SQRT(AEM/ALPRHT) + FAO=FAR*QUPD + FZR=FAR*CT2W + FZO=-FAO*TANW + FZX=-FAR/RTCM(47)/(2D0*SINW*COSW) + FWR=FAR/(2D0*SINW) + FWX=-FWR/RTCM(47) + + DO 110 I=1,5 + DO 100 J=1,5 + AT(I,J)=0D0 + 100 CONTINUE + 110 CONTINUE + +C...NC + IF(IOPT.EQ.1) THEN + 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(5,5) = SH-PMAS(PYCOMP(KTECHN+115),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 + AR(2,5) = SH*FZX + AR(5,2) = AR(2,5) + AR(1,5) = 0D0 + AR(5,1) = AR(1,5) + AR(3,5) = 0D0 + AR(5,3) = AR(3,5) + AR(4,5) = 0D0 + AR(5,4) = AR(4,5) + 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 + CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE) + AT(5,5) = WDTP(0)*SHR + IDIM=5 +C...CC + ELSE + AR(1,1) = SH-PMAS(24,1)**2 + AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2 + AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2 + AR(1,2) = SH*FWR + AR(2,1) = AR(1,2) + AR(1,3) = SH*FWX + AR(3,1) = AR(1,3) + AR(2,3) = 0D0 + AR(3,2) = 0D0 + CALL PYWIDT(24,SH,WDTP,WDTE) + AT(1,1) = WDTP(0)*SHR + CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE) + AT(2,2) = WDTP(0)*SHR + CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE) + AT(3,3) = WDTP(0)*SHR + IDIM=3 + ENDIF + CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR) + + IMIN=1 + SXMN=1D20 + DO 120 I=1,IDIM + WX(I)=SQRT(ABS(SH-WR(I))) + WR(I)=ABS(WR(I)) + IF(WR(I).LT.SXMN) THEN + SXMN=WR(I) + IMIN=I + ENDIF + 120 CONTINUE + SMOU=WX(IMIN)**2 + WIDO=WI(IMIN)/SHR + + RETURN + END +C********************************************************************* + +C...PYXDIN +C...Universal Extra Dimensions Model (UED) +C...Initialize the xd masses and widths +C...M. ELKACIMI 4/03/2006 +C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands + + SUBROUTINE PYXDIN + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) +C...UED Pythia common + COMMON/PYPUED/IUED(0:99),RUED(0:99) + +C...SAVE statements + SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPUED/ + +C...Print out some info about the UED model + WRITE(MSTU(11),7000) + & ' ', + & '********** PYXDIN: initialization of UED ******************', + & ' ', + & 'Universal Extra Dimensions (UED) switched on ', + & ' ', + & 'This implementation is courtesy of', + & ' M.Elkacimi, D.Goujdami, H.Przysiezniak, ', + & ' see [hep-ph/0602198] (Les Houches 2005) ', + & ' ', + & 'The model follows [hep-ph/0012100] (Appelquist, Cheng, ', + & 'Dobrescu), with gravity-mediated decay widths calculated in', + & '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ', + & 'radiative corrections to the KK masses from [hep/ph0204342]', + & '(Cheng, Matchev, Schmaltz).' + WRITE(MSTU(11),7000) + & ' ', + & 'SM particles can propagate into one small extra dimension ', + & 'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the', + & 'graviton is further allowed to propagate into N = IUED(4)', + & 'large (eV^-1) extra dimensions.' + WRITE(MSTU(11),7000) + & ' ', + & 'The switches and parameters for UED are:', + & ' IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ', + & ' IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)', + & ' IUED(3): (D=5) number of quark flavours', + & ' IUED(4): (D=6) number of large extra dimensions into', + & ' which the graviton propagates', + & ' IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used', + & ' IUED(6): (D=1) With/without rad.corrs. (=1/0)', + & ' ', + & ' RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)', + & ' RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)', + & ' RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used', + & ' when IUED(5)=0', + & ' RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1' + WRITE(MSTU(11),7000) + & ' ', + & 'N.B.: the Higgs mass is also a free parameter of the UED ', + & 'model, but is set through pmas(25,1).', + & ' ' + +C...Hardcoded switch, required by current implementation + CALL PYGIVE('MSTP(42)=0') + +C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF + IF(IUED(2).EQ.0) CALL PYGIVE('MDCY(C5100022,1)=0') + +C...Calculated the radiative corrections to the KK particle masses + CALL PYUEDC + +C...Initialize the graviton mass +C...only if the KK particles decays gravitationally + IF(IUED(2).EQ.1) CALL PYGRAM(0) + + WRITE(MSTU(11),7000) + & '********** PYXDIN: UED initialization completed ***********' + +C...Format to use for comments + 7000 FORMAT(' * ',A) + + RETURN + END +C********************************************************************* + +C...PYUEDC +C...Auxiliary to PYXDIN +C...Mass kk states radiative corrections +C...Radiative corrections are included (hep/ph0204342) + + SUBROUTINE PYUEDC + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP + + PARAMETER(KKPART=25,KKFLA=450) + +C...UED Pythia common + COMMON/PYPUED/IUED(0:99),RUED(0:99) +C...Pythia common: particles properties + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) +C...Parameters. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) +C...Decay information. + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) +C...Resonance width and secondary decay treatment. + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + +C...Local variables + DOUBLE PRECISION PI,QUP,QDW + DOUBLE PRECISION WDTP,WDTE + DIMENSION WDTP(0:400),WDTE(0:400,0:5) + DOUBLE PRECISION Q2,ALPHEM,ALPHS,SW2,CW2,RMKK,RMKK2,ZETA3 + DOUBLE PRECISION DSMG2,LOGLAM,DBMG2 + DOUBLE PRECISION DBMQU,DBMQD,DBMQDO,DBMLDO,DBMLE + DOUBLE PRECISION DSMA2,DSMB2,DBMA2,DBMB2 + DOUBLE PRECISION RFACT,RMW,RMZ,RMZ2,RMW2,A,B,C,SQRDEL,DMB2,DMA2 + DOUBLE PRECISION SWW1,CWW1 + DOUBLE PRECISION RMGST,RMPHST,RMZST,RMWST + DOUBLE PRECISION RMDQST,RMSQUS,RMSQDS,RMLSLD,RMLSLE + DOUBLE PRECISION SW21,CW21,SW021,CW021 + COMMON/SW1/SW021,CW021 +C...UED related declarations: +C...equivalences between ordered particles (451->475) +C...and UED particle code (5 000 000 + id) + DIMENSION IUEDEQ(475) + DATA (IUEDEQ(I),I=451,475)/ +C...Singlet quarks + & 6100001,6100002,6100003,6100004,6100005,6100006, +C...Doublet quarks + & 5100001,5100002,5100003,5100004,5100005,5100006, +C...Singlet leptons + & 6100011,6100013,6100015, +C...Doublet leptons + & 5100012,5100011,5100014,5100013,5100016,5100015, +C...Gauge boson KK excitations + & 5100021,5100022,5100023,5100024/ + +C...N.B. rinv=rued(1) + IF(RUED(1).LE.0.)THEN + WRITE(MSTU(11),*) 'PYUEDC: RINV < 0 : ',RUED(1) + WRITE(MSTU(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN ' + RETURN + ENDIF + + PI=DACOS(-1.D0) + RMZ = PMAS(23,1) + RMZ2 = RMZ**2 + RMW = PMAS(24,1) + RMW2 = RMW**2 + ALPHEM = PARU(101) + QUP = 2./3. + QDW = -1./3. + +c...qt is q-tilde, qs is q-star +c...strong coupling value + Q2 = RUED(1)**2 + ALPHS=PYALPS(Q2) + +c...weak mixing angle + SW2=PARU(102) + CW2=1D0-PARU(102) + +c...for the mass corrections + RMKK = RUED(1) + RMKK2 = RMKK**2 + ZETA3= 1.2 + +C... Either fix the cutoff scale LAMUED + IF(IUED(5).EQ.0)THEN + LOGLAM = DLOG((RUED(3)*(1./RUED(1)))**2) +C... or the ratio LAMUED/RINV (=product Lambda*R) + ELSEIF(IUED(5).EQ.1)THEN + LOGLAM = DLOG(RUED(4)**2) + ELSE + WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)' + CALL PYSTOP(6000) + ENDIF + +C...Calculate the radiative corrections for the UED KK masses + IF(IUED(6).EQ.1)THEN + RFACT=1.D0 +C...or induce a minute mass difference +C...keeping the UED KK mass values nearly equal to 1/R + ELSEIF(IUED(6).EQ.0)THEN + RFACT=0.01D0 + ELSE + WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)' + CALL PYSTOP(6001) + ENDIF + +c...Take into account only the strong interactions: + +c...The space bulk corrections : + DSMG2 = RMKK2*(-1.5)*(ALPHS/4./PI)*ZETA3/PI**2 +c...The boundary terms: + DBMG2 = RMKK2*(23./2.)*(ALPHS/4./PI)*LOGLAM + +c...Mass corrections for fermions are extracted from +c...Phys. Rev. D66 036005(2002)9 + DBMQDO=RMKK*(3.*(ALPHS/4./PI)+27./16.*(ALPHEM/4./PI/SW2) + . +1./16.*(ALPHEM/4./PI/CW2))*LOGLAM + DBMQU=RMKK*(3.*(ALPHS/4./PI) + . +(ALPHEM/4./PI/CW2))*LOGLAM + DBMQD=RMKK*(3.*(ALPHS/4./PI) + . +0.25*(ALPHEM/4./PI/CW2))*LOGLAM + + DBMLDO=RMKK *((27./16.)*(ALPHEM/4./PI/SW2)+9./16.* + . (ALPHEM/4./PI/CW2))*LOGLAM + DBMLE=RMKK *(9./4.*(ALPHEM/4./PI/CW2))*LOGLAM + +c...Vector boson masss matrix diagonalization + DBMB2 = RMKK2*(-1./6.)*(ALPHEM/4./PI/CW2)*LOGLAM + DSMB2 = RMKK2*(-39./2.)*(ALPHEM/4./PI**3/CW2)*ZETA3 + DBMA2 = RMKK2*(15./2.)*(ALPHEM/4./PI/SW2)*LOGLAM + DSMA2 = RMKK2*(-5./2.)*(ALPHEM/4./PI**3/SW2)*ZETA3 + +c...Elements of the mass matrix + A = RMZ2*SW2 + DBMB2 + DSMB2 + B = RMZ2*CW2 + DBMA2 + DSMA2 + C = RMZ2*DSQRT(SW2*CW2) + SQRDEL = DSQRT( (A-B)**2 + 4*C**2 ) + +c...Eigenvalues: corrections to X1 and Z1 masses + DMB2 = (A+B-SQRDEL)/2. + DMA2 = (A+B+SQRDEL)/2. + +c...Rotation angles + SWW1 = 2*C + CWW1 = A-B-SQRDEL +C...Weinberg angle + SW21= SWW1**2/(SWW1**2 + CWW1**2) + CW21= 1. - SW21 + + SW021=SW21 + CW021=CW21 + +c...Masses: + RMGST = RMKK+RFACT*(DSQRT(RMKK2 + DSMG2 + DBMG2)-RMKK) + + RMDQST=RMKK+RFACT*DBMQDO + RMSQUS=RMKK+RFACT*DBMQU + RMSQDS=RMKK+RFACT*DBMQD + +C...Note: MZ mass is included in ma2 + RMPHST= RMKK+RFACT*(DSQRT(RMKK2 + DMB2)-RMKK) + RMZST = RMKK+RFACT*(DSQRT(RMKK2 + DMA2)-RMKK) + RMWST = RMKK+RFACT*(DSQRT(RMKK2 + DBMA2 + DSMA2 + RMW**2)-RMKK) + + RMLSLD=RMKK+RFACT*DBMLDO + RMLSLE=RMKK+RFACT*DBMLE + + DO 100 IPART=1,5,2 + PMAS(KKFLA+IPART,1)=RMSQDS + 100 CONTINUE + DO 110 IPART=2,6,2 + PMAS(KKFLA+IPART,1)=RMSQUS + 110 CONTINUE + DO 120 IPART=7,12 + PMAS(KKFLA+IPART,1)=RMDQST + 120 CONTINUE + DO 130 IPART=13,15 + PMAS(KKFLA+IPART,1)=RMLSLE + 130 CONTINUE + DO 140 IPART=16,21 + PMAS(KKFLA+IPART,1)=RMLSLD + 140 CONTINUE + PMAS(KKFLA+22,1)=RMGST + PMAS(KKFLA+23,1)=RMPHST + PMAS(KKFLA+24,1)=RMZST + PMAS(KKFLA+25,1)=RMWST + + WRITE(MSTU(11),7000) ' PYUEDC: ', + & 'UED Mass Spectrum (GeV) :' + WRITE(MSTU(11),7100) ' m(d*_S,s*_S,b*_S) = ',RMSQDS + WRITE(MSTU(11),7100) ' m(u*_S,c*_S,t*_S) = ',RMSQUS + WRITE(MSTU(11),7100) ' m(q*_D) = ',RMDQST + WRITE(MSTU(11),7100) ' m(l*_S) = ',RMLSLE + WRITE(MSTU(11),7100) ' m(l*_D) = ',RMLSLD + WRITE(MSTU(11),7100) ' m(g*) = ',RMGST + WRITE(MSTU(11),7100) ' m(gamma*) = ',RMPHST + WRITE(MSTU(11),7100) ' m(Z*) = ',RMZST + WRITE(MSTU(11),7100) ' m(W*) = ',RMWST + WRITE(MSTU(11),7000) ' ' + +C...Initialize widths, branching ratios and life time + DO 199 IPART=1,25 + KC=KKFLA+IPART + IF(MWID(KC).EQ.1.AND.MDCY(KC,1).EQ.1)THEN + CALL PYWIDT(IUEDEQ(KC),PMAS(KC,1)**2,WDTP,WDTE) + IF(WDTP(0).LE.0)THEN + WRITE(MSTU(11),*) + + 'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', KC + WRITE(MSTU(11),*) 'INITIAL VALUE IS TAKEN',PMAS(KC,2) + GOTO 199 + ELSE + DO 180 IDC=1,MDCY(KC,3) + IC=IDC+MDCY(KC,2)-1 + IF(MDME(IC,1).EQ.1.AND.WDTP(IDC).GT.0.)THEN +C...Life time in cm^{-1}. paru(3) gev^{-1} -> fm + PMAS(KC,4)=PARU(3)/WDTP(IDC)*1.D-12 + BRAT(IC)=WDTP(IDC)/WDTP(0) + ENDIF + 180 CONTINUE + ENDIF + ENDIF + 199 CONTINUE + +C...Format to use for comments + 7000 FORMAT(' * ',A) + 7100 FORMAT(' * ',A,F12.3) + + END +C******************************************************************** +C...PYXUED +C... Last change: +C... 13/01/2009 : H. Przysiezniak Frey, P. Skands +C... Original version: +C... M. El Kacimi +C... 05/07/2005 +C Universal Extra Dimensions Subprocess cross sections +C The expressions used are from atl-com-phys-2005-003 +C What is coded here is shat**2/pi * dsigma/dt = |M|**2 +C For each UED subprocess, the color flow used is the same +C as the equivalent QCD subprocess. Different configuration +C color flows are considered to have the same probability. +C +C The Xsection is calculated following ATL-PHYS-PUB-2005-003 +C by G.Azuelos and P.H.Beauchemin. +C +C This routine is called from pysigh. + + SUBROUTINE PYXUED(NCHN,SIGS) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C... + INTEGER NGRDEC + COMMON/DECMOD/NGRDEC +C... + PARAMETER(KKPART=25,KKFLA=450) +C...Commonblocks + 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/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA, + &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4, + &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW, + &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR + SAVE /PYDAT2/,/PYINT1/,/PYINT3/,/PYPARS/ +C...UED Pythia common + COMMON/PYPUED/IUED(0:99),RUED(0:99) +C...Local arrays and complex variables + DOUBLE PRECISION SHAT,SP,THAT,TP,UHAT,UP,ALPHAS + + ,FAC1,XMNKK,XMUED,SIGS + INTEGER NCHN + +C...Return if UED not switched on + IF (IUED(1).LE.0) THEN + RETURN + ENDIF + +C...Energy scale of the parton processus +C...taken equal to the mass of the final state kk +c Q2=XMNKK**2 + +C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2 + XMNKK=PMAS(KKFLA+23,1) + +C...To compare the cross section with phys-pub-2005-03 +C...(no radiative corrections), +C...take xmnkk=rinv and q2=rinv**2 +c++lnk +C...n.b. (rinv=rued(1)) +c IF(NGRDEC.EQ.1)XMNKK=RUED(0) + IF(NGRDEC.EQ.1)XMNKK=RUED(1) +c--lnk + + SHAT=VINT(44) + SP=SHAT + THAT=VINT(45) + TP=THAT-XMNKK**2 + UHAT=VINT(46) + UP=UHAT-XMNKK**2 + BETA34=DSQRT(1.D0-4.D0*XMNKK**2/SHAT) + PI=DACOS(-1.D0) +c++lnk +c Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP + Q2=RUED(1)**2+(TP*UP-RUED(1)**4)/SP + +c IF(NGRDEC.EQ.1)Q2=RUED(0)**2 + IF(NGRDEC.EQ.1)Q2=RUED(1)**2 +c--lnk + +C...Strong coupling value + ALPHAS=PYALPS(Q2) + + IF(ISUB.EQ.311)THEN +C...gg --> g* g* + FAC1=9./8.*ALPHAS**2/(SP*TP*UP)**2 + XMUED=FAC1*(XMNKK**4*(6.*TP**4+18.*TP**3*UP+ + & 24.*TP**2*UP**2+18.*TP*UP**3+6.*UP**4) + & +XMNKK**2*(6.*TP**4*UP+12.*TP**3*UP**2+ + & 12.*TP**2*UP**3+6*TP*UP**4) + & +2.*TP**6+6*TP**5*UP+13*TP**4*UP**2+ + & 15.*TP**3*UP**3+13*TP**2*UP**4+ + & 6.*TP*UP**5+2.*UP**6) + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 +C...Three color flow configurations (qcd g+g->g+g) + XCOL=PYR(0) + IF(XCOL.LE.1./3.)THEN + ISIG(NCHN,3)=1 + ELSEIF(XCOL.LE.2./3.)THEN + ISIG(NCHN,3)=2 + ELSE + ISIG(NCHN,3)=3 + ENDIF + SIGH(NCHN)=COMFAC*XMUED + ELSEIF(ISUB.EQ.312)THEN +C...q + g -> q*_D + g*, q*_S + g* +C...(the two channels have the same cross section) + FAC1=-1./36.*ALPHAS**2/(SP*TP*UP)**2 + XMUED=FAC1*(12.*SP*UP**5+5.*SP**2*UP**4+22.*SP**3*UP**3+ + & 5.*SP**4*UP**2+12.*SP**5*UP) + XMUED=COMFAC*2.*XMUED + + DO 190 I=MMINA,MMAXA + IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190 + DO 180 ISDE=1,2 + + IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180 + IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180 + NCHN=NCHN+1 + ISIG(NCHN,ISDE)=I + ISIG(NCHN,3-ISDE)=21 + ISIG(NCHN,3)=1 + SIGH(NCHN)=XMUED + IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2 + 180 CONTINUE + 190 CONTINUE + + ELSEIF(ISUB.EQ.313)THEN +C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj +C...(the two channels have the same cross section) +C...qi and qj have the same charge sign + DO 100 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 100 + DO 101 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J). + & EQ.0) GOTO 101 + IF(J*I.LE.0)GOTO 101 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + IF(J.EQ.I)THEN + FAC1=1./72.*ALPHAS**2/(TP*UP)**2 + XMUED=FAC1* + & (XMNKK**2*(8*TP**3+4./3.*TP**2*UP+4./3.*TP*UP**2 + & +8.*UP**3)+8.*TP**4+56./3.*TP**3*UP+ + & 20.*TP**2*UP**2+56./3.* + & TP*UP**3+8.*UP**4) + SIGH(NCHN)=COMFAC*2.*XMUED + ISIG(NCHN,3)=1 + IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2 + ELSE + FAC1=2./9.*ALPHAS**2/TP**2 + XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2) + SIGH(NCHN)=COMFAC*2.*XMUED + ISIG(NCHN,3)=1 + ENDIF + 101 CONTINUE + 100 CONTINUE + ELSEIF(ISUB.EQ.314)THEN +C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar +C...(the two channels have the same cross section) + NCHN=NCHN+1 + ISIG(NCHN,1)=21 + ISIG(NCHN,2)=21 + ISIG(NCHN,3)=INT(1.5+PYR(0)) + + FAC1=5./6.*ALPHAS**2/(SP*TP*UP)**2 + XMUED=FAC1*(-XMNKK**4*(8.*TP*UP**3+8.*TP**2*UP**2+8.*TP**3*UP + + +4.*UP**4+4*TP**4) + + -XMNKK**2*(0.5*TP*UP**4+4.*TP**2*UP**3+15./2.*TP**3 + + *UP**2+ 4.*TP**4*UP)+TP*UP**5-0.25*TP**2*UP**4+ + + 2.*TP**3*UP**3-0.25*TP**4*UP**2+TP**5*UP) + + SIGH(NCHN)=COMFAC*XMUED +C...has been multiplied by 5: all possible quark flavors in final state + + ELSEIF(ISUB.EQ.315)THEN +C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar +C...(the two channels have the same cross section) + DO 141 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 141 + DO 142 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.ABS(I).NE.ABS(J).OR.I*J.GE.0) GOTO 142 + FAC1=2./9.*ALPHAS**2*1./(SP*TP)**2 + XMUED=FAC1*(XMNKK**2*SP*(4.*TP**2-SP*TP-SP**2)+ + & 4.*TP**4+3.*SP*TP**3+11./12.*TP**2*SP**2- + & 2./3.*SP**3*TP+SP**4) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=COMFAC*2.*XMUED + 142 CONTINUE + 141 CONTINUE + ELSEIF(ISUB.EQ.316)THEN +C...q + qbar' -> q*_D + q*_Sbar' + FAC1=2./9.*ALPHAS**2 + DO 300 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 300 + DO 301 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 301 + IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 301 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + FAC1=2./9.*ALPHAS**2/TP**2 + XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2) + SIGH(NCHN)=COMFAC*XMUED + 301 CONTINUE + 300 CONTINUE + + ELSEIF(ISUB.EQ.317)THEN +C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar' +C...(the two channels have the same cross section) + DO 400 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 400 + DO 401 J=MMIN1,MMAX1 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 401 + IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 401 + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + FAC1=1./18.*ALPHAS**2/TP**2 + XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2) + SIGH(NCHN)=COMFAC*2.*XMUED + 401 CONTINUE + 400 CONTINUE + ELSEIF(ISUB.EQ.318)THEN +C...q + q' -> q*_D + q*_S' + DO 500 I=MMIN1,MMAX1 + IA=IABS(I) + IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 500 + DO 501 J=MMIN2,MMAX2 + JA=IABS(J) + IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 501 + IF(J*I.LE.0)GOTO 501 + IF(IA.EQ.JA)THEN + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=INT(1.5+PYR(0)) + FAC1=1./36.*ALPHAS**2/(TP*UP)**2 + XMUED=FAC1*(-8.*XMNKK**2*(TP**3+TP**2*UP+TP*UP**2+UP**3) + & +8.*TP**4+4.*TP**2*UP**2+8.*UP**4) + SIGH(NCHN)=COMFAC*XMUED + ELSE + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=J + ISIG(NCHN,3)=1 + FAC1=1./18.*ALPHAS**2/TP**2 + XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2) + SIGH(NCHN)=COMFAC*2.*XMUED + ENDIF + 501 CONTINUE + 500 CONTINUE + ELSEIF(ISUB.EQ.319)THEN +C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar' +C...(the two channels have the same cross section) + DO 741 I=MMIN1,MMAX1 + IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR. + & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 741 + DO 742 J=MMIN2,MMAX2 + IF(J.EQ.0.OR.IABS(J).NE.IABS(I).OR.J*I.GT.0) GOTO 742 + FAC1=16./9.*ALPHAS**2*1./(SP)**2 + XMUED=FAC1*(2.*XMNKK**2*SP+SP**2+2.*SP*TP+2.*TP**2) + NCHN=NCHN+1 + ISIG(NCHN,1)=I + ISIG(NCHN,2)=-I + ISIG(NCHN,3)=1 + SIGH(NCHN)=COMFAC*2.*XMUED + 742 CONTINUE + 741 CONTINUE + + ENDIF + + RETURN + END +C********************************************************************* + +C...PYGRAM +C...Universal Extra Dimensions Model (UED) +C...Computation of the Graviton mass. + + SUBROUTINE PYGRAM(IN) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...Pythia commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) +C...UED Pythia common + COMMON/PYPUED/IUED(0:99),RUED(0:99) + +C...Local variables + INTEGER KCFLA,NMAX + PARAMETER(KCFLA=450,NMAX=5000) + DIMENSION YVEC(5000),RESVEC(5000) + COMMON/INTSAV/YSAV,YMAX,RESMAX + COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM + COMMON/KAPPA/XKAPPA + +C...External function (used in call to PYGAUS) + EXTERNAL PYGRAW + +C...SAVE statements + SAVE /PYDAT1/,/PYDAT2/,/PYPUED/,/INTSAV/ + +C...Initialization + NDIM=IUED(4) + RINV=RUED(1) + XMD=RUED(2) + PI=PARU(1) + +C...Initialize for numerical integration + XMPLNK=2.4D+18 + XKAPPA=DSQRT(2.D0)/XMPLNK + +C...For NDIM=2, compute graviton mass distribution numerically + IF(NDIM.EQ.2)THEN + +C... For first event: tabulate distribution of stepwise integrals: +C... int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK + IF(IN.EQ.0)THEN + RESMAX = 0D0 + YMAX = 0D0 + DO 100 I=1,NMAX + YSAV = (I-0.5)/DBLE(NMAX) + TOL = 1D-6 +C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV + RESINT = PYGAUS(PYGRAW,0D0,1D0,TOL) + YVEC(I) = YSAV + RESVEC(I) = RESINT +C... Save max of distribution (for accept/reject below) + IF(RESINT.GT.RESMAX)THEN + RESMAX = RESINT + YMAX = YVEC(I) + ENDIF + 100 CONTINUE + ENDIF + +C... Generate Mg for each graviton (1D0 ensures a minimal open phase space) + PCUJET=1D0 + KCGAKK=KCFLA+23 + XMGAMK=PMAS(KCGAKK,1) + +C... Pick random graviton mass, accept according to stored integrals + AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET) + 110 RMG=AMMAX*PYR(0) + X=RMG/XMGAMK + +C... Bin enumeration starts at 1, but make sure always in range + IBIN=INT(NMAX*X)+1 + IBIN=MIN(IBIN,NMAX) + IF(RESVEC(IBIN)/RESMAX.LT.PYR(0)) GOTO 110 + +C... For NDIM=4 and 6, the analytical expression for the +C... graviton mass distribution integral is used. + ELSEIF(NDIM.EQ.4.OR.NDIM.EQ.6)THEN + +C... Ensure minimal open phase space (max(mG*) < m(gamma*)) + PCUJET=1D0 + +C... KK photon (?) compressed code and mass + KCGAKK=KCFLA+23 + XMGAMK=PMAS(KCGAKK,1) + +C... Find maximum of (dGamma/dMg) + IF(IN.EQ.0)THEN + RESMAX=0D0 + YMAX=0D0 + DO 120 I=1,NMAX-1 + Y=I/DBLE(NMAX) + RESINT=Y**(NDIM-3)*(1D0/(1D0-Y**2))*(1D0+DCOS(PI*Y)) + IF(RESINT.GE.RESMAX)THEN + RESMAX=RESINT + YMAX=Y + ENDIF + 120 CONTINUE + ENDIF + +C... Pick random graviton mass, accept/reject + AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET) + 130 RMG=AMMAX*PYR(0) + X=RMG/XMGAMK + DGADMG=X**(NDIM-3)*(1./(1.-X**2))*(1.+DCOS(PI*X)) + IF(DGADMG/RESMAX.LT.PYR(0)) GOTO 130 + +C... If the user has not chosen N=2,4 or 6, STOP + ELSE + WRITE(MSTU(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',NDIM, + & ' (MUST BE 2, 4, OR 6) ' + CALL PYSTOP(6002) + ENDIF + +C... Now store the sampled Mg + PMAS(39,1)=RMG + + RETURN + END + +C********************************************************************* + +C...PYGRAW +C...Universal Extra Dimensions Model (UED) +C... +C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34. +C... +C...Integrand for the KK boson -> SM boson + graviton +C...graviton mass distribution (and gravity mediated total width), +C...which contains (see 0201300 and below for the full product) +C...the gravity mediated partial decay width Gamma(xx, yy) +C... i.e. GRADEN(YY)*PYWDKK(XXA) +C... where xx is exclusive to gravity +C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension +C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions. + + DOUBLE PRECISION FUNCTION PYGRAW(YIN) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + +C...Pythia commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + +C...Local UED commonblocks and variables + COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM + COMMON/INTSAV/YSAV,YMAX,RESMAX + +C...SAVE statements + SAVE /PYDAT1/,/INTSAV/ + +C...External: Pythia's Gamma function + EXTERNAL PYGAMM + +C...Pi + PI=PARU(1) + PI2=PI*PI + + YMIN=1.D-9/RINV + YY=YSAV + XX=DSQRT(1.-YY**2)*YIN + DJAC=(1.-YMIN)*DSQRT(1.-YY**2) + FAC=2.*PI**((NDIM-1.)/2.)*XMPLNK**2*RINV**NDIM/XMD**(NDIM+2) + XND=(NDIM-1.)/2. + GAMMN=PYGAMM(XND) + FAC=FAC/GAMMN + XXA=DSQRT(XX**2+YY**2) + GRADEN=4./PI2 * (YY**2/(1.-YY**2)**2)*(1.+DCOS(PI*YY)) + + PYGRAW=DJAC* + + FAC*XX**(NDIM-2)*GRADEN*PYWDKK(XXA) + + RETURN + END +C********************************************************************* + +C...PYWDKK +C...Universal Extra Dimensions Model (UED) +C... +C...Multiplied by the square modulus of a form factor +C...(see GRADEN in function PYGRAW) +C...PYWDKK is the KK boson -> SM boson + graviton +C...gravity mediated partial decay width Gamma(xx, yy) +C... where xx is exclusive to gravity +C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension +C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions +C... +C...N.B. The Feynman rules for the couplings of the graviton fields +C...to the UED fields are related to the corresponding couplings of +C...the graviton fields to the SM fields by the form factor. + + DOUBLE PRECISION FUNCTION PYWDKK(X) + +C...Double precision and integer declarations + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + +C...Pythia commonblocks + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + +C...Local UED commonblocks and variables + COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM + COMMON/KAPPA/XKAPPA + +C...SAVE statements + SAVE /PYDAT1/,/PYDAT2/,/UEDGRA/,/KAPPA/ + + PI=PARU(1) + +C...gamma* mass 473 + KCQKK=473 + XMNKK=PMAS(KCQKK,1) + +C...Bosons partial width Macesanu hep-ph/0201300 + PYWDKK=XKAPPA**2/(96.*PI)*XMNKK**3/X**4* + + ((1.-X**2)**2*(1.+3.*X**2+6.*X**4)) + + 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(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5), + X FV1(5),FV2(5),FV3(5) + 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(5,5),HI(5,5),WR(5),WI(5) + 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(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5), + X ORTR(5),ORTI(5) + 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 441 J = I, N + TR = DABS(HR(I,J)) + DABS(HI(I,J)) + IF (TR .GT. NORM) NORM = TR + 441 CONTINUE + 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 541 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 + 541 CONTINUE + 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(5,5),AI(5,5),SCALE(5) + 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 + SCALE(I) = 1.0D0 + 220 CONTINUE +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(5),ZR(5,5),ZI(5,5) + 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(5,5),AI(5,5),ORTR(5),ORTI(5) + 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 + SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1)) + 100 CONTINUE +C + IF (SCALE .EQ. 0.0D0) GOTO 200 + MP = M + IGH +C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... + DO 110 II = M, IGH + I = MP - II + ORTR(I) = AR(I,M-1) / SCALE + ORTI(I) = AI(I,M-1) / SCALE + H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I) + 110 CONTINUE +C + G = DSQRT(H) + F = PYTHAG(ORTR(M),ORTI(M)) + IF (F .EQ. 0.0D0) GOTO 120 + H = H + F * G + G = G / F + ORTR(M) = (1.0D0 + G) * ORTR(M) + ORTI(M) = (1.0D0 + G) * ORTI(M) + GOTO 130 +C + 120 ORTR(M) = G + AR(M,M-1) = SCALE +C .......... FORM (I-(U*UT)/H) * A .......... + 130 DO 160 J = M, N + FR = 0.0D0 + FI = 0.0D0 +C .......... FOR I=IGH STEP -1 UNTIL M DO -- .......... + DO 140 II = M, IGH + I = MP - II + FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J) + FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J) + 140 CONTINUE +C + FR = FR / H + FI = FI / H +C + DO 150 I = M, IGH + AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I) + AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I) + 150 CONTINUE +C + 160 CONTINUE +C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) .......... + DO 190 I = 1, IGH + FR = 0.0D0 + FI = 0.0D0 +C .......... FOR J=IGH STEP -1 UNTIL M DO -- .......... + DO 170 JJ = M, IGH + J = MP - JJ + FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J) + FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J) + 170 CONTINUE +C + FR = FR / H + FI = FI / H +C + DO 180 J = M, IGH + AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J) + AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J) + 180 CONTINUE +C + 190 CONTINUE +C + ORTR(M) = SCALE * ORTR(M) + ORTI(M) = SCALE * ORTI(M) + AR(M,M-1) = -G * AR(M,M-1) + AI(M,M-1) = -G * AI(M,M-1) + 200 CONTINUE +C + 210 RETURN + END + +C********************************************************************* + +C...PYLDCM +C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2 +C...processes. + + SUBROUTINE PYLDCM(A,N,NP,INDX,D) + IMPLICIT NONE + INTEGER N,NP,INDX(N) + REAL*8 D,TINY + COMPLEX*16 A(NP,NP) + PARAMETER (TINY=1.0D-20) + INTEGER I,IMAX,J,K + REAL*8 AAMAX,VV(6),DUM + COMPLEX*16 SUM,DUMC + + D=1D0 + DO 110 I=1,N + AAMAX=0D0 + DO 100 J=1,N + IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J)) + 100 CONTINUE + IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix') + VV(I)=1D0/AAMAX + 110 CONTINUE + DO 180 J=1,N + DO 130 I=1,J-1 + SUM=A(I,J) + DO 120 K=1,I-1 + SUM=SUM-A(I,K)*A(K,J) + 120 CONTINUE + A(I,J)=SUM + 130 CONTINUE + AAMAX=0D0 + DO 150 I=J,N + SUM=A(I,J) + DO 140 K=1,J-1 + SUM=SUM-A(I,K)*A(K,J) + 140 CONTINUE + A(I,J)=SUM + DUM=VV(I)*ABS(SUM) + IF (DUM.GE.AAMAX) THEN + IMAX=I + AAMAX=DUM + ENDIF + 150 CONTINUE + IF (J.NE.IMAX)THEN + DO 160 K=1,N + DUMC=A(IMAX,K) + A(IMAX,K)=A(J,K) + A(J,K)=DUMC + 160 CONTINUE + D=-D + VV(IMAX)=VV(J) + ENDIF + INDX(J)=IMAX + IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0) + IF(J.NE.N)THEN + DO 170 I=J+1,N + A(I,J)=A(I,J)/A(J,J) + 170 CONTINUE + ENDIF + 180 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYBKSB +C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2 +C...processes. + + SUBROUTINE PYBKSB(A,N,NP,INDX,B) + IMPLICIT NONE + INTEGER N,NP,INDX(N) + COMPLEX*16 A(NP,NP),B(N) + INTEGER I,II,J,LL + COMPLEX*16 SUM + + II=0 + DO 110 I=1,N + LL=INDX(I) + SUM=B(LL) + B(LL)=B(I) + IF (II.NE.0)THEN + DO 100 J=II,I-1 + SUM=SUM-A(I,J)*B(J) + 100 CONTINUE + ELSE IF (ABS(SUM).NE.0D0) THEN + II=I + ENDIF + B(I)=SUM + 110 CONTINUE + DO 130 I=N,1,-1 + SUM=B(I) + DO 120 J=I+1,N + SUM=SUM-A(I,J)*B(J) + 120 CONTINUE + B(I)=SUM/A(I,I) + 130 CONTINUE + RETURN + END + +C*********************************************************************** + +C...PYWIDX +C...Calculates full and partial widths of resonances. +C....copy of PYWIDT, used for techniparticle widths + + SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/, + &/PYINT4/,/PYMSSM/,/PYTCSM/ +C...Local arrays and saved variables. + DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2), + &WID2SV(3,2) + SAVE MOFSV,WIDWSV,WID2SV + DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/ + +C...Compressed code and sign; mass. + KFLA=IABS(KFLR) + KFLS=ISIGN(1,KFLR) + KC=PYCOMP(KFLA) + SHR=SQRT(SH) + PMR=PMAS(KC,1) + +C...Reset width information. + DO I=0,400 + WDTP(I)=0D0 + ENDDO + +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: + 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(PYCOMP(KFDP(IDC,1)),1)**2/SH + RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH + IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130 + IF(I.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) + 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 + 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) + 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(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.LE.16) THEN +C...W+/- -> q + qbar' + FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1) + ELSEIF(I.LE.20) THEN +C...W+/- -> l+/- + nu + FCOF=1D0 + 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) + 140 CONTINUE + +C.....V8 -> quark anti-quark + ELSEIF(KFLA.EQ.KTECHN+100021) THEN + FAC=AS/6D0*SHR + TANT3=RTCM(21) + IF(ITCM(2).EQ.0) THEN + IMDL=1 + ELSEIF(ITCM(2).EQ.1) THEN + IMDL=2 + ENDIF + DO 150 I=1,MDCY(KC,3) + IDC=I+MDCY(KC,2)-1 + IF(MDME(IDC,1).LT.0) GOTO 150 + PM1=PMAS(PYCOMP(KFDP(IDC,1)),1) + RM1=PM1**2/SH + IF(RM1.GT.0.25D0) GOTO 150 + WID2=1D0 + IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN + FMIX=1D0/TANT3**2 + ELSE + FMIX=TANT3**2 + ENDIF + WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX + IF(I.EQ.6) WID2=WIDS(6,1) + WDTP(0)=WDTP(0)+WDTP(I) + 150 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYRVSF +C...Calculates R-violating decays of sfermions. +C...P. Z. Skands + + SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) +C...Local variables. + DOUBLE PRECISION XLAM(0:400) + INTEGER IDLAM(400,3), PYCOMP + SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/ + +C...IS R-VIOLATION ON ? + IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN +C...Mass eigenstate counter + ICNT=INT(KFIN/KSUSY1) +C...SM KF code of SUSY particle + KFSM=KFIN-ICNT*KSUSY1 +C...Squared Sparticle Mass + SM=PMAS(PYCOMP(KFIN),1)**2 +C... Squared mass of top quark + SMT=PMAS(PYCOMP(6),1)**2 +C...IS L-VIOLATION ON ? + IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN +C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D + IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15)) + & THEN + K=INT((KFSM-9)/2) + DO 110 I=1,3 + DO 100 J=1,3 + IF(I.NE.J) THEN +C...~e,~mu,~tau -> nu_I + lepton-_J + LKNT = LKNT+1 + IDLAM(LKNT,1)= 12 +2*(I-1) + IDLAM(LKNT,2)= 11 +2*(J-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 + RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM + IF (IMSS(51).NE.0) XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + ENDIF + 100 CONTINUE + 110 CONTINUE +C...~e,~mu,~tau -> nu_Ibar + lepton-_K + J=INT((KFSM-9)/2) + DO 130 I=1,3 + IF(I.NE.J) THEN + DO 120 K=1,3 + LKNT = LKNT+1 + IDLAM(LKNT,1)=-12 -2*(I-1) + IDLAM(LKNT,2)= 11 +2*(K-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 + RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM + IF (IMSS(51).NE.0) XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + 120 CONTINUE + ENDIF + 130 CONTINUE +C...~e,~mu,~tau -> u_Jbar + d_K + I=INT((KFSM-9)/2) + DO 150 J=1,3 + DO 140 K=1,3 + LKNT = LKNT+1 + IDLAM(LKNT,1)=-2 -2*(J-1) + IDLAM(LKNT,2)= 1 +2*(K-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0 + IF (IMSS(52).NE.0) THEN +C...Use massive top quark + IF (IDLAM(LKNT,1).EQ.-6) THEN + RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 + & * (SM-SMT) + XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3) +C...If no top quark, all decay products massless + ELSE + RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM + XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) + ENDIF +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + ENDIF + 140 CONTINUE + 150 CONTINUE + ENDIF +C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D +C...No right-handed neutrinos + IF(ICNT.EQ.1) THEN + IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN + J=INT((KFSM-10)/2) + DO 170 I=1,3 + DO 160 K=1,3 + IF (I.NE.J) THEN +C...~nu_J -> lepton+_I + lepton-_K + LKNT = LKNT+1 + IDLAM(LKNT,1)=-11 -2*(I-1) + IDLAM(LKNT,2)= 11 +2*(K-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 + RM2=RVLAM(I,J,K)**2 * SM + IF (IMSS(51).NE.0) XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + ENDIF + 160 CONTINUE + 170 CONTINUE +C...~nu_I -> dbar_J + d_K + I=INT((KFSM-10)/2) + DO 190 J=1,3 + DO 180 K=1,3 + LKNT = LKNT+1 + IDLAM(LKNT,1)=-1 -2*(J-1) + IDLAM(LKNT,2)= 1 +2*(K-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 + RM2=3*RVLAMP(I,J,K)**2 * SM + IF (IMSS(52).NE.0) XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + 180 CONTINUE + 190 CONTINUE + ENDIF + ENDIF +C * SDOWN -> NU(BAR) + D and LEPTON- + U + IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN + J=INT((KFSM+1)/2) + DO 210 I=1,3 + DO 200 K=1,3 +C...~d_J -> nu_Ibar + d_K + LKNT = LKNT+1 + IDLAM(LKNT,1)=-12 -2*(I-1) + IDLAM(LKNT,2)= 1 +2*(K-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 + RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM + IF (IMSS(52).NE.0) XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + 200 CONTINUE + 210 CONTINUE + K=INT((KFSM+1)/2) + DO 240 I=1,3 + DO 230 J=1,3 +C...~d_K -> nu_I + d_J + LKNT = LKNT+1 + IDLAM(LKNT,1)= 12 +2*(I-1) + IDLAM(LKNT,2)= 1 +2*(J-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 + RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM + IF (IMSS(52).NE.0) XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF +C...~d_K -> lepton_I- + u_J + 220 LKNT = LKNT+1 + IDLAM(LKNT,1)= 11 +2*(I-1) + IDLAM(LKNT,2)= 2 +2*(J-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 + IF (IMSS(52).NE.0) THEN +C...Use massive top quark + IF (IDLAM(LKNT,2).EQ.6) THEN + RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT) + XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2) +C...If no top quark, all decay products massless + ELSE + RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM + XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) + ENDIF +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + ENDIF + 230 CONTINUE + 240 CONTINUE + ENDIF +C * SUP -> LEPTON+ + D + IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN + J=NINT(KFSM/2.) + DO 260 I=1,3 + DO 250 K=1,3 +C...~u_J -> lepton_I+ + d_K + LKNT = LKNT+1 + IDLAM(LKNT,1)=-11 -2*(I-1) + IDLAM(LKNT,2)= 1 +2*(K-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 + RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM + IF (IMSS(52).NE.0) XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + 250 CONTINUE + 260 CONTINUE + ENDIF + ENDIF +C...BARYON NUMBER VIOLATING DECAYS + IF (IMSS(53).GE.1) THEN +C * SUP -> DBAR + DBAR + IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN + I = KFSM/2 + DO 280 J=1,3 + DO 270 K=1,3 +C...~u_I -> dbar_J + dbar_K + IF (J.LT.K) THEN +C...(anti-) symmetry J <-> K. + LKNT = LKNT + 1 + IDLAM(LKNT,1) = -1 -2*(J-1) + IDLAM(LKNT,2) = -1 -2*(K-1) + IDLAM(LKNT,3) = 0 + XLAM(LKNT) = 0D0 + RM2 = 2.*(RVLAMB(I,J,K)**2) + & * SFMIX(KFSM,2*ICNT)**2 * SM + XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT = LKNT-1 + ENDIF + ENDIF + 270 CONTINUE + 280 CONTINUE + ENDIF +C * SDOWN -> UBAR + DBAR + IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN + K=(KFSM+1)/2 + DO 300 I=1,3 + DO 290 J=1,3 +C...LAMB coupling antisymmetric in J and K. + IF (J.NE.K) THEN +C...~d_K -> ubar_I + dbar_K + LKNT = LKNT + 1 + IDLAM(LKNT,1)= -2 -2*(I-1) + IDLAM(LKNT,2)= -1 -2*(J-1) + IDLAM(LKNT,3)= 0 + XLAM(LKNT)=0D0 +C...Use massive top quark + IF (IDLAM(LKNT,1).EQ.-6) THEN + RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT + & ) + XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3) +C...If no top quark, all decay products massless + ELSE + RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM + XLAM(LKNT) = + & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4) + ENDIF +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + ENDIF + 290 CONTINUE + 300 CONTINUE + ENDIF + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYRVNE +C...Calculates R-violating neutralino decay widths (pure 1->3 parts). +C...P. Z. Skands + + SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) +C...Local variables. + COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2 + & ,DCMASS,KFR(3) + DOUBLE PRECISION XLAM(0:400) + DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6) + INTEGER IDLAM(400,3), PYCOMP + LOGICAL DCMASS + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/ + +C...R-VIOLATING DECAYS + IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN + KFSM=KFIN-KSUSY1 + IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN +C...WHICH NEUTRALINO ? + NCHI=1 + IF (KFSM.EQ.23) NCHI=2 + IF (KFSM.EQ.25) NCHI=3 + IF (KFSM.EQ.35) NCHI=4 +C...SIGN OF MASS (Opposite convention as HERWIG) + ISM = 1 + IF (SMZ(NCHI).LT.0D0) ISM = -ISM + +C...Useful parameters for the calculation of the A and B constants. + WMASS = PMAS(PYCOMP(24),1) + ECHG = 2*SQRT(PARU(103)*PARU(1)) + COSB=1/(SQRT(1+RMSS(5)**2)) + SINB=RMSS(5)/SQRT(1+RMSS(5)**2) + COSW=SQRT(1-PARU(102)) + SINW=SQRT(PARU(102)) + GW=2D0*SQRT(PARU(103)*PARU(1))/SINW +C...Run quark masses to neutralino mass squared (for Higgs-type +C...couplings) + SQMCHI=PMAS(PYCOMP(KFIN),1)**2 + DO 100 I=1,6 + RMQ(I)=PYMRUN(I,SQMCHI) + 100 CONTINUE +C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS + DO 110 NCHJ=1,4 + ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW + ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW + ZPMIX(NCHJ,3)= ZMIX(NCHJ,3) + ZPMIX(NCHJ,4)= ZMIX(NCHJ,4) + 110 CONTINUE + C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS) + C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS) + C2=ECHG*ZPMIX(NCHI,1) + C3=GW*ZPMIX(NCHI,2)/COSW + EU=2D0/3D0 + ED=-1D0/3D0 +C... AB(x,y,z): +C x=1-2 : Select A or B constant (1:A ; 2:B) +C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ; +C 11-16:e,nu_e,mu,...) +C z=1-2 : Mass eigenstate number +C...CALCULATE COUPLINGS + DO 120 I = 11,15,2 + CMS=PMAS(PYCOMP(I),1) +C...Intermediate sleptons + AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2) + & *(C2-C3*SINW**2)) + AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4) + & *(C2-C3*SINW**2)) + AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW + & **2)) + AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW + & **2)) +C...Inermediate sneutrinos + AB(1,I+1,1)=0D0 + AB(2,I+1,1)=5D-1*C3 + AB(1,I+1,2)=0D0 + AB(2,I+1,2)=0D0 +C...Inermediate sdown + J=I-10 + CMS=RMQ(J) + AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2) + & *ED*(C2-C3*SINW**2)) + AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4) + & *ED*(C2-C3*SINW**2)) + AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1) + & *(ED*C2-C3*(1D0/2D0+ED*SINW**2)) + AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3) + & *(ED*C2-C3*(1D0/2D0+ED*SINW**2)) +C...Inermediate sup + J=J+1 + CMS=RMQ(J) + AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2) + & *EU*(C2-C3*SINW**2)) + AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4) + & *EU*(C2-C3*SINW**2)) + AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1) + & *(EU*C2+C3*(1D0/2D0-EU*SINW**2)) + AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3) + & *(EU*C2+C3*(1D0/2D0-EU*SINW**2)) + 120 CONTINUE + + IF (IMSS(51).GE.1) THEN +C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION) +C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K. +C...STEP IN I,J,K USING SINGLE COUNTER + DO 130 ISC=0,26 +C...LAMBDA COUPLING ASYM IN I,J + IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN + LKNT = LKNT+1 + IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 11 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1 + & ,MOD(ISC,3)+1)**2 + DCMASS=.FALSE. + IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15) + & DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1)=-IDLAM(LKNT,1) + KFR(2)=-IDLAM(LKNT,2) + KFR(3)=-IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...Charge conjugate mode. + LKNT=LKNT+1 + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + XLAM(LKNT)=XLAM(LKNT-1) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-2 + ENDIF + ENDIF + 130 CONTINUE + ENDIF + + IF (IMSS(52).GE.1) THEN +C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION) +C * CHI0 -> NUBAR_I + DBAR_J + D_K + DO 140 ISC=0,26 + LKNT = LKNT+1 + IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 1 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1 + & ,MOD(ISC,3)+1)**2 + DCMASS=.FALSE. + IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) + & DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1)=-IDLAM(LKNT,1) + KFR(2)=-IDLAM(LKNT,2) + KFR(3)=-IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...Charge conjugate mode. + LKNT=LKNT+1 + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + XLAM(LKNT)=XLAM(LKNT-1) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-2 + ENDIF + +C * CHI0 -> LEPTON_I+ + UBAR_J + D_K + LKNT = LKNT+1 + IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 1 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1 + & ,MOD(ISC,3)+1)**2 + DCMASS=.FALSE. + IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6 + & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1)=-IDLAM(LKNT,1) + KFR(2)=-IDLAM(LKNT,2) + KFR(3)=-IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...Charge conjugate mode. + LKNT=LKNT+1 + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + XLAM(LKNT)=XLAM(LKNT-1) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-2 + ENDIF + 140 CONTINUE + ENDIF + + IF (IMSS(53).GE.1) THEN +C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION) +C * CHI0 -> UBAR_I + DBAR_J + DBAR_K + DO 150 ISC=0,26 +C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K. + IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN + LKNT = LKNT+1 + IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = -1 -2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3) + & +1,MOD(ISC,3)+1)**2 + DCMASS=.FALSE. + IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5 + & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = IDLAM(LKNT,1) + KFR(2) = IDLAM(LKNT,2) + KFR(3) = IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...Charge conjugate mode. + LKNT=LKNT+1 + IDLAM(LKNT,1)=-IDLAM(LKNT-1,1) + IDLAM(LKNT,2)=-IDLAM(LKNT-1,2) + IDLAM(LKNT,3)=-IDLAM(LKNT-1,3) + XLAM(LKNT)=XLAM(LKNT-1) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-2 + ENDIF + ENDIF + 150 CONTINUE + ENDIF + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYRVCH +C...Calculates R-violating chargino decay widths. +C...P. Z. Skands + + SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) +C...Local variables. + DOUBLE PRECISION XLAM(0:400) + INTEGER IDLAM(400,3), PYCOMP +C...Information from main routine to PYRVGW + COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2 + & ,DCMASS,KFR(3) +C...Auxiliary variables needed for BV (RV Gauge STOre) + COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ + & ,RVLJKI,RVLJIK +C...Running quark masses + DOUBLE PRECISION RMQ(6) +C...Decay product masses on/off + LOGICAL DCMASS + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/, + & /RVGSTO/ + + +C...IF R-VIOLATION ON. + IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN + KFSM=KFIN-KSUSY1 + IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN +C...WHICH CHARGINO ? + NCHI = 1 + IF (KFSM.EQ.37) NCHI = 2 + +C...Useful parameters for calculating the A and B constants. +C...SIGN OF MASS (Opposite convention as HERWIG) + ISM = 1 + IF (SMW(NCHI).LT.0D0) ISM = -1 + WMASS = PMAS(PYCOMP(24),1) + COSB = 1/(SQRT(1+RMSS(5)**2)) + SINB = RMSS(5)/SQRT(1+RMSS(5)**2) + GW2 = 4*PARU(103)*PARU(1)/PARU(102) + C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS) + C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS) + C2 = UMIX(NCHI,1) + C3 = VMIX(NCHI,1) +C...Running masses at Q^2=MCHI^2. + SQMCHI = PMAS(PYCOMP(KFSM),1)**2 + DO 100 I=1,6 + RMQ(I)=PYMRUN(I,SQMCHI) + 100 CONTINUE + +C... AB(x,y,z) coefficients: +C x=1-2 : A or B coefficient (1:A ; 2:B) +C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ; +C 11-16:e,nu_e,mu,...) +C z=1-2 : Mass eigenstate number + DO 110 I = 11,15,2 +C...Intermediate sleptons + AB(1,I,1) = 0D0 + AB(1,I,2) = 0D0 + AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) + + & SFMIX(I,1)*C2 + AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) + + & SFMIX(I,3)*C2 +C...Intermediate sneutrinos + AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U + AB(1,I+1,2) = 0D0 + AB(2,I+1,1) = ISM*C3 + AB(2,I+1,2) = 0D0 +C...Intermediate sdown + J=I-10 + AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1) + AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3) + AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2) + AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2) +C...Intermediate sup + J=J+1 + AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1) + AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3) + AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3) + AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3) + 110 CONTINUE + +C...LLE TYPE R-VIOLATION + IF (IMSS(51).GE.1) THEN +C...LOOP OVER DECAY MODES + DO 140 ISC=0,26 + +C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K. + IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN + LKNT = LKNT+1 + IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 12 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = GW2 * 5D-1 * + & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1) + & **2 + DCMASS=.FALSE. + IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K). + KFR(1) = 0 + KFR(2) = 0 + KFR(3) = -IDLAM(LKNT,3)+1 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + +C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J) + 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN + LKNT = LKNT+1 + IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3) + IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3) + IDLAM(LKNT,3) =-11 -2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = GW2 * 5D-1 * + & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 +C...I,J SYMMETRY => FACTOR 2 + RVLAMC=2*RVLAMC + DCMASS=.FALSE. + IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1)=IDLAM(LKNT,1)-1 + KFR(2)=IDLAM(LKNT,2)-1 + KFR(3)=0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + +C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K (NOTE: SYMM. IN I AND J) +C * 19/04 2010: Bug corrected. Moved channel inside the I < J IF statement +C * from above, thanks to N.-E. Bomark. + LKNT = LKNT+1 + IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 11 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = GW2 * 5D-1 * + & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 +C...I,J SYMMETRY => FACTOR 2 + RVLAMC=2*RVLAMC + DCMASS=.FALSE. + IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15 + & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) =-IDLAM(LKNT,1)+1 + KFR(2) =-IDLAM(LKNT,2)+1 + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC + & /((2*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + ENDIF + ENDIF + 140 CONTINUE + ENDIF + +C...LQD TYPE R-VIOLATION + IF (IMSS(52).GE.1) THEN +C...LOOP OVER DECAY MODES + DO 180 ISC=0,26 + +C...CHI+ -> NUBAR_I + DBAR_J + U_K + LKNT = LKNT+1 + IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 2 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = 3. * GW2 * 5D-1 * + & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 + DCMASS=.FALSE. + IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6) + & DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1)=0 + KFR(2)=0 + KFR(3)=-IDLAM(LKNT,3)+1 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + +C * CHI+ -> LEPTON+_I + UBAR_J + U_K. + 150 LKNT = LKNT+1 + IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 2 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = 3. * GW2 * 5D-1 * + & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 + DCMASS=.FALSE. + IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6 + & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1)=0 + KFR(2)=0 + KFR(3)=-IDLAM(LKNT,3)+1 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + +C * CHI+ -> LEPTON+_I + DBAR_J + D_K. + 160 LKNT = LKNT+1 + IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 1 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = 3. * GW2 * 5D-1 * + & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 + DCMASS = .FALSE. + IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5 + & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1)=-IDLAM(LKNT,1)+1 + KFR(2)=-IDLAM(LKNT,2)+1 + KFR(3)=0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + +C * CHI+ -> NU_I + U_J + DBAR_K. + 170 LKNT = LKNT+1 + IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3) + IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3) + IDLAM(LKNT,3) = -1 -2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + DCMASS = .FALSE. + RVLAMC = 3. * GW2 * 5D-1 * + & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 + IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5) + & DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1)=IDLAM(LKNT,1)-1 + KFR(2)=IDLAM(LKNT,2)-1 + KFR(3)=0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + + 180 CONTINUE + ENDIF + +C...UDD TYPE R-VIOLATION +C...These decays need special treatment since more than one BV coupling +C...contributes (with interference). Consider e.g. (symbolically) +C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I)) +C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J)) +C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J)) +C...The problem is that a single call to PYRVGW would evaluate all +C...these terms and sum them, but without the different couplings. The +C...way out is to call PYRVGW three times, once for the first line, once +C...for the second line, and then once for all the lines (it is +C...impossible to get just the last line out) without multiplying by +C...couplings. The last line is then obtained as the result of the third +C...call minus the results of the two first calls. Each term is then +C...multiplied by its respective coupling before the whole thing is +C...summed up in XLAM. +C...Note that with three interfering resonances, this procedure becomes +C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode. + + IF (IMSS(53).GE.1) THEN +C...LOOP OVER DECAY MODES + DO 190 ISC=1,25 + +C...CHI+ -> U_I + U_J + D_K +C...Decay mode I<->J symmetric. + IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN + LKNT = LKNT+1 + IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3) + IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 1 +2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC= 6. * GW2 * 5D-1 + RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3) + & +1) + RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3) + & +1) + IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1 + & * RVLAMC + DCMASS=.FALSE. + IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6 + & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = -IDLAM(LKNT,1)+1 + KFR(2) = 0 + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESI) +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = -IDLAM(LKNT,2)+1 + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESJ) +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = -IDLAM(LKNT,1)+1 + KFR(2) = -IDLAM(LKNT,2)+1 + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESIJ) + IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN + XRESIJ = XRESIJ-XRESI-XRESJ + ELSE + XRESIJ = 0D0 + ENDIF +C...CALCULATE TOTAL WIDTH + XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ + & + RVLJIK*RVLIJK * XRESIJ + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + ENDIF +C...CHI+ -> DBAR_I + DBAR_J + DBAR_K +C...Symmetry I<->J<->K. + IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE + & .MOD(ISC,3)).AND.ISC.NE.13) THEN + LKNT = LKNT+1 + IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = -1 -2*MOD(ISC,3) + XLAM(LKNT) = 0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = 6. * GW2 * 5D-1 + RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3) + & +1) + RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3) + & +1) + RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3) + & +1) + DCMASS = .FALSE. + IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5 + & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE. +C...Collect symmetry factors + IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ + & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3)) + & RVLAMC = 5D-1 * RVLAMC +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = IDLAM(LKNT,1)-1 + KFR(2) = 0 + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESI) +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = IDLAM(LKNT,2)-1 + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESJ) +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = 0 + KFR(3) = IDLAM(LKNT,3)-1 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESK) +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = IDLAM(LKNT,1)-1 + KFR(2) = IDLAM(LKNT,2)-1 + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESIJ) + IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*(XRESI+XRESJ)) THEN + XRESIJ = XRESI+XRESJ-XRESIJ + ELSE + XRESIJ = 0D0 + ENDIF +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = IDLAM(LKNT,2)-1 + KFR(3) = IDLAM(LKNT,3)-1 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESJK) + IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*(XRESJ+XRESK)) THEN + XRESJK = XRESJ+XRESK-XRESJK + ELSE + XRESJK = 0D0 + ENDIF +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = IDLAM(LKNT,1)-1 + KFR(2) = 0 + KFR(3) = IDLAM(LKNT,3)-1 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2), + & IDLAM(LKNT,3),XRESIK) + IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*(XRESI+XRESK)) THEN + XRESIK = XRESI+XRESK-XRESIK + ELSE + XRESIK = 0D0 + ENDIF +C...CALCULATE TOTAL WIDTH + XLAM(LKNT) = + & RVLIJK**2 * XRESI + & + RVLJKI**2 * XRESJ + & + RVLKIJ**2 * XRESK + & + RVLIJK*RVLJKI * XRESIJ + & + RVLIJK*RVLKIJ * XRESIK + & + RVLJKI*RVLKIJ * XRESJK + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-1 + ENDIF + ENDIF + 190 CONTINUE + ENDIF + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYRVGL +C...Calculates R-violating gluino decay widths. +C...See BV part of PYRVCH for comments about the way the BV decay width +C...is calculated. Same comments apply here. +C...P. Z. Skands + + SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) +C...Local variables. + DOUBLE PRECISION XLAM(0:400) + INTEGER IDLAM(400,3), PYCOMP +C...Information from main routine to PYRVGW + COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2 + & ,DCMASS,KFR(3) +C...Auxiliary variables needed for BV (RV Gauge STOre) + COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ + & ,RVLJKI,RVLJIK +C...Running quark masses + DOUBLE PRECISION RMQ(6) +C...Decay product masses on/off + LOGICAL DCMASS + SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/, + & /RVGSTO/ + +C...IF LQD OR UDD TYPE R-VIOLATION ON. + IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN + KFSM=KFIN-KSUSY1 + +C... AB(x,y,z): +C x=1-2 : Select A or B coupling (1:A ; 2:B) +C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ; +C 11-16:e,nu_e,mu,... not used here) +C z=1-2 : Mass eigenstate number + DO 100 I = 1,6 +C...A Couplings + AB(1,I,1) = SFMIX(I,2) + AB(1,I,2) = SFMIX(I,4) +C...B Couplings + AB(2,I,1) = -SFMIX(I,1) + AB(2,I,2) = -SFMIX(I,3) + 100 CONTINUE + GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2) +C...LQD DECAYS. + IF (IMSS(52).GE.1) THEN +C...STEP IN I,J,K USING SINGLE COUNTER + DO 120 ISC=0,26 +C * GLUINO -> NUBAR_I + DBAR_J + D_K. + LKNT = LKNT+1 + IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 1 +2*MOD(ISC,3) + XLAM(LKNT)=0D0 +C...Set coupling, and decay product masses on/off + RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2 + & * 5D-1 * GSTR2 + DCMASS = .FALSE. + IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = -IDLAM(LKNT,2) + KFR(3) = -IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XLAM(LKNT)) +C...Normalize + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...Charge conjugate mode. + 110 LKNT = LKNT+1 + IDLAM(LKNT,1) =-IDLAM(LKNT-1,1) + IDLAM(LKNT,2) =-IDLAM(LKNT-1,2) + IDLAM(LKNT,3) =-IDLAM(LKNT-1,3) + XLAM(LKNT) = XLAM(LKNT-1) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-2 + ENDIF + +C * GLUINO -> LEPTON+_I + UBAR_J + D_K + LKNT = LKNT+1 + IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = 1 +2*MOD(ISC,3) + XLAM(LKNT)=0D0 +C...Set coupling, and decay product masses on/off + RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1) + & **2* 5D-1 * GSTR2 + DCMASS = .FALSE. + IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6 + & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = -IDLAM(LKNT,2) + KFR(3) = -IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XLAM(LKNT)) + XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...Charge conjugate mode. + LKNT=LKNT+1 + IDLAM(LKNT,1) = -IDLAM(LKNT-1,1) + IDLAM(LKNT,2) = -IDLAM(LKNT-1,2) + IDLAM(LKNT,3) = -IDLAM(LKNT-1,3) + XLAM(LKNT) = XLAM(LKNT-1) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-2 + ENDIF + + 120 CONTINUE + ENDIF + +C...UDD DECAYS. + IF (IMSS(53).GE.1) THEN +C...STEP IN I,J,K USING SINGLE COUNTER + DO 130 ISC=0,26 +C * GLUINO -> UBAR_I + DBAR_J + DBAR_K. + IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN + LKNT = LKNT+1 + IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3) + IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3) + IDLAM(LKNT,3) = -1 -2*MOD(ISC,3) + XLAM(LKNT)=0D0 +C...Set coupling, and decay product masses on/off. A factor of 2 for +C...(N_C-1) has been used to cancel a factor 0.5. + RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1) + & **2 * GSTR2 + DCMASS = .FALSE. + IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5 + & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE. +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = IDLAM(LKNT,1) + KFR(2) = 0 + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XRESI) +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = IDLAM(LKNT,2) + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XRESJ) +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = 0 + KFR(3) = IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XRESK) +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = IDLAM(LKNT,1) + KFR(2) = IDLAM(LKNT,2) + KFR(3) = 0 +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XRESIJ) +C...Calculate interference function. (Factor -1/2 to make up for factor +C...-2 in PYRVGW. + IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN + XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ) + ELSE + XRESIJ = 0D0 + ENDIF +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = 0 + KFR(2) = IDLAM(LKNT,2) + KFR(3) = IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XRESJK) + IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*XRESJK) THEN + XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK) + ELSE + XRESJK = 0D0 + ENDIF +C...Resonance KF codes (1=I,2=J,3=K) + KFR(1) = IDLAM(LKNT,1) + KFR(2) = 0 + KFR(3) = IDLAM(LKNT,3) +C...Calculate width. + CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3) + & ,XRESIK) + IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*XRESIK) THEN + XRESIK = 5D-1 * (XRESI+XRESK-XRESIK) + ELSE + XRESIK = 0D0 + ENDIF +C...Calculate total width (factor 1/2 from 1/(N_C-1)) + XLAM(LKNT) = XRESI + XRESJ + XRESK + & + 5D-1 * (XRESIJ + XRESIK + XRESJK) +C...Normalize + XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32) +C...Charge conjugate mode. + LKNT = LKNT+1 + IDLAM(LKNT,1) =-IDLAM(LKNT-1,1) + IDLAM(LKNT,2) =-IDLAM(LKNT-1,2) + IDLAM(LKNT,3) =-IDLAM(LKNT-1,3) + XLAM(LKNT) = XLAM(LKNT-1) +C...KINEMATICS CHECK + IF (XLAM(LKNT).EQ.0D0) THEN + LKNT=LKNT-2 + ENDIF + ENDIF + 130 CONTINUE + ENDIF + ENDIF + RETURN + END + +C********************************************************************* + +C...PYRVSB +C...Auxiliary function to PYRVSF for calculating R-Violating +C...sfermion widths. Though the decay products are most often treated +C...as massless in the calculation, the kinematical boundary of phase +C...space is tested using the true masses. +C...MODE = 1: All decay products massive +C...MODE = 2: Decay product 1 massless +C...MODE = 3: Decay product 2 massless +C...MODE = 4: All decay products massless + + FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE) + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ + DOUBLE PRECISION SM(3) + INTEGER PYCOMP, KC(3) + KC(1)=PYCOMP(KFIN) + KC(2)=PYCOMP(ID1) + KC(3)=PYCOMP(ID2) + SM(1)=PMAS(KC(1),1)**2 + SM(2)=PMAS(KC(2),1)**2 + SM(3)=PMAS(KC(3),1)**2 +C...Kinematics check + IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN + PYRVSB=0D0 + RETURN + ENDIF +C...CM momenta squared + IF (MODE.EQ.1) THEN + P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2) + & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2) + ELSE IF (MODE.EQ.2) THEN + P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2 + ELSE IF (MODE.EQ.3) THEN + P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2 + ELSE + P2CM=SM(1)/4. + ENDIF +C...Calculate Width + PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1)) + RETURN + END + +C********************************************************************* + +C...PYRVGW +C...Generalized Matrix Element for R-Violating 3-body widths. +C...P. Z. Skands + SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM) + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + IMPLICIT INTEGER (I-N) + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) + PARAMETER (EPS=1D-4) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2 + & ,DCMASS,KFR(3) + COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2), + & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2) + DOUBLE PRECISION XLIM(3,3) + INTEGER KC(0:3), PYCOMP + LOGICAL DCMASS, DCHECK(6) + SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/ + + XLAM = 0D0 + + KC(0) = PYCOMP(KFIN) + KC(1) = PYCOMP(ID1) + KC(2) = PYCOMP(ID2) + KC(3) = PYCOMP(ID3) + RMS(0) = PMAS(KC(0),1) + RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2) + RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2) + RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2) +C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK + XLIM(1,1)=(RMS(1)+RMS(2))**2 + XLIM(1,2)=(RMS(0)-RMS(3))**2 + XLIM(1,3)=XLIM(1,2)-XLIM(1,1) + XLIM(2,1)=(RMS(2)+RMS(3))**2 + XLIM(2,2)=(RMS(0)-RMS(1))**2 + XLIM(2,3)=XLIM(2,2)-XLIM(2,1) + XLIM(3,1)=(RMS(1)+RMS(3))**2 + XLIM(3,2)=(RMS(0)-RMS(2))**2 + XLIM(3,3)=XLIM(3,2)-XLIM(3,1) +C...Check Phase Space + IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN + RETURN + ENDIF + +C...INITIALIZE RESONANCE INFORMATION + DO 110 JRES = 1,3 + DO 100 IMASS = 1,2 + IRES = 2*(JRES-1)+IMASS + INTRES(IRES,1) = 0 + DCHECK(IRES) =.FALSE. +C...NO RIGHT-HANDED NEUTRINOS + IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR + & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR + & .KFR(JRES).EQ.0) GOTO 100 + RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1) + RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2) + INTRES(IRES,1) = IABS(KFR(JRES)) + INTRES(IRES,2) = IMASS + IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1 + IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0 + 100 CONTINUE + 110 CONTINUE + +C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE + +C...RESONANCE CONTRIBUTIONS +C...(Only sum contributions where the resonance is off shell). +C...Store whether diagram on/off in DCHECK. +C...LOOP OVER MASS STATES + DO 120 J=1,2 + IDR=J + IF(INTRES(IDR,1).NE.0) THEN + + TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2 + IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2) + & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN + DCHECK(IDR) =.TRUE. + XLAM = XLAM + TMIX * PYRVI1(2,3,1) + ENDIF + ENDIF + + IDR=J+2 + IF(INTRES(IDR,1).NE.0) THEN + TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2 + IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1) + & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN + DCHECK(IDR) =.TRUE. + XLAM = XLAM + TMIX * PYRVI1(1,3,2) + ENDIF + ENDIF + + IDR=J+4 + IF(INTRES(IDR,1).NE.0) THEN + TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2 + IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1) + & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN + DCHECK(IDR) =.TRUE. + XLAM = XLAM + TMIX * PYRVI1(1,2,3) + ENDIF + ENDIF + 120 CONTINUE +C... L-R INTERFERENCES +C... (Only add contributions where both contributing diagrams +C... are non-resonant). + IDR=1 + IF (DCHECK(1).AND.DCHECK(2)) THEN +C...Bug corrected 11/12 2001. Skands. + XLAM = XLAM + 2D0 * PYRVI2(2,3,1) + & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1) + & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1) + ENDIF + + IDR=3 + IF (DCHECK(3).AND.DCHECK(4)) THEN + XLAM = XLAM + 2D0 * PYRVI2(1,3,2) + & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1) + & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1) + ENDIF + + IDR=5 + IF (DCHECK(5).AND.DCHECK(6)) THEN + XLAM = XLAM + 2D0 * PYRVI2(1,2,3) + & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1) + & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1) + ENDIF +C... TRUE INTERFERENCES +C... (Only add contributions where both contributing diagrams +C... are non-resonant). + PREF=-2D0 + IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0 + DO 140 IKR1 = 1,2 + DO 130 IKR2 = 1,2 + IDR = IKR1+2 + IDR2 = IKR2 + IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN + XLAM = XLAM + PREF*PYRVI3(1,3,2) * + & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1) + & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1) + ENDIF + + IDR = IKR1+4 + IDR2 = IKR2 + IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN + XLAM = XLAM + PREF*PYRVI3(1,2,3) * + & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1) + & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1) + ENDIF + + IDR = IKR1+4 + IDR2 = IKR2+2 + IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN + XLAM = XLAM + PREF*PYRVI3(2,1,3) * + & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1) + & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1) + ENDIF + 130 CONTINUE + 140 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYRVI1 +C...Function to integrate resonance contributions + + FUNCTION PYRVI1(ID1,ID2,ID3) + + IMPLICIT NONE + DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS + DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS + INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES + LOGICAL MFLAG,DCMASS + EXTERNAL PYRVG1,PYGAUS + COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2 + & ,DCMASS,KFR(3) + COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG + SAVE/PYRVNV/,/PYRVPM/ +C...Initialize mass and width information + PYRVI1 = 0D0 + RM(0) = RMS(0) + RM(1) = RMS(ID1) + RM(2) = RMS(ID2) + RM(3) = RMS(ID3) + RESM(1)= RES(IDR,1) + RESW(1)= RES(IDR,2) +C...A->B and B->A for antisparticles + A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2)) + B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2)) +C...Integration boundaries and mass flag + LO = (RM(1)+RM(2))**2 + HI = (RM(0)-RM(3))**2 + MFLAG = DCMASS + PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3) + RETURN + END + +C********************************************************************* + +C...PYRVI2 +C...Function to integrate L-R interference contributions + + FUNCTION PYRVI2(ID1,ID2,ID3) + + IMPLICIT NONE + DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS + DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS + INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES + LOGICAL MFLAG,DCMASS + EXTERNAL PYRVG2,PYGAUS + COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2 + & ,DCMASS,KFR(3) + COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG + SAVE/PYRVNV/,/PYRVPM/ +C...Initialize mass and width information + PYRVI2 = 0D0 + RM(0) = RMS(0) + RM(1) = RMS(ID1) + RM(2) = RMS(ID2) + RM(3) = RMS(ID3) + RESM(1)= RES(IDR,1) + RESW(1)= RES(IDR,2) + RESM(2)= RES(IDR+1,1) + RESW(2)= RES(IDR+1,2) +C...A->B and B->A for antisparticles + A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2)) + B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2)) + A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2)) + B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2)) +C...Boundaries and mass flag + LO = (RM(1)+RM(2))**2 + HI = (RM(0)-RM(3))**2 + MFLAG = DCMASS + PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3) + RETURN + END + +C********************************************************************* + +C...PYRVI3 +C...Function to integrate true interference contributions + + FUNCTION PYRVI3(ID1,ID2,ID3) + + IMPLICIT NONE + DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS + DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS + INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES + LOGICAL MFLAG,DCMASS + EXTERNAL PYRVG3,PYGAUS + COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2 + & ,DCMASS,KFR(3) + COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG + SAVE/PYRVNV/,/PYRVPM/ +C...Initialize mass and width information + PYRVI3 = 0D0 + RM(0) = RMS(0) + RM(1) = RMS(ID1) + RM(2) = RMS(ID2) + RM(3) = RMS(ID3) + RESM(1)= RES(IDR,1) + RESW(1)= RES(IDR,2) + RESM(2)= RES(IDR2,1) + RESW(2)= RES(IDR2,2) +C...A -> B and B -> A for antisparticles + A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2)) + B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2)) + A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2)) + B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2)) +C...Boundaries and mass flag + LO = (RM(1)+RM(2))**2 + HI = (RM(0)-RM(3))**2 + MFLAG = DCMASS + PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3) + RETURN + END + +C********************************************************************* + +C...PYRVG1 +C...Integrand for resonance contributions + + FUNCTION PYRVG1(X) + + IMPLICIT NONE + COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG + DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR + DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2 + LOGICAL MFLAG + SAVE/PYRVPM/ + RVR = PYRVR(X,RESM(1),RESW(1)) + C1 = 2D0*SQRT(MAX(0D0,X)) + IF (.NOT.MFLAG) THEN + E2 = X/C1 + E3 = (RM(0)**2-X)/C1 + DELTAY = 4D0*E2*E3 + PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X) + ELSE + E2 = (X-RM(1)**2+RM(2)**2)/C1 + E3 = (RM(0)**2-X-RM(3)**2)/C1 + SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2)) + SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2)) + DELTAY = 4D0*SR1*SR2 + A1 = 4.*A(1)*B(1)*RM(3)*RM(0) + A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X) + PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2) + ENDIF + RETURN + END + +C********************************************************************* + +C...PYRVG2 +C...Integrand for L-R interference contributions + + FUNCTION PYRVG2(X) + + IMPLICIT NONE + COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG + DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS + DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2 + LOGICAL MFLAG + SAVE/PYRVPM/ + C1 = 2D0*SQRT(MAX(0D0,X)) + RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2)) + IF (.NOT.MFLAG) THEN + E2 = X/C1 + E3 = (RM(0)**2-X)/C1 + DELTAY = 4D0*E2*E3 + PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X) + ELSE + E2 = (X-RM(1)**2+RM(2)**2)/C1 + E3 = (RM(0)**2-X-RM(3)**2)/C1 + SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2)) + SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2)) + DELTAY = 4D0*SR1*SR2 + PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2) + & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X) + & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0)) + ENDIF + RETURN + END + +C********************************************************************* + +C...PYRVG3 +C...Function to do Y integration over true interference contributions + + FUNCTION PYRVG3(X) + + IMPLICIT NONE + COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG +C...Second Dalitz variable for PYRVG4 + COMMON/PYG2DX/X1 + DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1 + DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX + DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2 + LOGICAL MFLAG + EXTERNAL PYGAU2,PYRVG4 + SAVE/PYRVPM/,/PYG2DX/ + PYRVG3=0D0 + C1=2D0*SQRT(MAX(1D-9,X)) + X1=X + IF (.NOT.MFLAG) THEN + E2 = X/C1 + E3 = (RM(0)**2-X)/C1 + YMIN = 0D0 + YMAX = 4D0*E2*E3 + ELSE + E2 = (X-RM(1)**2+RM(2)**2)/C1 + E3 = (RM(0)**2-X-RM(3)**2)/C1 + SQ1 = (E2+E3)**2 + SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2)) + SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2)) + YMIN = SQ1-(SR1+SR2)**2 + YMAX = SQ1-(SR1-SR2)**2 + ENDIF + PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3) + RETURN + END + +C********************************************************************* + +C...PYRVG4 +C...Integrand for true intereference contributions + + FUNCTION PYRVG4(Y) + + IMPLICIT NONE + COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG + COMMON/PYG2DX/X + DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS + LOGICAL MFLAG + SAVE /PYRVPM/,/PYG2DX/ + PYRVG4=0D0 + RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2)) + IF (.NOT.MFLAG) THEN + PYRVG4 = RVS*B(1)*B(2)*X*Y + ELSE + PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2) + & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2) + & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2) + & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2)) + ENDIF + RETURN + END + +C********************************************************************* + +C...PYRVR +C...Breit-Wigner for resonance contributions + + FUNCTION PYRVR(Mab2,RM,RW) + + IMPLICIT NONE + DOUBLE PRECISION Mab2,RM,RW,PYRVR + PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2) + RETURN + END + +C********************************************************************* + +C...PYRVS +C...Interference function + + FUNCTION PYRVS(X,Y,M1,W1,M2,W2) + + IMPLICIT NONE + DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2 + PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2) + & +W1*W2*M1*M2) + RETURN + END + +C********************************************************************* + +C...PY1ENT +C...Stores one parton/particle in commonblock PYJETS. + + SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Standard checks. + MSTU(28)=0 + IF(MSTU(12).NE.12345) CALL PYLIST(0) + IPA=MAX(1,IABS(IP)) + IF(IPA.GT.MSTU(4)) CALL PYERRM(21, + &'(PY1ENT:) writing outside PYJETS memory') + KC=PYCOMP(KF) + IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code') + +C...Find mass. Reset K, P and V vectors. + PM=0D0 + IF(MSTU(10).EQ.1) PM=P(IPA,5) + IF(MSTU(10).GE.2) PM=PYMASS(KF) + DO 100 J=1,5 + K(IPA,J)=0 + P(IPA,J)=0D0 + V(IPA,J)=0D0 + 100 CONTINUE + +C...Store parton/particle in K and P vectors. + K(IPA,1)=1 + IF(IP.LT.0) K(IPA,1)=2 + K(IPA,2)=KF + P(IPA,5)=PM + P(IPA,4)=MAX(PE,PM) + PA=SQRT(P(IPA,4)**2-P(IPA,5)**2) + P(IPA,1)=PA*SIN(THE)*COS(PHI) + P(IPA,2)=PA*SIN(THE)*SIN(PHI) + P(IPA,3)=PA*COS(THE) + +C...Set N. Optionally fragment/decay. + N=IPA + IF(IP.EQ.0) CALL PYEXEC + + RETURN + END + +C********************************************************************* + +C...PY2ENT +C...Stores two partons/particles in their CM frame, +C...with the first along the +z axis. + + SUBROUTINE PY2ENT(IP,KF1,KF2,PECM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Standard checks. + MSTU(28)=0 + IF(MSTU(12).NE.12345) CALL PYLIST(0) + IPA=MAX(1,IABS(IP)) + IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21, + &'(PY2ENT:) writing outside PYJETS memory') + KC1=PYCOMP(KF1) + KC2=PYCOMP(KF2) + IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12, + &'(PY2ENT:) unknown flavour code') + +C...Find masses. Reset K, P and V vectors. + PM1=0D0 + IF(MSTU(10).EQ.1) PM1=P(IPA,5) + IF(MSTU(10).GE.2) PM1=PYMASS(KF1) + PM2=0D0 + IF(MSTU(10).EQ.1) PM2=P(IPA+1,5) + IF(MSTU(10).GE.2) PM2=PYMASS(KF2) + DO 110 I=IPA,IPA+1 + DO 100 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 100 CONTINUE + 110 CONTINUE + +C...Check flavours. + KQ1=KCHG(KC1,2)*ISIGN(1,KF1) + KQ2=KCHG(KC2,2)*ISIGN(1,KF2) + IF(MSTU(19).EQ.1) THEN + MSTU(19)=0 + ELSE + IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2, + & '(PY2ENT:) unphysical flavour combination') + ENDIF + K(IPA,2)=KF1 + K(IPA+1,2)=KF2 + +C...Store partons/particles in K vectors for normal case. + IF(IP.GE.0) THEN + K(IPA,1)=1 + IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2 + K(IPA+1,1)=1 + +C...Store partons in K vectors for parton shower evolution. + ELSE + K(IPA,1)=3 + K(IPA+1,1)=3 + K(IPA,4)=MSTU(5)*(IPA+1) + K(IPA,5)=K(IPA,4) + K(IPA+1,4)=MSTU(5)*IPA + K(IPA+1,5)=K(IPA+1,4) + ENDIF + +C...Check kinematics and store partons/particles in P vectors. + IF(PECM.LE.PM1+PM2) CALL PYERRM(13, + &'(PY2ENT:) energy smaller than sum of masses') + PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/ + &(2D0*PECM) + P(IPA,3)=PA + P(IPA,4)=SQRT(PM1**2+PA**2) + P(IPA,5)=PM1 + P(IPA+1,3)=-PA + P(IPA+1,4)=SQRT(PM2**2+PA**2) + P(IPA+1,5)=PM2 + +C...Set N. Optionally fragment/decay. + N=IPA+1 + IF(IP.EQ.0) CALL PYEXEC + + RETURN + END + +C********************************************************************* + +C...PY3ENT +C...Stores three partons or particles in their CM frame, +C...with the first along the +z axis and the third in the (x,z) +C...plane with x > 0. + + SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Standard checks. + MSTU(28)=0 + IF(MSTU(12).NE.12345) CALL PYLIST(0) + IPA=MAX(1,IABS(IP)) + IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21, + &'(PY3ENT:) writing outside PYJETS memory') + KC1=PYCOMP(KF1) + KC2=PYCOMP(KF2) + KC3=PYCOMP(KF3) + IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12, + &'(PY3ENT:) unknown flavour code') + +C...Find masses. Reset K, P and V vectors. + PM1=0D0 + IF(MSTU(10).EQ.1) PM1=P(IPA,5) + IF(MSTU(10).GE.2) PM1=PYMASS(KF1) + PM2=0D0 + IF(MSTU(10).EQ.1) PM2=P(IPA+1,5) + IF(MSTU(10).GE.2) PM2=PYMASS(KF2) + PM3=0D0 + IF(MSTU(10).EQ.1) PM3=P(IPA+2,5) + IF(MSTU(10).GE.2) PM3=PYMASS(KF3) + DO 110 I=IPA,IPA+2 + DO 100 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 100 CONTINUE + 110 CONTINUE + +C...Check flavours. + KQ1=KCHG(KC1,2)*ISIGN(1,KF1) + KQ2=KCHG(KC2,2)*ISIGN(1,KF2) + KQ3=KCHG(KC3,2)*ISIGN(1,KF3) + IF(MSTU(19).EQ.1) THEN + MSTU(19)=0 + ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN + ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR. + & KQ1+KQ3.EQ.4)) THEN + ELSE + CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination') + ENDIF + K(IPA,2)=KF1 + K(IPA+1,2)=KF2 + K(IPA+2,2)=KF3 + +C...Store partons/particles in K vectors for normal case. + IF(IP.GE.0) THEN + K(IPA,1)=1 + IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2 + K(IPA+1,1)=1 + IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2 + K(IPA+2,1)=1 + +C...Store partons in K vectors for parton shower evolution. + ELSE + K(IPA,1)=3 + K(IPA+1,1)=3 + K(IPA+2,1)=3 + KCS=4 + IF(KQ1.EQ.-1) KCS=5 + K(IPA,KCS)=MSTU(5)*(IPA+1) + K(IPA,9-KCS)=MSTU(5)*(IPA+2) + K(IPA+1,KCS)=MSTU(5)*(IPA+2) + K(IPA+1,9-KCS)=MSTU(5)*IPA + K(IPA+2,KCS)=MSTU(5)*IPA + K(IPA+2,9-KCS)=MSTU(5)*(IPA+1) + ENDIF + +C...Check kinematics. + MKERR=0 + IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR. + &0.5D0*X3*PECM.LE.PM3) MKERR=1 + PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2)) + PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2)) + PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2)) + CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2) + CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3) + IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1 + CTHE3=MAX(-1D0,MIN(1D0,CTHE3)) + IF(MKERR.NE.0) CALL PYERRM(13, + &'(PY3ENT:) unphysical kinematical variable setup') + +C...Store partons/particles in P vectors. + P(IPA,3)=PA1 + P(IPA,4)=SQRT(PA1**2+PM1**2) + P(IPA,5)=PM1 + P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2) + P(IPA+2,3)=PA3*CTHE3 + P(IPA+2,4)=SQRT(PA3**2+PM3**2) + P(IPA+2,5)=PM3 + P(IPA+1,1)=-P(IPA+2,1) + P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3) + P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2) + P(IPA+1,5)=PM2 + +C...Set N. Optionally fragment/decay. + N=IPA+2 + IF(IP.EQ.0) CALL PYEXEC + + RETURN + END + +C********************************************************************* + +C...PY4ENT +C...Stores four partons or particles in their CM frame, with +C...the first along the +z axis, the last in the xz plane with x > 0 +C...and the second having y < 0 and y > 0 with equal probability. + + SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Standard checks. + MSTU(28)=0 + IF(MSTU(12).NE.12345) CALL PYLIST(0) + IPA=MAX(1,IABS(IP)) + IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21, + &'(PY4ENT:) writing outside PYJETS momory') + KC1=PYCOMP(KF1) + KC2=PYCOMP(KF2) + KC3=PYCOMP(KF3) + KC4=PYCOMP(KF4) + IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12, + &'(PY4ENT:) unknown flavour code') + +C...Find masses. Reset K, P and V vectors. + PM1=0D0 + IF(MSTU(10).EQ.1) PM1=P(IPA,5) + IF(MSTU(10).GE.2) PM1=PYMASS(KF1) + PM2=0D0 + IF(MSTU(10).EQ.1) PM2=P(IPA+1,5) + IF(MSTU(10).GE.2) PM2=PYMASS(KF2) + PM3=0D0 + IF(MSTU(10).EQ.1) PM3=P(IPA+2,5) + IF(MSTU(10).GE.2) PM3=PYMASS(KF3) + PM4=0D0 + IF(MSTU(10).EQ.1) PM4=P(IPA+3,5) + IF(MSTU(10).GE.2) PM4=PYMASS(KF4) + DO 110 I=IPA,IPA+3 + DO 100 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=0D0 + 100 CONTINUE + 110 CONTINUE + +C...Check flavours. + KQ1=KCHG(KC1,2)*ISIGN(1,KF1) + KQ2=KCHG(KC2,2)*ISIGN(1,KF2) + KQ3=KCHG(KC3,2)*ISIGN(1,KF3) + KQ4=KCHG(KC4,2)*ISIGN(1,KF4) + IF(MSTU(19).EQ.1) THEN + MSTU(19)=0 + ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN + ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR. + & KQ1+KQ4.EQ.4)) THEN + ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0) + & THEN + ELSE + CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination') + ENDIF + K(IPA,2)=KF1 + K(IPA+1,2)=KF2 + K(IPA+2,2)=KF3 + K(IPA+3,2)=KF4 + +C...Store partons/particles in K vectors for normal case. + IF(IP.GE.0) THEN + K(IPA,1)=1 + IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2 + K(IPA+1,1)=1 + IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0)) + & K(IPA+1,1)=2 + K(IPA+2,1)=1 + IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2 + K(IPA+3,1)=1 + +C...Store partons for parton shower evolution from q-g-g-qbar or +C...g-g-g-g event. + ELSEIF(KQ1+KQ2.NE.0) THEN + K(IPA,1)=3 + K(IPA+1,1)=3 + K(IPA+2,1)=3 + K(IPA+3,1)=3 + KCS=4 + IF(KQ1.EQ.-1) KCS=5 + K(IPA,KCS)=MSTU(5)*(IPA+1) + K(IPA,9-KCS)=MSTU(5)*(IPA+3) + K(IPA+1,KCS)=MSTU(5)*(IPA+2) + K(IPA+1,9-KCS)=MSTU(5)*IPA + K(IPA+2,KCS)=MSTU(5)*(IPA+3) + K(IPA+2,9-KCS)=MSTU(5)*(IPA+1) + K(IPA+3,KCS)=MSTU(5)*IPA + K(IPA+3,9-KCS)=MSTU(5)*(IPA+2) + +C...Store partons for parton shower evolution from q-qbar-q-qbar event. + ELSE + K(IPA,1)=3 + K(IPA+1,1)=3 + K(IPA+2,1)=3 + K(IPA+3,1)=3 + K(IPA,4)=MSTU(5)*(IPA+1) + K(IPA,5)=K(IPA,4) + K(IPA+1,4)=MSTU(5)*IPA + K(IPA+1,5)=K(IPA+1,4) + K(IPA+2,4)=MSTU(5)*(IPA+3) + K(IPA+2,5)=K(IPA+2,4) + K(IPA+3,4)=MSTU(5)*(IPA+2) + K(IPA+3,5)=K(IPA+3,4) + ENDIF + +C...Check kinematics. + MKERR=0 + IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR. + &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4) + &MKERR=1 + PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2)) + PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2)) + PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2)) + X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2 + CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4) + IF(ABS(CTHE4).GE.1.002D0) MKERR=1 + CTHE4=MAX(-1D0,MIN(1D0,CTHE4)) + STHE4=SQRT(1D0-CTHE4**2) + CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2) + IF(ABS(CTHE2).GE.1.002D0) MKERR=1 + CTHE2=MAX(-1D0,MIN(1D0,CTHE2)) + STHE2=SQRT(1D0-CTHE2**2) + CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/ + &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4) + IF(ABS(CPHI2).GE.1.05D0) MKERR=1 + CPHI2=MAX(-1D0,MIN(1D0,CPHI2)) + IF(MKERR.EQ.1) CALL PYERRM(13, + &'(PY4ENT:) unphysical kinematical variable setup') + +C...Store partons/particles in P vectors. + P(IPA,3)=PA1 + P(IPA,4)=SQRT(PA1**2+PM1**2) + P(IPA,5)=PM1 + P(IPA+3,1)=PA4*STHE4 + P(IPA+3,3)=PA4*CTHE4 + P(IPA+3,4)=SQRT(PA4**2+PM4**2) + P(IPA+3,5)=PM4 + P(IPA+1,1)=PA2*STHE2*CPHI2 + P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0) + P(IPA+1,3)=PA2*CTHE2 + P(IPA+1,4)=SQRT(PA2**2+PM2**2) + P(IPA+1,5)=PM2 + P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1) + P(IPA+2,2)=-P(IPA+1,2) + P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3) + P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2) + P(IPA+2,5)=PM3 + +C...Set N. Optionally fragment/decay. + N=IPA+3 + IF(IP.EQ.0) CALL PYEXEC + + RETURN + END + +C********************************************************************* + +C...PY2FRM +C...An interface from a two-fermion generator to include +C...parton showers and hadronization. + + SUBROUTINE PY2FRM(IRAD,ITAU,ICOM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYJETS/,/PYDAT1/ +C...Local arrays. + DIMENSION IJOIN(2),PTOT(4),BETA(3) + +C...Call PYHEPC to convert input from HEPEVT to PYJETS common. + IF(ICOM.EQ.0) THEN + MSTU(28)=0 + CALL PYHEPC(2) + ENDIF + +C...Loop through entries and pick up all final partons. + I1=0 + I2=0 + I3=0 + I4=0 + DO 100 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100 + KFA=IABS(K(I,2)) + IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN + IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN + IF(I1.EQ.0) THEN + I1=I + ELSEIF(I3.EQ.0) THEN + I3=I + ELSE + CALL PYERRM(16,'(PY4JET:) more than two quarks') + ENDIF + ELSEIF(K(I,2).LT.0) THEN + IF(I2.EQ.0) THEN + I2=I + ELSEIF(I4.EQ.0) THEN + I4=I + ELSE + CALL PYERRM(16,'(PY4JET:) more than two antiquarks') + ENDIF + ELSE + IF(I3.EQ.0) THEN + I3=I + ELSEIF(I4.EQ.0) THEN + I4=I + ELSE + CALL PYERRM(16,'(PY4JET:) more than two gluons') + ENDIF + ENDIF + ENDIF + 100 CONTINUE + +C...Check that event is arranged according to conventions. + IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN + CALL PYERRM(16,'(PY4JET:) event contains too few partons') + ENDIF + IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN + CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order') + ENDIF + +C...Check whether second pair are quarks or gluons. + IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN + IQG34=1 + ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN + IQG34=2 + ELSE + CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent') + ENDIF + +C...Boost partons to their cm frame. + DO 110 J=1,4 + PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J) + 110 CONTINUE + ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2)) + DO 120 J=1,3 + BETA(J)=PTOT(J)/PTOT(4) + 120 CONTINUE + CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) + CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3)) + NSAV=N + +C...Decide and set up shower history for q qbar q' qbar' events. + IF(IQG34.EQ.1) THEN + W1=PY4JTW(0,I1,I3,I4) + W2=PY4JTW(0,I2,I3,I4) + IF(W1.GT.PYR(0)*(W1+W2)) THEN + CALL PY4JTS(0,I1,I3,I4,I2,QMAX) + ELSE + CALL PY4JTS(0,I2,I3,I4,I1,QMAX) + ENDIF + +C...Decide and set up shower history for q qbar g g events. + ELSE + W1=PY4JTW(I1,I3,I2,I4) + W2=PY4JTW(I1,I4,I2,I3) + W3=PY4JTW(0,I3,I1,I4) + W4=PY4JTW(0,I4,I1,I3) + W5=PY4JTW(0,I3,I2,I4) + W6=PY4JTW(0,I4,I2,I3) + W7=PY4JTW(0,I1,I3,I4) + W8=PY4JTW(0,I2,I3,I4) + WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0) + IF(W1.GT.WR) THEN + CALL PY4JTS(I1,I3,I2,I4,0,QMAX) + ELSEIF(W1+W2.GT.WR) THEN + CALL PY4JTS(I1,I4,I2,I3,0,QMAX) + ELSEIF(W1+W2+W3.GT.WR) THEN + CALL PY4JTS(0,I3,I1,I4,I2,QMAX) + ELSEIF(W1+W2+W3+W4.GT.WR) THEN + CALL PY4JTS(0,I4,I1,I3,I2,QMAX) + ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN + CALL PY4JTS(0,I3,I2,I4,I1,QMAX) + ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN + CALL PY4JTS(0,I4,I2,I3,I1,QMAX) + ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN + CALL PY4JTS(0,I1,I3,I4,I2,QMAX) + ELSE + CALL PY4JTS(0,I2,I3,I4,I1,QMAX) + ENDIF + ENDIF + +C...Boost back original partons and mark them as deleted. + CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3)) + CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3)) + K(I1,1)=K(I1,1)+10 + K(I2,1)=K(I2,1)+10 + K(I3,1)=K(I3,1)+10 + K(I4,1)=K(I4,1)+10 + +C...Rotate shower initiating partons to be along z axis. + PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2)) + CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0) + THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1)) + CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0) + +C...Set up copy of shower initiating partons as on mass shell. + DO 140 I=N+1,N+2 + DO 130 J=1,5 + K(I,J)=0 + P(I,J)=0D0 + V(I,J)=V(I1,J) + 130 CONTINUE + K(I,1)=1 + K(I,2)=K(I-6,2) + 140 CONTINUE + IF(K(NSAV+1,2).EQ.K(I1,2)) THEN + K(N+1,3)=I1 + P(N+1,5)=P(I1,5) + K(N+2,3)=I2 + P(N+2,5)=P(I2,5) + ELSE + K(N+1,3)=I2 + P(N+1,5)=P(I2,5) + K(N+2,3)=I1 + P(N+2,5)=P(I1,5) + ENDIF + PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2- + &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM) + P(N+1,3)=PABS + P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2) + P(N+2,3)=-PABS + P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2) + N=N+2 + +C...Decide whether to allow or not photon radiation in showers. +C...Connect up colours. + MSTJ(41)=2 + IF(IRAD.EQ.0) MSTJ(41)=1 + IJOIN(1)=N-1 + IJOIN(2)=N + CALL PYJOIN(2,IJOIN) + +C...Decide on maximum virtuality and do parton shower. + IF(PMAX.LT.PARJ(82)) THEN + PQMAX=QMAX + ELSE + PQMAX=PMAX + ENDIF + CALL PYSHOW(NSAV+1,-100,PQMAX) + +C...Rotate and boost back system. + CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3)) + +C...Do fragmentation and decays. + CALL PYEXEC + +C...Call PYHEPC to convert output from PYJETS to HEPEVT common. + IF(ICOM.EQ.0) THEN + MSTU(28)=0 + CALL PYHEPC(1) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PY4JTW +C...Auxiliary to PY4JET, to evaluate weight of configuration. + + FUNCTION PY4JTW(IA1,IA2,IA3,IA4) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYDAT4/CHAF(500,2) + CHARACTER CHAF*16 + COMMON/PYDATR/MRPY(6),RRPY(100) + COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000) + COMMON/PYINT4/MWID(500),WIDS(500,5) + COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3) + COMMON/PYINT6/PROC(0:500) + CHARACTER PROC*28 + COMMON/PYINT7/SIGT(0:6,0:6,0:5) + COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6), + &XPDIR(-6:6) + COMMON/PYMSSM/IMSS(0:99),RMSS(0:99) + COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3) + COMMON/PYTCSM/ITCM(0:99),RTCM(0:99) + COMMON/PYPUED/IUED(0:99),RUED(0:99) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/, + &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/, + &/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/,/PYPUED/ +C...Local arrays and character variables. + CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28, + &CHNEW2*28,CHNAM*6,CHVAR(56)*6,CHALP(2)*26,CHIND*8,CHINI*10, + &CHINR*16,CHDIG*10 + DIMENSION MSVAR(56,8) + +C...For each variable to be translated give: name, +C...integer/real/character, no. of indices, lower&upper index bounds. + DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG', + &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY', + &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI', + &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH', + &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL', + &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB', + &'ITCM','RTCM','IUED','RUED'/ + DATA ((MSVAR(I,J),J=1,8),I=1,56)/ 1,7*0, 1,2,1,4000,1,5,2*0, + &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0, + &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0, + &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0, + &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0, + &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0, + &1,1,1,6,4*0, 2,1,1,100,4*0, + &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0, + &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0, + &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0, + &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2, + &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0, + &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0, + &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5, + &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0, + &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0, + &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, + &1,1,0,99,4*0, 2,1,0,99,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/ + DATA CHALP/'abcdefghijklmnopqrstuvwxyz', + &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/ + +C...Length of character variable. Subdivide it into instructions. + IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND. + &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0) + CHBIT=CHIN//' ' + LBIT=101 + 100 LBIT=LBIT-1 + IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100 + LTOT=0 + DO 110 LCOM=1,LBIT + IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110 + LTOT=LTOT+1 + CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM) + 110 CONTINUE + LLOW=0 + 120 LHIG=LLOW+1 + 130 LHIG=LHIG+1 + IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130 + LBIT=LHIG-LLOW-1 + CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1) + +C...Send off decay-mode on/off commands to PYONOF. + IONOF=0 + DO 135 LDIG=1,10 + IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1 + 135 CONTINUE + IF(IONOF.EQ.1) THEN + CALL PYONOF(CHIN) + RETURN + ENDIF + +C...Peel off any text following exclamation mark. + LHIG2=LBIT + DO 140 LLOW2=LHIG2,1,-1 + IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1 + 140 CONTINUE + IF(LBIT.EQ.0) RETURN + +C...Identify commonblock variable. + LNAM=1 + 150 LNAM=LNAM+1 + IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND. + &LNAM.LE.6) GOTO 150 + CHNAM=CHBIT(1:LNAM-1)//' ' + DO 170 LCOM=1,LNAM-1 + DO 160 LALP=1,26 + IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)= + & CHALP(2)(LALP:LALP) + 160 CONTINUE + 170 CONTINUE + IVAR=0 + DO 180 IV=1,56 + IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV + 180 CONTINUE + IF(IVAR.EQ.0) THEN + CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM) + LLOW=LHIG + IF(LLOW.LT.LTOT) GOTO 120 + RETURN + ENDIF + +C...Identify any indices. + I1=0 + I2=0 + I3=0 + NINDX=0 + IF(CHBIT(LNAM:LNAM).EQ.'(') THEN + LIND=LNAM + 190 LIND=LIND+1 + IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190 + CHIND=' ' + IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c') + & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR. + & IVAR.EQ.37)) THEN + CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1) + READ(CHIND,'(I8)') KF + I1=PYCOMP(KF) + ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ. + & 'c') THEN + CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '// + & CHNAM) + LLOW=LHIG + IF(LLOW.LT.LTOT) GOTO 120 + RETURN + ELSE + CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1) + READ(CHIND,'(I8)') I1 + ENDIF + LNAM=LIND + IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1 + NINDX=1 + ENDIF + IF(CHBIT(LNAM:LNAM).EQ.',') THEN + LIND=LNAM + 200 LIND=LIND+1 + IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200 + CHIND=' ' + CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1) + READ(CHIND,'(I8)') I2 + LNAM=LIND + IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1 + NINDX=2 + ENDIF + IF(CHBIT(LNAM:LNAM).EQ.',') THEN + LIND=LNAM + 210 LIND=LIND+1 + IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210 + CHIND=' ' + CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1) + READ(CHIND,'(I8)') I3 + LNAM=LIND+1 + NINDX=3 + ENDIF + +C...Check that indices allowed. + IERR=0 + IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1 + IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4))) + &IERR=2 + IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6))) + &IERR=3 + IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8))) + &IERR=4 + IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5 + IF(IERR.GE.1) THEN + CALL PYERRM(18,'(PYGIVE:) unallowed indices for '// + & CHBIT(1:LNAM-1)) + LLOW=LHIG + IF(LLOW.LT.LTOT) GOTO 120 + RETURN + ENDIF + +C...Save old value of variable. + IF(IVAR.EQ.1) THEN + IOLD=N + ELSEIF(IVAR.EQ.2) THEN + IOLD=K(I1,I2) + ELSEIF(IVAR.EQ.3) THEN + ROLD=P(I1,I2) + ELSEIF(IVAR.EQ.4) THEN + ROLD=V(I1,I2) + ELSEIF(IVAR.EQ.5) THEN + IOLD=MSTU(I1) + ELSEIF(IVAR.EQ.6) THEN + ROLD=PARU(I1) + ELSEIF(IVAR.EQ.7) THEN + IOLD=MSTJ(I1) + ELSEIF(IVAR.EQ.8) THEN + ROLD=PARJ(I1) + ELSEIF(IVAR.EQ.9) THEN + IOLD=KCHG(I1,I2) + ELSEIF(IVAR.EQ.10) THEN + ROLD=PMAS(I1,I2) + ELSEIF(IVAR.EQ.11) THEN + ROLD=PARF(I1) + ELSEIF(IVAR.EQ.12) THEN + ROLD=VCKM(I1,I2) + ELSEIF(IVAR.EQ.13) THEN + IOLD=MDCY(I1,I2) + ELSEIF(IVAR.EQ.14) THEN + IOLD=MDME(I1,I2) + ELSEIF(IVAR.EQ.15) THEN + ROLD=BRAT(I1) + ELSEIF(IVAR.EQ.16) THEN + IOLD=KFDP(I1,I2) + ELSEIF(IVAR.EQ.17) THEN + CHOLD=CHAF(I1,I2)(1:8) + ELSEIF(IVAR.EQ.18) THEN + IOLD=MRPY(I1) + ELSEIF(IVAR.EQ.19) THEN + ROLD=RRPY(I1) + ELSEIF(IVAR.EQ.20) THEN + IOLD=MSEL + ELSEIF(IVAR.EQ.21) THEN + IOLD=MSUB(I1) + ELSEIF(IVAR.EQ.22) THEN + IOLD=KFIN(I1,I2) + ELSEIF(IVAR.EQ.23) THEN + ROLD=CKIN(I1) + ELSEIF(IVAR.EQ.24) THEN + IOLD=MSTP(I1) + ELSEIF(IVAR.EQ.25) THEN + ROLD=PARP(I1) + ELSEIF(IVAR.EQ.26) THEN + IOLD=MSTI(I1) + ELSEIF(IVAR.EQ.27) THEN + ROLD=PARI(I1) + ELSEIF(IVAR.EQ.28) THEN + IOLD=MINT(I1) + ELSEIF(IVAR.EQ.29) THEN + ROLD=VINT(I1) + ELSEIF(IVAR.EQ.30) THEN + IOLD=ISET(I1) + ELSEIF(IVAR.EQ.31) THEN + IOLD=KFPR(I1,I2) + ELSEIF(IVAR.EQ.32) THEN + ROLD=COEF(I1,I2) + ELSEIF(IVAR.EQ.33) THEN + IOLD=ICOL(I1,I2,I3) + ELSEIF(IVAR.EQ.34) THEN + ROLD=XSFX(I1,I2) + ELSEIF(IVAR.EQ.35) THEN + IOLD=ISIG(I1,I2) + ELSEIF(IVAR.EQ.36) THEN + ROLD=SIGH(I1) + ELSEIF(IVAR.EQ.37) THEN + IOLD=MWID(I1) + ELSEIF(IVAR.EQ.38) THEN + ROLD=WIDS(I1,I2) + ELSEIF(IVAR.EQ.39) THEN + IOLD=NGEN(I1,I2) + ELSEIF(IVAR.EQ.40) THEN + ROLD=XSEC(I1,I2) + ELSEIF(IVAR.EQ.41) THEN + CHOLD2=PROC(I1) + ELSEIF(IVAR.EQ.42) THEN + ROLD=SIGT(I1,I2,I3) + ELSEIF(IVAR.EQ.43) THEN + ROLD=XPVMD(I1) + ELSEIF(IVAR.EQ.44) THEN + ROLD=XPANL(I1) + ELSEIF(IVAR.EQ.45) THEN + ROLD=XPANH(I1) + ELSEIF(IVAR.EQ.46) THEN + ROLD=XPBEH(I1) + ELSEIF(IVAR.EQ.47) THEN + ROLD=XPDIR(I1) + ELSEIF(IVAR.EQ.48) THEN + IOLD=IMSS(I1) + ELSEIF(IVAR.EQ.49) THEN + ROLD=RMSS(I1) + ELSEIF(IVAR.EQ.50) THEN + ROLD=RVLAM(I1,I2,I3) + ELSEIF(IVAR.EQ.51) THEN + ROLD=RVLAMP(I1,I2,I3) + ELSEIF(IVAR.EQ.52) THEN + ROLD=RVLAMB(I1,I2,I3) + ELSEIF(IVAR.EQ.53) THEN + IOLD=ITCM(I1) + ELSEIF(IVAR.EQ.54) THEN + ROLD=RTCM(I1) + ELSEIF(IVAR.EQ.55) THEN + IOLD=IUED(I1) + ELSEIF(IVAR.EQ.56) THEN + ROLD=RUED(I1) + ENDIF + +C...Print current value of variable. Loop back. + IF(LNAM.GE.LBIT) THEN + CHBIT(LNAM:14)=' ' + CHBIT(15:60)=' has the value ' + IF(MSVAR(IVAR,1).EQ.1) THEN + WRITE(CHBIT(51:60),'(I10)') IOLD + ELSEIF(MSVAR(IVAR,1).EQ.2) THEN + WRITE(CHBIT(47:60),'(F14.5)') ROLD + ELSEIF(MSVAR(IVAR,1).EQ.3) THEN + CHBIT(53:60)=CHOLD + ELSE + CHBIT(33:60)=CHOLD + ENDIF + IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60) + LLOW=LHIG + IF(LLOW.LT.LTOT) GOTO 120 + RETURN + ENDIF + +C...Read in new variable value. + IF(MSVAR(IVAR,1).EQ.1) THEN + CHINI=' ' + CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT) + READ(CHINI,'(I10)') INEW + ELSEIF(MSVAR(IVAR,1).EQ.2) THEN + CHINR=' ' + CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT) + READ(CHINR,*) RNEW + ELSEIF(MSVAR(IVAR,1).EQ.3) THEN + CHNEW=CHBIT(LNAM+1:LBIT)//' ' + ELSE + CHNEW2=CHBIT(LNAM+1:LBIT)//' ' + ENDIF + +C...Store new variable value. + IF(IVAR.EQ.1) THEN + N=INEW + ELSEIF(IVAR.EQ.2) THEN + K(I1,I2)=INEW + ELSEIF(IVAR.EQ.3) THEN + P(I1,I2)=RNEW + ELSEIF(IVAR.EQ.4) THEN + V(I1,I2)=RNEW + ELSEIF(IVAR.EQ.5) THEN + MSTU(I1)=INEW + ELSEIF(IVAR.EQ.6) THEN + PARU(I1)=RNEW + ELSEIF(IVAR.EQ.7) THEN + MSTJ(I1)=INEW + ELSEIF(IVAR.EQ.8) THEN + PARJ(I1)=RNEW + ELSEIF(IVAR.EQ.9) THEN + KCHG(I1,I2)=INEW + ELSEIF(IVAR.EQ.10) THEN + PMAS(I1,I2)=RNEW + ELSEIF(IVAR.EQ.11) THEN + PARF(I1)=RNEW + ELSEIF(IVAR.EQ.12) THEN + VCKM(I1,I2)=RNEW + ELSEIF(IVAR.EQ.13) THEN + MDCY(I1,I2)=INEW + ELSEIF(IVAR.EQ.14) THEN + MDME(I1,I2)=INEW + ELSEIF(IVAR.EQ.15) THEN + BRAT(I1)=RNEW + ELSEIF(IVAR.EQ.16) THEN + KFDP(I1,I2)=INEW + ELSEIF(IVAR.EQ.17) THEN + CHAF(I1,I2)=CHNEW + ELSEIF(IVAR.EQ.18) THEN + MRPY(I1)=INEW + ELSEIF(IVAR.EQ.19) THEN + RRPY(I1)=RNEW + ELSEIF(IVAR.EQ.20) THEN + MSEL=INEW + ELSEIF(IVAR.EQ.21) THEN + MSUB(I1)=INEW + ELSEIF(IVAR.EQ.22) THEN + KFIN(I1,I2)=INEW + ELSEIF(IVAR.EQ.23) THEN + CKIN(I1)=RNEW + ELSEIF(IVAR.EQ.24) THEN + MSTP(I1)=INEW + ELSEIF(IVAR.EQ.25) THEN + PARP(I1)=RNEW + ELSEIF(IVAR.EQ.26) THEN + MSTI(I1)=INEW + ELSEIF(IVAR.EQ.27) THEN + PARI(I1)=RNEW + ELSEIF(IVAR.EQ.28) THEN + MINT(I1)=INEW + ELSEIF(IVAR.EQ.29) THEN + VINT(I1)=RNEW + ELSEIF(IVAR.EQ.30) THEN + ISET(I1)=INEW + ELSEIF(IVAR.EQ.31) THEN + KFPR(I1,I2)=INEW + ELSEIF(IVAR.EQ.32) THEN + COEF(I1,I2)=RNEW + ELSEIF(IVAR.EQ.33) THEN + ICOL(I1,I2,I3)=INEW + ELSEIF(IVAR.EQ.34) THEN + XSFX(I1,I2)=RNEW + ELSEIF(IVAR.EQ.35) THEN + ISIG(I1,I2)=INEW + ELSEIF(IVAR.EQ.36) THEN + SIGH(I1)=RNEW + ELSEIF(IVAR.EQ.37) THEN + MWID(I1)=INEW + ELSEIF(IVAR.EQ.38) THEN + WIDS(I1,I2)=RNEW + ELSEIF(IVAR.EQ.39) THEN + NGEN(I1,I2)=INEW + ELSEIF(IVAR.EQ.40) THEN + XSEC(I1,I2)=RNEW + ELSEIF(IVAR.EQ.41) THEN + PROC(I1)=CHNEW2 + ELSEIF(IVAR.EQ.42) THEN + SIGT(I1,I2,I3)=RNEW + ELSEIF(IVAR.EQ.43) THEN + XPVMD(I1)=RNEW + ELSEIF(IVAR.EQ.44) THEN + XPANL(I1)=RNEW + ELSEIF(IVAR.EQ.45) THEN + XPANH(I1)=RNEW + ELSEIF(IVAR.EQ.46) THEN + XPBEH(I1)=RNEW + ELSEIF(IVAR.EQ.47) THEN + XPDIR(I1)=RNEW + ELSEIF(IVAR.EQ.48) THEN + IMSS(I1)=INEW + ELSEIF(IVAR.EQ.49) THEN + RMSS(I1)=RNEW + ELSEIF(IVAR.EQ.50) THEN + RVLAM(I1,I2,I3)=RNEW + ELSEIF(IVAR.EQ.51) THEN + RVLAMP(I1,I2,I3)=RNEW + ELSEIF(IVAR.EQ.52) THEN + RVLAMB(I1,I2,I3)=RNEW + ELSEIF(IVAR.EQ.53) THEN + ITCM(I1)=INEW + ELSEIF(IVAR.EQ.54) THEN + RTCM(I1)=RNEW + ELSEIF(IVAR.EQ.55) THEN + IUED(I1)=INEW + ELSEIF(IVAR.EQ.56) THEN + RUED(I1)=RNEW + ENDIF + +C...Write old and new value. Loop back. + CHBIT(LNAM:14)=' ' + CHBIT(15:60)=' changed from to ' + IF(MSVAR(IVAR,1).EQ.1) THEN + WRITE(CHBIT(33:42),'(I10)') IOLD + WRITE(CHBIT(51:60),'(I10)') INEW + IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60) + ELSEIF(MSVAR(IVAR,1).EQ.2) THEN + WRITE(CHBIT(29:42),'(F14.5)') ROLD + WRITE(CHBIT(47:60),'(F14.5)') RNEW + IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60) + ELSEIF(MSVAR(IVAR,1).EQ.3) THEN + CHBIT(35:42)=CHOLD + CHBIT(53:60)=CHNEW + IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60) + ELSE + CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2 + IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88) + ENDIF + LLOW=LHIG + IF(LLOW.LT.LTOT) GOTO 120 + +C...Format statement for output on unit MSTU(11) (by default 6). + 5000 FORMAT(5X,A60) + 5100 FORMAT(5X,A88) + + RETURN + END + +C********************************************************************* + +C...PYONOF +C...Switches on and off decay channel by search for match. + + SUBROUTINE PYONOF(CHIN) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + SAVE /PYDAT1/,/PYDAT3/ +C...Local arrays and character variables. + INTEGER KFCMP(10),KFTMP(10) + CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8, + &CHALP(2)*26 + DATA CHALP/'abcdefghijklmnopqrstuvwxyz', + &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ + +C...Determine length of character variable. + CHTMP=CHIN//' ' + LBEG=0 + 100 LBEG=LBEG+1 + IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100 + LEND=LBEG-1 + 105 LEND=LEND+1 + IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105 + 110 LEND=LEND-1 + IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110 + LEN=1+LEND-LBEG + CHFIX(1:LEN)=CHTMP(LBEG:LEND) + +C...Find colon separator and particle code. + LCOLON=0 + 120 LCOLON=LCOLON+1 + IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120 + CHCODE=' ' + CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1) + READ(CHCODE,'(I8)',ERR=300) KF + KC=PYCOMP(KF) + +C...Done if unknown code or no decay channels. + IF(KC.EQ.0) THEN + CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE) + RETURN + ENDIF + IDCBEG=MDCY(KC,2) + IDCLEN=MDCY(KC,3) + IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN + CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE) + RETURN + ENDIF + +C...Find command name up to blank or equal sign. + LSEP=LCOLON + 130 LSEP=LSEP+1 + IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND. + &CHFIX(LSEP:LSEP).NE.'=') GOTO 130 + CHMODE=' ' + LMODE=LSEP-LCOLON-1 + CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1) + +C...Convert to uppercase. + DO 150 LCOM=1,LMODE + DO 140 LALP=1,26 + IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) + & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP) + 140 CONTINUE + 150 CONTINUE + +C...Identify command. Failed if not identified. + MODE=0 + IF(CHMODE.EQ.'ALLOFF') MODE=1 + IF(CHMODE.EQ.'ALLON') MODE=2 + IF(CHMODE.EQ.'OFFIFANY') MODE=3 + IF(CHMODE.EQ.'ONIFANY') MODE=4 + IF(CHMODE.EQ.'OFFIFALL') MODE=5 + IF(CHMODE.EQ.'ONIFALL') MODE=6 + IF(CHMODE.EQ.'OFFIFMATCH') MODE=7 + IF(CHMODE.EQ.'ONIFMATCH') MODE=8 + IF(MODE.EQ.0) THEN + CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE) + RETURN + ENDIF + +C...Simple cases when all on or all off. + IF(MODE.EQ.1.OR.MODE.EQ.2) THEN + WRITE(MSTU(11),1000) KF,CHMODE + DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1 + IF(MDME(IDC,1).LT.0) GOTO 160 + MDME(IDC,1)=MODE-1 + 160 CONTINUE + RETURN + ENDIF + +C...Identify matching list. + NCMP=0 + LBEG=LSEP + 170 LBEG=LBEG+1 + IF(LBEG.GT.LEN) GOTO 190 + IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR. + &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170 + LEND=LBEG-1 + 180 LEND=LEND+1 + IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND. + &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180 + IF(LEND.LT.LEN) LEND=LEND-1 + CHCODE=' ' + CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND) + READ(CHCODE,'(I8)',ERR=300) KFREAD + NCMP=NCMP+1 + KFCMP(NCMP)=IABS(KFREAD) + LBEG=LEND + IF(NCMP.LT.10) GOTO 170 + 190 CONTINUE + WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP) + +C...Only one matching required. + IF(MODE.EQ.3.OR.MODE.EQ.4) THEN + DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1 + IF(MDME(IDC,1).LT.0) GOTO 220 + DO 210 IKF=1,5 + KFNOW=IABS(KFDP(IDC,IKF)) + IF(KFNOW.EQ.0) GOTO 210 + DO 200 ICMP=1,NCMP + IF(KFCMP(ICMP).EQ.KFNOW) THEN + MDME(IDC,1)=MODE-3 + GOTO 220 + ENDIF + 200 CONTINUE + 210 CONTINUE + 220 CONTINUE + RETURN + ENDIF + +C...Multiple matchings required. + DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1 + IF(MDME(IDC,1).LT.0) GOTO 260 + NTMP=NCMP + DO 230 ITMP=1,NTMP + KFTMP(ITMP)=KFCMP(ITMP) + 230 CONTINUE + NFIN=0 + DO 250 IKF=1,5 + KFNOW=IABS(KFDP(IDC,IKF)) + IF(KFNOW.EQ.0) GOTO 250 + NFIN=NFIN+1 + DO 240 ITMP=1,NTMP + IF(KFTMP(ITMP).EQ.KFNOW) THEN + KFTMP(ITMP)=KFTMP(NTMP) + NTMP=NTMP-1 + GOTO 250 + ENDIF + 240 CONTINUE + 250 CONTINUE + IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5 + IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7) + & MDME(IDC,1)=MODE-7 + 260 CONTINUE + RETURN + +C...Error exit for impossible read of particle code. + 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code ' + &//CHCODE) + +C...Formats for output. + 1000 FORMAT(' Decays for',I8,' set ',A10) + 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8) + + RETURN + END +C********************************************************************* + +C...PYTUNE +C...Presets for a few specific underlying-event and min-bias tunes +C...Note some tunes require external pdfs to be linked (e.g. 105:QW), +C...others require particular versions of pythia (e.g. the SCI and GAL +C...models). See below for details. + SUBROUTINE PYTUNE(ITUNE) +C +C ITUNE NAME (detailed descriptions below) +C 0 Default : No settings changed => defaults. +C +C ====== Old UE, Q2-ordered showers ==================================== +C 100 A : Rick Field's CDF Tune A (Oct 2002) +C 101 AW : Rick Field's CDF Tune AW (Apr 2006) +C 102 BW : Rick Field's CDF Tune BW (Apr 2006) +C 103 DW : Rick Field's CDF Tune DW (Apr 2006) +C 104 DWT : As DW but with slower UE ECM-scaling (Apr 2006) +C 105 QW : Rick Field's CDF Tune QW using CTEQ6.1M (?) +C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome") (?) +C 107 ACR : Tune A modified with new CR model (Mar 2007) +C 108 D6 : Rick Field's CDF Tune D6 using CTEQ6L1 (?) +C 109 D6T : Rick Field's CDF Tune D6T using CTEQ6L1 (?) +C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ---- +C 110 A-Pro : Tune A, with LEP tune from Professor (Oct 2008) +C 111 AW-Pro : Tune AW, -"- (Oct 2008) +C 112 BW-Pro : Tune BW, -"- (Oct 2008) +C 113 DW-Pro : Tune DW, -"- (Oct 2008) +C 114 DWT-Pro : Tune DWT, -"- (Oct 2008) +C 115 QW-Pro : Tune QW, -"- (Oct 2008) +C 116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"- (Oct 2008) +C 117 ACR-Pro : Tune ACR, -"- (Oct 2008) +C 118 D6-Pro : Tune D6, -"- (Oct 2008) +C 119 D6T-Pro : Tune D6T, -"- (Oct 2008) +C ---- Professor's Q2-ordered Perugia Tune : 129 ----------------------- +C 129 Pro-Q2O : Professor Q2-ordered tune (Feb 2009) +C +C ====== Intermediate and Hybrid Models ================================ +C 200 IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR +C 201 APT : Tune A w. pT-ordered FSR (Mar 2007) +C 211 APT-Pro : Tune APT, with LEP tune from Professor (Oct 2008) +C 221 Perugia APT : "Perugia" update of APT-Pro (Feb 2009) +C 226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009) +C +C ====== New UE, interleaved pT-ordered showers, annealing CR ========== +C 300 S0 : Sandhoff-Skands Tune using the S0 CR model (Apr 2006) +C 301 S1 : Sandhoff-Skands Tune using the S1 CR model (Apr 2006) +C 302 S2 : Sandhoff-Skands Tune using the S2 CR model (Apr 2006) +C 303 S0A : S0 with "Tune A" UE energy scaling (Apr 2006) +C 304 NOCR : New UE "best try" without col. rec. (Apr 2006) +C 305 Old : New UE, original (primitive) col. rec. (Aug 2004) +C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?) +C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP) +C 310 S0-Pro : S0 with updated LEP pars from Professor (Oct 2008) +C 311 S1-Pro : S1 -"- (Oct 2008) +C 312 S2-Pro : S2 -"- (Oct 2008) +C 313 S0A-Pro : S0A -"- (Oct 2008) +C 314 NOCR-Pro : NOCR -"- (Oct 2008) +C 315 Old-Pro : Old -"- (Oct 2008) +C 316 ATLAS MC08 : pT-ordered showers, CTEQ6L1 (2008) +C ---- Peter's Perugia Tunes : 320+ ------------------------------------ +C 320 Perugia 0 : "Perugia" update of S0-Pro (Feb 2009) +C 321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD +C 322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD +C 323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI +C balance & different scaling to LHC & RHIC (Feb 2009) +C 324 Perugia NOCR : "Perugia" update of NOCR-Pro (Feb 2009) +C 325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009) +C 326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009) +C 327 Perugia 10: Alternative to Perugia 0, with more FSR (May 2010) +C off ISR, more BR breakup, more strangeness +C 328 Perugia K : Alternative to Perugia 2010, with a (May 2010) +C K-factor applied to MPI cross sections +C ---- Professor's pT-ordered Perugia Tune : 329 ----------------------- +C 329 Pro-pTO : Professor pT-ordered tune w. S0 CR model (Feb 2009) +C ---- Tunes introduced in 6.4.23: +C 330 ATLAS MC09 : pT-ordered showers, LO* PDFs (2009) +C 331 ATLAS MC09c : pT-ordered showers, LO* PDFs, better CR (2009) +C 334 Perugia 10 NOCR : Perugia 2010 with no CR, less MPI (Oct 2010) +C 335 Pro-pT* : Professor Tune with LO* (Mar 2009) +C 336 Pro-pT6 : Professor Tune with CTEQ6LL (Mar 2009) +C 339 Pro-pT** : Professor Tune with LO** (Mar 2009) +C 340 AMBT1 : First ATLAS tune including 7 TeV data (May 2010) +C 341 Z1 : First CMS tune including 7 TeV data (Aug 2010) +C 342 Z1-LEP : CMS tune Z1, with improved LEP parameters (Oct 2010) +C 343 Z2 : Retune of Z1 by Field w CTEQ6L1 PDFs (2010) +C 344 Z2-LEP : Retune of Z1 by Skands w CTEQ6L1 PDFs (Feb 2011) +C 350 Perugia 2011 : Retune of Perugia 2010 incl 7-TeV data (Mar 2011) +C 351 P2011 radHi : Variation with alphaS(pT/2) +C 352 P2011 radLo : Variation with alphaS(2pT) +C 353 P2011 mpiHi : Variation with more semi-hard MPI +C 354 P2011 noCR : Variation without color reconnections +C 355 P2011 LO** : Perugia 2011 using MSTW LO** PDFs (Mar 2011) +C 356 P2011 C6 : Perugia 2011 using CTEQ6L1 PDFs (Mar 2011) +C 357 P2011 T16 : Variation with PARP(90)=0.32 away from 7 TeV +C 358 P2011 T32 : Variation with PARP(90)=0.16 awat from 7 TeV +C 359 P2011 TeV : Perugia 2011 optimized for Tevatron (Mar 2011) +C 360 S Global : Schulz-Skands Global fit (Mar 2011) +C 361 S 7000 : Schulz-Skands at 7000 GeV (Mar 2011) +C 362 S 1960 : Schulz-Skands at 1960 GeV (Mar 2011) +C 363 S 1800 : Schulz-Skands at 1800 GeV (Mar 2011) +C 364 S 900 : Schulz-Skands at 900 GeV (Mar 2011) +C 365 S 630 : Schulz-Skands at 630 GeV (Mar 2011) +C +C ======= The Uppsala models =========================================== +C ( NB! must be run with special modified Pythia 6.215 version ) +C ( available from http://www.isv.uu.se/thep/MC/scigal/ ) +C 400 GAL 0 : Generalized area-law model. Org pars (Dec 1998) +C 401 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998) +C 402 GAL 1 : GAL 0. Tevatron MB retuned (Skands) (Oct 2006) +C 403 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006) +C +C More details; +C +C Quick Dictionary: +C BE : Bose-Einstein +C BR : Beam Remnants +C CR : Colour Reconnections +C HAD: Hadronization +C ISR/FSR: Initial-State Radiation / Final-State Radiation +C FSI: Final-State Interactions (=CR+BE) +C MB : Minimum-bias +C MI : Multiple Interactions +C UE : Underlying Event +C +C======================================================================= +C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE) +C======================================================================= +C +C A (100) and AW (101). CTEQ5L parton distributions +C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) *** +C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+ +C...Key feature: extensively compared to CDF data (R.D. Field). +C...* Large starting scale for ISR (PARP(67)=4) +C...* AW has even more radiation due to smaller mu_R choice in alpha_s. +C...* See: http://www.phys.ufl.edu/~rfield/cdf/ +C +C BW (102). CTEQ5L parton distributions +C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) *** +C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+ +C...Key feature: extensively compared to CDF data (R.D. Field). +C...NB: Can also be run with Pythia 6.2 or 6.312+ +C...* Small starting scale for ISR (PARP(67)=1) +C...* BW has more radiation due to smaller mu_R choice in alpha_s. +C...* See: http://www.phys.ufl.edu/~rfield/cdf/ +C +C DW (103) and DWT (104). CTEQ5L parton distributions +C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) *** +C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+ +C...Key feature: extensively compared to CDF data (R.D. Field). +C...NB: Can also be run with Pythia 6.2 or 6.312+ +C...* Intermediate starting scale for ISR (PARP(67)=2.5) +C...* DWT has a different reference energy, the same as the "S" models +C... below, leading to more UE activity at the LHC, but less at RHIC. +C...* See: http://www.phys.ufl.edu/~rfield/cdf/ +C +C QW (105). CTEQ61 parton distributions +C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) *** +C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+ +C...Key feature: uses CTEQ61 (external pdf library must be linked) +C +C ATLAS-DC2 (106). CTEQ5L parton distributions +C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) *** +C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+ +C...Key feature: tune used by the ATLAS collaboration. +C +C ACR (107). CTEQ5L parton distributions +C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ *** +C...Key feature: Tune A modified to use annealing CR. +C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78). +C +C D6 (108) and D6T (109). CTEQ6L parton distributions +C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs. +C +C A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions +C Old UE model, Q2-ordered showers. +C...Key feature: Rick Field's family of tunes revamped with the +C...Professor Q2-ordered final-state shower and fragmentation tunes +C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008. +C...Key feature: improved descriptions of LEP data. +C +C Pro-Q2O (129). CTEQ5L parton distributions +C Old UE model, Q2-ordered showers. +C...Key feature: Complete retune of old model by Professor, including +C...large amounts of both LEP and Tevatron data. +C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite +C...extreme in this tune, corresponding to using mu_R = pT/3 . +C +C======================================================================= +C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS) +C======================================================================= +C +C IM1 (200). Intermediate model, Q2-ordered showers, +C CTEQ5L parton distributions +C...Key feature: new UE model w Q2-ordered showers and no interleaving. +C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR. +C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078. +C +C APT (201). Old UE model, pT-ordered final-state showers, +C CTEQ5L parton distributions +C...Key feature: Rick Field's Tune A, but with new final-state showers +C +C APT-Pro (211). Old UE model, pT-ordered final-state showers, +C CTEQ5L parton distributions +C...Key feature: APT revamped with the Professor pT-ordered final-state +C...shower and fragmentation tunes presented by Hendrik Hoeth at the +C...Perugia MPI workshop in October 2008. +C +C Perugia-APT (221). Old UE model, pT-ordered final-state showers, +C CTEQ5L parton distributions +C...Key feature: APT-Pro with final-state showers off the MPI, +C...lower ISR renormalization scale to improve agreement with the +C...Tevatron Drell-Yan pT measurements and with improved energy scaling +C...to min-bias at 630 GeV. +C +C Perugia-APT6 (226). Old UE model, pT-ordered final-state showers, +C CTEQ6L1 parton distributions. +C...Key feature: uses CTEQ6L1 (external pdf library must be linked), +C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller +C...UE activity obtained with CTEQ6L1 relative to CTEQ5L. +C +C======================================================================= +C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE) +C======================================================================= +C +C S0 (300) and S0A (303). CTEQ5L parton distributions +C...Key feature: large amount of multiple interactions +C...* Somewhat faster than the other colour annealing scenarios. +C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed +C... from Tune A, leading to less UE at the LHC, but more at RHIC. +C...* Small amount of radiation. +C...* Large amount of low-pT MI +C...* Low degree of proton lumpiness (broad matter dist.) +C...* CR Type S (driven by free triplets), of medium strength. +C...* See: Pythia6402 update notes or later. +C +C S1 (301). CTEQ5L parton distributions +C...Key feature: large amount of radiation. +C...* Large amount of low-pT perturbative ISR +C...* Large amount of FSR off ISR partons +C...* Small amount of low-pT multiple interactions +C...* Moderate degree of proton lumpiness +C...* Least aggressive CR type (S+S Type I), but with large strength +C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120. +C +C S2 (302). CTEQ5L parton distributions +C...Key feature: very lumpy proton + gg string cluster formation allowed +C...* Small amount of radiation +C...* Moderate amount of low-pT MI +C...* High degree of proton lumpiness (more spiky matter distribution) +C...* Most aggressive CR type (S+S Type II), but with small strength +C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120. +C +C NOCR (304). CTEQ5L parton distributions +C...Key feature: no colour reconnections (NB: "Best fit" only). +C...* NB: (Nch) problematic in this tune. +C...* Small amount of radiation +C...* Small amount of low-pT MI +C...* Low degree of proton lumpiness +C...* Large BR composite x enhancement factor +C...* Most clever colour flow without CR ("Lambda ordering") +C +C ATLAS-CSC (306). CTEQ6L parton distributions +C...Key feature: 11-parameter ATLAS tune of the new framework. +C...* Old (pre-annealing) colour reconnections a la 305. +C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally) +C +C S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions. +C...Key feature: the S0 family of tunes revamped with the Professor +C...pT-ordered final-state shower and fragmentation tunes presented by +C...Hendrik Hoeth at the Perugia MPI workshop in October 2008. +C...Key feature: improved descriptions of LEP data. +C +C ATLAS MC08 (316). CTEQ6L1 parton distributions +C...Key feature: ATLAS tune of the new framework using CTEQ6L1 PDFs +C...* Warning: uses Peterson fragmentation function for heavy quarks +C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally) +C +C Perugia-0 (320). CTEQ5L parton distributions. +C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan +C...pT spectrum, better (Nch) in min-bias, and better scaling to +C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more +C...beam-remnant breakup (more baryon number transport), and suppression +C...of CR in high-pT string pieces. +C +C Perugia-HARD (321). CTEQ5L parton distributions. +C...Key feature: More ISR, More FSR, Less MPI, Less BR +C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR. +C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less +C...baryon number transport), and more fragmentation pT. +C...Multiplicity in min-bias is LOW, (Nch) is HIGH, +C...DY pT spectrum is HARD. +C +C Perugia-SOFT (322). CTEQ5L parton distributions. +C...Key feature: Less ISR, Less FSR, More MPI, More BR +C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower +C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon +C...number transport), and less fragmentation pT. +C...Multiplicity in min-bias is HIGH, (Nch) is LOW, +C...DY pT spectrum is SOFT +C +C Perugia-3 (323). CTEQ5L parton distributions. +C...Key feature: variant of Perugia-0 with more extreme energy scaling +C...properties while still agreeing with Tevatron data from 630 to 1960. +C...More ISR and less MPI than Perugia-0 at the Tevatron and above and +C...allows FSR off the active end of dipoles stretched to the remnant. +C +C Perugia-NOCR (324). CTEQ5L parton distributions. +C...Key feature: Retune of NOCR-Pro with better scaling properties to +C...lower energies and somewhat better agreement with Tevatron data +C...at 1800/1960. +C +C Perugia-* (325). MRST LO* parton distributions for generators +C...Key feature: first attempt at using the LO* distributions +C...(external pdf library must be linked). +C +C Perugia-6 (326). CTEQ6L1 parton distributions +C...Key feature: uses CTEQ6L1 (external pdf library must be linked). +C +C Perugia-2010 (327). CTEQ5L parton distributions +C...Key feature: Retune of Perugia 0 to attempt to better describe +C...strangeness yields at RHIC and at LEP. Also increased the amount +C...of FSR off ISR following the conclusions in arXiv:1001.4082. +C...Increased the amount of beam blowup, causing more baryon transport +C...into the detector, to further explore this possibility. Using +C...a new color-reconnection model that relies on determining a thrust +C...axis for the events and then computing reconnection probabilities for +C...the individual string pieces based on the actual string densities +C...per rapidity interval along that thrust direction. +C +C Perugia-K (328). CTEQ5L parton distributions +C...Key feature: uses a ``K'' factor on the MPI cross sections +C...This gives a larger rate of minijets and pushes the underlying-event +C...activity towards higher pT. To compensate for the increased activity +C...at higher pT, the infared regularization scale is larger for this tune. +C +C Pro-pTO (329). CTEQ5L parton distributions +C...Key feature: Complete retune of new model by Professor, including +C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro. +C +C ATLAS MC09 (330). LO* parton distributions +C...Key feature: Good overall agreement with Tevatron and early LHC data. +C...Similar to Perugia *. +C +C ATLAS MC09c (331). LO* parton distributions +C...Key feature: Good overall agreement with Tevatron and 900-GeV LHC data. +C...Similar to Perugia *. Retuned CR model with respect to MC09. +C +C Pro-pT* (335) LO* parton distributions +C...Key feature: Retune of Pro-PTO with MRST LO* PDFs. +C +C Pro-pT6 (336). CTEQ6L1 parton distributions +C...Key feature: Retune of Pro-PTO with CTEQ6L1 PDFs. +C +C Pro-pT** (339). LO** parton distributions +C...Key feature: Retune of Pro-PTO with MRST LO** PDFs. +C +C AMBT1 (340). LO* parton distributions +C...Key feature: First ATLAS tune including 7-TeV LHC data. +C...Mainly retuned CR and mass distribution with respect to MC09c. +C...Note: cannot be run standalone since it uses external PDFs. +C +C CMSZ1 (341). CTEQ5L parton distributions +C...Key feature: First CMS tune including 7-TeV LHC data. +C...Uses many of the features of AMBT1, but uses CTEQ5L PDFs, +C...has a lower pT0 at the Tevatron, which scales faster with energy. +C +C Z1-LEP (342). CTEQ5L parton distributions +C...Key feature: CMS tune Z1 with improved LEP parameters, mostly +C...taken from the Professor/Perugia tunes, with a few minor updates. +C +C======================================================================= +C OTHER TUNES +C======================================================================= +C +C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run +C...with an unmodified Pythia distribution. +C...See http://www.isv.uu.se/thep/MC/scigal/ for more information. +C +C ::: + Future improvements? +C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK? +C (problem: K-factor affects everything so only works as +C intended for min-bias, not for UE ... probably need a +C better long-term solution to handle UE as well. Anyway, +C Mark uses MSTP(33) and PARP(31)-PARP(33).) + +C...Global statements + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + INTEGER PYK,PYCHGE,PYCOMP + +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + +C...SCI and GAL Commonblocks + COMMON /SCIPAR/MSWI(2),PARSCI(2) + +C...SAVE statements + SAVE /PYDAT1/,/PYPARS/ + SAVE /SCIPAR/ + +C...Internal parameters + PARAMETER(MXTUNS=500) + CHARACTER*8 CHDOC + PARAMETER (CHDOC='Mar 2011') + CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME + CHARACTER*42 CHMSTJ(50), CHMSTP(100), CHPARP(100), + & CHPARJ(100), CHMSTU(101:121), CHPARU(101:121), CH40 + CHARACTER*60 CH60 + CHARACTER*70 CH70 + DATA (CHNAMS(I),I=0,1)/'Default',' '/ + DATA (CHNAMS(I),I=100,119)/ + & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW', + & 'ATLAS DC2','Tune ACR','Tune D6','Tune D6T', + 1 'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro', + 1 'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro', + 1 'Tune D6-Pro','Tune D6T-Pro'/ + DATA (CHNAMS(I),I=120,129)/ + & 9*' ','Pro-Q2O'/ + DATA (CHNAMS(I),I=300,309)/ + & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old', + 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/ + DATA (CHNAMS(I),I=310,316)/ + & 'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro', + & 'NOCR-Pro','Old-Pro','ATLAS MC08'/ + DATA (CHNAMS(I),I=320,329)/ + & 'Perugia 0','Perugia HARD','Perugia SOFT', + & 'Perugia 3','Perugia NOCR','Perugia LO*', + & 'Perugia 6','Perugia 10','Perugia K','Pro-pTO'/ + DATA (CHNAMS(I),I=330,349)/ + & 'ATLAS MC09','ATLAS MC09c',2*' ','Perugia 10 NOCR','Pro-PT*', + & 'Pro-PT6',' ',' ','Pro-PT**', + 4 'Tune AMBT1','Tune Z1','Tune Z1-LEP','Tune Z2','Tune Z2-LEP', + 4 5*' '/ + DATA (CHNAMS(I),I=350,359)/ + & 'Perugia 2011','P2011 radHi','P2011 radLo','P2011 mpiHi', + & 'P2011 noCR','P2011 M(LO**)', 'P2011 CTEQ6L1', + & 'P2011 T16','P2011 T32','P2011 Tevatron'/ + DATA (CHNAMS(I),I=360,369)/ + & 'S Global','S 7000','S 1960','S 1800', + & 'S 900','S 630', 4*' '/ + DATA (CHNAMS(I),I=200,229)/ + & 'IM Tune 1','Tune APT',8*' ', + & ' ','Tune APT-Pro',8*' ', + & ' ','Perugia APT',4*' ','Perugia APT6',3*' '/ + DATA (CHNAMS(I),I=400,409)/ + & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/ + DATA (CHMSTJ(I),I=11,20)/ + & 'HAD choice of fragmentation function(s)',4*' ', + & 'HAD treatment of small-mass systems',4*' '/ + DATA (CHMSTJ(I),I=41,50)/ + & 'FSR type (Q2 or pT) for old framework',9*' '/ + DATA (CHMSTP(I),I=1,10)/ + & 2*' ','INT switch for choice of LambdaQCD',7*' '/ + DATA (CHMSTP(I),I=31,40)/ + & 2*' ','"K" switch for K-factor on/off & type',7*' '/ + DATA (CHMSTP(I),I=51,100)/ + 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ', + 6 'ISR master switch',2*' ','ISR alphaS type',2*' ', + 6 'ISR coherence option for 1st emission', + 6 'ISR phase space choice & ME corrections',' ', + 7 'ISR IR regularization scheme',' ', + 7 'IFSR scheme for non-decay FSR',8*' ', + 8 'UE model', + 8 'UE hadron transverse mass distribution',5*' ', + 8 'BR composite scheme','BR color scheme', + 9 'BR primordial kT compensation', + 9 'BR primordial kT distribution', + 9 'BR energy partitioning scheme',2*' ', + 9 'FSI color (re-)connection model',5*' '/ + DATA (CHPARP(I),I=1,10)/ + & 'ME/UE LambdaQCD',9*' '/ + DATA (CHPARP(I),I=31,40)/ + & ' ','"K" K-factor',8*' '/ + DATA (CHPARP(I),I=61,100)/ + 6 'ISR LambdaQCD','ISR IR cutoff',' ', + 6 'ISR renormalization scale prefactor', + 6 2*' ','ISR Q2max factor',3*' ', + 7 'IFSR Q2max factor in non-s-channel procs', + 7 'IFSR LambdaQCD (outside resonance decays)',4*' ', + 7 'FSI color reco high-pT damping strength', + 7 'FSI color reconnection strength', + 7 'BR composite x enhancement','BR breakup suppression', + 8 2*'UE IR cutoff at reference ecm', + 8 2*'UE mass distribution parameter', + 8 'UE gg color correlated fraction','UE total gg fraction', + 8 2*' ', + 8 'UE IR cutoff reference ecm', + 8 'UE IR cutoff ecm scaling power', + 9 'BR primordial kT width <|kT|>',' ', + 9 'BR primordial kT UV cutoff',7*' '/ + DATA (CHPARJ(I),I=1,30)/ + & 'HAD diquark suppression','HAD strangeness suppression', + & 'HAD strange diquark suppression', + & 'HAD vector diquark suppression','HAD P(popcorn)', + & 'HAD extra popcorn B(s)-M-B(s) supp', + & 'HAD extra popcorn B-M(s)-B supp', + & 3*' ', + 1 'HAD P(vector meson), u and d only', + 1 'HAD P(vector meson), contains s', + 1 'HAD P(vector meson), heavy quarks',7*' ', + 2 'HAD fragmentation pT',' ',' ',' ', + 2 'HAD eta0 suppression',"HAD eta0' suppression",4*' '/ + DATA (CHPARJ(I),I=41,90)/ + 4 'HAD string parameter a(Meson)','HAD string parameter b', + 4 2*' ','HAD string a(Baryon)-a(Meson)', + 4 'HAD Lund(=0)-Bowler(=1) rQ (rc)', + 4 'HAD Lund(=0)-Bowler(=1) rb',3*' ', + 5 3*' ', 'HAD charm parameter','HAD bottom parameter',5*' ', + 6 10*' ',10*' ', + 8 'FSR LambdaQCD (inside resonance decays)', + & 'FSR IR cutoff',8*' '/ + DATA (CHMSTU(I),I=111,120)/ + 1 ' ','INT n(flavors) for LambdaQCD',8*' '/ + DATA (CHPARU(I),I=111,120)/ + 1 ' ','INT LambdaQCD',8*' '/ + +C...1) Shorthand notation + M13=MSTU(13) + M11=MSTU(11) + IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN + CHNAME=CHNAMS(ITUNE) + IF (ITUNE.EQ.0) GOTO 9999 + ELSE + CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.') + GOTO 9999 + ENDIF + +C...2) Hello World + IF (M13.GE.1) WRITE(M11,5000) CHDOC + +C...Hardcode some defaults +C...Get Lambda from PDF + MSTP(3) = 2 +C...CTEQ5L1 PDFs + MSTP(52) = 1 + MSTP(51) = 7 +C... No K-factor + MSTP(33) = 0 + +C...3) Tune parameters + +C======================================================================= +C...ATLAS MC08 + + IF (ITUNE.EQ.316) THEN + + IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME + IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune.') + ENDIF + +C...First set some explicit defaults from 6.4.20 +C...# Old defaults + MSTJ(11) = 4 +C...# Old default flavour parameters + PARJ(1) = 0.1 + PARJ(2) = 0.3 + PARJ(3) = 0.40 + PARJ(4) = 0.05 + PARJ(11) = 0.5 + PARJ(12) = 0.6 + PARJ(21) = 0.36 + PARJ(41) = 0.30 + PARJ(42) = 0.58 + PARJ(46) = 1.0 + PARJ(82) = 1.0 + +C...PDFs: CTEQ6L1 for 326 + MSTP(52)=2 + MSTP(51)=10042 + +C...UE and ISR switches + MSTP(81)=21 + MSTP(82)=4 + MSTP(70)=0 + MSTP(72)=1 + +C...CR: + MSTP(95)=2 + PARP(78)=0.3 + PARP(77)=0.0 + PARP(80)=0.1 + +C...Primordial kT + PARP(91)=2.0D0 + PARP(93)=5.0D0 + +C...MPI: + PARP(82)=2.1 + PARP(83)=0.8 + PARP(84)=0.7 + PARP(89)=1800.0 + PARP(90)=0.16 + +C...FSR inside resonance decays + PARJ(81)=0.29 + +C...Fragmentation (warning: uses Peterson) + MSTJ(11)=3 + PARJ(54)=-0.07 + PARJ(55)=-0.006 + MSTJ(22)=2 + + IF (M13.GE.1) THEN + CH60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002' + WRITE(M11,5030) CH60 + CH60='Physics model: '// + & 'T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + +C...Output + WRITE(M11,5030) ' ' + WRITE(M11,5040) 51, MSTP(51), CHMSTP(51) + WRITE(M11,5040) 52, MSTP(52), CHMSTP(52) + WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3) + IF (MSTP(70).EQ.0) THEN + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + ENDIF + WRITE(M11,5040) 64, MSTP(64), CHMSTP(64) + WRITE(M11,5050) 64, PARP(64), CHPARP(64) + WRITE(M11,5040) 67, MSTP(67), CHMSTP(67) + WRITE(M11,5050) 67, PARP(67), CHPARP(67) + WRITE(M11,5040) 68, MSTP(68), CHMSTP(68) + CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)' + WRITE(M11,5030) CH60 + WRITE(M11,5040) 70, MSTP(70), CHMSTP(70) + WRITE(M11,5040) 72, MSTP(72), CHMSTP(72) + WRITE(M11,5050) 71, PARP(71), CHPARP(71) + WRITE(M11,5060) 81, PARJ(81), CHPARJ(81) + WRITE(M11,5060) 82, PARJ(82), CHPARJ(82) + WRITE(M11,5040) 33, MSTP(33), CHMSTP(33) + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5050) 89, PARP(89), CHPARP(89) + WRITE(M11,5050) 90, PARP(90), CHPARP(90) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 84, PARP(84), CHPARP(84) + WRITE(M11,5040) 88, MSTP(88), CHMSTP(88) + WRITE(M11,5040) 89, MSTP(89), CHMSTP(89) + WRITE(M11,5050) 79, PARP(79), CHPARP(79) + WRITE(M11,5050) 80, PARP(80), CHPARP(80) + WRITE(M11,5040) 91, MSTP(91), CHMSTP(91) + WRITE(M11,5050) 91, PARP(91), CHPARP(91) + WRITE(M11,5050) 93, PARP(93), CHPARP(93) + WRITE(M11,5040) 95, MSTP(95), CHMSTP(95) + IF (MSTP(95).GE.1) THEN + WRITE(M11,5050) 78, PARP(78), CHPARP(78) + IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77) + ENDIF + + ENDIF + +C======================================================================= +C...ATLAS MC09, MC09c, AMBT1 +C...CMS Z1 (R. Field), Z1-LEP + + ELSEIF (ITUNE.EQ.330.OR.ITUNE.EQ.331.OR.ITUNE.EQ.340.OR. + & ITUNE.GE.341.AND.ITUNE.LE.344) THEN + + IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME + IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune.') + ENDIF + +C...First set some explicit defaults from 6.4.20 + IF (ITUNE.LE.341.OR.ITUNE.EQ.343) THEN +C... # Old defaults + MSTJ(11) = 4 +C...# Old default flavour parameters + PARJ(1) = 0.1 + PARJ(2) = 0.3 + PARJ(3) = 0.40 + PARJ(4) = 0.05 + PARJ(11) = 0.5 + PARJ(12) = 0.6 + PARJ(21) = 0.36 + PARJ(41) = 0.30 + PARJ(42) = 0.58 + PARJ(46) = 1.0 + PARJ(82) = 1.0 + ELSE +C...# For Zn-LEP tunes, use tuned flavour parameters from Professor/Perugia + PARJ( 1) = 0.08D0 + PARJ( 2) = 0.21D0 + PARJ(3) = 0.94 + PARJ( 4) = 0.04D0 + PARJ(11) = 0.35D0 + PARJ(12) = 0.35D0 + PARJ(13) = 0.54 + PARJ(25) = 0.63 + PARJ(26) = 0.12 +C...# Switch on Bowler: + MSTJ(11) = 5 +C...# Fragmentation + PARJ(21) = 0.34D0 + PARJ(41) = 0.35D0 + PARJ(42) = 0.80D0 + PARJ(47) = 1.0 + PARJ(81) = 0.26D0 + PARJ(82) = 1.0D0 + ENDIF + +C...PDFs: MRST LO* + MSTP(52)=2 + MSTP(51)=20650 + IF (ITUNE.EQ.341.OR.ITUNE.EQ.342) THEN +C...Z1 uses CTEQ5L + MSTP(52)=1 + MSTP(51)=7 + ELSEIF (ITUNE.EQ.343.OR.ITUNE.EQ.344) THEN +C...Z2 uses CTEQ6L + MSTP(52)=2 + MSTP(51)=10042 + ENDIF + +C...UE and ISR switches + MSTP(81)=21 + MSTP(82)=4 + MSTP(70)=0 + MSTP(72)=1 + +C...CR: + MSTP(95)=6 + PARP(78)=0.3 + PARP(77)=0.0 + PARP(80)=0.1 + IF (ITUNE.EQ.331) THEN + PARP(78)=0.224 + ELSEIF (ITUNE.EQ.340) THEN +C...AMBT1 + PARP(77)=1.016D0 + PARP(78)=0.538D0 + ELSEIF (ITUNE.GE.341.AND.ITUNE.LE.344) THEN +C...Z1 and Z2 use the AMBT1 CR values + PARP(77)=1.016D0 + PARP(78)=0.538D0 + ENDIF + +C...MPI: + PARP(82)=2.3 + PARP(83)=0.8 + PARP(84)=0.7 + PARP(89)=1800.0 + PARP(90)=0.25 + IF (ITUNE.EQ.331) THEN + PARP(82)=2.315 + PARP(90)=0.2487 + ELSEIF (ITUNE.EQ.340) THEN + PARP(82)=2.292D0 + PARP(83)=0.356D0 + PARP(84)=0.651 + PARP(90)=0.25D0 + ELSEIF (ITUNE.EQ.341.OR.ITUNE.EQ.342) THEN + PARP(82)=1.932D0 + PARP(83)=0.356D0 + PARP(84)=0.651 + PARP(90)=0.275D0 + ELSEIF (ITUNE.EQ.343.OR.ITUNE.EQ.344) THEN + PARP(82)=1.832D0 + PARP(83)=0.356D0 + PARP(84)=0.651 + PARP(90)=0.275D0 + ENDIF + +C...Primordial kT + PARP(91)=2.0D0 + PARP(93)=5D0 + IF (ITUNE.GE.340) THEN + PARP(93)=10D0 + ENDIF + +C...ISR + IF (ITUNE.GE.340) THEN + PARP(62)=1.025 + ENDIF + +C...FSR inside resonance decays + PARJ(81)=0.29 + +C...Fragmentation (org 6.4 defs hardcoded) + MSTJ(11)=4 + PARJ(41)=0.3 + PARJ(42)=0.58 + MSTJ(22)=2 +C...AMBT1 mentions 46 explicitly, but Z1 doesn't ... + PARJ(46)=0.75 + IF (ITUNE.GE.341.AND.ITUNE.LE.344) THEN +C...Reset PARJ(46) to org def value for Z1 and Z2 + PARJ(46)=1.0 + ENDIF + + IF (M13.GE.1) THEN + IF (ITUNE.LT.340) THEN + CH60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002' + ELSEIF (ITUNE.EQ.340) THEN + CH60='Tuned by ATLAS, ATLAS-CONF-2010-031' + ELSEIF (ITUNE.EQ.341) THEN + CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031' + WRITE(M11,5030) CH60 + CH60='Z1 variation tuned by R. D. Field (CMS)' + ELSEIF (ITUNE.EQ.342) THEN + CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031' + WRITE(M11,5030) CH60 + CH60='Z1 variation retuned by R. D. Field (CMS)' + WRITE(M11,5030) CH60 + CH60='Z1-LEP variation retuned by Professor / P. Skands' + ELSEIF (ITUNE.EQ.343) THEN + CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031' + WRITE(M11,5030) CH60 + CH60='Z2 variation retuned by R. D. Field (CMS)' + ELSEIF (ITUNE.EQ.344) THEN + CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031' + WRITE(M11,5030) CH60 + CH60='Z2 variation retuned by R. D. Field (CMS)' + WRITE(M11,5030) CH60 + CH60='Z2-LEP variation retuned by Professor / P. Skands' + ENDIF + WRITE(M11,5030) CH60 + CH60='Physics Model: '// + & 'T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + +C...Output + WRITE(M11,5030) ' ' + WRITE(M11,5040) 51, MSTP(51), CHMSTP(51) + WRITE(M11,5040) 52, MSTP(52), CHMSTP(52) + WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3) + IF (MSTP(70).EQ.0) THEN + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + ENDIF + WRITE(M11,5040) 64, MSTP(64), CHMSTP(64) + WRITE(M11,5050) 64, PARP(64), CHPARP(64) + WRITE(M11,5040) 67, MSTP(67), CHMSTP(67) + WRITE(M11,5050) 67, PARP(67), CHPARP(67) + WRITE(M11,5040) 68, MSTP(68), CHMSTP(68) + CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)' + WRITE(M11,5030) CH60 + WRITE(M11,5040) 70, MSTP(70), CHMSTP(70) + WRITE(M11,5040) 72, MSTP(72), CHMSTP(72) + WRITE(M11,5050) 71, PARP(71), CHPARP(71) + WRITE(M11,5060) 81, PARJ(81), CHPARJ(81) + WRITE(M11,5060) 82, PARJ(82), CHPARJ(82) + WRITE(M11,5040) 33, MSTP(33), CHMSTP(33) + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5050) 89, PARP(89), CHPARP(89) + WRITE(M11,5050) 90, PARP(90), CHPARP(90) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 84, PARP(84), CHPARP(84) + WRITE(M11,5040) 88, MSTP(88), CHMSTP(88) + WRITE(M11,5040) 89, MSTP(89), CHMSTP(89) + WRITE(M11,5050) 79, PARP(79), CHPARP(79) + WRITE(M11,5050) 80, PARP(80), CHPARP(80) + WRITE(M11,5040) 91, MSTP(91), CHMSTP(91) + WRITE(M11,5050) 91, PARP(91), CHPARP(91) + WRITE(M11,5050) 93, PARP(93), CHPARP(93) + WRITE(M11,5040) 95, MSTP(95), CHMSTP(95) + IF (MSTP(95).GE.1) THEN + WRITE(M11,5050) 78, PARP(78), CHPARP(78) + IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77) + ENDIF + + ENDIF + +C======================================================================= +C...S0, S1, S2, S0A, NOCR, Rap, +C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro +C...Perugia 0, HARD, SOFT, 3, LO*, 6, 2010, K +C...Pro-pTO, Pro-PT*, Pro-PT6, Pro-PT** +C...Perugia 2011 (incl variations) +C...Schulz-Skands tunes + ELSEIF ((ITUNE.GE.300.AND.ITUNE.LE.305) + & .OR.(ITUNE.GE.310.AND.ITUNE.LE.315) + & .OR.(ITUNE.GE.320.AND.ITUNE.LE.329) + & .OR.(ITUNE.GE.334.AND.ITUNE.LE.336).OR.ITUNE.EQ.339 + & .OR.(ITUNE.GE.350.AND.ITUNE.LE.365)) THEN + IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME + IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune.') + ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.339.AND.ITUNE.NE.324.AND. + & ITUNE.NE.334.AND. + & (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.419))) + & THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune.') + ELSEIF((ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.GE.350).AND. + & (MSTP(181).LE.5.OR. + & (MSTP(181).EQ.6.AND.MSTP(182).LE.422))) + & THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune.') + ENDIF + +C...Use 327 as base tune for 350-359 (Perugia 2011) + ITUNSV = ITUNE + IF (ITUNE.GE.350.AND.ITUNE.LE.359) ITUNE = 327 +C...Use 320 as base tune for 360+ (Schulz-Skands) + IF (ITUNE.GE.360) ITUNE = 320 + +C...HAD: Use Professor's LEP pars if ITUNE >= 310 +C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes) + IF (ITUNE.LT.310) THEN +C...# Old defaults + MSTJ(11) = 4 +C...# Old default flavour parameters + PARJ(1) = 0.1 + PARJ(2) = 0.3 + PARJ(3) = 0.40 + PARJ(4) = 0.05 + PARJ(11) = 0.5 + PARJ(12) = 0.6 + PARJ(21) = 0.36 + PARJ(41) = 0.30 + PARJ(42) = 0.58 + PARJ(46) = 1.0 + PARJ(82) = 1.0 + + ELSEIF (ITUNE.GE.310) THEN +C...# Tuned flavour parameters: + PARJ(1) = 0.073 + PARJ(2) = 0.2 + PARJ(3) = 0.94 + PARJ(4) = 0.032 + PARJ(11) = 0.31 + PARJ(12) = 0.4 + PARJ(13) = 0.54 + PARJ(25) = 0.63 + PARJ(26) = 0.12 +C...# Always use pT-ordered shower: + MSTJ(41) = 12 +C...# Switch on Bowler: + MSTJ(11) = 5 +C...# Fragmentation + PARJ(21) = 0.313 + PARJ(41) = 0.49 + PARJ(42) = 1.2 + PARJ(47) = 1.0 + PARJ(81) = 0.257 + PARJ(82) = 0.8 + +C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT + IF (ITUNE.EQ.321) PARJ(21)=0.34D0 + IF (ITUNE.EQ.322) PARJ(21)=0.28D0 + +C...HAD: P-2010 and P-K use different strangeness parameters +C... indicated by LEP and RHIC yields. +C...(only 5% different from Professor values, so should be within acceptable +C...theoretical uncertainty range) +C...(No attempt made to retune other flavor parameters post facto) + IF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN + PARJ( 1) = 0.08D0 + PARJ( 2) = 0.21D0 + PARJ( 4) = 0.04D0 + PARJ(11) = 0.35D0 + PARJ(12) = 0.35D0 + PARJ(21) = 0.36D0 + PARJ(41) = 0.35D0 + PARJ(42) = 0.90D0 + PARJ(81) = 0.26D0 + PARJ(82) = 1.0D0 + ENDIF + ENDIF + +C...Remove middle digit now for Professor variants, since identical pars + ITUNEB=ITUNE + IF (ITUNE.GE.310.AND.ITUNE.LE.319) THEN + ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10) + ENDIF + +C...PDFs: all use CTEQ5L as starting point + MSTP(52)=1 + MSTP(51)=7 + IF (ITUNE.EQ.325.OR.ITUNE.EQ.335) THEN +C...MRST LO* for 325 and 335 + MSTP(52)=2 + MSTP(51)=20650 + ELSEIF (ITUNE.EQ.326.OR.ITUNE.EQ.336) THEN +C...CTEQ6L1 for 326 and 336 + MSTP(52)=2 + MSTP(51)=10042 + ELSEIF (ITUNE.EQ.339) THEN +C...MRST LO** for 339 + MSTP(52)=2 + MSTP(51)=20651 + ENDIF + +C...LambdaQCD choice: 327 and 328 use hardcoded, others get from PDF + MSTP(3)=2 + IF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN + MSTP(3) = 1 +C...Hardcode CTEQ5L values for ME and ISR + MSTU(112) = 4 + PARU(112) = 0.192D0 + PARP(61) = 0.192D0 + PARP( 1) = 0.192D0 +C...but use LEP value also for non-res FSR + PARP(72) = 0.260D0 + ENDIF + +C...ISR: use Lambda_MSbar with default scale for S0(A) + MSTP(64)=2 + PARP(64)=1D0 + IF (ITUNE.EQ.320.OR.ITUNE.EQ.323.OR.ITUNE.EQ.324.OR.ITUNE.EQ.334 + & .OR.ITUNE.EQ.326.OR.ITUNE.EQ.327.OR.ITUNE.EQ.328) THEN +C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes + MSTP(64)=3 + PARP(64)=1D0 + ELSEIF (ITUNE.EQ.321) THEN +C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD + MSTP(64)=3 + PARP(64)=0.25D0 + ELSEIF (ITUNE.EQ.322) THEN +C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT + MSTP(64)=2 + PARP(64)=2D0 + ELSEIF (ITUNE.EQ.325) THEN +C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO* + MSTP(64)=3 + PARP(64)=2D0 + ELSEIF (ITUNE.EQ.329.OR.ITUNE.EQ.335.OR.ITUNE.EQ.336.OR. + & ITUNE.EQ.339) THEN +C...Use Lambda_MSbar with P64=1.3 for Pro-pT0 + MSTP(64)=2 + PARP(64)=1.3D0 + IF (ITUNE.EQ.335) PARP(64)=0.92D0 + IF (ITUNE.EQ.336) PARP(64)=0.89D0 + IF (ITUNE.EQ.339) PARP(64)=0.97D0 + ENDIF + +C...ISR : power-suppressed power showers above s_color (since 6.4.19) + MSTP(67)=2 + PARP(67)=4D0 +C...Perugia tunes have stronger suppression, except HARD + IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN + PARP(67)=1D0 + IF (ITUNE.EQ.321) PARP(67)=4D0 + IF (ITUNE.EQ.322) PARP(67)=0.25D0 + ENDIF + +C...ISR IR cutoff type and FSR off ISR setting: +C...Smooth ISR, low FSR-off-ISR + MSTP(70)=2 + MSTP(72)=0 + IF (ITUNEB.EQ.301) THEN +C...S1, S1-Pro: sharp ISR, high FSR + MSTP(70)=0 + MSTP(72)=1 + ELSEIF (ITUNE.EQ.320.OR.ITUNE.EQ.324.OR.ITUNE.EQ.326 + & .OR.ITUNE.EQ.325) THEN +C...Perugia default is smooth ISR, high FSR-off-ISR + MSTP(70)=2 + MSTP(72)=1 + ELSEIF (ITUNE.EQ.321) THEN +C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad) + MSTP(70)=0 + PARP(62)=1.25D0 + MSTP(72)=1 + ELSEIF (ITUNE.EQ.322) THEN +C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR + MSTP(70)=1 + PARP(81)=1.5D0 + MSTP(72)=0 + ELSEIF (ITUNE.EQ.323) THEN +C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating) + MSTP(70)=0 + PARP(62)=1.25D0 + MSTP(72)=2 + ELSEIF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN +C...Perugia 2010/K: smooth ISR, high FSR-off-ISR (with dipole-to-BR radiating) + MSTP(70)=2 + MSTP(72)=2 + ENDIF + +C...FSR activity: Perugia tunes use a lower PARP(71) as indicated +C...by Professor tunes (with HARD and SOFT variations) + PARP(71)=4D0 + IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN + PARP(71)=2D0 + IF (ITUNE.EQ.321) PARP(71)=4D0 + IF (ITUNE.EQ.322) PARP(71)=1D0 + ENDIF + IF (ITUNE.EQ.329) PARP(71)=2D0 + IF (ITUNE.EQ.335) PARP(71)=1.29D0 + IF (ITUNE.EQ.336) PARP(71)=1.72D0 + IF (ITUNE.EQ.339) PARP(71)=1.20D0 + +C...FSR: Lambda_FSR scale (only if not using professor) + IF (ITUNE.LT.310) PARJ(81)=0.23D0 + IF (ITUNE.EQ.321) PARJ(81)=0.30D0 + IF (ITUNE.EQ.322) PARJ(81)=0.20D0 + +C...K-factor : only 328 uses a K-factor on the UE cross sections + MSTP(33)=0 + IF (ITUNE.EQ.328) THEN + MSTP(33)=10 + PARP(32)=1.5 + ENDIF +C...UE on, new model + MSTP(81)=21 + +C...UE: hadron-hadron overlap profile (expOfPow for all) + MSTP(82)=5 +C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian) + PARP(83)=1.6D0 + IF (ITUNEB.EQ.301) PARP(83)=1.4D0 + IF (ITUNEB.EQ.302) PARP(83)=1.2D0 +C...NOCR variants have very smooth distributions + IF (ITUNEB.EQ.304) PARP(83)=1.8D0 + IF (ITUNEB.EQ.305) PARP(83)=2.0D0 + IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN +C...Perugia variants have slightly smoother profiles by default +C...(to compensate for more tail by added radiation) +C...Perugia-SOFT has more peaked distribution, NOCR less peaked + PARP(83)=1.7D0 + IF (ITUNE.EQ.322) PARP(83)=1.5D0 + IF (ITUNE.EQ.327) PARP(83)=1.5D0 + IF (ITUNE.EQ.328) PARP(83)=1.5D0 +C...NOCR variants have smoother mass profiles + IF (ITUNE.EQ.324) PARP(83)=1.8D0 + IF (ITUNE.EQ.334) PARP(83)=1.8D0 + ENDIF +C...Professor-pT0 also has very smooth distribution + IF (ITUNE.EQ.329) PARP(83)=1.8 + IF (ITUNE.EQ.335) PARP(83)=1.68 + IF (ITUNE.EQ.336) PARP(83)=1.72 + IF (ITUNE.EQ.339) PARP(83)=1.67 + +C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version + PARP(82)=1.85D0 + IF (ITUNEB.EQ.301) PARP(82)=2.1D0 + IF (ITUNEB.EQ.302) PARP(82)=1.9D0 + IF (ITUNEB.EQ.304) PARP(82)=2.05D0 + IF (ITUNEB.EQ.305) PARP(82)=1.9D0 + IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN +C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower, +C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower, +C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be +C...slightly higher, due to increased activity. + PARP(82)=2.0D0 + IF (ITUNE.EQ.321) PARP(82)=2.3D0 + IF (ITUNE.EQ.322) PARP(82)=1.9D0 + IF (ITUNE.EQ.323) PARP(82)=2.2D0 + IF (ITUNE.EQ.324) PARP(82)=1.95D0 + IF (ITUNE.EQ.325) PARP(82)=2.2D0 + IF (ITUNE.EQ.326) PARP(82)=1.95D0 + IF (ITUNE.EQ.327) PARP(82)=2.05D0 + IF (ITUNE.EQ.328) PARP(82)=2.45D0 + IF (ITUNE.EQ.334) PARP(82)=2.15D0 + ENDIF +C...Professor-pT0 maintains low pT0 vaue + IF (ITUNE.EQ.329) PARP(82)=1.85D0 + IF (ITUNE.EQ.335) PARP(82)=2.10D0 + IF (ITUNE.EQ.336) PARP(82)=1.83D0 + IF (ITUNE.EQ.339) PARP(82)=2.28D0 + +C...UE: IR cutoff reference energy and default energy scaling pace + PARP(89)=1800D0 + PARP(90)=0.16D0 +C...S0A, S0A-Pro have tune A energy scaling + IF (ITUNEB.EQ.303) PARP(90)=0.25D0 + IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN +C...Perugia tunes explicitly include MB at 630 to fix energy scaling + PARP(90)=0.26 + IF (ITUNE.EQ.321) PARP(90)=0.30D0 + IF (ITUNE.EQ.322) PARP(90)=0.24D0 + IF (ITUNE.EQ.323) PARP(90)=0.32D0 + IF (ITUNE.EQ.324) PARP(90)=0.24D0 +C...LO* and CTEQ6L1 tunes have slower energy scaling + IF (ITUNE.EQ.325) PARP(90)=0.23D0 + IF (ITUNE.EQ.326) PARP(90)=0.22D0 + ENDIF +C...Professor-pT0 has intermediate scaling + IF (ITUNE.EQ.329) PARP(90)=0.22D0 + IF (ITUNE.EQ.335) PARP(90)=0.20D0 + IF (ITUNE.EQ.336) PARP(90)=0.20D0 + IF (ITUNE.EQ.339) PARP(90)=0.21D0 + +C...BR: MPI initiator color connections rap-ordered by default +C...NOCR variants are Lambda-ordered, Perugia SOFT & 2010 random-ordered + MSTP(89)=1 + IF (ITUNEB.EQ.304.OR.ITUNE.EQ.324) MSTP(89)=2 + IF (ITUNE.EQ.322) MSTP(89)=0 + IF (ITUNE.EQ.327) MSTP(89)=0 + IF (ITUNE.EQ.328) MSTP(89)=0 + +C...BR: BR-g-BR suppression factor (higher values -> more beam blowup) + PARP(80)=0.01D0 + IF (ITUNE.GE.320.AND.ITUNE.LE.328) THEN +C...Perugia tunes have more beam blowup by default + PARP(80)=0.05D0 + IF (ITUNE.EQ.321) PARP(80)=0.01 + IF (ITUNE.EQ.323) PARP(80)=0.03 + IF (ITUNE.EQ.324) PARP(80)=0.01 + IF (ITUNE.EQ.327) PARP(80)=0.1 + IF (ITUNE.EQ.328) PARP(80)=0.1 + ENDIF + +C...BR: diquarks (def = valence qq and moderate diquark x enhancement) + MSTP(88)=0 + PARP(79)=2D0 + IF (ITUNEB.EQ.304) PARP(79)=3D0 + IF (ITUNE.EQ.329) PARP(79)=1.18 + IF (ITUNE.EQ.335) PARP(79)=1.11 + IF (ITUNE.EQ.336) PARP(79)=1.10 + IF (ITUNE.EQ.339) PARP(79)=3.69 + +C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV + MSTP(91)=1 + PARP(91)=2D0 + PARP(93)=10D0 +C...Perugia-HARD only uses 1.0 GeV + IF (ITUNE.EQ.321) PARP(91)=1.0D0 +C...Perugia-3 only uses 1.5 GeV + IF (ITUNE.EQ.323) PARP(91)=1.5D0 +C...Professor-pT0 uses 7-GeV cutoff + IF (ITUNE.EQ.329) PARP(93)=7.0 + IF (ITUNE.EQ.335) THEN + PARP(91)=2.15 + PARP(93)=6.79 + ELSEIF (ITUNE.EQ.336) THEN + PARP(91)=1.85 + PARP(93)=6.86 + ELSEIF (ITUNE.EQ.339) THEN + PARP(91)=2.11 + PARP(93)=5.08 + ENDIF + +C...FSI: Colour Reconnections - Seattle algorithm is default (S0) + MSTP(95)=6 +C...S1, S1-Pro: use S1 + IF (ITUNEB.EQ.301) MSTP(95)=2 +C...S2, S2-Pro: use S2 + IF (ITUNEB.EQ.302) MSTP(95)=4 +C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR + IF (ITUNE.EQ.304.OR.ITUNE.EQ.314.OR.ITUNE.EQ.324.OR. + & ITUNE.EQ.334) MSTP(95)=0 +C..."Old" and "Old"-Pro: use old CR + IF (ITUNEB.EQ.305) MSTP(95)=1 +C...Perugia 2010 and K use Paquis model + IF (ITUNE.EQ.327.OR.ITUNE.EQ.328) MSTP(95)=8 + +C...FSI: CR strength and high-pT dampening, default is S0 + PARP(77)=0D0 + IF (ITUNE.LT.320.OR.ITUNE.EQ.329.OR.ITUNE.GE.335) THEN + PARP(78)=0.2D0 + IF (ITUNEB.EQ.301) PARP(78)=0.35D0 + IF (ITUNEB.EQ.302) PARP(78)=0.15D0 + IF (ITUNEB.EQ.304) PARP(78)=0.0D0 + IF (ITUNEB.EQ.305) PARP(78)=1.0D0 + IF (ITUNE.EQ.329) PARP(78)=0.17D0 + IF (ITUNE.EQ.335) PARP(78)=0.14D0 + IF (ITUNE.EQ.336) PARP(78)=0.17D0 + IF (ITUNE.EQ.339) PARP(78)=0.13D0 + ELSE +C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6 + PARP(78)=0.33 + PARP(77)=0.9D0 + IF (ITUNE.EQ.321) THEN +C...HARD has HIGH amount of CR + PARP(78)=0.37D0 + PARP(77)=0.4D0 + ELSEIF (ITUNE.EQ.322) THEN +C...SOFT has LOW amount of CR + PARP(78)=0.15D0 + PARP(77)=0.5D0 + ELSEIF (ITUNE.EQ.323) THEN +C...Scaling variant appears to need slightly more than default + PARP(78)=0.35D0 + PARP(77)=0.6D0 + ELSEIF (ITUNE.EQ.324.OR.ITUNE.EQ.334) THEN +C...NOCR has no CR + PARP(78)=0D0 + PARP(77)=0D0 + ELSEIF (ITUNE.EQ.327) THEN +C...2010 + PARP(78)=0.035D0 + PARP(77)=1D0 + ELSEIF (ITUNE.EQ.328) THEN +C...K + PARP(78)=0.033D0 + PARP(77)=1D0 + ENDIF + ENDIF + +C================ +C...Perugia 2011 tunes +C...(written as modifications on top of Perugia 2010) +C================ + IF (ITUNSV.GE.350.AND.ITUNSV.LE.359) THEN + ITUNE = ITUNSV +C... Scale setting for matching applications. +C... Switch to 5-flavor CMW LambdaQCD = 0.26 for all shower activity +C... (equivalent to a 5-flavor MSbar LambdaQCD = 0.26/1.6 = 0.16) + MSTP(64)=2 + MSTU(112)=5 +C... This sets the Lambda scale for ISR, IFSR, and FSR + PARP(61)=0.26D0 + PARP(72)=0.26D0 + PARJ(81)=0.26D0 +C... This sets the Lambda scale for QCD hard interactions (important for the +C... UE dijet cross sections. Here we still use an MSbar value, rather than +C... a CMW one, in order not to hugely increase the UE jettiness. The CTEQ5L +C... value corresponds to a Lambda5 of 0.146 for comparison, so quite close.) + PARP(1)=0.16D0 + PARU(112)=0.16D0 +C... For matching applications, PARP(71) and PARP(67) = 1 + PARP(67) = 1D0 + PARP(71) = 1D0 +C... Primordial kT: only use 1 GeV + MSTP(91)=1 + PARP(91)=1D0 +C... ADDITIONAL LESSONS WRT PERUGIA 2010 +C... ALICE taught us: need less baryon transport than SOFT + MSTP(89)=0 + PARP(80)=0.015 +C... Small adjustments at LEP (slightly softer frag functions, esp for baryons) + PARJ(21)=0.33 + PARJ(41)=0.35 + PARJ(42)=0.8 + PARJ(45)=0.55 +C... Increase Lambda/K ratio and other strange baryon yields + PARJ(1)=0.087D0 + PARJ(3)=0.95D0 + PARJ(4)=0.043D0 + PARJ(6)=1.0D0 + PARJ(7)=1.0D0 +C... Also reduce total strangeness yield a bit, with higher K*/K + PARJ(2)=0.19D0 + PARJ(12)=0.40D0 +C... Perugia 2011 default is sharp ISR, dipoles to BR radiating, pTmax individual + MSTP(70)=0 + MSTP(72)=2 + PARP(62)=1.5D0 +C... Holger taught us a smoother proton is preferred at high energies +C... Just use a simple Gaussian + MSTP(82)=3 +C... Scaling of pt0 cutoff + PARP(90)=0.265 +C... Now retune pT0 to give right UE activity. +C... Low CR strength indicated by LHC tunes +C... (also keep low to get (Nch) a bit down for pT>100MeV samples) + PARP(78)=0.036D0 +C... Choose 7 TeV as new reference scale + PARP(89)=7000.0D0 + PARP(82)=2.93D0 +C================ +C... P2011 Variations +C================ + IF (ITUNE.EQ.351) THEN +C... radHi: high Lambda scale for ISR, IFSR, and FSR +C... ( ca 10% more particles at LEP after retune ) + PARP(61)=0.52D0 + PARP(72)=0.52D0 + PARJ(81)=0.52D0 +C... Retune cutoff scales to compensate partially +C... (though higher cutoff causes faster multiplicity drop at low energies) + PARP(62)=1.75D0 + PARJ(82)=1.75D0 + PARP(82)=3.00D0 +C... Needs faster cutoff scaling than nominal variant for same scaling +C... (since more radiation otherwise generates faster mult growth) + PARP(90)=0.28 + ELSEIF (ITUNE.EQ.352) THEN +C... radLo: low Lambda scale for ISR, IFSR, and FSR +C... ( ca 10% less particles at LEP after retune ) + PARP(61)=0.13D0 + PARP(72)=0.13D0 + PARJ(81)=0.13D0 +C... Retune cutoff scales to compensate partially + PARP(62)=1.00D0 + PARJ(82)=0.75D0 + PARP(82)=2.95D0 +C... Needs slower cutoff scaling than nominal variant for same scaling +C... (since less radiation otherwise generates slower mult growth) + PARP(90)=0.24 + ELSEIF (ITUNE.EQ.353) THEN +C... mpiHi: high Lambda scale for MPI + PARP(1)=0.26D0 + PARU(112)=0.26D0 + PARP(82)=3.35D0 + PARP(90)=0.26D0 + ELSEIF (ITUNE.EQ.354) THEN + MSTP(95)=0 + PARP(82)=3.05D0 + ELSEIF (ITUNE.EQ.355) THEN +C... LO** + MSTP(52)=2 + MSTP(51)=20651 + PARP(62)=1.5D0 +C... Compensate for higher with less CR + PARP(78)=0.034 + PARP(82)=3.40D0 +C... Need slower energy scaling than CTEQ5L + PARP(90)=0.23D0 + ELSEIF (ITUNE.EQ.356) THEN +C... CTEQ6L1 + MSTP(52)=2 + MSTP(51)=10042 + PARP(82)=2.65D0 +C... Need slower cutoff scaling than CTEQ5L + PARP(90)=0.22D0 + ELSEIF (ITUNE.EQ.357) THEN +C... T16 + PARP(90)=0.16 + ELSEIF (ITUNE.EQ.358) THEN +C... T32 + PARP(90)=0.32 + ELSEIF (ITUNE.EQ.359) THEN +C... Tevatron + PARP(89)=1800D0 + PARP(90)=0.28 + PARP(82)=2.10 + PARP(78)=0.05 + ENDIF + +C================ +C...Schulz-Skands 2011 tunes +C...(written as modifications on top of Perugia 0) +C================ + ELSEIF (ITUNSV.GE.360.AND.ITUNSV.LE.365) THEN + ITUNE = ITUNSV + + IF (ITUNE.EQ.360) THEN + PARP(78)=0.40D0 + PARP(82)=2.19D0 + PARP(83)=1.45D0 + PARP(89)=1800.0D0 + PARP(90)=0.27D0 + ELSEIF (ITUNE.EQ.361) THEN + PARP(78)=0.20D0 + PARP(82)=2.75D0 + PARP(83)=1.73D0 + PARP(89)=7000.0D0 + ELSEIF (ITUNE.EQ.362) THEN + PARP(78)=0.31D0 + PARP(82)=1.97D0 + PARP(83)=1.98D0 + PARP(89)=1960.0D0 + ELSEIF (ITUNE.EQ.363) THEN + PARP(78)=0.35D0 + PARP(82)=1.91D0 + PARP(83)=2.02D0 + PARP(89)=1800.0D0 + ELSEIF (ITUNE.EQ.364) THEN + PARP(78)=0.33D0 + PARP(82)=1.69D0 + PARP(83)=1.92D0 + PARP(89)=900.0D0 + ELSEIF (ITUNE.EQ.365) THEN + PARP(78)=0.47D0 + PARP(82)=1.61D0 + PARP(83)=1.50D0 + PARP(89)=630.0D0 + ENDIF + + ENDIF + +C...Switch off trial joinings + MSTP(96)=0 + +C...S0 (300), S0A (303) + IF (ITUNEB.EQ.300.OR.ITUNEB.EQ.303) THEN + IF (M13.GE.1) THEN + CH60='see P. Skands & D. Wicke, hep-ph/0703081' + WRITE(M11,5030) CH60 + CH60='M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + IF (ITUNE.GE.310) THEN + CH60='LEP parameters tuned by Professor,'// + & ' hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + ENDIF + +C...S1 (301) + ELSEIF(ITUNEB.EQ.301) THEN + IF (M13.GE.1) THEN + CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + IF (ITUNE.GE.310) THEN + CH60='LEP parameters tuned by Professor,'// + & ' hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + ENDIF + +C...S2 (302) + ELSEIF(ITUNEB.EQ.302) THEN + IF (M13.GE.1) THEN + CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + IF (ITUNE.GE.310) THEN + CH60='LEP parameters tuned by Professor,'// + & ' hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + ENDIF + +C...NOCR (304) + ELSEIF(ITUNEB.EQ.304) THEN + IF (M13.GE.1) THEN + CH60='"best try" without colour reconnections' + WRITE(M11,5030) CH60 + CH60='see P. Skands & D. Wicke, hep-ph/0703081' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + IF (ITUNE.GE.310) THEN + CH60='LEP parameters tuned by Professor,'// + & ' hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + ENDIF + +C..."Lo FSR" retune (305) + ELSEIF(ITUNEB.EQ.305) THEN + IF (M13.GE.1) THEN + CH60='"Lo FSR retune" with primitive colour reconnections' + WRITE(M11,5030) CH60 + CH60='see T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + IF (ITUNE.GE.310) THEN + CH60='LEP parameters tuned by Professor,'// + & ' hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + ENDIF + +C...Perugia Tunes (320-328 and 334) + ELSEIF((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN + IF (M13.GE.1) THEN + CH60='Tuned by P. Skands, hep-ph/1005.3457' + WRITE(M11,5030) CH60 + CH60='Physics Model: '// + & 'T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + IF (ITUNE.LE.326) THEN + CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + CH60='LEP parameters tuned by Professor, hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + IF (ITUNE.EQ.325) THEN + CH70='NB! This tune requires MRST LO* pdfs to be '// + & 'externally linked' + WRITE(M11,5035) CH70 + ELSEIF (ITUNE.EQ.326) THEN + CH70='NB! This tune requires CTEQ6L1 pdfs to be '// + & 'externally linked' + WRITE(M11,5035) CH70 + ELSEIF (ITUNE.EQ.321) THEN + CH60='NB! This tune has MORE ISR & FSR / LESS UE & BR' + WRITE(M11,5030) CH60 + ELSEIF (ITUNE.EQ.322) THEN + CH60='NB! This tune has LESS ISR & FSR / MORE UE & BR' + WRITE(M11,5030) CH60 + ENDIF + ENDIF + +C...Professor-pTO (329) + ELSEIF(ITUNE.EQ.329.OR.ITUNE.EQ.335.OR.ITUNE.EQ.336.OR. + & ITUNE.EQ.339) THEN + IF (M13.GE.1) THEN + CH60='Tuned by Professor, hep-ph/0907.2973' + WRITE(M11,5030) CH60 + CH60='Physics Model: '// + & 'T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + ENDIF + +C...Perugia 2011 Tunes (350-359) + ELSEIF(ITUNE.GE.350.AND.ITUNE.LE.359) THEN + IF (M13.GE.1) THEN + CH60='Tuned by P. Skands, hep-ph/1005.3457' + WRITE(M11,5030) CH60 + CH60='Physics Model: '// + & 'T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + IF (ITUNE.EQ.355) THEN + CH70='NB! This tune requires MRST LO** pdfs to be '// + & 'externally linked' + WRITE(M11,5035) CH70 + ELSEIF (ITUNE.EQ.356) THEN + CH70='NB! This tune requires CTEQ6L1 pdfs to be '// + & 'externally linked' + WRITE(M11,5035) CH70 + ENDIF + ENDIF + +C...Schulz-Skands Tunes (360-365) + ELSEIF(ITUNE.GE.360.AND.ITUNE.LE.365) THEN + IF (M13.GE.1) THEN + CH60='Tuned by H. Schulz & P. Skands, MCNET-11-07' + WRITE(M11,5030) CH60 + CH60='Based on Perugia 0, hep-ph/1005.3457' + WRITE(M11,5030) CH60 + CH60='Physics Model: '// + & 'T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120' + WRITE(M11,5030) CH60 + ENDIF + + ENDIF + +C...Output + IF (M13.GE.1) THEN + WRITE(M11,5030) ' ' + WRITE(M11,5040) 51, MSTP(51), CHMSTP(51) + WRITE(M11,5040) 52, MSTP(52), CHMSTP(52) + IF (MSTP(33).GE.10) THEN + WRITE(M11,5050) 32, PARP(32), CHPARP(32) + ENDIF + WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3) + IF (MSTP(3).EQ.1) THEN + WRITE(M11,6100) 112, MSTU(112), CHMSTU(112) + WRITE(M11,6110) 112, PARU(112), CHPARU(112) + WRITE(M11,5050) 1, PARP(1) , CHPARP( 1) + ENDIF + WRITE(M11,5060) 81, PARJ(81), CHPARJ(81) + IF (MSTP(3).EQ.1) + & WRITE(M11,5050) 72, PARP(72) , CHPARP( 72) + IF (MSTP(3).EQ.1) THEN + WRITE(M11,5050) 61, PARP(61) , CHPARP( 61) + ENDIF + WRITE(M11,5040) 64, MSTP(64), CHMSTP(64) + WRITE(M11,5050) 64, PARP(64), CHPARP(64) + WRITE(M11,5040) 67, MSTP(67), CHMSTP(67) + WRITE(M11,5040) 68, MSTP(68), CHMSTP(68) + CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)' + WRITE(M11,5030) CH60 + WRITE(M11,5050) 67, PARP(67), CHPARP(67) + WRITE(M11,5040) 72, MSTP(72), CHMSTP(72) + WRITE(M11,5050) 71, PARP(71), CHPARP(71) + WRITE(M11,5040) 70, MSTP(70), CHMSTP(70) + IF (MSTP(70).EQ.0) THEN + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + ELSEIF (MSTP(70).EQ.1) THEN + WRITE(M11,5050) 81, PARP(81), CHPARP(62) + CH60='(Note: PARP(81) replaces PARP(62).)' + WRITE(M11,5030) CH60 + ENDIF + WRITE(M11,5060) 82, PARJ(82), CHPARJ(82) + WRITE(M11,5040) 33, MSTP(33), CHMSTP(33) + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + IF (MSTP(70).EQ.2) THEN + CH60='(Note: PARP(82) replaces PARP(62).)' + WRITE(M11,5030) CH60 + ENDIF + WRITE(M11,5050) 89, PARP(89), CHPARP(89) + WRITE(M11,5050) 90, PARP(90), CHPARP(90) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + IF (MSTP(82).EQ.5) THEN + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + ELSEIF (MSTP(82).EQ.4) THEN + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 84, PARP(84), CHPARP(84) + ENDIF + WRITE(M11,5040) 88, MSTP(88), CHMSTP(88) + WRITE(M11,5040) 89, MSTP(89), CHMSTP(89) + WRITE(M11,5050) 79, PARP(79), CHPARP(79) + WRITE(M11,5050) 80, PARP(80), CHPARP(80) + WRITE(M11,5040) 91, MSTP(91), CHMSTP(91) + WRITE(M11,5050) 91, PARP(91), CHPARP(91) + WRITE(M11,5050) 93, PARP(93), CHPARP(93) + WRITE(M11,5040) 95, MSTP(95), CHMSTP(95) + IF (MSTP(95).GE.1) THEN + WRITE(M11,5050) 78, PARP(78), CHPARP(78) + IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77) + ENDIF + + ENDIF + +C======================================================================= +C...ATLAS-CSC 11-parameter tune (By A. Moraes) + ELSEIF (ITUNE.EQ.306) THEN + IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME + IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune.') + ENDIF + +C...PDFs + MSTP(52)=2 + MSTP(54)=2 + MSTP(51)=10042 + MSTP(53)=10042 +C...ISR +C PARP(64)=1D0 +C...UE on, new model. + MSTP(81)=21 +C...Energy scaling + PARP(89)=1800D0 + PARP(90)=0.22D0 +C...Switch off trial joinings + MSTP(96)=0 +C...Primordial kT cutoff + + IF (M13.GE.1) THEN + CH60='see presentations by A. Moraes (ATLAS),' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + WRITE(M11,5030) ' ' + CH70='NB! This tune requires CTEQ6.1 pdfs to be '// + & 'externally linked' + WRITE(M11,5035) CH70 + ENDIF +C...Smooth ISR, low FSR + MSTP(70)=2 + MSTP(72)=0 +C...pT0 + PARP(82)=1.9D0 +C...Transverse density profile. + MSTP(82)=4 + PARP(83)=0.3D0 + PARP(84)=0.5D0 +C...ISR & FSR in interactions after the first (default) + MSTP(84)=1 + MSTP(85)=1 +C...No double-counting (default) + MSTP(86)=2 +C...Companion quark parent gluon (1-x) power + MSTP(87)=4 +C...Primordial kT compensation along chaings (default = 0 : uniform) + MSTP(90)=1 +C...Colour Reconnections + MSTP(95)=1 + PARP(78)=0.2D0 +C...Lambda_FSR scale. + PARJ(81)=0.23D0 +C...Rap order, Valence qq, qq x enhc, BR-g-BR supp + MSTP(89)=1 + MSTP(88)=0 +C PARP(79)=2D0 + PARP(80)=0.01D0 +C...Peterson charm frag, and c and b hadr parameters + MSTJ(11)=3 + PARJ(54)=-0.07 + PARJ(55)=-0.006 +C... Output + IF (M13.GE.1) THEN + WRITE(M11,5030) ' ' + WRITE(M11,5040) 51, MSTP(51), CHMSTP(51) + WRITE(M11,5040) 52, MSTP(52), CHMSTP(52) + WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3) + WRITE(M11,5050) 64, PARP(64), CHPARP(64) + WRITE(M11,5040) 68, MSTP(68), CHMSTP(68) + CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)' + WRITE(M11,5030) CH60 + WRITE(M11,5040) 70, MSTP(70), CHMSTP(70) + WRITE(M11,5040) 72, MSTP(72), CHMSTP(72) + WRITE(M11,5050) 71, PARP(71), CHPARP(71) + WRITE(M11,5060) 81, PARJ(81), CHPARJ(81) + CH60='(Note: PARJ(81) changed from 0.14! See update notes)' + WRITE(M11,5030) CH60 + WRITE(M11,5040) 33, MSTP(33), CHMSTP(33) + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5050) 89, PARP(89), CHPARP(89) + WRITE(M11,5050) 90, PARP(90), CHPARP(90) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 84, PARP(84), CHPARP(84) + WRITE(M11,5040) 88, MSTP(88), CHMSTP(88) + WRITE(M11,5040) 89, MSTP(89), CHMSTP(89) + WRITE(M11,5040) 90, MSTP(90), CHMSTP(90) + WRITE(M11,5050) 79, PARP(79), CHPARP(79) + WRITE(M11,5050) 80, PARP(80), CHPARP(80) + WRITE(M11,5050) 93, PARP(93), CHPARP(93) + WRITE(M11,5040) 95, MSTP(95), CHMSTP(95) + WRITE(M11,5050) 78, PARP(78), CHPARP(78) + + ENDIF + +C======================================================================= +C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF) +C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106) +C...A-Pro, DW-Pro, etc (100-119), and Pro-Q2O (129) + ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR. + & ITUNE.EQ.109.OR.(ITUNE.GE.110.AND.ITUNE.LE.116).OR. + & ITUNE.EQ.118.OR.ITUNE.EQ.119.OR.ITUNE.EQ.129) THEN + IF (M13.GE.1.AND.ITUNE.NE.106.AND.ITUNE.NE.129) THEN + WRITE(M11,5010) ITUNE, CHNAME + CH60='see R.D. Field, in hep-ph/0610012' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019' + WRITE(M11,5030) CH60 + IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN + CH60='LEP parameters tuned by Professor, hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + ELSEIF (M13.GE.1.AND.ITUNE.EQ.129) THEN + WRITE(M11,5010) ITUNE, CHNAME + CH60='Tuned by Professor, hep-ph/0907.2973' + WRITE(M11,5030) CH60 + CH60='Physics Model: '// + & 'T. Sjostrand & M. v. Zijl, PRD36(1987)2019' + WRITE(M11,5030) CH60 + ENDIF + +C...Make sure we start from old default fragmentation parameters + PARJ(81) = 0.29 + PARJ(82) = 1.0 + +C...Use Professor's LEP pars if ITUNE >= 110 +C...(i.e., for A-Pro, DW-Pro etc) + IF (ITUNE.LT.110) THEN +C...# Old defaults + MSTJ(11) = 4 + PARJ(1) = 0.1 + PARJ(2) = 0.3 + PARJ(3) = 0.40 + PARJ(4) = 0.05 + PARJ(11) = 0.5 + PARJ(12) = 0.6 + PARJ(21) = 0.36 + PARJ(41) = 0.30 + PARJ(42) = 0.58 + PARJ(46) = 1.0 + PARJ(81) = 0.29 + PARJ(82) = 1.0 + ELSE +C...# Tuned flavour parameters: + PARJ(1) = 0.073 + PARJ(2) = 0.2 + PARJ(3) = 0.94 + PARJ(4) = 0.032 + PARJ(11) = 0.31 + PARJ(12) = 0.4 + PARJ(13) = 0.54 + PARJ(25) = 0.63 + PARJ(26) = 0.12 +C...# Switch on Bowler: + MSTJ(11) = 5 +C...# Fragmentation + PARJ(21) = 0.325 + PARJ(41) = 0.5 + PARJ(42) = 0.6 + PARJ(47) = 0.67 + PARJ(81) = 0.29 + PARJ(82) = 1.65 + ENDIF + +C...Remove middle digit now for Professor variants, since identical pars + ITUNEB=ITUNE + IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN + ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10) + ENDIF + +C...Multiple interactions on, old framework + MSTP(81)=1 +C...Fast IR cutoff energy scaling by default + PARP(89)=1800D0 + PARP(90)=0.25D0 +C...Default CTEQ5L (internal), except for QW: CTEQ61 (external) + MSTP(51)=7 + MSTP(52)=1 + IF (ITUNEB.EQ.105) THEN + MSTP(51)=10150 + MSTP(52)=2 + ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN + MSTP(52)=2 + MSTP(54)=2 + MSTP(51)=10042 + MSTP(53)=10042 + ENDIF +C...Double Gaussian matter distribution. + MSTP(82)=4 + PARP(83)=0.5D0 + PARP(84)=0.4D0 +C...FSR activity. + PARP(71)=4D0 +C...Fragmentation functions and c and b parameters +C...(only if not using Professor) + IF (ITUNE.LE.109) THEN + MSTJ(11)=4 + PARJ(54)=-0.05 + PARJ(55)=-0.005 + ENDIF + +C...Tune A and AW + IF(ITUNEB.EQ.100.OR.ITUNEB.EQ.101) THEN +C...pT0. + PARP(82)=2.0D0 +c...String drawing almost completely minimizes string length. + PARP(85)=0.9D0 + PARP(86)=0.95D0 +C...ISR cutoff, muR scale factor, and phase space size + PARP(62)=1D0 + PARP(64)=1D0 + PARP(67)=4D0 +C...Intrinsic kT, size, and max + MSTP(91)=1 + PARP(91)=1D0 + PARP(93)=5D0 +C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT + IF (ITUNEB.EQ.101) THEN + PARP(62)=1.25D0 + PARP(64)=0.2D0 + PARP(91)=2.1D0 + PARP(92)=15.0D0 + ENDIF + +C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space) + ELSEIF (ITUNEB.EQ.102) THEN +C...pT0. + PARP(82)=1.9D0 +c...String drawing completely minimizes string length. + PARP(85)=1.0D0 + PARP(86)=1.0D0 +C...ISR cutoff, muR scale factor, and phase space size + PARP(62)=1.25D0 + PARP(64)=0.2D0 + PARP(67)=1D0 +C...Intrinsic kT, size, and max + MSTP(91)=1 + PARP(91)=2.1D0 + PARP(93)=15D0 + +C...Tune DW + ELSEIF (ITUNEB.EQ.103) THEN +C...pT0. + PARP(82)=1.9D0 +c...String drawing completely minimizes string length. + PARP(85)=1.0D0 + PARP(86)=1.0D0 +C...ISR cutoff, muR scale factor, and phase space size + PARP(62)=1.25D0 + PARP(64)=0.2D0 + PARP(67)=2.5D0 +C...Intrinsic kT, size, and max + MSTP(91)=1 + PARP(91)=2.1D0 + PARP(93)=15D0 + +C...Tune DWT + ELSEIF (ITUNEB.EQ.104) THEN +C...pT0. + PARP(82)=1.9409D0 +C...Run II ref scale and slow scaling + PARP(89)=1960D0 + PARP(90)=0.16D0 +c...String drawing completely minimizes string length. + PARP(85)=1.0D0 + PARP(86)=1.0D0 +C...ISR cutoff, muR scale factor, and phase space size + PARP(62)=1.25D0 + PARP(64)=0.2D0 + PARP(67)=2.5D0 +C...Intrinsic kT, size, and max + MSTP(91)=1 + PARP(91)=2.1D0 + PARP(93)=15D0 + +C...Tune QW + ELSEIF(ITUNEB.EQ.105) THEN + IF (M13.GE.1) THEN + WRITE(M11,5030) ' ' + CH70='NB! This tune requires CTEQ6.1 pdfs to be '// + & 'externally linked' + WRITE(M11,5035) CH70 + ENDIF +C...pT0. + PARP(82)=1.1D0 +c...String drawing completely minimizes string length. + PARP(85)=1.0D0 + PARP(86)=1.0D0 +C...ISR cutoff, muR scale factor, and phase space size + PARP(62)=1.25D0 + PARP(64)=0.2D0 + PARP(67)=2.5D0 +C...Intrinsic kT, size, and max + MSTP(91)=1 + PARP(91)=2.1D0 + PARP(93)=15D0 + +C...Tune D6 and D6T + ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN + IF (M13.GE.1) THEN + WRITE(M11,5030) ' ' + CH70='NB! This tune requires CTEQ6L pdfs to be '// + & 'externally linked' + WRITE(M11,5035) CH70 + ENDIF +C...The "Rick" proton, double gauss with 0.5/0.4 + MSTP(82)=4 + PARP(83)=0.5D0 + PARP(84)=0.4D0 +c...String drawing completely minimizes string length. + PARP(85)=1.0D0 + PARP(86)=1.0D0 + IF (ITUNEB.EQ.108) THEN +C...D6: pT0, Run I ref scale, and fast energy scaling + PARP(82)=1.8D0 + PARP(89)=1800D0 + PARP(90)=0.25D0 + ELSE +C...D6T: pT0, Run II ref scale, and slow energy scaling + PARP(82)=1.8387D0 + PARP(89)=1960D0 + PARP(90)=0.16D0 + ENDIF +C...ISR cutoff, muR scale factor, and phase space size + PARP(62)=1.25D0 + PARP(64)=0.2D0 + PARP(67)=2.5D0 +C...Intrinsic kT, size, and max + MSTP(91)=1 + PARP(91)=2.1D0 + PARP(93)=15D0 + +C...Old ATLAS-DC2 5-parameter tune + ELSEIF(ITUNEB.EQ.106) THEN + IF (M13.GE.1) THEN + WRITE(M11,5010) ITUNE, CHNAME + CH60='see A. Moraes et al., SN-ATLAS-2006-057,' + WRITE(M11,5030) CH60 + CH60=' R. Field in hep-ph/0610012,' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019' + WRITE(M11,5030) CH60 + ENDIF +C... pT0. + PARP(82)=1.8D0 +C... Different ref and rescaling pacee + PARP(89)=1000D0 + PARP(90)=0.16D0 +C... Parameters of mass distribution + PARP(83)=0.5D0 + PARP(84)=0.5D0 +C... Old default string drawing + PARP(85)=0.33D0 + PARP(86)=0.66D0 +C... ISR, phase space equivalent to Tune B + PARP(62)=1D0 + PARP(64)=1D0 + PARP(67)=1D0 +C... FSR + PARP(71)=4D0 +C... Intrinsic kT + MSTP(91)=1 + PARP(91)=1D0 + PARP(93)=5D0 + +C...Professor's Pro-Q2O Tune + ELSEIF(ITUNE.EQ.129) THEN + PARP(62)=2.9 + PARP(64)=0.14 + PARP(67)=2.65 + PARP(82)=1.9 + PARP(83)=0.83 + PARP(84)=0.6 + PARP(85)=0.86 + PARP(86)=0.93 + PARP(89)=1800D0 + PARP(90)=0.22 + MSTP(91)=1 + PARP(91)=2.1 + PARP(93)=5.0 + + ENDIF + +C... Output + IF (M13.GE.1) THEN + WRITE(M11,5030) ' ' + WRITE(M11,5040) 51, MSTP(51), CHMSTP(51) + WRITE(M11,5040) 52, MSTP(52), CHMSTP(52) + WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3) + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + WRITE(M11,5050) 64, PARP(64), CHPARP(64) + WRITE(M11,5050) 67, PARP(67), CHPARP(67) + WRITE(M11,5040) 68, MSTP(68), CHMSTP(68) + CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)' + WRITE(M11,5030) CH60 + WRITE(M11,5050) 71, PARP(71), CHPARP(71) + WRITE(M11,5060) 81, PARJ(81), CHPARJ(81) + WRITE(M11,5060) 82, PARJ(82), CHPARJ(82) + WRITE(M11,5040) 33, MSTP(33), CHMSTP(33) + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5050) 89, PARP(89), CHPARP(89) + WRITE(M11,5050) 90, PARP(90), CHPARP(90) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 84, PARP(84), CHPARP(84) + WRITE(M11,5050) 85, PARP(85), CHPARP(85) + WRITE(M11,5050) 86, PARP(86), CHPARP(86) + WRITE(M11,5040) 91, MSTP(91), CHMSTP(91) + WRITE(M11,5050) 91, PARP(91), CHPARP(91) + WRITE(M11,5050) 93, PARP(93), CHPARP(93) + + ENDIF + +C======================================================================= +C... ACR, tune A with new CR (107) + ELSEIF(ITUNE.EQ.107.OR.ITUNE.EQ.117) THEN + IF (M13.GE.1) THEN + WRITE(M11,5010) ITUNE, CHNAME + CH60='Tune A modified with new colour reconnections' + WRITE(M11,5030) CH60 + CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)' + WRITE(M11,5030) CH60 + CH60='see P. Skands & D. Wicke, hep-ph/0703081,' + WRITE(M11,5030) CH60 + CH60=' R. Field, in hep-ph/0610012 (Tune A),' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019' + WRITE(M11,5030) CH60 + IF (ITUNE.EQ.117) THEN + CH60='LEP parameters tuned by Professor, hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + ENDIF + IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune. Using defaults.') + GOTO 100 + ENDIF + +C...Make sure we start from old default fragmentation parameters + PARJ(81) = 0.29 + PARJ(82) = 1.0 + +C...Use Professor's LEP pars if ITUNE >= 110 +C...(i.e., for A-Pro, DW-Pro etc) + IF (ITUNE.LT.110) THEN +C...# Old defaults + MSTJ(11) = 4 +C...# Old default flavour parameters + PARJ(21) = 0.36 + PARJ(41) = 0.30 + PARJ(42) = 0.58 + PARJ(46) = 1.0 + PARJ(82) = 1.0 + ELSE +C...# Tuned flavour parameters: + PARJ(1) = 0.073 + PARJ(2) = 0.2 + PARJ(3) = 0.94 + PARJ(4) = 0.032 + PARJ(11) = 0.31 + PARJ(12) = 0.4 + PARJ(13) = 0.54 + PARJ(25) = 0.63 + PARJ(26) = 0.12 +C...# Switch on Bowler: + MSTJ(11) = 5 +C...# Fragmentation + PARJ(21) = 0.325 + PARJ(41) = 0.5 + PARJ(42) = 0.6 + PARJ(47) = 0.67 + PARJ(81) = 0.29 + PARJ(82) = 1.65 + ENDIF + + MSTP(81)=1 + PARP(89)=1800D0 + PARP(90)=0.25D0 + MSTP(82)=4 + PARP(83)=0.5D0 + PARP(84)=0.4D0 + MSTP(51)=7 + MSTP(52)=1 + PARP(71)=4D0 + PARP(82)=2.0D0 + PARP(85)=0.0D0 + PARP(86)=0.66D0 + PARP(62)=1D0 + PARP(64)=1D0 + PARP(67)=4D0 + MSTP(91)=1 + PARP(91)=1D0 + PARP(93)=5D0 + MSTP(95)=6 +C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve (Nch) + PARP(78)=0.09D0 +C...Frag functions (only if not using Professor) + IF (ITUNE.LE.109) THEN + MSTJ(11)=4 + PARJ(54)=-0.05 + PARJ(55)=-0.005 + ENDIF + +C...Output + IF (M13.GE.1) THEN + WRITE(M11,5030) ' ' + WRITE(M11,5040) 51, MSTP(51), CHMSTP(51) + WRITE(M11,5040) 52, MSTP(52), CHMSTP(52) + WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3) + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + WRITE(M11,5050) 64, PARP(64), CHPARP(64) + WRITE(M11,5050) 67, PARP(67), CHPARP(67) + WRITE(M11,5040) 68, MSTP(68), CHMSTP(68) + CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)' + WRITE(M11,5030) CH60 + WRITE(M11,5050) 71, PARP(71), CHPARP(71) + WRITE(M11,5060) 81, PARJ(81), CHPARJ(81) + WRITE(M11,5060) 82, PARJ(82), CHPARJ(82) + WRITE(M11,5040) 33, MSTP(33), CHMSTP(33) + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5050) 89, PARP(89), CHPARP(89) + WRITE(M11,5050) 90, PARP(90), CHPARP(90) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 84, PARP(84), CHPARP(84) + WRITE(M11,5050) 85, PARP(85), CHPARP(85) + WRITE(M11,5050) 86, PARP(86), CHPARP(86) + WRITE(M11,5040) 91, MSTP(91), CHMSTP(91) + WRITE(M11,5050) 91, PARP(91), CHPARP(91) + WRITE(M11,5050) 93, PARP(93), CHPARP(93) + WRITE(M11,5040) 95, MSTP(95), CHMSTP(95) + WRITE(M11,5050) 78, PARP(78), CHPARP(78) + + ENDIF + +C======================================================================= +C...Intermediate model. Rap tune +C...(retuned to post-6.406 IR factorization) + ELSEIF(ITUNE.EQ.200) THEN + IF (M13.GE.1) THEN + WRITE(M11,5010) ITUNE, CHNAME + CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053' + WRITE(M11,5030) CH60 + ENDIF + IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune.') + ENDIF +C...PDF + MSTP(51)=7 + MSTP(52)=1 +C...ISR + PARP(62)=1D0 + PARP(64)=1D0 + PARP(67)=4D0 +C...FSR + PARP(71)=4D0 + PARJ(81)=0.29D0 +C...UE + MSTP(81)=11 + PARP(82)=2.25D0 + PARP(89)=1800D0 + PARP(90)=0.25D0 +C... ExpOfPow(1.8) overlap profile + MSTP(82)=5 + PARP(83)=1.8D0 +C... Valence qq + MSTP(88)=0 +C... Rap Tune + MSTP(89)=1 +C... Default diquark, BR-g-BR supp + PARP(79)=2D0 + PARP(80)=0.01D0 +C... Final state reconnect. + MSTP(95)=1 + PARP(78)=0.55D0 +C...Fragmentation functions and c and b parameters + MSTJ(11)=4 + PARJ(54)=-0.05 + PARJ(55)=-0.005 +C... Output + IF (M13.GE.1) THEN + WRITE(M11,5030) ' ' + WRITE(M11,5040) 51, MSTP(51), CHMSTP(51) + WRITE(M11,5040) 52, MSTP(52), CHMSTP(52) + WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3) + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + WRITE(M11,5050) 64, PARP(64), CHPARP(64) + WRITE(M11,5050) 67, PARP(67), CHPARP(67) + WRITE(M11,5040) 68, MSTP(68), CHMSTP(68) + CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)' + WRITE(M11,5030) CH60 + WRITE(M11,5050) 71, PARP(71), CHPARP(71) + WRITE(M11,5060) 81, PARJ(81), CHPARJ(81) + WRITE(M11,5040) 33, MSTP(33), CHMSTP(33) + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5050) 89, PARP(89), CHPARP(89) + WRITE(M11,5050) 90, PARP(90), CHPARP(90) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5040) 88, MSTP(88), CHMSTP(88) + WRITE(M11,5040) 89, MSTP(89), CHMSTP(89) + WRITE(M11,5050) 79, PARP(79), CHPARP(79) + WRITE(M11,5050) 80, PARP(80), CHPARP(80) + WRITE(M11,5050) 93, PARP(93), CHPARP(93) + WRITE(M11,5040) 95, MSTP(95), CHMSTP(95) + WRITE(M11,5050) 78, PARP(78), CHPARP(78) + + ENDIF + +C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226). +C...Old model for ISR and UE, new pT-ordered model for FSR + ELSEIF(ITUNE.EQ.201.OR.ITUNE.EQ.211.OR.ITUNE.EQ.221.OR + & .ITUNE.EQ.226) THEN + IF (M13.GE.1) THEN + WRITE(M11,5010) ITUNE, CHNAME + CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),' + WRITE(M11,5030) CH60 + CH60=' R.D. Field, in hep-ph/0610012 (Tune A)' + WRITE(M11,5030) CH60 + CH60=' T. Sjostrand & M. v. Zijl, PRD36(1987)2019' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & P. Skands, hep-ph/0408302' + WRITE(M11,5030) CH60 + IF (ITUNE.EQ.211.OR.ITUNE.GE.221) THEN + CH60='LEP parameters tuned by Professor, hep-ph/0907.2973' + WRITE(M11,5030) CH60 + ENDIF + ENDIF + IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN + CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'// + & ' with tune.') + ENDIF +C...First set as if Pythia tune A +C...Multiple interactions on, old framework + MSTP(81)=1 +C...Fast IR cutoff energy scaling by default + PARP(89)=1800D0 + PARP(90)=0.25D0 +C...Default CTEQ5L (internal) + MSTP(51)=7 + MSTP(52)=1 +C...Double Gaussian matter distribution. + MSTP(82)=4 + PARP(83)=0.5D0 + PARP(84)=0.4D0 +C...FSR activity. + PARP(71)=4D0 +c...String drawing almost completely minimizes string length. + PARP(85)=0.9D0 + PARP(86)=0.95D0 +C...ISR cutoff, muR scale factor, and phase space size + PARP(62)=1D0 + PARP(64)=1D0 + PARP(67)=4D0 +C...Intrinsic kT, size, and max + MSTP(91)=1 + PARP(91)=1D0 + PARP(93)=5D0 +C...Use 2 GeV of primordial kT for "Perugia" version + IF (ITUNE.EQ.221) THEN + PARP(91)=2D0 + PARP(93)=10D0 + ENDIF +C...Use pT-ordered FSR + MSTJ(41)=12 +C...Lambda_FSR scale for pT-ordering + PARJ(81)=0.23D0 +C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20) + PARP(82)=2.05D0 +C...Fragmentation functions and c and b parameters +C...(overwritten for 211, i.e., if using Professor pars) + PARJ(54)=-0.05 + PARJ(55)=-0.005 + +C...Use Professor's LEP pars if ITUNE == 211, 221, 226 + IF (ITUNE.LT.210) THEN +C...# Old defaults + MSTJ(11) = 4 +C...# Old default flavour parameters + PARJ(21) = 0.36 + PARJ(41) = 0.30 + PARJ(42) = 0.58 + PARJ(46) = 1.0 + PARJ(82) = 1.0 + ELSE +C...# Tuned flavour parameters: + PARJ(1) = 0.073 + PARJ(2) = 0.2 + PARJ(3) = 0.94 + PARJ(4) = 0.032 + PARJ(11) = 0.31 + PARJ(12) = 0.4 + PARJ(13) = 0.54 + PARJ(25) = 0.63 + PARJ(26) = 0.12 +C...# Always use pT-ordered shower: + MSTJ(41) = 12 +C...# Switch on Bowler: + MSTJ(11) = 5 +C...# Fragmentation + PARJ(21) = 3.1327e-01 + PARJ(41) = 4.8989e-01 + PARJ(42) = 1.2018e+00 + PARJ(47) = 1.0000e+00 + PARJ(81) = 2.5696e-01 + PARJ(82) = 8.0000e-01 + ENDIF + +C...221, 226 : Perugia-APT and Perugia-APT6 + IF (ITUNE.EQ.221.OR.ITUNE.EQ.226) THEN + + PARP(64)=0.5D0 + PARP(82)=2.05D0 + PARP(90)=0.26D0 + PARP(91)=2.0D0 +C...The Perugia variants use Steve's showers off the old MPI + MSTP(152)=1 +C...And use a lower PARP(71) as suggested by Professor tunings +C...(although not certain that applies to Q2-pT2 hybrid) + PARP(71)=2.5D0 + +C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0 + IF (ITUNE.EQ.226) THEN + CH70='NB! This tune requires CTEQ6L1 pdfs to be '// + & 'externally linked' + WRITE(M11,5035) CH70 + MSTP(52)=2 + MSTP(51)=10042 + PARP(82)=1.95D0 + ENDIF + + ENDIF + +C... Output + IF (M13.GE.1) THEN + WRITE(M11,5030) ' ' + WRITE(M11,5040) 51, MSTP(51), CHMSTP(51) + WRITE(M11,5040) 52, MSTP(52), CHMSTP(52) + WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3) + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + WRITE(M11,5050) 64, PARP(64), CHPARP(64) + WRITE(M11,5050) 67, PARP(67), CHPARP(67) + WRITE(M11,5040) 68, MSTP(68), CHMSTP(68) + CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)' + WRITE(M11,5030) CH60 + WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41) + WRITE(M11,5050) 71, PARP(71), CHPARP(71) + WRITE(M11,5060) 81, PARJ(81), CHPARJ(81) + WRITE(M11,5040) 33, MSTP(33), CHMSTP(33) + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5050) 89, PARP(89), CHPARP(89) + WRITE(M11,5050) 90, PARP(90), CHPARP(90) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 84, PARP(84), CHPARP(84) + WRITE(M11,5050) 85, PARP(85), CHPARP(85) + WRITE(M11,5050) 86, PARP(86), CHPARP(86) + WRITE(M11,5040) 91, MSTP(91), CHMSTP(91) + WRITE(M11,5050) 91, PARP(91), CHPARP(91) + WRITE(M11,5050) 93, PARP(93), CHPARP(93) + + ENDIF + +C====================================================================== +C...Uppsala models: Generalized Area Law and Soft Colour Interactions + ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN + IF (M13.GE.1) THEN + WRITE(M11,5010) ITUNE, CHNAME + CH60='see J. Rathsman, PLB452(1999)364' + WRITE(M11,5030) CH60 +C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,' +C ? WRITE(M11,5030) + CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019' + WRITE(M11,5030) CH60 + WRITE(M11,5030) ' ' + CH70='NB! The GAL model must be run with modified '// + & 'Pythia v6.215:' + WRITE(M11,5035) CH70 + CH70='available from http://www.isv.uu.se/thep/MC/scigal/' + WRITE(M11,5035) CH70 + WRITE(M11,5030) ' ' + ENDIF +C...GAL Recommended settings from Uppsala web page (as per 22/08 2006) + MSWI(2) = 3 + PARSCI(2) = 0.10 + MSWI(1) = 2 + PARSCI(1) = 0.44 + MSTJ(16) = 0 + PARJ(42) = 0.45 + PARJ(82) = 2.0 + PARP(62) = 2.0 + MSTP(81) = 1 + MSTP(82) = 1 + PARP(81) = 1.9 + MSTP(92) = 1 + IF(CHNAME.EQ.'GAL Tune 1') THEN +C...GAL retune (P. Skands) to get better min-bias at Tevatron + MSTP(82)=4 + PARP(83)=0.25D0 + PARP(84)=0.5D0 + PARP(82) = 1.75 + IF (M13.GE.1) THEN + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 84, PARP(84), CHPARP(84) + ENDIF + ELSE + IF (M13.GE.1) THEN + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 81, PARP(81), CHPARP(81) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + ENDIF + ENDIF +C...Output + IF (M13.GE.1) THEN + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + WRITE(M11,5060) 82, PARJ(82), CHPARJ(82) + WRITE(M11,5040) 92, MSTP(92), CHMSTP(92) + CH40='FSI SCI/GAL selection' + WRITE(M11,6040) 1, MSWI(1), CH40 + CH40='FSI SCI/GAL sea quark treatment' + WRITE(M11,6040) 2, MSWI(2), CH40 + CH40='FSI SCI/GAL sea quark treatment parm' + WRITE(M11,6050) 1, PARSCI(1), CH40 + CH40='FSI SCI/GAL string reco probability R_0' + WRITE(M11,6050) 2, PARSCI(2), CH40 + WRITE(M11,5060) 42, PARJ(42), CHPARJ(42) + WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16) + ENDIF + ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN + IF (M13.GE.1) THEN + WRITE(M11,5010) ITUNE, CHNAME + CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,' + WRITE(M11,5030) CH60 + CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019' + WRITE(M11,5030) CH60 + WRITE(M11,5030) ' ' + CH70='NB! The SCI model must be run with modified '// + & 'Pythia v6.215:' + WRITE(M11,5035) CH70 + CH70='available from http://www.isv.uu.se/thep/MC/scigal/' + WRITE(M11,5035) CH70 + WRITE(M11,5030) ' ' + ENDIF +C...SCI Recommended settings from Uppsala web page (as per 22/08 2006) + MSTP(81)=1 + MSTP(82)=1 + PARP(81)=2.2 + MSTP(92)=1 + MSWI(2)=2 + PARSCI(2)=0.50 + MSWI(1)=2 + PARSCI(1)=0.44 + MSTJ(16)=0 + IF (CHNAME.EQ.'SCI Tune 1') THEN +C...SCI retune (P. Skands) to get better min-bias at Tevatron + MSTP(81) = 1 + MSTP(82) = 3 + PARP(82) = 2.4 + PARP(83) = 0.5D0 + PARP(62) = 1.5 + PARP(84)=0.25D0 + IF (M13.GE.1) THEN + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 82, PARP(82), CHPARP(82) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + WRITE(M11,5050) 83, PARP(83), CHPARP(83) + WRITE(M11,5050) 62, PARP(62), CHPARP(62) + ENDIF + ELSE + IF (M13.GE.1) THEN + WRITE(M11,5040) 81, MSTP(81), CHMSTP(81) + WRITE(M11,5050) 81, PARP(81), CHPARP(81) + WRITE(M11,5040) 82, MSTP(82), CHMSTP(82) + ENDIF + ENDIF +C...Output + IF (M13.GE.1) THEN + WRITE(M11,5040) 92, MSTP(92), CHMSTP(92) + CH40='FSI SCI/GAL selection' + WRITE(M11,6040) 1, MSWI(1), CH40 + CH40='FSI SCI/GAL sea quark treatment' + WRITE(M11,6040) 2, MSWI(2), CH40 + CH40='FSI SCI/GAL sea quark treatment parm' + WRITE(M11,6050) 1, PARSCI(1), CH40 + CH40='FSI SCI/GAL string reco probability R_0' + WRITE(M11,6050) 2, PARSCI(2), CH40 + WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16) + ENDIF + + ELSE + IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE + + ENDIF + +C...Output of LEP parameters, common to all models + IF (M13.GE.1) THEN + WRITE(M11,5080) + WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11) + IF (MSTJ(11).EQ.3) THEN + CH60='Warning: using Peterson fragmentation function' + WRITE(M11,5030) CH60 + ENDIF + + WRITE(M11,5060) 1, PARJ( 1), CHPARJ( 1) + WRITE(M11,5060) 2, PARJ( 2), CHPARJ( 2) + WRITE(M11,5060) 3, PARJ( 3), CHPARJ( 3) + WRITE(M11,5060) 4, PARJ( 4), CHPARJ( 4) + WRITE(M11,5060) 5, PARJ( 5), CHPARJ( 5) + WRITE(M11,5060) 6, PARJ( 6), CHPARJ( 6) + WRITE(M11,5060) 7, PARJ( 7), CHPARJ( 7) + + WRITE(M11,5060) 11, PARJ(11), CHPARJ(11) + WRITE(M11,5060) 12, PARJ(12), CHPARJ(12) + WRITE(M11,5060) 13, PARJ(13), CHPARJ(13) + + WRITE(M11,5060) 21, PARJ(21), CHPARJ(21) + + WRITE(M11,5060) 25, PARJ(25), CHPARJ(25) + WRITE(M11,5060) 26, PARJ(26), CHPARJ(26) + + WRITE(M11,5060) 41, PARJ(41), CHPARJ(41) + WRITE(M11,5060) 42, PARJ(42), CHPARJ(42) + WRITE(M11,5060) 45, PARJ(45), CHPARJ(45) + + IF (MSTJ(11).LE.3) THEN + WRITE(M11,5060) 54, PARJ(54), CHPARJ(54) + WRITE(M11,5060) 55, PARJ(55), CHPARJ(55) + ELSE + WRITE(M11,5060) 46, PARJ(46), CHPARJ(46) + ENDIF + IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47) + ENDIF + + 100 IF (MSTU(13).GE.1) WRITE(M11,6000) + + 9999 RETURN + + 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE : ', + & 'Presets for underlying-event (and min-bias)',21x,'*'/' *', + & 12x,'Last Change : ',A8,' - P. Skands',30x,'*'/' *',76x,'*') + 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*') + 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.') + 5030 FORMAT(' *',3x,10x,A60,3x,'*') + 5035 FORMAT(' *',3x,A70,3x,'*') + 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*') + 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*') + 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*') + 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*') + 5080 FORMAT(' *',3x,'----------------------------',42('-'),3x,'*') + 6100 FORMAT(' *',5x,'MSTU(',I3,')= ',I12,3x,A42,3x,'*') + 6110 FORMAT(' *',5x,'PARU(',I3,')= ',F12.4,3x,A42,3x,'*') +C 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*') +C 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*') + 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*')) + 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*') + 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*') + + END + +C********************************************************************* + +C...PYEXEC +C...Administrates the fragmentation and decay chain. + + SUBROUTINE PYEXEC + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT4/MWID(500),WIDS(500,5) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/ +C...Local array. + DIMENSION PS(2,6),IJOIN(100) + +C...Initialize and reset. + MSTU(24)=0 + IF(MSTU(12).NE.12345) CALL PYLIST(0) + MSTU(29)=0 + MSTU(31)=MSTU(31)+1 + MSTU(1)=0 + MSTU(2)=0 + MSTU(3)=0 + IF(MSTU(17).LE.0) MSTU(90)=0 + MCONS=1 + +C...Sum up momentum, energy and charge for starting entries. + NSAV=N + DO 110 I=1,2 + DO 100 J=1,6 + PS(I,J)=0D0 + 100 CONTINUE + 110 CONTINUE + DO 130 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130 + DO 120 J=1,4 + PS(1,J)=PS(1,J)+P(I,J) + 120 CONTINUE + PS(1,6)=PS(1,6)+PYCHGE(K(I,2)) + 130 CONTINUE + PARU(21)=PS(1,4) + +C...Start by all decays of coloured resonances involved in shower. + NORIG=N + DO 140 I=1,NORIG + IF(K(I,1).EQ.3) THEN + KC=PYCOMP(K(I,2)) + IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I) + ENDIF + 140 CONTINUE + +C...Prepare system for subsequent fragmentation/decay. + CALL PYPREP(0) + IF(MINT(51).NE.0) RETURN + +C...Loop through jet fragmentation and particle decays. + MBE=0 + 150 MBE=MBE+1 + IP=0 + 160 IP=IP+1 + KC=0 + IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2)) + IF(KC.EQ.0) THEN + +C...Deal with any remaining undecayed resonance +C...(normally the task of PYEVNT, so seldom used). + ELSEIF(MWID(KC).NE.0) THEN + IBEG=IP + IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN + IBEG=IP+1 + 170 IBEG=IBEG-1 + IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170 + IF(K(IBEG,1).NE.2) IBEG=IBEG+1 + IEND=IP-1 + 180 IEND=IEND+1 + IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180 + IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180 + NJOIN=0 + DO 190 I=IBEG,IEND + IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN + NJOIN=NJOIN+1 + IJOIN(NJOIN)=I + ENDIF + 190 CONTINUE + ENDIF + CALL PYRESD(IP) + CALL PYPREP(IBEG) + IF(MINT(51).NE.0) RETURN + +C...Particle decay if unstable and allowed. Save long-lived particle +C...decays until second pass after Bose-Einstein effects. + ELSEIF(KCHG(KC,2).EQ.0) THEN + IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE + & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311)) + & CALL PYDECY(IP) + +C...Decay products may develop a shower. + IF(MSTJ(92).GT.0) THEN + IP1=MSTJ(92) + QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1, + & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2)) + MINT(33)=0 + CALL PYSHOW(IP1,IP1+1,QMAX) + CALL PYPREP(IP1) + IF(MINT(51).NE.0) RETURN + MSTJ(92)=0 + ELSEIF(MSTJ(92).LT.0) THEN + IP1=-MSTJ(92) + MINT(33)=0 + CALL PYSHOW(IP1,-3,P(IP,5)) + CALL PYPREP(IP1) + IF(MINT(51).NE.0) RETURN + MSTJ(92)=0 + ENDIF + +C...Jet fragmentation: string or independent fragmentation. + ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN + MFRAG=MSTJ(1) + IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2 + IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN + IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND. + & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN + IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG) + ENDIF + ENDIF + IF(MFRAG.EQ.1) CALL PYSTRF(IP) + IF(MFRAG.EQ.2) CALL PYINDF(IP) + IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0 + IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0 + ENDIF + +C...Loop back if enough space left in PYJETS and no error abort. + IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN + ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN + GOTO 160 + ELSEIF(IP.LT.N) THEN + CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS') + ENDIF + +C...Include simple Bose-Einstein effect parametrization if desired. + IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN + CALL PYBOEI(NSAV) + GOTO 150 + ENDIF + +C...Check that momentum, energy and charge were conserved. + DO 210 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210 + DO 200 J=1,4 + PS(2,J)=PS(2,J)+P(I,J) + 200 CONTINUE + PS(2,6)=PS(2,6)+PYCHGE(K(I,2)) + 210 CONTINUE + PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)- + &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4))) + IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15, + &'(PYEXEC:) four-momentum was not conserved') + IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15, + &'(PYEXEC:) charge was not conserved') + + RETURN + END + +C********************************************************************* + +C...PYPREP +C...Rearranges partons along strings. +C...Special considerations for systems with junctions, with +C...possibility of junction-antijunction annihilation. +C...Allows small systems to collapse into one or two particles. +C...Checks flavours and colour singlet invariant masses. + + SUBROUTINE PYPREP(IP) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYINT1/MINT(400),VINT(400) +C...The common block of colour tags. + COMMON/PYCTAG/NCT,MCT(4000,2) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/, + &/PYPARS/ + DATA NERRPR/0/ + SAVE NERRPR +C...Local arrays. + DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3), + &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4), + &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5), + &IJCP(0:6),TJUOLD(5) + CHARACTER CHTMP*6 + +C...Function to give four-product. + FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) + +C...Rearrange parton shower product listing along strings: begin loop. + MSTU(24)=0 + NOLD=N + I1=N + NJUNC=0 + NPIECE=0 + NJJSTR=0 + MSTU32=MSTU(32)+1 + DO 100 I=MAX(1,IP),N +C...First store junction positions. + IF(K(I,1).EQ.42) THEN + NJUNC=NJUNC+1 + IJUNC(NJUNC,0)=I + IJUNC(NJUNC,4)=0 + ENDIF + 100 CONTINUE + + DO 250 MQGST=1,3 + DO 240 I=MAX(1,IP),N +C...Special treatment for junctions + IF (K(I,1).LE.0) GOTO 240 + IF(K(I,1).EQ.42) THEN +C...MQGST=2: Look for junction-junction strings (not detected in the +C...main search below). + IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN + IF (NJJSTR.EQ.0) THEN + NJJSTR = (3*NJUNC-NPIECE)/2 + ENDIF +C...Check how many already identified strings end on this junction + ILC=0 + DO 110 J=1,NPIECE + IF (IPIECE(J,4).EQ.I) ILC=ILC+1 + 110 CONTINUE +C...If less than 3, remaining must be to another junction + IF (ILC.LT.3) THEN + IF (ILC.NE.2) THEN +C...Multiple j-j connections not handled yet. + CALL PYERRM(2, + & '(PYPREP:) Too many junction-junction strings.') + MINT(51)=1 + RETURN + ENDIF +C...The colour information in the junction is unreadable for the +C...colour space search further down in this routine, so we must +C...start on the colour mother of this junction and then "artificially" +C...prevent the colour mother from connecting here again. + ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5)) + KCS=4 + IF (MOD(ITJUNC,2).EQ.0) KCS=5 +C...Switch colour if the junction-junction leg is presumably a +C...junction mother leg rather than a junction daughter leg. + IF (ITJUNC.GE.3) KCS=9-KCS + IF (MINT(33).EQ.0) THEN +C...Find the unconnected leg and reorder junction daughter pointers so +C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string +C...piece. + IA=MOD(K(I,4),MSTU(5)) + IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN + ITMP=MOD(K(I,5),MSTU(5)) + IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN + ITMP=MOD(K(I,5)/MSTU(5),MSTU(5)) + K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5) + ELSE + K(I,5)=K(I,5)+(IA-ITMP) + ENDIF + K(I,4)=K(I,4)+(ITMP-IA) + IA=ITMP + ENDIF + IF (ITJUNC.LE.2) THEN +C...Beam baryon junction + K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2 + K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2 +C...Else 1 -> 2 decay junction + ELSE + K(IA,KCS) = K(IA,KCS) + MSTU(5)**2 + K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2 + ENDIF + I1BEG = I1 + NSTP = 0 + GOTO 170 +C...Alternatively use colour tag information. + ELSE +C...Find a final state parton with appropriate dangling colour tag. + JCT=0 + IA=0 + IJUMO=K(I,3) + DO 140 J1=MAX(1,IP),N + IF (K(J1,1).NE.3) GOTO 140 +C...Check for matching final-state colour tag + IMATCH=0 + DO 120 J2=MAX(1,IP),N + IF (K(J2,1).NE.3) GOTO 120 + IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1 + 120 CONTINUE + IF (IMATCH.EQ.1) GOTO 140 +C...Check whether this colour tag belongs to the present junction +C...by seeing whether any parton with this colour tag has the same +C...mother as the junction. + JCT=MCT(J1,KCS-3) + IMATCH=0 + DO 130 J2=MINT(84)+1,N + IMO2=K(J2,3) +C...First scattering partons have IMO1 = 3 and 4. + IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4) + & IMO2=IMO2-2 + IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO) + & IMATCH=1 + 130 CONTINUE + IF (IMATCH.EQ.0) GOTO 140 + IA=J1 + 140 CONTINUE +C...Check for junction-junction strings without intermediate final state +C...glue (not detected above). + IF (IA.EQ.0) THEN + DO 160 MJU=1,NJUNC + IJU2=IJUNC(MJU,0) + IF (IJU2.EQ.I) GOTO 160 + ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5)) +C...Only opposite types of junctions can connect to each other. + IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160 + IS=0 + DO 150 J=1,NPIECE + IF (IPIECE(J,4).EQ.IJU2) IS=IS+1 + 150 CONTINUE + IF (IS.EQ.3) GOTO 160 + IB=I + IA=IJU2 + 160 CONTINUE + ENDIF +C...Switch to other side of adjacent parton and step from there. + KCS=9-KCS + I1BEG = I1 + NSTP = 0 + GOTO 170 + ENDIF + ELSE IF (ILC.NE.3) THEN + ENDIF + ENDIF + ENDIF + +C...Look for coloured string endpoint, or (later) leftover gluon. + IF(K(I,1).NE.3) GOTO 240 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 240 + KQ=KCHG(KC,2) + IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240 + +C...Pick up loose string end. + KCS=4 + IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5 + IA=I + IB=I + I1BEG=I1 + NSTP=0 + 170 NSTP=NSTP+1 + IF(NSTP.GT.4*N) THEN + CALL PYERRM(14,'(PYPREP:) caught in infinite loop') + MINT(51)=1 + RETURN + ENDIF + +C...Copy undecayed parton. Finished if reached string endpoint. + IF(K(IA,1).EQ.3) THEN + IF(I1.GE.MSTU(4)-MSTU32-5) THEN + CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS') + MINT(51)=1 + MSTU(24)=1 + RETURN + ENDIF + I1=I1+1 + K(I1,1)=2 + IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1 + K(I1,2)=K(IA,2) + K(I1,3)=IA + K(I1,4)=0 + K(I1,5)=0 + DO 180 J=1,5 + P(I1,J)=P(IA,J) + V(I1,J)=V(IA,J) + 180 CONTINUE + K(IA,1)=K(IA,1)+10 + IF(K(I1,1).EQ.1) GOTO 240 + ENDIF + +C...Also finished (for now) if reached junction; then copy to end. + IF(K(IA,1).EQ.42) THEN + NCOPY=I1-I1BEG + IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN + CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS') + MINT(51)=1 + MSTU(24)=1 + RETURN + ENDIF + IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN + DO 200 ICOPY=1,NCOPY + DO 190 J=1,5 + K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J) + P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J) + V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J) + 190 CONTINUE + 200 CONTINUE + ENDIF +C...For junction-junction strings, find end leg and reorder junction +C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the +C...junction-junction string piece. + IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN + ITMP=MOD(K(IA,4),MSTU(5)) + IF (ITMP.NE.IB) THEN + IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN + K(IA,5)=K(IA,5)+(ITMP-IB) + ELSE + K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5) + ENDIF + K(IA,4)=K(IA,4)+(IB-ITMP) + ENDIF + ENDIF + NPIECE=NPIECE+1 +C...IPIECE: +C...0: endpoint in original ER +C...1: +C...2: +C...3: Parton immediately next to junction +C...4: Junction + IPIECE(NPIECE,0)=I + IPIECE(NPIECE,1)=MSTU32+1 + IPIECE(NPIECE,2)=MSTU32+NCOPY + IPIECE(NPIECE,3)=IB + IPIECE(NPIECE,4)=IA + MSTU32=MSTU32+NCOPY + I1=I1BEG + GOTO 240 + ENDIF + +C...GOTO next parton in colour space. + IB=IA + IF (MINT(33).EQ.0) THEN + IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5 + & )).NE.0) THEN + IA=MOD(K(IB,KCS),MSTU(5)) + K(IB,KCS)=K(IB,KCS)+MSTU(5)**2 + MREV=0 + ELSE + IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5), + & MSTU(5)).EQ.0) KCS=9-KCS + IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5)) + K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2 + MREV=1 + ENDIF + IF(IA.LE.0.OR.IA.GT.N) THEN + CALL PYERRM(12,'(PYPREP:) colour rearrangement failed') + IF(NERRPR.LT.5) THEN + NERRPR=NERRPR+1 + WRITE(MSTU(11),*) 'started at:', I + WRITE(MSTU(11),*) 'ended going from',IB,' to',IA + WRITE(MSTU(11),*) 'MQGST =',MQGST + CALL PYLIST(4) + ENDIF + MINT(51)=1 + RETURN + ENDIF + IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5) + & ,MSTU(5)).EQ.IB) THEN + IF(MREV.EQ.1) KCS=9-KCS + IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS + K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2 + ELSE + IF(MREV.EQ.0) KCS=9-KCS + IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS + K(IA,KCS)=K(IA,KCS)+MSTU(5)**2 + ENDIF + IF(IA.NE.I) GOTO 170 +C...Use colour tag information + ELSE +C...First create colour tags starting on IB if none already present. + IF (MCT(IB,KCS-3).EQ.0) THEN + CALL PYCTTR(IB,KCS,IB) + IF(MINT(51).NE.0) RETURN + ENDIF + JCT=MCT(IB,KCS-3) + IFOUND=0 +C...Find final state tag partner + DO 210 IT=MAX(1,IP),N + IF (IT.EQ.IB) GOTO 210 + IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT + & .0) THEN + IFOUND=IFOUND+1 + IA=IT + ENDIF + 210 CONTINUE +C...Just copy and goto next if exactly one partner found. + IF (IFOUND.EQ.1) THEN + GOTO 170 +C...When no match found, match is presumably junction. + ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN +C...Check whether this colour tag matches a junction +C...by seeing whether any parton with this colour tag has the same +C...mother as a junction. +C...NB: Only type 1 and 2 junctions handled presently. + DO 230 IJU=1,NJUNC + IJUMO=K(IJUNC(IJU,0),3) + ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5)) +C...Colours only connect to junctions, anti-colours to antijunctions: + IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230 + IMATCH=0 + DO 220 J1=MAX(1,IP),N + IF (K(J1,1).LE.0) GOTO 220 +C...First scattering partons have IMO1 = 3 and 4. + IMO=K(J1,3) + IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4) + & IMO=IMO-2 + IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1 + & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0)) + & IMATCH=1 +C...Attempt at handling type > 3 junctions also. Not tested. + IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ + & .IJUMO) IMATCH=1 + 220 CONTINUE + IF (IMATCH.EQ.0) GOTO 230 + IA=IJUNC(IJU,0) + IFOUND=IFOUND+1 + 230 CONTINUE + + IF (IFOUND.EQ.1) THEN + GOTO 170 + ELSEIF (IFOUND.EQ.0) THEN + WRITE(CHTMP,'(I6)') JCT + CALL PYERRM(12,'(PYPREP:) no matching colour tag: ' + & //CHTMP) + IF(NERRPR.LT.5) THEN + NERRPR=NERRPR+1 + CALL PYLIST(4) + ENDIF + MINT(51)=1 + RETURN + ENDIF + ELSEIF (IFOUND.GE.2) THEN + WRITE(CHTMP,'(I6)') JCT + CALL PYERRM(12 + & ,'(PYPREP:) too many occurences of colour line: '// + & CHTMP) + IF(NERRPR.LT.5) THEN + NERRPR=NERRPR+1 + CALL PYLIST(4) + ENDIF + MINT(51)=1 + RETURN + ENDIF + ENDIF + K(I1,1)=1 + 240 CONTINUE + 250 CONTINUE + +C...Junction systems remain. + IJU=0 + IJUS=0 + IJUCNT=0 + MREV=0 + IJJSTR=0 + 260 IJUCNT=IJUCNT+1 + IF (IJUCNT.LE.NJUNC) THEN +C...If we are not processing a j-j string, treat this junction as new. + IF (IJJSTR.EQ.0) THEN + IJU=IJUNC(IJUCNT,0) + MREV=0 +C...If junction has already been read, ignore it. + IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260 +C...If we are on a j-j string, goto second j-j junction. + ELSE + IJUCNT=IJUCNT-1 + IJU=IJUS + ENDIF +C...Mark selected junction read. + DO 270 J=1,NJUNC + IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1 + 270 CONTINUE +C...Determine junction type + ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5)) +C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar +C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar +C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar + IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN + IHK=0 + 280 IHK=IHK+1 +C...Find which quarks belong to given junction. + IHF=0 + DO 290 IPC=1,NPIECE + IF (IPIECE(IPC,4).EQ.IJU) THEN + IHF=IHF+1 + IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3) + ENDIF + IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3) + 290 CONTINUE +C...IHK = 3 is special. Either normal string piece, or j-j string. + IF(IHK.EQ.3) THEN + IF (MREV.NE.1) THEN + DO 300 IPC=1,NPIECE +C...If there is a j-j string starting on the present junction which has +C...zero length, insert next junction immediately. + IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1) + & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN + IJJSTR = 1 + GOTO 340 + ENDIF + 300 CONTINUE + MREV = 1 +C...If MREV is 1 and IHK is 3 we are finished with this system. + ELSE + MREV=0 + GOTO 260 + ENDIF + ENDIF + +C...If we've gotten this far, then either IHK < 3, or +C...an interjunction string exists, or just a third normal string. + IJUNC(IJUCNT,IHK)=0 + IJJSTR = 0 +C..Order pieces belonging to this junction. Also look for j-j. + DO 310 IPC=1,NPIECE + IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC + IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0) + & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN + IJUNC(IJUCNT,IHK)=IPC + IJJSTR = 1 + MREV = 0 + ENDIF + 310 CONTINUE +C...Copy back chains in proper order. MREV=0/1 : descending/ascending + IPC=IJUNC(IJUCNT,IHK) +C...Temporary solution to cover for bug. + IF(IPC.LE.0) THEN + CALL PYERRM(12,'(PYPREP:) fails to hook up junctions') + MINT(51)=1 + RETURN + ENDIF + DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV + I1=I1+1 + DO 320 J=1,5 + K(I1,J)=K(MSTU(4)-ICP,J) + P(I1,J)=P(MSTU(4)-ICP,J) + V(I1,J)=V(MSTU(4)-ICP,J) + 320 CONTINUE + 330 CONTINUE + K(I1,1)=2 +C...Mark last quark. + IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1 +C...Do not insert junctions at wrong places. + IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360 +C...Insert junction. + 340 IJUS = IJU + IF (IHK.EQ.3) THEN +C...Shift to end junction if a j-j string has been processed. + IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4) + MREV= 1 + ENDIF + I1=I1+1 + DO 350 J=1,5 + K(I1,J)=0 + P(I1,J)=0. + V(I1,J)=0. + 350 CONTINUE + K(I1,1)=41 + K(IJUS,1)=K(IJUS,1)+10 + K(I1,2)=K(IJUS,2) + K(I1,3)=IJUS + 360 IF (IHK.LT.3) GOTO 280 + ELSE + CALL PYERRM(12,'(PYPREP:) Unknown junction type') + MINT(51)=1 + RETURN + ENDIF + IF (IJUCNT.NE.NJUNC) GOTO 260 + ENDIF + N=I1 + +C...Rearrange three strings from junction, e.g. in case one has been +C...shortened by shower, so the last is the largest-energy one. + IF(NJUNC.GE.1) THEN +C...Find systems with exactly one junction. + MJUN1=0 + NBEG=NOLD+1 + DO 470 I=NOLD+1,N + IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN + ELSEIF(K(I,1).EQ.41) THEN + MJUN1=MJUN1+1 + ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN + MJUN1=0 + NBEG=I+1 + ELSE + NEND=I +C...Sum up energy-momentum in each junction string. + DO 370 J=1,5 + PJU(1,J)=0D0 + PJU(2,J)=0D0 + PJU(3,J)=0D0 + 370 CONTINUE + NJU=0 + DO 390 I1=NBEG,NEND + IF(K(I1,2).NE.21) THEN + NJU=NJU+1 + IJUR(NJU)=I1 + ENDIF + DO 380 J=1,5 + PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J) + 380 CONTINUE + 390 CONTINUE +C...Find which of them has highest energy (minus mass) in rest frame. + DO 400 J=1,5 + PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J) + 400 CONTINUE + PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2- + & PJU(4,3)**2)) + DO 410 I2=1,3 + PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)- + & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5) + 410 CONTINUE + IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN +C...Decide how to rearrange so that new last has highest energy. + IF(PJU(1,6).LT.PJU(2,6)) THEN + IRNG(1,1)=IJUR(1) + IRNG(1,2)=IJUR(2)-1 + IRNG(2,1)=IJUR(4) + IRNG(2,2)=IJUR(3)+1 + IRNG(4,1)=IJUR(3)-1 + IRNG(4,2)=IJUR(2) + ELSE + IRNG(1,1)=IJUR(4) + IRNG(1,2)=IJUR(3)+1 + IRNG(2,1)=IJUR(2) + IRNG(2,2)=IJUR(3)-1 + IRNG(4,1)=IJUR(2)-1 + IRNG(4,2)=IJUR(1) + ENDIF + IRNG(3,1)=IJUR(3) + IRNG(3,2)=IJUR(3) +C...Copy in correct order below bottom of current event record. + I2=N + DO 440 II=1,4 + DO 430 I1=IRNG(II,1),IRNG(II,2), + & ISIGN(1,IRNG(II,2)-IRNG(II,1)) + I2=I2+1 + IF(I2.GE.MSTU(4)-MSTU32-5) THEN + CALL PYERRM(11, + & '(PYPREP:) no more memory left in PYJETS') + MINT(51)=1 + MSTU(24)=1 + RETURN + ENDIF + DO 420 J=1,5 + K(I2,J)=K(I1,J) + P(I2,J)=P(I1,J) + V(I2,J)=V(I1,J) + 420 CONTINUE + IF(K(I2,1).EQ.1) K(I2,1)=2 + 430 CONTINUE + 440 CONTINUE + K(I2,1)=1 +C...Copy back up, overwriting but now in correct order. + DO 460 I1=NBEG,NEND + I2=I1-NBEG+N+1 + DO 450 J=1,5 + K(I1,J)=K(I2,J) + P(I1,J)=P(I2,J) + V(I1,J)=V(I2,J) + 450 CONTINUE + 460 CONTINUE + ENDIF + MJUN1=0 + NBEG=I+1 + ENDIF + 470 CONTINUE + +C...Check whether q-q-j-j-qbar-qbar systems should be collapsed +C...to two q-qbar systems. +C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.) + IF (MSTJ(19).NE.1) THEN + MJUN1 = 0 + JJGLUE = 0 + NBEG = NOLD+1 +C...Force collapse when MSTJ(19)=2. + IF (MSTJ(19).EQ.2) THEN + DELMJJ = 1D9 + DELMQQ = 0D0 + ENDIF +C...Find systems with exactly two junctions. + DO 700 I=NOLD+1,N +C...Count junctions + IF (K(I,1).EQ.41) THEN + MJUN1 = MJUN1+1 +C...Check for interjunction gluons + IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN + JJGLUE = 1 + ENDIF + ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN +C...If end of system reached with either zero or one junction, restart +C...with next system. + MJUN1 = 0 + JJGLUE = 0 + NBEG = I+1 + ELSEIF(K(I,1).EQ.1) THEN +C...If end of system reached with exactly two junctions, compute string +C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with +C...length measure for the (q-qbar)(q-qbar) topology. + NEND=I +C...Loop down through chain. + ISID=0 + DO 480 I1=NBEG,NEND +C...Store string piece division locations in event record + IF (K(I1,2).NE.21) THEN + ISID = ISID+1 + IJCP(ISID) = I1 + ENDIF + 480 CONTINUE +C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies. + ISW=0 + IF (PYR(0).LT.0.5D0) ISW=1 +C...Randomly choose which qqbar string gets the jj gluons. + IGS=1 + IF (PYR(0).GT.0.5D0) IGS=2 +C...Only compute string lengths when no topology forced. + IF (MSTJ(19).EQ.0) THEN +C...Repeat following for each junction + DO 570 IJU=1,2 +C...Initialize iterative procedure for finding JRF + IJRFIT=0 + DO 490 IX=1,3 + TJUOLD(IX)=0D0 + 490 CONTINUE + TJUOLD(4)=1D0 +C...Start iteration. Sum up momenta in string pieces + 500 DO 540 IJS=1,3 +C...JD=-1 for first junction, +1 for second junction. +C...Find out where piece starts and ends and which direction to go. + JD=2*IJU-3 + IF (IJS.LE.2) THEN + IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD + IB = IJCP((IJU-1)*7 - JD*IJS) + ELSEIF (IJS.EQ.3) THEN + JD =-JD + IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD + IB = IJCP((IJU-1)*7 + JD*(IJS+3)) + ENDIF +C...Initialize junction pull 4-vector. + DO 510 J=1,5 + PUL(IJS,J)=0D0 + 510 CONTINUE +C...Initialize weight + PWT = 0D0 + PWTOLD = 0D0 +C...Sum up (weighted) momenta along each string piece + DO 530 ISP=IA,IB,JD +C...If present parton not last in chain + IF (ISP.NE.IA.AND.ISP.NE.IB) THEN +C...If last parton was a junction, store present weight + IF (K(ISP-JD,2).EQ.88) THEN + PWTOLD = PWT +C...If last parton was a quark, reset to stored weight. + ELSEIF (K(ISP-JD,2).NE.21) THEN + PWT = PWTOLD + ENDIF + ENDIF +C...Skip next parton if weight already large + IF (PWT.GT.10D0) GOTO 530 +C...Compute momentum in TJUOLD frame: + TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3 + & )*P(ISP,3) + BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4) + DO 520 J=1,3 + TMP=P(ISP,J)+TJUOLD(J)*BFC + PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT) + 520 CONTINUE +C...Boosted energy + TMP=TJUOLD(4)*P(ISP,4)+TDP + PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT) +C...Update weight + PWT=PWT+TMP/PARJ(48) +C...Put |p| rather than m in 5th slot + PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2 + & +PUL(IJS,3)**2) + 530 CONTINUE + 540 CONTINUE +C...Compute boost + IJRFIT=IJRFIT+1 + CALL PYJURF(PUL,T) +C...Combine new boost (T) with old boost (TJUOLD) + TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3) + DO 550 IX=1,3 + TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4 + & )) + 550 CONTINUE + TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3) + & **2) +C...If last boost small, accept JRF, else iterate. +C...Also prevent possibility of infinite loop. + IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND. + & IJRFIT.LT.MSTJ(18))THEN + GOTO 500 + ELSEIF (IJRFIT.GE.MSTJ(18)) THEN + CALL PYERRM(1,'(PYPREP:) failed to converge on JRF') + ENDIF +C...Store final boost, with change of sign since TJJ motion vector. + DO 560 IX=1,3 + TJJ(IJU,IX)=-TJUOLD(IX) + 560 CONTINUE + TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2 + & +TJJ(IJU,3)**2) + 570 CONTINUE +C...String length measure for (q-qbar)(q-qbar) topology. +C...Note only momenta of nearest partons used (since rest of system +C...identical). + IF (JJGLUE.EQ.0) THEN + DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3) + & -1,IJCP(5-ISW)+1) + ELSE +C...Put jj gluons on selected string (IGS selected randomly above). + IF (IGS.EQ.1) THEN + DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1 + & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1) + ELSE + DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1) + & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1 + & ,IJCP(5-ISW)+1) + ENDIF + ENDIF +C...String length measure for q-q-j-j-q-q topology. + T1G1=0D0 + T2G2=0D0 + T1T2=0D0 + T1P1=0D0 + T1P2=0D0 + T2P3=0D0 + T2P4=0D0 + ISGN=-1 +C...Note only momenta of nearest partons used (since rest of system +C...identical). + DO 580 IX=1,4 + IF (IX.EQ.4) ISGN=1 + T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX) + T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX) + T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX) + T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX) + IF (JJGLUE.EQ.0) THEN +C...Junction motion vector dot product gives length when inter-junction +C...gluons absent. + T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX) + ELSE +C...Junction motion vector dot products with gluon momenta give length +C...when inter-junction gluons present. + T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX) + T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX) + ENDIF + 580 CONTINUE + DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4 + IF (JJGLUE.EQ.0) THEN + DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1)) + ELSE + DELMJJ=DELMJJ*4D0*T1G1*T2G2 + ENDIF + ENDIF +C...If delmjj > delmqq collapse string system to q-qbar q-qbar +C...(Always the case for MSTJ(19)=2 due to initialization above) + IF (DELMJJ.GT.DELMQQ) THEN +C...Put new system at end of event record + NCOP=N + DO 650 IST=1,2 + DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1 + NCOP=NCOP+1 + DO 590 IX=1,5 + P(NCOP,IX)=P(ICOP,IX) + K(NCOP,IX)=K(ICOP,IX) + 590 CONTINUE + 600 CONTINUE + IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN +C...Insert inter-junction gluon string piece (reversed) + NJJGL=0 + DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1 + NJJGL=NJJGL+1 + NCOP=NCOP+1 + DO 610 IX=1,5 + P(NCOP,IX)=P(ICOP,IX) + K(NCOP,IX)=K(ICOP,IX) + 610 CONTINUE + 620 CONTINUE + ENDIF + IFC=-2*IST+3 + DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4) + NCOP=NCOP+1 + DO 630 IX=1,5 + P(NCOP,IX)=P(ICOP,IX) + K(NCOP,IX)=K(ICOP,IX) + 630 CONTINUE + 640 CONTINUE + K(NCOP,1)=1 + 650 CONTINUE +C...Copy system back in right order + DO 670 ICOP=NBEG,NEND-2 + DO 660 IX=1,5 + P(ICOP,IX)=P(N+ICOP-NBEG+1,IX) + K(ICOP,IX)=K(N+ICOP-NBEG+1,IX) + 660 CONTINUE + 670 CONTINUE +C...Shift down rest of event record + DO 690 ICOP=NEND+1,N + DO 680 IX=1,5 + P(ICOP-2,IX)=P(ICOP,IX) + K(ICOP-2,IX)=K(ICOP,IX) + 680 CONTINUE + 690 CONTINUE +C...Update length of event record. + N=N-2 + ENDIF + MJUN1=0 + NBEG=I+1 + ENDIF + 700 CONTINUE + ENDIF + ENDIF + +C...Done if no checks on small-mass systems. + IF(MSTJ(14).LT.0) RETURN + IF(MSTJ(14).EQ.0) GOTO 1140 + +C...Find lowest-mass colour singlet jet system. + NS=N + 710 NSIN=N-NS + PDMIN=1D0+PARJ(32) + IC=0 + DO 770 I=MAX(1,IP),N + IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN + ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN + NSIN=NSIN+1 + IC=I + DO 720 J=1,4 + DPS(J)=P(I,J) + 720 CONTINUE + MSTJ(93)=1 + DPS(5)=PYMASS(K(I,2)) + ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN + DO 730 J=1,4 + DPS(J)=DPS(J)+P(I,J) + 730 CONTINUE + MSTJ(93)=1 + DPS(5)=DPS(5)+PYMASS(K(I,2)) + ELSEIF(K(I,1).EQ.2) THEN + DO 740 J=1,4 + DPS(J)=DPS(J)+P(I,J) + 740 CONTINUE + ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN + DO 750 J=1,4 + DPS(J)=DPS(J)+P(I,J) + 750 CONTINUE + MSTJ(93)=1 + DPS(5)=DPS(5)+PYMASS(K(I,2)) + PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))- + & DPS(5) + IF(PD.LT.PDMIN) THEN + PDMIN=PD + DO 760 J=1,5 + DPC(J)=DPS(J) + 760 CONTINUE + IC1=IC + IC2=I + ENDIF + IC=0 + ELSE + NSIN=NSIN+1 + ENDIF + 770 CONTINUE + +C...Done if lowest-mass system above threshold for string frag. + IF(PDMIN.GE.PARJ(32)) GOTO 1140 + +C...Fill small-mass system as cluster. + NSAV=N + PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2)) + K(N+1,1)=11 + K(N+1,2)=91 + K(N+1,3)=IC1 + P(N+1,1)=DPC(1) + P(N+1,2)=DPC(2) + P(N+1,3)=DPC(3) + P(N+1,4)=DPC(4) + P(N+1,5)=PECM + +C...Set up history, assuming cluster -> 2 hadrons. + NBODY=2 + K(N+1,4)=N+2 + K(N+1,5)=N+3 + K(N+2,1)=1 + K(N+3,1)=1 + IF(MSTU(16).NE.2) THEN + K(N+2,3)=N+1 + K(N+3,3)=N+1 + ELSE + K(N+2,3)=IC1 + K(N+3,3)=IC2 + ENDIF + K(N+2,4)=0 + K(N+3,4)=0 + K(N+2,5)=0 + K(N+3,5)=0 + V(N+1,5)=0D0 + V(N+2,5)=0D0 + V(N+3,5)=0D0 + +C...Find total flavour content - complicated by presence of junctions. + NQ=0 + NDIQ=0 + DO 780 I=IC1,IC2 + IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN + NQ=NQ+1 + KFQ(NQ)=K(I,2) + IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1 + ENDIF + 780 CONTINUE + +C...If several diquarks, split up one to give even number of flavours. + IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN + I1=3 + IF(IABS(KFQ(3)).LT.1000) I1=1 + KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1)) + KFQ(I1)=KFQ(I1)/1000 + NQ=4 + NDIQ=NDIQ-1 + ENDIF + +C...If four quark ends, join two to diquark. + IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN + I1=1 + I2=2 + IF(KFQ(I1)*KFQ(I2).LT.0) I2=3 + IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4 + KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1 + IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3 + KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+ + & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1)) + KFQ(I2)=KFQ(4) + NQ=3 + NDIQ=1 + ENDIF + +C...If two quark ends, plus quark or diquark, join quarks to diquark. + IF(NQ.EQ.3) THEN + I1=1 + I2=2 + IF(IABS(KFQ(I1)).GT.1000) I1=3 + IF(IABS(KFQ(I2)).GT.1000) I2=3 + KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1 + IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3 + KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+ + & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1)) + KFQ(I2)=KFQ(3) + NQ=2 + NDIQ=NDIQ+1 + ENDIF + +C...Form two particles from flavours of lowest-mass system, if feasible. + NTRY = 0 + 790 NTRY = NTRY + 1 + +C...Open string with two specified endpoint flavours. + IF(NQ.EQ.2) THEN + KC1=PYCOMP(KFQ(1)) + KC2=PYCOMP(KFQ(2)) + IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140 + KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1)) + KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2)) + IF(KQ1+KQ2.NE.0) GOTO 1140 +C...Start with qq, if there is one. Only allow for rank 1 popcorn meson + 800 K1=KFQ(1) + IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2) + MSTU(125)=0 + CALL PYDCYK(K1,0,KFLN,K(N+2,2)) + CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2)) + IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800 + +C...Open string with four specified flavours. + ELSEIF(NQ.EQ.4) THEN + KC1=PYCOMP(KFQ(1)) + KC2=PYCOMP(KFQ(2)) + KC3=PYCOMP(KFQ(3)) + KC4=PYCOMP(KFQ(4)) + IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140 + KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1)) + KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2)) + KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3)) + KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4)) + IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140 +C...Combine flavours pairwise to form two hadrons. + 810 I1=1 + I2=2 + IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND. + & IABS(KFQ(2)).GT.1000)) I2=3 + IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND. + & IABS(KFQ(3)).GT.1000))) I2=4 + I3=3 + IF(I2.EQ.3) I3=2 + I4=10-I1-I2-I3 + CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2)) + CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2)) + IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810 + +C...Closed string. + ELSE + IF(IABS(K(IC2,2)).NE.21) GOTO 1140 +C...No room for popcorn mesons in closed string -> 2 hadrons. + MSTU(125)=0 + 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP) + CALL PYDCYK(KFLN,0,KFLM,K(N+2,2)) + CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2)) + IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820 + ENDIF + P(N+2,5)=PYMASS(K(N+2,2)) + P(N+3,5)=PYMASS(K(N+3,2)) + +C...If it does not work: try again (a number of times), give up (if no +C...place to shuffle momentum or too many flavours), or form one hadron. + IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN + IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN + GOTO 790 + ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN + GOTO 1140 + ELSE + GOTO 890 + END IF + END IF + +C...Perform two-particle decay of jet system. +C...First step: find reference axis in decaying system rest frame. +C...(Borrow slot N+2 for temporary direction.) + DO 830 J=1,4 + P(N+2,J)=P(IC1,J) + 830 CONTINUE + DO 850 I=IC1+1,IC2-1 + IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND. + & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN + FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I)) + DO 840 J=1,4 + P(N+2,J)=P(N+2,J)+FRAC1*P(I,J) + 840 CONTINUE + ENDIF + 850 CONTINUE + CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4), + &-DPC(3)/DPC(4)) + THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2)) + PHI1=PYANGL(P(N+2,1),P(N+2,2)) + +C...Second step: generate isotropic/anisotropic decay. + PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2- + &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM) + 860 UE(3)=PYR(0) + IF(PARJ(21).LE.0.01D0) UE(3)=1D0 + PT2=(1D0-UE(3)**2)*PA**2 + IF(MSTJ(16).LE.0) THEN + PREV=0.5D0 + ELSE + IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860 + PR1=P(N+2,5)**2+PT2 + PR2=P(N+3,5)**2+PT2 + ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2)) + PREVCF=PARJ(42) + IF(MSTJ(11).EQ.2) PREVCF=PARJ(39) + PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40)))) + ENDIF + IF(PYR(0).LT.PREV) UE(3)=-UE(3) + PHI=PARU(2)*PYR(0) + UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI) + UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI) + DO 870 J=1,3 + P(N+2,J)=PA*UE(J) + P(N+3,J)=-PA*UE(J) + 870 CONTINUE + P(N+2,4)=SQRT(PA**2+P(N+2,5)**2) + P(N+3,4)=SQRT(PA**2+P(N+3,5)**2) + +C...Third step: move back to event frame and set production vertex. + CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4), + &DPC(3)/DPC(4)) + DO 880 J=1,4 + V(N+1,J)=V(IC1,J) + V(N+2,J)=V(IC1,J) + V(N+3,J)=V(IC2,J) + 880 CONTINUE + N=N+3 + GOTO 1120 + +C...Else form one particle, if possible. + 890 NBODY=1 + K(N+1,5)=N+2 + DO 900 J=1,4 + V(N+1,J)=V(IC1,J) + V(N+2,J)=V(IC1,J) + 900 CONTINUE + +C...Select hadron flavour from available quark flavours. + 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN + GOTO 1140 + ELSEIF(NQ.EQ.2) THEN + CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2)) + ELSE + KFLN=1+INT((2D0+PARJ(2))*PYR(0)) + CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2)) + ENDIF + IF(K(N+2,2).EQ.0) GOTO 910 + P(N+2,5)=PYMASS(K(N+2,2)) + +C...Use old algorithm for E/p conservation? (EN) + IF (MSTJ(16).LE.0) GOTO 1080 + +C...Find the string piece closest to the cluster by a loop +C...over the undecayed partons not in present cluster. (EN) + DGLOMI=1D30 + IBEG=0 + I0=0 + NJUNC=0 + DO 940 I1=MAX(1,IP),N-1 + IF(K(I1,1).EQ.1) NJUNC=0 + IF(K(I1,1).EQ.41) NJUNC=NJUNC+1 + IF(K(I1,1).EQ.41) GOTO 940 + IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN + I0=0 + ELSEIF(K(I1,1).EQ.2) THEN + IF(I0.EQ.0) I0=I1 + I2=I1 + 920 I2=I2+1 + IF(K(I2,1).EQ.41) GOTO 940 + IF(K(I2,1).GT.10) GOTO 920 + IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920 + IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND. + & NJUNC.EQ.0) GOTO 940 + IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940 + IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR. + & K(I2,1).NE.1)) GOTO 940 + +C...Define velocity vectors e1, e2, ecl and differences e3, e4. + DO 930 J=1,3 + E1(J)=P(I1,J)/P(I1,4) + E2(J)=P(I2,J)/P(I2,4) + ECL(J)=P(N+1,J)/P(N+1,4) + E3(J)=E2(J)-E1(J) + E4(J)=ECL(J)-E1(J) + 930 CONTINUE + +C...Calculate minimal D=(e4-alpha*e3)**2 for 0 0: emit a 'gluon' (EN) + IF (P(N+1,5).GE.P(N+2,5)) THEN + +C...Construct 'gluon' that is needed to put hadron on the mass shell. + FRAC=P(N+2,5)/P(N+1,5) + DO 950 J=1,5 + P(N+2,J)=FRAC*P(N+1,J) + PG(J)=(1D0-FRAC)*P(N+1,J) + 950 CONTINUE + +C... Copy string with new gluon put in. + N=N+2 + I=IBEG-1 + 960 I=I+1 + IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960 + IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960 + N=N+1 + DO 970 J=1,5 + K(N,J)=K(I,J) + P(N,J)=P(I,J) + V(N,J)=V(I,J) + 970 CONTINUE + K(I,1)=K(I,1)+10 + K(I,4)=N + K(I,5)=N + K(N,3)=I + IF(I.EQ.IPCS) THEN + N=N+1 + DO 980 J=1,5 + K(N,J)=K(N-1,J) + P(N,J)=PG(J) + V(N,J)=V(N-1,J) + 980 CONTINUE + K(N,2)=21 + K(N,3)=NSAV+1 + ENDIF + IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960 + GOTO 1120 + +C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead, +C...from string piece endpoints. + ELSE + +C...Begin by copying string that should give energy to cluster. + N=N+2 + I=IBEG-1 + 990 I=I+1 + IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990 + IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990 + N=N+1 + DO 1000 J=1,5 + K(N,J)=K(I,J) + P(N,J)=P(I,J) + V(N,J)=V(I,J) + 1000 CONTINUE + K(I,1)=K(I,1)+10 + K(I,4)=N + K(I,5)=N + K(N,3)=I + IF(I.EQ.IPCS) I1=N + IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990 + I2=I1+1 + +C...Set initial Phad. + DO 1010 J=1,4 + P(NSAV+2,J)=P(NSAV+1,J) + 1010 CONTINUE + +C...Calculate Pg, a part of which will be added to Phad later. (EN) + 1020 IF(MSTJ(16).EQ.1) THEN + ALPHA=1D0 + BETA=1D0 + ELSE + ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2) + BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2) + ENDIF + DO 1030 J=1,4 + PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J) + 1030 CONTINUE + PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2)) + +C..Solve 2nd order equation, use the best (smallest) solution. (EN) + PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2- + & P(NSAV+2,3)**2 + PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)- + & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2 + DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG + +C...If all gluon energy eaten, zero it and take a step back. + ITER=0 + IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN + ITER=1 + DO 1040 J=1,4 + P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J) + P(I1,J)=0D0 + 1040 CONTINUE + P(I1,5)=0D0 + K(I1,1)=K(I1,1)+10 + I1=I1-1 + IF(K(I1,1).EQ.41) ITER=-1 + ENDIF + IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN + ITER=1 + DO 1050 J=1,4 + P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J) + P(I2,J)=0D0 + 1050 CONTINUE + P(I2,5)=0D0 + K(I2,1)=K(I2,1)+10 + I2=I2+1 + IF(K(I2,1).EQ.41) ITER=-1 + ENDIF + IF(ITER.EQ.1) GOTO 1020 + +C...If also all endpoint energy eaten, revert to old procedure. + IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR. + & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN + DO 1060 I=NSAV+3,N + IM=K(I,3) + K(IM,1)=K(IM,1)-10 + K(IM,4)=0 + K(IM,5)=0 + 1060 CONTINUE + N=NSAV + GOTO 1080 + ENDIF + +C... Construct the collapsed hadron and modified string partons. + DO 1070 J=1,4 + P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J) + P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J) + P(I2,J)=(1D0-DELTA*BETA)*P(I2,J) + 1070 CONTINUE + P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5) + P(I2,5)=(1D0-DELTA*BETA)*P(I2,5) + +C...Finished with string collapse in new scheme. + GOTO 1120 + ENDIF + +C... Use old algorithm; by choice or when in trouble. + 1080 CONTINUE +C...Find parton/particle which combines to largest extra mass. + IR=0 + HA=0D0 + HSM=0D0 + DO 1100 MCOMB=1,3 + IF(IR.NE.0) GOTO 1100 + DO 1090 I=MAX(1,IP),N + IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2 + & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090 + IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2)) + IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090 + IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090 + IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100) + & GOTO 1090 + HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3) + HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5) + IF(HSR.GT.HSM) THEN + IR=I + HA=HCR + HSM=HSR + ENDIF + 1090 CONTINUE + 1100 CONTINUE + +C...Shuffle energy and momentum to put new particle on mass shell. + IF(IR.NE.0) THEN + HB=PECM**2+HA + HC=P(N+2,5)**2+HA + HD=P(IR,5)**2+HA + HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/ + & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD) + HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB + DO 1110 J=1,4 + P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J) + P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J) + 1110 CONTINUE + N=N+2 + ELSE + CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster') + RETURN + ENDIF + +C...Mark collapsed system and store daughter pointers. Iterate. + 1120 DO 1130 I=IC1,IC2 + IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND. + & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN + K(I,1)=K(I,1)+10 + IF(MSTU(16).NE.2) THEN + K(I,4)=NSAV+1 + K(I,5)=NSAV+1 + ELSE + K(I,4)=NSAV+2 + K(I,5)=NSAV+1+NBODY + ENDIF + ENDIF + IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10 + 1130 CONTINUE + IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710 + +C...Check flavours and invariant masses in parton systems. + 1140 NP=0 + KFN=0 + KQS=0 + NJU=0 + DO 1150 J=1,5 + DPS(J)=0D0 + 1150 CONTINUE + DO 1180 I=MAX(1,IP),N + IF(K(I,1).EQ.41) NJU=NJU+1 + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 1180 + KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) + IF(KQ.EQ.0) GOTO 1180 + NP=NP+1 + IF(KQ.NE.2) THEN + KFN=KFN+1 + KQS=KQS+KQ + MSTJ(93)=1 + DPS(5)=DPS(5)+PYMASS(K(I,2)) + ENDIF + DO 1160 J=1,4 + DPS(J)=DPS(J)+P(I,J) + 1160 CONTINUE + IF(K(I,1).EQ.1) THEN + NFERR=0 + IF(NJU.EQ.0.AND.NP.NE.1) THEN + IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1 + ELSEIF(NJU.EQ.1) THEN + IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1 + ELSEIF(NJU.EQ.2) THEN + IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1 + ELSEIF(NJU.GE.3) THEN + NFERR=1 + ENDIF + IF(NFERR.EQ.1) THEN + CALL PYERRM(2,'(PYPREP:) unphysical flavour combination') + MINT(51)=1 + RETURN + ENDIF + IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT. + & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3, + & '(PYPREP:) too small mass in jet system') + NP=0 + KFN=0 + KQS=0 + NJU=0 + DO 1170 J=1,5 + DPS(J)=0D0 + 1170 CONTINUE + ENDIF + 1180 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYSTRF +C...Handles the fragmentation of an arbitrary colour singlet +C...jet system according to the Lund string fragmentation model. + + SUBROUTINE PYSTRF(IP) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ +C...Local arrays. All MOPS variables ends with MO + DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2), + &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5), + &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8), + &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2), + &PBST(3,5),TJUOLD(5) + +C...Function: four-product of two vectors. + FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) + DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)- + &DP(I,3)*DP(J,3) + +C...Reset counters. + MSTJ(91)=0 + NSAV=N + MSTU90=MSTU(90) + NP=0 + KQSUM=0 + DO 100 J=1,5 + DPS(J)=0D0 + 100 CONTINUE + MJU(1)=0 + MJU(2)=0 + NTRYFN=0 + IJUORI(1)=0 + IJUORI(2)=0 + +C...Identify parton system. + I=IP-1 + 110 I=I+1 + IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN + CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system') + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 110 + KQ=KCHG(KC,2)*ISIGN(1,K(I,2)) + IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110 + IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Take copy of partons to be considered. Check flavour sum. + NP=NP+1 + DO 120 J=1,5 + K(N+NP,J)=K(I,J) + P(N+NP,J)=P(I,J) + IF(J.NE.4) DPS(J)=DPS(J)+P(I,J) + 120 CONTINUE + DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2) + K(N+NP,3)=I + IF(KQ.NE.2) KQSUM=KQSUM+KQ + IF(K(I,1).EQ.41) THEN + IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN + MJU(1)=N+NP + IJUORI(1)=I + ELSE + MJU(2)=N+NP + IJUORI(2)=I + ENDIF + ENDIF + IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110 + IF(MOD(KQSUM,3).NE.0) THEN + CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination') + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1 + +C...Boost copied system to CM frame (for better numerical precision). + IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN + MBST=0 + MSTU(33)=1 + CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4), + & -DPS(3)/DPS(4)) + ELSE + MBST=1 + HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3))) + DO 130 I=N+1,N+NP + HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2 + IF(P(I,3).GT.0D0) THEN + HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ) + P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ) + P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ) + ELSE + HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ) + P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ) + P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ) + ENDIF + 130 CONTINUE + ENDIF + +C...Search for very nearby partons that may be recombined. + NTRYR=0 + NTRYWR=0 + PARU12=PARU(12) + PARU13=PARU(13) + MJU(3)=MJU(1) + MJU(4)=MJU(2) + NR=NP + NRMIN=2 + IF(MJU(1).GT.0) NRMIN=NRMIN+2 + IF(MJU(2).GT.0) NRMIN=NRMIN+2 + 140 IF(NR.GT.NRMIN) THEN + PDRMIN=2D0*PARU12 + DO 150 I=N+1,N+NR + IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150 + I1=I+1 + IF(I.EQ.N+NR) I1=N+1 + IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150 + IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21) + & GOTO 150 + IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21) + & GOTO 150 + PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+ + & P(I1,2)**2+P(I1,3)**2)) + PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3) + PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP)) + IF(PDR.LT.PDRMIN) THEN + IR=I + PDRMIN=PDR + ENDIF + 150 CONTINUE + +C...Recombine very nearby partons to avoid machine precision problems. + IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN + DO 160 J=1,4 + P(N+1,J)=P(N+1,J)+P(N+NR,J) + 160 CONTINUE + P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2- + & P(N+1,3)**2)) + NR=NR-1 + GOTO 140 + ELSEIF(PDRMIN.LT.PARU12) THEN + DO 170 J=1,4 + P(IR,J)=P(IR,J)+P(IR+1,J) + 170 CONTINUE + P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2- + & P(IR,3)**2)) + IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2) + DO 190 I=IR+1,N+NR-1 + K(I,1)=K(I+1,1) + K(I,2)=K(I+1,2) + DO 180 J=1,5 + P(I,J)=P(I+1,J) + 180 CONTINUE + 190 CONTINUE + IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2) + NR=NR-1 + IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1 + IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1 + GOTO 140 + ENDIF + ENDIF + NTRYR=NTRYR+1 + +C...Reset particle counter. Skip ahead if no junctions are present; +C...this is usually the case! + NRS=MAX(5*NR+11,NP) + NTRY=0 + 200 NTRY=NTRY+1 + IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN + PARU12=4D0*PARU12 + PARU13=2D0*PARU13 + GOTO 140 + ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN + CALL PYERRM(14,'(PYSTRF:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + I=N+NRS + MSTU(90)=MSTU90 + IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650 + IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'// + & ' junction strings not handled by MSTJ(12)>3 options') + DO 640 JT=1,2 + NJS(JT)=0 + IF(MJU(JT).EQ.0) GOTO 640 + JS=3-2*JT + +C++SKANDS +C...Find and sum up momentum on three sides of junction. +C...Begin with previous boost = zero. + IJRFIT=0 + DO 210 IX=1,3 + TJUOLD(IX)=0D0 + 210 CONTINUE +C...Prevent IJU (specifically IJU(5)) from containing junk below + DO 215 IU=1,6 + IJU(IU)=0 + 215 CONTINUE + TJUOLD(4)=1D0 + 220 IU=0 +C...Beginning and end of string system in event record. + I1BEG=N+1+(JT-1)*(NR-1) + I1END=N+NR+(JT-1)*(1-NR) +C...Look for junction string piece end points + DO 230 I1=I1BEG,I1END,JS + IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN +C...Store junction string piece end points. +C 1-junction systems 2-junction systems +C IU : 1 2 3 4 1 2 3 4 5 6 +C IJU(IU): q-g-g-q-g-g-j-g-q q-g-g-q-g-j-g-g-j-g-q-g-g-q + IU=IU+1 + IJU(IU)=I1 + ENDIF +C...Sum over momenta, from junction outwards. + 230 CONTINUE + DO 280 IU=1,3 + PWT=0D0 +C...Initialize junction drag and string piece 4-vectors. + DO 240 J=1,5 + PBST(IU,J)=0D0 + PJU(IU,J)=0D0 + 240 CONTINUE +C...First two branches. Inwards out means opposite direction to JS. +C...(JS is 1 for JT=1, -1 for JT=2) + IF (IU.LT.3) THEN + I1A=IJU(IU+1)-JS + I1B=IJU(IU) + IDIR=-JS +C...Last branch (gq or gjgqgq). Direction now reversed. + ELSE + I1A=IJU(IU)+JS + I1B=I1END + IDIR=JS + ENDIF + DO 270 I1=I1A,I1B,IDIR +C...Sum up momentum directions with exponential suppression +C...for use in finding junction rest frame below. + IF (K(I1,2).EQ.88) THEN +C...gjgqgq type system encountered. Use current PWT as start +C...for both strings. + PWTOLD=PWT + ELSE + IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD +C...Sum up string piece (boosted) 4-momenta. + DO 250 J=1,4 + PJU(IU,J)=PJU(IU,J)+P(I1,J) + 250 CONTINUE +C...Compute "junction drag" vectors from (boosted) 4-momenta (initial +C...boost is zero, see above). Skip parton if suppression factor large. + IF (PWT.GT.10D0) GOTO 270 +C...Compute momentum in current frame: + TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3) + BFC=TDP/(1D0+TJUOLD(4))+P(I1,4) + DO 260 J=1,3 + PTMP=P(I1,J)+TJUOLD(J)*BFC + PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT) + 260 CONTINUE +C...Boosted energy + PTMP=TJUOLD(4)*P(I1,4)+TDP + PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT) + PWT=PWT+PTMP/PARJ(48) + ENDIF + 270 CONTINUE +C...Put |p| rather than m in 5th slot. + PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2) + PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2) + 280 CONTINUE + +C...Calculate boost from present frame to next JRF candidate. + IJRFIT=IJRFIT+1 + CALL PYJURF(PBST,TJU) + +C...After some iterations do not take full step in new direction. + IF(IJRFIT.GT.5) THEN + REDUCE=0.8D0**(IJRFIT-5) + TJU(1)=REDUCE*TJU(1) + TJU(2)=REDUCE*TJU(2) + TJU(3)=REDUCE*TJU(3) + TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2) + ENDIF + +C...Combine new boost (TJU) with old boost (TJUOLD) + TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3) + DO 290 IX=1,3 + TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4)) + 290 CONTINUE + TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2) + +C...If last boost small, accept JRF, else iterate. +C...Also prevent possibility of infinite loop. + IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND. + & IJRFIT.LT.MSTJ(18)) THEN + GOTO 220 + ELSEIF (IJRFIT.GE.MSTJ(18)) THEN + CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF') + ENDIF + +C...Now store total boost in TJU and change perception. +C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth, +C...TJU = junction motion vector in string CM, so the sign changes. + DO 300 J=1,3 + TJU(J)=-TJUOLD(J) + 300 CONTINUE + TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2) + +C--SKANDS + +C...Calculate string piece energies in junction rest frame. + DO 310 IU=1,3 + PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)- + & TJU(3)*PJU(IU,3) + PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)- + & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3) + 310 CONTINUE + +C...Start preparing for fragmentation of two strings from junction. + ISTA=I + NTRYER=0 + 320 NTRYER=NTRYER+1 + I=ISTA + DO 620 IU=1,2 + NS=IABS(IJU(IU+1)-IJU(IU)) + +C...Junction strings: find longitudinal string directions. + DO 350 IS=1,NS + IS1=IJU(IU)+JS*(IS-1) + IS2=IJU(IU)+JS*IS + DO 330 J=1,5 + DP(1,J)=0.5D0*P(IS1,J) + IF(IS.EQ.1) DP(1,J)=P(IS1,J) + DP(2,J)=0.5D0*P(IS2,J) + IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))* + & (PJU(IU,5)/PBST(IU,5)) + 330 CONTINUE + IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2- + & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2)) + DP(3,5)=DFOUR(1,1) + DP(4,5)=DFOUR(2,2) + DHKC=DFOUR(1,2) + IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN + DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) + DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) + DP(3,5)=0D0 + DP(4,5)=0D0 + DHKC=DFOUR(1,2) + ENDIF + DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5)) + DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0) + DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0) + IN1=N+NR+4*IS-3 + P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5)) + DO 340 J=1,4 + P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J) + P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J) + 340 CONTINUE + 350 CONTINUE + +C...Junction strings: initialize flavour, momentum and starting pos. + ISAV=I + MSTU91=MSTU(90) + 360 NTRY=NTRY+1 + IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN + PARU12=4D0*PARU12 + PARU13=2D0*PARU13 + GOTO 140 + ELSEIF(NTRY.GT.100) THEN + CALL PYERRM(14,'(PYSTRF:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + I=ISAV + MSTU(90)=MSTU91 + IRANKJ=0 + IE(1)=K(N+1+(JT/2)*(NP-1),3) + IF (MOD(JT+IU,2).NE.0) THEN + IE(1)=K(IJU(IU),3) + IF (NP-NR.NE.0) THEN +C...If gluons have disappeared. Original IJU must be used. + IT=IP + NE=1 + 370 IT=IT+1 + IF (K(IT,2).NE.21) THEN + NE=NE+1 + ENDIF + IF (NE.EQ.IU+4*(JT-1)) THEN + IE(1)=IT + ELSEIF (IT.LE.IP+NP) THEN + GOTO 370 + ELSE + CALL PYERRM(14,'(PYSTRF:) '// + & 'Original IJU could not be reconstructed!') + ENDIF + ENDIF + ENDIF + IN(4)=N+NR+1 + IN(5)=IN(4)+1 + IN(6)=N+NR+4*NS+1 + DO 390 JQ=1,2 + DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4 + P(IN1,1)=2-JQ + P(IN1,2)=JQ-1 + P(IN1,3)=1D0 + 380 CONTINUE + 390 CONTINUE + KFL(1)=K(IJU(IU),2) + PX(1)=0D0 + PY(1)=0D0 + GAM(1)=0D0 + DO 400 J=1,5 + PJU(IU+3,J)=0D0 + 400 CONTINUE + +C...Junction strings: find initial transverse directions. + DO 410 J=1,4 + DP(1,J)=P(IN(4),J) + DP(2,J)=P(IN(4)+1,J) + DP(3,J)=0D0 + DP(4,J)=0D0 + 410 CONTINUE + DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) + DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) + DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) + DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) + DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) + IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0 + IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0 + IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0 + IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0 + DHC12=DFOUR(1,2) + DHCX1=DFOUR(3,1)/DHC12 + DHCX2=DFOUR(3,2)/DHC12 + DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) + DHCY1=DFOUR(4,1)/DHC12 + DHCY2=DFOUR(4,2)/DHC12 + DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 + DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2) + DO 420 J=1,4 + DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) + P(IN(6),J)=DP(3,J) + P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)- + & DHCYX*DP(3,J)) + 420 CONTINUE + +C...Junction strings: produce new particle, origin. + 430 I=I+1 + IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF + IRANKJ=IRANKJ+1 + K(I,1)=1 + K(I,3)=IE(1) + K(I,4)=0 + K(I,5)=0 + +C...Junction strings: generate flavour, hadron, pT, z and Gamma. + 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2)) + IF(K(I,2).EQ.0) GOTO 360 + IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND. + & IABS(KFL(3)).GT.10) THEN + IF(PYR(0).GT.PARJ(19)) GOTO 440 + ENDIF + P(I,5)=PYMASS(K(I,2)) + CALL PYPTDI(KFL(1),PX(3),PY(3)) + PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2 + CALL PYZDIS(KFL(1),KFL(3),PR(1),Z) + IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND. + & MSTU(90).LT.8) THEN + MSTU(90)=MSTU(90)+1 + MSTU(90+MSTU(90))=I + PARU(90+MSTU(90))=Z + ENDIF + GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z) + DO 450 J=1,3 + IN(J)=IN(3+J) + 450 CONTINUE + +C...Junction strings: stepping within 'low' string region. + IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)* + & P(IN(1),5)**2.GE.PR(1)) THEN + P(IN(1)+2,4)=Z*P(IN(1)+2,3) + P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2) + DO 460 J=1,4 + P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J) + 460 CONTINUE + GOTO 560 +C...Has used up energy of junction string, i.e. no more hadrons in it. + ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN + DO 470 J=1,5 + P(I,J)=0D0 + 470 CONTINUE + GOTO 600 +C...Stepping from 'low' string region + ELSEIF(IN(1)+1.EQ.IN(2)) THEN + P(IN(2)+2,4)=P(IN(2)+2,3) + P(IN(2)+2,1)=1D0 + IN(2)=IN(2)+4 + IF(IN(2).GT.N+NR+4*NS) GOTO 360 + IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN + P(IN(1)+2,4)=P(IN(1)+2,3) + P(IN(1)+2,1)=0D0 + IN(1)=IN(1)+4 + ENDIF + ENDIF + +C...Junction strings: find new transverse directions. + 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR. + & IN(1).GT.IN(2)) GOTO 360 + IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN + DO 490 J=1,4 + DP(1,J)=P(IN(1),J) + DP(2,J)=P(IN(2),J) + DP(3,J)=0D0 + DP(4,J)=0D0 + 490 CONTINUE + DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) + DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) + DHC12=DFOUR(1,2) + IF(DHC12.LE.1D-2) THEN + P(IN(1)+2,4)=P(IN(1)+2,3) + P(IN(1)+2,1)=0D0 + IN(1)=IN(1)+4 + GOTO 480 + ENDIF + IN(3)=N+NR+4*NS+5 + DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) + DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) + DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) + IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0 + IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0 + IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0 + IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0 + DHCX1=DFOUR(3,1)/DHC12 + DHCX2=DFOUR(3,2)/DHC12 + DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) + DHCY1=DFOUR(4,1)/DHC12 + DHCY2=DFOUR(4,2)/DHC12 + DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 + DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2) + DO 500 J=1,4 + DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) + P(IN(3),J)=DP(3,J) + P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)- + & DHCYX*DP(3,J)) + 500 CONTINUE +C...Express pT with respect to new axes, if sensible. + PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3))) + PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1)) + IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN + PX(3)=PXP + PY(3)=PYP + ENDIF + ENDIF + +C...Junction strings: sum up known four-momentum, coefficients for m2. + DO 530 J=1,4 + DHG(J)=0D0 + P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+ + & PY(3)*P(IN(3)+1,J) + DO 510 IN1=IN(4),IN(1)-4,4 + P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J) + 510 CONTINUE + DO 520 IN2=IN(5),IN(2)-4,4 + P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J) + 520 CONTINUE + 530 CONTINUE + DHM(1)=FOUR(I,I) + DHM(2)=2D0*FOUR(I,IN(1)) + DHM(3)=2D0*FOUR(I,IN(2)) + DHM(4)=2D0*FOUR(IN(1),IN(2)) + +C...Junction strings: find coefficients for Gamma expression. + DO 550 IN2=IN(1)+1,IN(2),4 + DO 540 IN1=IN(1),IN2-1,4 + DHC=2D0*FOUR(IN1,IN2) + DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC + IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC + IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC + IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC + 540 CONTINUE + 550 CONTINUE + +C...Junction strings: solve (m2, Gamma) equation system for energies. + DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3) + IF(ABS(DHS1).LT.1D-4) GOTO 360 + DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)* + & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3) + DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1)) + P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/ + & ABS(DHS1)-DHS2/DHS1) + IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360 + P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/ + & (DHM(2)+DHM(4)*P(IN(2)+2,4)) + +C...Junction strings: step to new region if necessary. + IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN + P(IN(2)+2,4)=P(IN(2)+2,3) + P(IN(2)+2,1)=1D0 + IN(2)=IN(2)+4 + IF(IN(2).GT.N+NR+4*NS) GOTO 360 + IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN + P(IN(1)+2,4)=P(IN(1)+2,3) + P(IN(1)+2,1)=0D0 + IN(1)=IN(1)+4 + ENDIF + GOTO 480 + ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN + P(IN(1)+2,4)=P(IN(1)+2,3) + P(IN(1)+2,1)=0D0 + IN(1)=IN(1)+4 + GOTO 480 + ENDIF + +C...Junction strings: particle four-momentum, remainder, loop back. + 560 DO 570 J=1,4 + P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+ + & P(IN(2)+2,4)*P(IN(2),J) + PJU(IU+3,J)=PJU(IU+3,J)+P(I,J) + 570 CONTINUE + IF(P(I,4).LT.P(I,5)) GOTO 360 + PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)- + & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3) + IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN + KFL(1)=-KFL(3) + PX(1)=-PX(3) + PY(1)=-PY(3) + GAM(1)=GAM(3) + IF(IN(3).NE.IN(6)) THEN + DO 580 J=1,4 + P(IN(6),J)=P(IN(3),J) + P(IN(6)+1,J)=P(IN(3)+1,J) + 580 CONTINUE + ENDIF + DO 590 JQ=1,2 + IN(3+JQ)=IN(JQ) + P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4) + P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4) + 590 CONTINUE + GOTO 430 + ENDIF + +C...Junction strings: save quantities left after each string. + IF(IABS(KFL(1)).GT.10) GOTO 360 + 600 I=I-1 + KFJH(IU)=KFL(1) + DO 610 J=1,4 + PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J) + 610 CONTINUE + +C...Junction strings: loopback if much unused energy in both strings. + PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)- + & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3) + EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5) + 620 CONTINUE + IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR. + & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR. + & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50)) + & .AND.NTRYER.LT.10) GOTO 320 + +C...Junction strings: put together to new effective string endpoint. + NJS(JT)=I-ISTA + KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1 + IF(KFJH(1).EQ.KFJH(2)) KFLS=3 + KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+ + & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1)) + DO 630 J=1,4 + PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J) + PJS(JT+2,J)=PJU(4,J)+PJU(5,J) + 630 CONTINUE + PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2- + & PJS(JT,3)**2)) + PJS(JT+2,5)=0D0 + 640 CONTINUE + +C...Open versus closed strings. Choose breakup region for latter. + 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN + NS=MJU(2)-MJU(1) + NB=MJU(1)-N + ELSEIF(MJU(1).NE.0) THEN + NS=N+NR-MJU(1) + NB=MJU(1)-N + ELSEIF(MJU(2).NE.0) THEN + NS=MJU(2)-N + NB=1 + ELSEIF(IABS(K(N+1,2)).NE.21) THEN + NS=NR-1 + NB=1 + ELSE + NS=NR+1 + W2SUM=0D0 + DO 660 IS=1,NR + P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR)) + W2SUM=W2SUM+P(N+NR+IS,1) + 660 CONTINUE + W2RAN=PYR(0)*W2SUM + NB=0 + 670 NB=NB+1 + W2SUM=W2SUM-P(N+NR+NB,1) + IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670 + ENDIF + +C...Find longitudinal string directions (i.e. lightlike four-vectors). + DO 700 IS=1,NS + IS1=N+IS+NB-1-NR*((IS+NB-2)/NR) + IS2=N+IS+NB-NR*((IS+NB-1)/NR) + DO 680 J=1,5 + DP(1,J)=P(IS1,J) + IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J) + IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J) + DP(2,J)=P(IS2,J) + IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J) + IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J) + 680 CONTINUE + IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2- + & DP(1,2)**2-DP(1,3)**2)) + IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2- + & DP(2,2)**2-DP(2,3)**2)) + DP(3,5)=DFOUR(1,1) + DP(4,5)=DFOUR(2,2) + DHKC=DFOUR(1,2) + IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200 + DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5)) + DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0) + DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0) + IN1=N+NR+4*IS-3 + P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5)) + DO 690 J=1,4 + P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J) + P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J) + 690 CONTINUE + 700 CONTINUE + +C...Begin initialization: sum up energy, set starting position. + ISAV=I + MSTU91=MSTU(90) + 710 NTRY=NTRY+1 + IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN + PARU12=4D0*PARU12 + PARU13=2D0*PARU13 + GOTO 140 + ELSEIF(NTRY.GT.100) THEN + CALL PYERRM(14,'(PYSTRF:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + I=ISAV + MSTU(90)=MSTU91 + DO 730 J=1,4 + P(N+NRS,J)=0D0 + DO 720 IS=1,NR + P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J) + 720 CONTINUE + 730 CONTINUE + DO 750 JT=1,2 + IRANK(JT)=0 + IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT) + IF(NS.GT.NR) IRANK(JT)=1 + IBARRK(JT)=0 + IE(JT)=K(N+1+(JT/2)*(NP-1),3) + IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1) + IN(3*JT+2)=IN(3*JT+1)+1 + IN(3*JT+3)=N+NR+4*NS+2*JT-1 + DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4 + P(IN1,1)=2-JT + P(IN1,2)=JT-1 + P(IN1,3)=1D0 + 740 CONTINUE + 750 CONTINUE + +C.. MOPS variables and switches + NRVMO=0 + XBMO=1D0 + MSTU(121)=0 + MSTU(122)=0 + +C...Initialize flavour and pT variables for open string. + IF(NS.LT.NR) THEN + PX(1)=0D0 + PY(1)=0D0 + IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1)) + PX(2)=-PX(1) + PY(2)=-PY(1) + DO 760 JT=1,2 + KFL(JT)=K(IE(JT),2) + IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT) + IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1 + MSTJ(93)=1 + PMQ(JT)=PYMASS(KFL(JT)) + GAM(JT)=0D0 + 760 CONTINUE + +C...Closed string: random initial breakup flavour, pT and vertex. + ELSE + KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0) + IBMO=0 + 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP) +C.. Closed string: first vertex diq attempt => enforced second +C.. vertex diq + IF(IABS(KFL(1)).GT.10)THEN + IBMO=1 + MSTU(121)=0 + GOTO 770 + ENDIF + IF(IBMO.EQ.1) MSTU(121)=-1 + KFL(2)=-KFL(1) + CALL PYPTDI(KFL(1),PX(1),PY(1)) + PX(2)=-PX(1) + PY(2)=-PY(1) + PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2) + 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z) + ZR=PR3/(Z*P(N+NR+1,5)**2) + IF(ZR.GE.1D0) GOTO 780 + DO 790 JT=1,2 + MSTJ(93)=1 + PMQ(JT)=PYMASS(KFL(JT)) + GAM(JT)=PR3*(1D0-Z)/Z + IN1=N+NR+3+4*(JT/2)*(NS-1) + P(IN1,JT)=1D0-Z + P(IN1,3-JT)=JT-1 + P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z + P(IN1+1,JT)=ZR + P(IN1+1,3-JT)=2-JT + P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR + 790 CONTINUE + ENDIF +C.. MOPS variables + DO 800 JT=1,2 + XTMO(JT)=1D0 + PM2QMO(JT)=PMQ(JT)**2 + IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0 + 800 CONTINUE + +C...Find initial transverse directions (i.e. spacelike four-vectors). + DO 840 JT=1,2 + IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN + IN1=IN(3*JT+1) + IN3=IN(3*JT+3) + DO 810 J=1,4 + DP(1,J)=P(IN1,J) + DP(2,J)=P(IN1+1,J) + DP(3,J)=0D0 + DP(4,J)=0D0 + 810 CONTINUE + DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) + DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) + DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) + DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) + DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) + IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0 + IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0 + IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0 + IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0 + DHC12=DFOUR(1,2) + DHCX1=DFOUR(3,1)/DHC12 + DHCX2=DFOUR(3,2)/DHC12 + DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) + DHCY1=DFOUR(4,1)/DHC12 + DHCY2=DFOUR(4,2)/DHC12 + DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 + DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2) + DO 820 J=1,4 + DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) + P(IN3,J)=DP(3,J) + P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)- + & DHCYX*DP(3,J)) + 820 CONTINUE + ELSE + DO 830 J=1,4 + P(IN3+2,J)=P(IN3,J) + P(IN3+3,J)=P(IN3+1,J) + 830 CONTINUE + ENDIF + 840 CONTINUE + +C...Remove energy used up in junction string fragmentation. + IF(MJU(1)+MJU(2).GT.0) THEN + DO 860 JT=1,2 + IF(NJS(JT).EQ.0) GOTO 860 + DO 850 J=1,4 + P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J) + 850 CONTINUE + 860 CONTINUE + PARJST=PARJ(33) + IF(MSTJ(11).EQ.2) PARJST=PARJ(34) + WMIN=PARJST+PMQ(1)+PMQ(2) + WREM2=FOUR(N+NRS,N+NRS) + IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN + NTRYWR=NTRYWR+1 + IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1 + GOTO 140 + ENDIF + ENDIF + +C...Produce new particle: side, origin. + 870 I=I+1 + IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF +C.. New side priority for popcorn systems + IF(MSTU(121).LE.0)THEN + JT=1.5D0+PYR(0) + IF(IABS(KFL(3-JT)).GT.10) JT=3-JT + IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT + ENDIF + JR=3-JT + JS=3-2*JT + IRANK(JT)=IRANK(JT)+1 + K(I,1)=1 + K(I,4)=0 + K(I,5)=0 + +C...Generate flavour, hadron and pT. + 880 K(I,3)=IE(JT) + CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2)) + IF(K(I,2).EQ.0) GOTO 710 + MU90MO=MSTU(90) + IF(MSTU(121).EQ.-1) GOTO 910 + IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND. + &IABS(KFL(3)).GT.10) THEN + IF(PYR(0).GT.PARJ(19)) GOTO 880 + ENDIF + IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000) + &K(I,3)=IJUORI(JT) + P(I,5)=PYMASS(K(I,2)) + CALL PYPTDI(KFL(JT),PX(3),PY(3)) + PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2 + +C...Final hadrons for small invariant mass. + MSTJ(93)=1 + PMQ(3)=PYMASS(KFL(3)) + PARJST=PARJ(33) + IF(MSTJ(11).EQ.2) PARJST=PARJ(34) + WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3) + IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN= + &WMIN-0.5D0*PARJ(36)*PMQ(3) + WREM2=FOUR(N+NRS,N+NRS) + IF(WREM2.LT.0.10D0) GOTO 710 + IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)), + &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080 + +C...Choose z, which gives Gamma. Shift z for heavy flavours. + CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z) + IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND. + &MSTU(90).LT.8) THEN + MSTU(90)=MSTU(90)+1 + MSTU(90+MSTU(90))=I + PARU(90+MSTU(90))=Z + ENDIF + KFL1A=IABS(KFL(1)) + KFL2A=IABS(KFL(2)) + IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10), + &MOD(KFL2A/1000,10)).GE.4) THEN + PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2 + PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2))) + Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2) + PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2 + IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080 + ENDIF + GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z) + +C.. MOPS baryon model modification + XTMO3=(1D0-Z)*XTMO(JT) + IF(IABS(KFL(3)).LE.10) NRVMO=0 + IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN + GTSTMO=1D0 + PTSTMO=1D0 + RTSTMO=PYR(0) + IF(IABS(KFL(JT)).LE.10)THEN + XBMO=MIN(XTMO3,1D0-(2D-10)) + GBMO=GAM(3) + PMMO=0D0 + PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT) + GTSTMO=1D0-PARF(192)**PGMO + ELSE + IF(IRANK(JT).EQ.1) THEN + GBMO=GAM(JT) + PMMO=0D0 + XBMO=1D0 + ENDIF + IF(XBMO.LT.1D0-(1D-10))THEN + PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3) + GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO) + PGMO=PGNMO + ENDIF + IF(MSTJ(12).GE.5)THEN + PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO)) + PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3) + PTSTMO=EXP((PMMO-PMNMO)*PARF(193)) + PMMO=PMNMO + ENDIF + ENDIF + +C.. MOPS Accepting popcorn system hadron. + IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN + IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN + NRVMO=I-N-NR + IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11, + & '(PYSTRF:) no more memory left in PYJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF + IMO=I + KFLMO=KFL(JT) + PMQMO=PMQ(JT) + PXMO=PX(JT) + PYMO=PY(JT) + GAMMO=GAM(JT) + IRMO=IRANK(JT) + XMO=XTMO(JT) + DO 900 J=1,9 + IF(J.LE.5) THEN + DO 890 LINE=1,I-N-NR + P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J) + K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J) + 890 CONTINUE + ENDIF + INMO(J)=IN(J) + 900 CONTINUE + ENDIF + ELSE +C..Reject popcorn system, flag=-1 if enforcing new one + MSTU(121)=-1 + IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2 + ENDIF + ENDIF + + +C..Lift restoring string outside MOPS block + 910 IF(MSTU(121).LT.0) THEN + IF(MSTU(121).EQ.-2) MSTU(121)=0 + MSTU(90)=MU90MO + NRVMO=0 + IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880 + I=IMO + KFL(JT)=KFLMO + PMQ(JT)=PMQMO + PX(JT)=PXMO + PY(JT)=PYMO + GAM(JT)=GAMMO + IRANK(JT)=IRMO + XTMO(JT)=XMO + DO 930 J=1,9 + IF(J.LE.5) THEN + DO 920 LINE=1,I-N-NR + P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J) + K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J) + 920 CONTINUE + ENDIF + IN(J)=INMO(J) + 930 CONTINUE + GOTO 880 + ENDIF + XTMO(JT)=XTMO3 +C.. MOPS end of modification + + DO 940 J=1,3 + IN(J)=IN(3*JT+J) + 940 CONTINUE + +C...Stepping within or from 'low' string region easy. + IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)* + &P(IN(1),5)**2.GE.PR(JT)) THEN + P(IN(JT)+2,4)=Z*P(IN(JT)+2,3) + P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2) + DO 950 J=1,4 + P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J) + 950 CONTINUE + GOTO 1040 + ELSEIF(IN(1)+1.EQ.IN(2)) THEN + P(IN(JR)+2,4)=P(IN(JR)+2,3) + P(IN(JR)+2,JT)=1D0 + IN(JR)=IN(JR)+4*JS + IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710 + IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN + P(IN(JT)+2,4)=P(IN(JT)+2,3) + P(IN(JT)+2,JT)=0D0 + IN(JT)=IN(JT)+4*JS + ENDIF + ENDIF + +C...Find new transverse directions (i.e. spacelike string vectors). + 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR. + &IN(1).GT.IN(2)) GOTO 710 + IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN + DO 970 J=1,4 + DP(1,J)=P(IN(1),J) + DP(2,J)=P(IN(2),J) + DP(3,J)=0D0 + DP(4,J)=0D0 + 970 CONTINUE + DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2) + DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2) + DHC12=DFOUR(1,2) + IF(DHC12.LE.1D-2) THEN + P(IN(JT)+2,4)=P(IN(JT)+2,3) + P(IN(JT)+2,JT)=0D0 + IN(JT)=IN(JT)+4*JS + GOTO 960 + ENDIF + IN(3)=N+NR+4*NS+5 + DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4) + DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4) + DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4) + IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0 + IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0 + IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0 + IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0 + DHCX1=DFOUR(3,1)/DHC12 + DHCX2=DFOUR(3,2)/DHC12 + DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12) + DHCY1=DFOUR(4,1)/DHC12 + DHCY2=DFOUR(4,2)/DHC12 + DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12 + DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2) + DO 980 J=1,4 + DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J)) + P(IN(3),J)=DP(3,J) + P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)- + & DHCYX*DP(3,J)) + 980 CONTINUE +C...Express pT with respect to new axes, if sensible. + PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)* + & FOUR(IN(3*JT+3)+1,IN(3))) + PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)* + & FOUR(IN(3*JT+3)+1,IN(3)+1)) + IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN + PX(3)=PXP + PY(3)=PYP + ENDIF + ENDIF + +C...Sum up known four-momentum. Gives coefficients for m2 expression. + DO 1010 J=1,4 + DHG(J)=0D0 + P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+ + & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J) + DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS + P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J) + 990 CONTINUE + DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS + P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J) + 1000 CONTINUE + 1010 CONTINUE + DHM(1)=FOUR(I,I) + DHM(2)=2D0*FOUR(I,IN(1)) + DHM(3)=2D0*FOUR(I,IN(2)) + DHM(4)=2D0*FOUR(IN(1),IN(2)) + +C...Find coefficients for Gamma expression. + DO 1030 IN2=IN(1)+1,IN(2),4 + DO 1020 IN1=IN(1),IN2-1,4 + DHC=2D0*FOUR(IN1,IN2) + DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC + IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC + IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC + IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC + 1020 CONTINUE + 1030 CONTINUE + +C...Solve (m2, Gamma) equation system for energies taken. + DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1) + IF(ABS(DHS1).LT.1D-4) GOTO 710 + DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)* + &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1) + DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1)) + P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/ + &ABS(DHS1)-DHS2/DHS1) + IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710 + P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/ + &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4)) + +C...Step to new region if necessary. + IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN + P(IN(JR)+2,4)=P(IN(JR)+2,3) + P(IN(JR)+2,JT)=1D0 + IN(JR)=IN(JR)+4*JS + IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710 + IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN + P(IN(JT)+2,4)=P(IN(JT)+2,3) + P(IN(JT)+2,JT)=0D0 + IN(JT)=IN(JT)+4*JS + ENDIF + GOTO 960 + ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN + P(IN(JT)+2,4)=P(IN(JT)+2,3) + P(IN(JT)+2,JT)=0D0 + IN(JT)=IN(JT)+4*JS + GOTO 960 + ENDIF + +C...Four-momentum of particle. Remaining quantities. Loop back. + 1040 DO 1050 J=1,4 + P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J) + P(N+NRS,J)=P(N+NRS,J)-P(I,J) + 1050 CONTINUE + IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR. + &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14)) + &GOTO 200 + IF(P(I,4).LT.P(I,5)) GOTO 710 + KFL(JT)=-KFL(3) + PMQ(JT)=PMQ(3) + PX(JT)=-PX(3) + PY(JT)=-PY(3) + GAM(JT)=GAM(3) + IF(IN(3).NE.IN(3*JT+3)) THEN + DO 1060 J=1,4 + P(IN(3*JT+3),J)=P(IN(3),J) + P(IN(3*JT+3)+1,J)=P(IN(3)+1,J) + 1060 CONTINUE + ENDIF + DO 1070 JQ=1,2 + IN(3*JT+JQ)=IN(JQ) + P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4) + P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4) + 1070 CONTINUE + IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000) + &IBARRK(JT)=0 + GOTO 870 + +C...Final hadron: side, flavour, hadron, mass. + 1080 I=I+1 + K(I,1)=1 + K(I,3)=IE(JR) + K(I,4)=0 + K(I,5)=0 + CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2)) + IF(K(I,2).EQ.0) GOTO 710 + IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000) + &IBARRK(JT)=0 + IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000) + &K(I,3)=IJUORI(JT) + IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000) + &K(I,3)=IJUORI(JR) + P(I,5)=PYMASS(K(I,2)) + PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2 + +C...Final two hadrons: find common setup of four-vectors. + JQ=1 + IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT. + &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2 + DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2)) + DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12 + DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12 + IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN + PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ) + PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ) + PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS* + & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2 + ENDIF + +C...Solve kinematics for final two hadrons, if possible. + WREM2=2D0*DHR1*DHR2*DHC12 + FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2) + IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200 + IF(FD.GE.1D0) GOTO 710 + FA=WREM2+PR(JT)-PR(JR) + FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT))) + PREVCF=PARJ(42) + IF(MSTJ(11).EQ.2) PREVCF=PARJ(39) + PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40)))) + FB=SIGN(FB,JS*(PYR(0)-PREV)) + KFL1A=IABS(KFL(1)) + KFL2A=IABS(KFL(2)) + IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10), + &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2- + &4D0*WREM2*PR(JT))),DBLE(JS)) + DO 1090 J=1,4 + P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))* + & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+ + & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2 + P(I,J)=P(N+NRS,J)-P(I-1,J) + 1090 CONTINUE + IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710 + DM2F1=P(I-1,4)**2-P(I-1,1)**2-P(I-1,2)**2-P(I-1,3)**2-P(I-1,5)**2 + DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2 + IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN + NTRYFN=NTRYFN+1 + IF(NTRYFN.LT.100) GOTO 140 + CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons') + ENDIF + +C...Mark jets as fragmented and give daughter pointers. + N=I-NRS+1 + DO 1100 I=NSAV+1,NSAV+NP + IM=K(I,3) + K(IM,1)=K(IM,1)+10 + IF(MSTU(16).NE.2) THEN + K(IM,4)=NSAV+1 + K(IM,5)=NSAV+1 + ELSE + K(IM,4)=NSAV+2 + K(IM,5)=N + ENDIF + 1100 CONTINUE + +C...Document string system. Move up particles. + NSAV=NSAV+1 + K(NSAV,1)=11 + K(NSAV,2)=92 + K(NSAV,3)=IP + K(NSAV,4)=NSAV+1 + K(NSAV,5)=N + DO 1110 J=1,4 + P(NSAV,J)=DPS(J) + V(NSAV,J)=V(IP,J) + 1110 CONTINUE + P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2)) + V(NSAV,5)=0D0 + DO 1130 I=NSAV+1,N + DO 1120 J=1,5 + K(I,J)=K(I+NRS-1,J) + P(I,J)=P(I+NRS-1,J) + V(I,J)=0D0 + 1120 CONTINUE + 1130 CONTINUE + MSTU91=MSTU(90) + DO 1140 IZ=MSTU90+1,MSTU91 + MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N + PARU9T(IZ)=PARU(90+IZ) + 1140 CONTINUE + MSTU(90)=MSTU90 + +C...Order particles in rank along the chain. Update mother pointer. + DO 1160 I=NSAV+1,N + DO 1150 J=1,5 + K(I-NSAV+N,J)=K(I,J) + P(I-NSAV+N,J)=P(I,J) + 1150 CONTINUE + 1160 CONTINUE + I1=NSAV + DO 1190 I=N+1,2*N-NSAV + IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190 + I1=I1+1 + DO 1170 J=1,5 + K(I1,J)=K(I,J) + P(I1,J)=P(I,J) + 1170 CONTINUE + IF(MSTU(16).NE.2) K(I1,3)=NSAV + DO 1180 IZ=MSTU90+1,MSTU91 + IF(MSTU9T(IZ).EQ.I) THEN + MSTU(90)=MSTU(90)+1 + MSTU(90+MSTU(90))=I1 + PARU(90+MSTU(90))=PARU9T(IZ) + ENDIF + 1180 CONTINUE + 1190 CONTINUE + DO 1220 I=2*N-NSAV,N+1,-1 + IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220 + I1=I1+1 + DO 1200 J=1,5 + K(I1,J)=K(I,J) + P(I1,J)=P(I,J) + 1200 CONTINUE + IF(MSTU(16).NE.2) K(I1,3)=NSAV + DO 1210 IZ=MSTU90+1,MSTU91 + IF(MSTU9T(IZ).EQ.I) THEN + MSTU(90)=MSTU(90)+1 + MSTU(90+MSTU(90))=I1 + PARU(90+MSTU(90))=PARU9T(IZ) + ENDIF + 1210 CONTINUE + 1220 CONTINUE + +C...Boost back particle system. Set production vertices. + IF(MBST.EQ.0) THEN + MSTU(33)=1 + CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4), + & DPS(3)/DPS(4)) + ELSE + DO 1230 I=NSAV+1,N + HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2 + IF(P(I,3).GT.0D0) THEN + HHPEZ=(P(I,4)+P(I,3))*HHBZ + P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ) + P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ) + ELSE + HHPEZ=(P(I,4)-P(I,3))/HHBZ + P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ) + P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ) + ENDIF + 1230 CONTINUE + ENDIF + DO 1250 I=NSAV+1,N + DO 1240 J=1,4 + V(I,J)=V(IP,J) + 1240 CONTINUE + 1250 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYJURF +C...From three given input vectors in PJU the boost VJU from +C...the "lab frame" to the junction rest frame is constructed. + + SUBROUTINE PYJURF(PJU,VJU) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...Input, output and local arrays. + DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5) + DATA TWOPI/6.283186D0/ + +C...Calculate masses and other invariants. + DO 100 J=1,4 + PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J) + 100 CONTINUE + PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2 + PSUM(5)=SQRT(PSUM2) + DO 120 I=1,3 + DO 110 J=1,3 + A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)- + & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3) + 110 CONTINUE + 120 CONTINUE + +C...Pick I to be most massive parton and J to be the one closest to I. + ITRY=0 + I=1 + IF(A(2,2).GT.A(1,1)) I=2 + IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3 + 130 ITRY=ITRY+1 + J=1+MOD(I,3) + K=1+MOD(J,3) + IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN + K=1+MOD(I,3) + J=1+MOD(K,3) + ENDIF + PMI2=A(I,I) + PMJ2=A(J,J) + PMK2=A(K,K) + AIJ=A(I,J) + AIK=A(I,K) + AJK=A(J,K) + +C...Trivial find new parton energies if all three partons are massless. + IF(PMI2.LT.1D-4) THEN + PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK)) + PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK)) + PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ)) + +C...Else find momentum range for parton I and values at extremes. + ELSE + PAIMIN=0D0 + PEIMIN=SQRT(PMI2) + PEJMIN=AIJ/PEIMIN + PEKMIN=AIK/PEIMIN + PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2)) + PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2)) + FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK + PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK) + IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2) + PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2)) + HI=PEIMAX**2-0.25D0*PAIMAX**2 + PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))- + & 0.5D0*PAIMAX*AIJ)/HI + PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))- + & 0.5D0*PAIMAX*AIK)/HI + PEJMAX=SQRT(PAJMAX**2+PMJ2) + PEKMAX=SQRT(PAKMAX**2+PMK2) + FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK + +C...If unexpected values at upper endpoint then pick another parton. + IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN + I1=1+MOD(I,3) + IF(A(I1,I1).GE.1D-4) THEN + I=I1 + GOTO 130 + ENDIF + ITRY=ITRY+1 + I1=1+MOD(I,3) + IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN + I=I1 + GOTO 130 + ENDIF + ENDIF + +C..Start binary + linear search to find solution inside range. + ITER=0 + ITMIN=0 + ITMAX=0 + PAI=0.5D0*(PAIMIN+PAIMAX) + 140 ITER=ITER+1 + +C...Derive momentum of other two partons and distance to root. + PEI=SQRT(PAI**2+PMI2) + HI=PEI**2-0.25D0*PAI**2 + PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI + PEJ=SQRT(PAJ**2+PMJ2) + PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI + PEK=SQRT(PAK**2+PMK2) + FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK + +C...Pick next I momentum to explore, hopefully closer to root. + IF(FNOW.GT.0D0) THEN + PAIMIN=PAI + FMIN=FNOW + ITMIN=ITMIN+1 + ELSE + PAIMAX=PAI + FMAX=FNOW + ITMAX=ITMAX+1 + ENDIF + IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20) + & THEN + PAI=0.5D0*(PAIMIN+PAIMAX) + GOTO 140 + ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND. + & ABS(FNOW).GT.1D-12*PSUM2) THEN + PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX) + GOTO 140 + ENDIF + ENDIF + +C...Now know energies in junction rest frame. + PENEW(I)=PEI + PENEW(J)=PEJ + PENEW(K)=PEK + +C...Boost (copy of) partons to their rest frame. + VXCM=-PSUM(1)/PSUM(5) + VYCM=-PSUM(2)/PSUM(5) + VZCM=-PSUM(3)/PSUM(5) + GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2) + DO 150 I=1,3 + FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM + FAC2=FAC1/(1D0+GAMCM)+PJU(I,4) + PCM(I,1)=PJU(I,1)+FAC2*VXCM + PCM(I,2)=PJU(I,2)+FAC2*VYCM + PCM(I,3)=PJU(I,3)+FAC2*VZCM + PCM(I,4)=PJU(I,4)*GAMCM+FAC1 + PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2) + 150 CONTINUE + +C...Construct difference vectors and boost to junction rest frame. + DO 160 J=1,3 + PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4) + PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4) + 160 CONTINUE + PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4) + PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4) + PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2 + PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2 + PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3) + C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2) + C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2) + VXJU=C4*PCM(4,1)+C5*PCM(5,1) + VYJU=C4*PCM(4,2)+C5*PCM(5,2) + VZJU=C4*PCM(4,3)+C5*PCM(5,3) + GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2) + +C...Add two boosts, giving final result. + FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU + VJU(1)=VXJU+FCM*VXCM + VJU(2)=VYJU+FCM*VYCM + VJU(3)=VZJU+FCM*VZCM + VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2) + VJU(5)=1D0 + +C...In case of error in reconstruction: revert to CM frame of system. + CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/ + &(PCM(1,5)*PCM(2,5)) + CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/ + &(PCM(1,5)*PCM(3,5)) + CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/ + &(PCM(2,5)*PCM(3,5)) + ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2 + ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23) + DO 170 I=1,3 + FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3) + FAC2=FAC1/(1D0+VJU(4))+PJU(I,4) + PCM(I,1)=PJU(I,1)+FAC2*VJU(1) + PCM(I,2)=PJU(I,2)+FAC2*VJU(2) + PCM(I,3)=PJU(I,3)+FAC2*VJU(3) + PCM(I,4)=PJU(I,4)*VJU(4)+FAC1 + PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2) + 170 CONTINUE + CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/ + &(PCM(1,5)*PCM(2,5)) + CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/ + &(PCM(1,5)*PCM(3,5)) + CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/ + &(PCM(2,5)*PCM(3,5)) + ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2 + ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23) + IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN + VJU(1)=VXCM + VJU(2)=VYCM + VJU(3)=VZCM + VJU(4)=GAMCM + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYINDF +C...Handles the fragmentation of a jet system (or a single +C...jet) according to independent fragmentation models. + + SUBROUTINE PYINDF(IP) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/ +C...Local arrays. + DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3), + &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3) + CHARACTER CIDC*4 + DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/ + +C...Functions: momentum in two-particle decays and four-product. + PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A) + FOUR(I,J)=P(I,4)*P(J,4)-P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3) + +C...Initial values. + NTRY=0 + NSAV=N + KFA=IABS(K(IP,2)) + KFS=ISIGN(1,K(IP,2)) + KC=PYCOMP(KFA) + MSTJ(92)=0 + +C...Choose lifetime and determine decay vertex. + IF(K(IP,1).EQ.5) THEN + V(IP,5)=0D0 + ELSEIF(K(IP,1).NE.4) THEN + V(IP,5)=-PMAS(KC,4)*LOG(PYR(0)) + ENDIF + DO 100 J=1,4 + VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5) + 100 CONTINUE + +C...Determine whether decay allowed or not. + MOUT=0 + IF(MSTJ(22).EQ.2) THEN + IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1 + ELSEIF(MSTJ(22).EQ.3) THEN + IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1 + ELSEIF(MSTJ(22).EQ.4) THEN + IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1 + IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1 + ENDIF + IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN + K(IP,1)=4 + RETURN + ENDIF + +C...Interface to external tau decay library (for tau polarization). + IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN + +C...Starting values for pointers and momenta. + ITAU=IP + DO 110 J=1,4 + PTAU(J)=P(ITAU,J) + PCMTAU(J)=P(ITAU,J) + 110 CONTINUE + +C...Iterate to find position and code of mother of tau. + IMTAU=ITAU + 120 IMTAU=K(IMTAU,3) + + IF(IMTAU.EQ.0) THEN +C...If no known origin then impossible to do anything further. + KFORIG=0 + IORIG=0 + + ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN +C...If tau -> tau + gamma then add gamma energy and loop. + IF(K(K(IMTAU,4),2).EQ.22) THEN + DO 130 J=1,4 + PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J) + 130 CONTINUE + ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN + DO 140 J=1,4 + PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J) + 140 CONTINUE + ENDIF + GOTO 120 + + ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN +C...If coming from weak decay of hadron then W is not stored in record, +C...but can be reconstructed by adding neutrino momentum. + KFORIG=-ISIGN(24,K(ITAU,2)) + IORIG=0 + DO 160 II=K(IMTAU,4),K(IMTAU,5) + IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN + DO 150 J=1,4 + PCMTAU(J)=PCMTAU(J)+P(II,J) + 150 CONTINUE + ENDIF + 160 CONTINUE + + ELSE +C...If coming from resonance decay then find latest copy of this +C...resonance (may not completely agree). + KFORIG=K(IMTAU,2) + IORIG=IMTAU + DO 170 II=IMTAU+1,IP-1 + IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND. + & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II + 170 CONTINUE + DO 180 J=1,4 + PCMTAU(J)=P(IORIG,J) + 180 CONTINUE + ENDIF + +C...Boost tau to rest frame of production process (where known) +C...and rotate it to sit along +z axis. + DO 190 J=1,3 + DBETAU(J)=PCMTAU(J)/PCMTAU(4) + 190 CONTINUE + IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1), + & -DBETAU(2),-DBETAU(3)) + PHITAU=PYANGL(P(ITAU,1),P(ITAU,2)) + CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0) + THETAU=PYANGL(P(ITAU,3),P(ITAU,1)) + CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0) + +C...Call tau decay routine (if meaningful) and fill extra info. + IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN + CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY) + DO 200 II=NSAV+1,NSAV+NDECAY + K(II,1)=1 + K(II,3)=IP + K(II,4)=0 + K(II,5)=0 + 200 CONTINUE + N=NSAV+NDECAY + ENDIF + +C...Boost back decay tau and decay products. + DO 210 J=1,4 + P(ITAU,J)=PTAU(J) + 210 CONTINUE + IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN + CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0) + IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1), + & DBETAU(2),DBETAU(3)) + +C...Skip past ordinary tau decay treatment. + MMAT=0 + MBST=0 + ND=0 + GOTO 630 + ENDIF + ENDIF + +C...B-Bbar mixing: flip sign of meson appropriately. + MMIX=0 + IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN + XBBMIX=PARJ(76) + IF(KFA.EQ.531) XBBMIX=PARJ(77) + IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1 + IF(MMIX.EQ.1) KFS=-KFS + ENDIF + +C...Check existence of decay channels. Particle/antiparticle rules. + KCA=KC + IF(MDCY(KC,2).GT.0) THEN + MDMDCY=MDME(MDCY(KC,2),2) + IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY + ENDIF + IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN + CALL PYERRM(9,'(PYDECY:) no decay channel defined') + RETURN + ENDIF + IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS + IF(KCHG(KC,3).EQ.0) THEN + KFSP=1 + KFSN=0 + IF(PYR(0).GT.0.5D0) KFS=-KFS + ELSEIF(KFS.GT.0) THEN + KFSP=1 + KFSN=0 + ELSE + KFSP=0 + KFSN=1 + ENDIF + +C...Sum branching ratios of allowed decay channels. + 220 NOPE=0 + BRSU=0D0 + DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1 + IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND. + & KFSN*MDME(IDL,1).NE.3) GOTO 230 + IF(MDME(IDL,2).GT.100) GOTO 230 + NOPE=NOPE+1 + BRSU=BRSU+BRAT(IDL) + 230 CONTINUE + IF(NOPE.EQ.0) THEN + CALL PYERRM(2,'(PYDECY:) all decay channels closed by user') + RETURN + ENDIF + +C...Select decay channel among allowed ones. + 240 RBR=BRSU*PYR(0) + IDL=MDCY(KCA,2)-1 + 250 IDL=IDL+1 + IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND. + &KFSN*MDME(IDL,1).NE.3) THEN + IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250 + ELSEIF(MDME(IDL,2).GT.100) THEN + IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250 + ELSE + IDC=IDL + RBR=RBR-BRAT(IDL) + IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250 + ENDIF + +C...Start readout of decay channel: matrix element, reset counters. + MMAT=MDME(IDC,2) + 260 NTRY=NTRY+1 + IF(MOD(NTRY,200).EQ.0) THEN + WRITE(CIDC,'(I4)') IDC +C...Do not print warning for some well-known special cases. + IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215) + & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'// + & CIDC) + GOTO 240 + ENDIF + IF(NTRY.GT.1000) THEN + CALL PYERRM(14,'(PYDECY:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + I=N + NP=0 + NQ=0 + MBST=0 + IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1 + DO 270 J=1,4 + PV(1,J)=0D0 + IF(MBST.EQ.0) PV(1,J)=P(IP,J) + 270 CONTINUE + IF(MBST.EQ.1) PV(1,4)=P(IP,5) + PV(1,5)=P(IP,5) + PS=0D0 + PSQ=0D0 + MREM=0 + MHADDY=0 + IF(KFA.GT.80) MHADDY=1 +C.. Random flavour and popcorn system memory. + IRNDMO=0 + JTMO=0 + MSTU(121)=0 + MSTU(125)=10 + +C...Read out decay products. Convert to standard flavour code. + JTMAX=5 + IF(MDME(IDC+1,2).EQ.101) JTMAX=10 + DO 280 JT=1,JTMAX + IF(JT.LE.5) KP=KFDP(IDC,JT) + IF(JT.GE.6) KP=KFDP(IDC+1,JT-5) + IF(KP.EQ.0) GOTO 280 + KPA=IABS(KP) + KCP=PYCOMP(KPA) + IF(KPA.GT.80) MHADDY=1 + IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN + KFP=KP + ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN + KFP=KFS*KP + ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN + KFP=-KFS*MOD(KFA/10,10) + ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN + KFP=KFS*(100*MOD(KFA/10,100)+3) + ELSEIF(KPA.EQ.81) THEN + KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1) + ELSEIF(KP.EQ.82) THEN + CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP) + IF(KFP.EQ.0) GOTO 260 + KFP=-KFP + IRNDMO=1 + MSTJ(93)=1 + IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260 + ELSEIF(KP.EQ.-82) THEN + KFP=MSTU(124) + ENDIF + IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP) + +C...Add decay product to event record or to quark flavour list. + KFPA=IABS(KFP) + KQP=KCHG(KCP,2) + IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN + NQ=NQ+1 + KFLO(NQ)=KFP +C...set rndmflav popcorn system pointer + IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ + MSTJ(93)=2 + PSQ=PSQ+PYMASS(KFLO(NQ)) + ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND. + & MOD(NQ,2).EQ.1) THEN + NQ=NQ-1 + PS=PS-P(I,5) + K(I,1)=1 + KFI=K(I,2) + CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2)) + IF(K(I,2).EQ.0) GOTO 260 + MSTJ(93)=1 + P(I,5)=PYMASS(K(I,2)) + PS=PS+P(I,5) + ELSE + I=I+1 + NP=NP+1 + IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1 + IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1 + K(I,1)=1+MOD(NQ,2) + IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2 + IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1 + K(I,2)=KFP + K(I,3)=IP + K(I,4)=0 + K(I,5)=0 + P(I,5)=PYMASS(KFP) + PS=PS+P(I,5) + ENDIF + 280 CONTINUE + +C...Check masses for resonance decays. + IF(MHADDY.EQ.0) THEN + IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240 + ENDIF + +C...Choose decay multiplicity in phase space model. + 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN + PSP=PS + CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0)) + IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63) + 300 NTRY=NTRY+1 +C...Reset popcorn flags if new attempt. Re-select rndmflav if failed. + IF(IRNDMO.EQ.0) THEN + MSTU(121)=0 + JTMO=0 + ELSEIF(IRNDMO.EQ.1) THEN + IRNDMO=2 + ELSE + GOTO 260 + ENDIF + IF(NTRY.GT.1000) THEN + CALL PYERRM(14,'(PYDECY:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(MMAT.LE.20) THEN + GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))* + & SIN(PARU(2)*PYR(0)) + ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS + IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300 + IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300 + IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300 + IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300 + ELSE + ND=MMAT-20 + ENDIF +C.. Set maximum popcorn meson number. Test rndmflav popcorn size. + MSTU(125)=ND-NQ/2 + IF(MSTU(121).GT.MSTU(125)) GOTO 300 + +C...Form hadrons from flavour content. + DO 310 JT=1,NQ + KFL1(JT)=KFLO(JT) + 310 CONTINUE + IF(ND.EQ.NP+NQ/2) GOTO 330 + DO 320 I=N+NP+1,N+ND-NQ/2 +C.. Stick to started popcorn system, else pick side at random + JT=JTMO + IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0)) + CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2)) + IF(K(I,2).EQ.0) GOTO 300 + MSTU(125)=MSTU(125)-1 + JTMO=0 + IF(MSTU(121).GT.0) JTMO=JT + KFL1(JT)=-KFL2 + 320 CONTINUE + 330 JT=2 + JT2=3 + JT3=4 + IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4 + IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))* + & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3 + IF(JT.EQ.3) JT2=2 + IF(JT.EQ.4) JT3=2 + CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2)) + IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300 + IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2)) + IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300 + +C...Check that sum of decay product masses not too large. + PS=PSP + DO 340 I=N+NP+1,N+ND + K(I,1)=1 + K(I,3)=IP + K(I,4)=0 + K(I,5)=0 + P(I,5)=PYMASS(K(I,2)) + PS=PS+P(I,5) + 340 CONTINUE + IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300 + +C...Rescale energy to subtract off spectator quark mass. + ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44) + & .AND.NP.GE.3) THEN + PS=PS-P(N+NP,5) + PQT=(P(N+NP,5)+PARJ(65))/PV(1,5) + DO 350 J=1,5 + P(N+NP,J)=PQT*PV(1,J) + PV(1,J)=(1D0-PQT)*PV(1,J) + 350 CONTINUE + IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260 + ND=NP-1 + MREM=1 + +C...Fully specified final state: check mass broadening effects. + ELSE + IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260 + ND=NP + ENDIF + +C...Determine position of grandmother, number of sisters. + NM=0 + KFAS=0 + MSGN=0 + IF(MMAT.EQ.3) THEN + IM=K(IP,3) + IF(IM.LT.0.OR.IM.GE.IP) IM=0 + IF(IM.NE.0) KFAM=IABS(K(IM,2)) + IF(IM.NE.0) THEN + DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N) + IF(K(IL,3).EQ.IM) NM=NM+1 + IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL + 360 CONTINUE + IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR. + & MOD(KFAM/1000,10).NE.0) NM=0 + IF(NM.EQ.2) THEN + KFAS=IABS(K(ISIS,2)) + IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR. + & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0 + ENDIF + ENDIF + ENDIF + +C...Kinematics of one-particle decays. + IF(ND.EQ.1) THEN + DO 370 J=1,4 + P(N+1,J)=P(IP,J) + 370 CONTINUE + GOTO 630 + ENDIF + +C...Calculate maximum weight ND-particle decay. + PV(ND,5)=P(N+ND,5) + IF(ND.GE.3) THEN + WTMAX=1D0/WTCOR(ND-2) + PMAX=PV(1,5)-PS+P(N+ND,5) + PMIN=0D0 + DO 380 IL=ND-1,1,-1 + PMAX=PMAX+P(N+IL,5) + PMIN=PMIN+P(N+IL+1,5) + WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5)) + 380 CONTINUE + ENDIF + +C...Find virtual gamma mass in Dalitz decay. + 390 IF(ND.EQ.2) THEN + ELSEIF(MMAT.EQ.2) THEN + PMES=4D0*PMAS(11,1)**2 + PMRHO2=PMAS(131,1)**2 + PGRHO2=PMAS(131,2)**2 + 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0) + WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))* + & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/ + & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2) + IF(WT.LT.PYR(0)) GOTO 400 + PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST)) + +C...M-generator gives weight. If rejected, try again. + ELSE + 410 RORD(1)=1D0 + DO 440 IL1=2,ND-1 + RSAV=PYR(0) + DO 420 IL2=IL1-1,1,-1 + IF(RSAV.LE.RORD(IL2)) GOTO 430 + RORD(IL2+1)=RORD(IL2) + 420 CONTINUE + 430 RORD(IL2+1)=RSAV + 440 CONTINUE + RORD(ND)=0D0 + WT=1D0 + DO 450 IL=ND-1,1,-1 + PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))* + & (PV(1,5)-PS) + WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5)) + 450 CONTINUE + IF(WT.LT.PYR(0)*WTMAX) GOTO 410 + ENDIF + +C...Perform two-particle decays in respective CM frame. + 460 DO 480 IL=1,ND-1 + PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5)) + UE(3)=2D0*PYR(0)-1D0 + PHI=PARU(2)*PYR(0) + UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI) + UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI) + DO 470 J=1,3 + P(N+IL,J)=PA*UE(J) + PV(IL+1,J)=-PA*UE(J) + 470 CONTINUE + P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2) + PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2) + 480 CONTINUE + +C...Lorentz transform decay products to lab frame. + DO 490 J=1,4 + P(N+ND,J)=PV(ND,J) + 490 CONTINUE + DO 530 IL=ND-1,1,-1 + DO 500 J=1,3 + BE(J)=PV(IL,J)/PV(IL,4) + 500 CONTINUE + GA=PV(IL,4)/PV(IL,5) + DO 520 I=N+IL,N+ND + BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3) + DO 510 J=1,3 + P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J) + 510 CONTINUE + P(I,4)=GA*(P(I,4)+BEP) + 520 CONTINUE + 530 CONTINUE + +C...Check that no infinite loop in matrix element weight. + NTRY=NTRY+1 + IF(NTRY.GT.800) GOTO 560 + +C...Matrix elements for omega and phi decays. + IF(MMAT.EQ.1) THEN + WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2 + & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2 + & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3) + IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390 + +C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-. + ELSEIF(MMAT.EQ.2) THEN + FOUR12=FOUR(N+1,N+2) + FOUR13=FOUR(N+1,N+3) + WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+ + & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2) + IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460 + +C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar, +C...V vector), of form cos**2(theta02) in V1 rest frame, and for +C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02). + ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN + FOUR10=FOUR(IP,IM) + FOUR12=FOUR(IP,N+1) + FOUR02=FOUR(IM,N+1) + PMS1=P(IP,5)**2 + PMS0=P(IM,5)**2 + PMS2=P(N+1,5)**2 + IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2 + IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02- + & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2) + HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM) + HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2) + IF(HNUM.LT.PYR(0)*HDEN) GOTO 460 + +C...Matrix element for "onium" -> g + g + g or gamma + g + g. + ELSEIF(MMAT.EQ.4) THEN + HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2 + HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2 + HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2 + WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+ + & ((1D0-HX3)/(HX1*HX2))**2 + IF(WT.LT.2D0*PYR(0)) GOTO 390 + IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2) + & GOTO 390 + +C...Effective matrix element for nu spectrum in tau -> nu + hadrons. + ELSEIF(MMAT.EQ.41) THEN + IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2 + IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5) + HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5))) + IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390 + +C...Matrix elements for weak decays (only semileptonic for c and b) + ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) + & .AND.ND.EQ.3) THEN + IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3) + IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3) + IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390 + ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN + DO 550 J=1,4 + P(N+NP+1,J)=0D0 + DO 540 IS=N+3,N+NP + P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J) + 540 CONTINUE + 550 CONTINUE + IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1) + IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1) + IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390 + ENDIF + +C...Scale back energy and reattach spectator. + 560 IF(MREM.EQ.1) THEN + DO 570 J=1,5 + PV(1,J)=PV(1,J)/(1D0-PQT) + 570 CONTINUE + ND=ND+1 + MREM=0 + ENDIF + +C...Low invariant mass for system with spectator quark gives particle, +C...not two jets. Readjust momenta accordingly. + IF(MMAT.EQ.31.AND.ND.EQ.3) THEN + MSTJ(93)=1 + PM2=PYMASS(K(N+2,2)) + MSTJ(93)=1 + PM3=PYMASS(K(N+3,2)) + IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE. + & (PARJ(32)+PM2+PM3)**2) GOTO 630 + K(N+2,1)=1 + KFTEMP=K(N+2,2) + CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2)) + IF(K(N+2,2).EQ.0) GOTO 260 + P(N+2,5)=PYMASS(K(N+2,2)) + PS=P(N+1,5)+P(N+2,5) + PV(2,5)=P(N+2,5) + MMAT=0 + ND=2 + GOTO 460 + ELSEIF(MMAT.EQ.44) THEN + MSTJ(93)=1 + PM3=PYMASS(K(N+3,2)) + MSTJ(93)=1 + PM4=PYMASS(K(N+4,2)) + IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE. + & (PARJ(32)+PM3+PM4)**2) GOTO 600 + K(N+3,1)=1 + KFTEMP=K(N+3,2) + CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2)) + IF(K(N+3,2).EQ.0) GOTO 260 + P(N+3,5)=PYMASS(K(N+3,2)) + DO 580 J=1,3 + P(N+3,J)=P(N+3,J)+P(N+4,J) + 580 CONTINUE + P(N+3,4)=SQRT(P(N+3,1)**2+P(N+3,2)**2+P(N+3,3)**2+P(N+3,5)**2) + HA=P(N+1,4)**2-P(N+2,4)**2 + HB=HA-(P(N+1,5)**2-P(N+2,5)**2) + HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+ + & (P(N+1,3)-P(N+2,3))**2 + HD=(PV(1,4)-P(N+3,4))**2 + HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2 + HF=HD*HC-HB**2 + HG=HD*HC-HA*HB + HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF) + DO 590 J=1,3 + PCOR=HH*(P(N+1,J)-P(N+2,J)) + P(N+1,J)=P(N+1,J)+PCOR + P(N+2,J)=P(N+2,J)-PCOR + 590 CONTINUE + P(N+1,4)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2+P(N+1,5)**2) + P(N+2,4)=SQRT(P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2+P(N+2,5)**2) + ND=ND-1 + ENDIF + +C...Check invariant mass of W jets. May give one particle or start over. + 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) + &.AND.IABS(K(N+1,2)).LT.10) THEN + PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2))) + MSTJ(93)=1 + PM1=PYMASS(K(N+1,2)) + MSTJ(93)=1 + PM2=PYMASS(K(N+2,2)) + IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610 + KFLDUM=INT(1.5D0+PYR(0)) + CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1) + CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2) + IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260 + PSM=PYMASS(KF1)+PYMASS(KF2) + IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610 + IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610 + IF(MMAT.EQ.48) GOTO 390 + IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260 + K(N+1,1)=1 + KFTEMP=K(N+1,2) + CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2)) + IF(K(N+1,2).EQ.0) GOTO 260 + P(N+1,5)=PYMASS(K(N+1,2)) + K(N+2,2)=K(N+3,2) + P(N+2,5)=P(N+3,5) + PS=P(N+1,5)+P(N+2,5) + IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260 + PV(2,5)=P(N+3,5) + MMAT=0 + ND=2 + GOTO 460 + ENDIF + +C...Phase space decay of partons from W decay. + 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN + KFLO(1)=K(N+1,2) + KFLO(2)=K(N+2,2) + K(N+1,1)=K(N+3,1) + K(N+1,2)=K(N+3,2) + DO 620 J=1,5 + PV(1,J)=P(N+1,J)+P(N+2,J) + P(N+1,J)=P(N+3,J) + 620 CONTINUE + PV(1,5)=PMR + N=N+1 + NP=0 + NQ=2 + PS=0D0 + MSTJ(93)=2 + PSQ=PYMASS(KFLO(1)) + MSTJ(93)=2 + PSQ=PSQ+PYMASS(KFLO(2)) + MMAT=11 + GOTO 290 + ENDIF + +C...Boost back for rapidly moving particle. + 630 N=N+ND + IF(MBST.EQ.1) THEN + DO 640 J=1,3 + BE(J)=P(IP,J)/P(IP,4) + 640 CONTINUE + GA=P(IP,4)/P(IP,5) + DO 660 I=NSAV+1,N + BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3) + DO 650 J=1,3 + P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J) + 650 CONTINUE + P(I,4)=GA*(P(I,4)+BEP) + 660 CONTINUE + ENDIF + +C...Fill in position of decay vertex. + DO 680 I=NSAV+1,N + DO 670 J=1,4 + V(I,J)=VDCY(J) + 670 CONTINUE + V(I,5)=0D0 + 680 CONTINUE + +C...Set up for parton shower evolution from jets. + IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN + K(NSAV+1,1)=3 + K(NSAV+2,1)=3 + K(NSAV+3,1)=3 + K(NSAV+1,4)=MSTU(5)*(NSAV+2) + K(NSAV+1,5)=MSTU(5)*(NSAV+3) + K(NSAV+2,4)=MSTU(5)*(NSAV+3) + K(NSAV+2,5)=MSTU(5)*(NSAV+1) + K(NSAV+3,4)=MSTU(5)*(NSAV+1) + K(NSAV+3,5)=MSTU(5)*(NSAV+2) + MSTJ(92)=-(NSAV+1) + ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN + K(NSAV+2,1)=3 + K(NSAV+3,1)=3 + K(NSAV+2,4)=MSTU(5)*(NSAV+3) + K(NSAV+2,5)=MSTU(5)*(NSAV+3) + K(NSAV+3,4)=MSTU(5)*(NSAV+2) + K(NSAV+3,5)=MSTU(5)*(NSAV+2) + MSTJ(92)=NSAV+2 + ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND. + & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN + K(NSAV+1,1)=3 + K(NSAV+2,1)=3 + K(NSAV+1,4)=MSTU(5)*(NSAV+2) + K(NSAV+1,5)=MSTU(5)*(NSAV+2) + K(NSAV+2,4)=MSTU(5)*(NSAV+1) + K(NSAV+2,5)=MSTU(5)*(NSAV+1) + MSTJ(92)=NSAV+1 + ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND. + & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN + MSTJ(92)=NSAV+1 + ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21) + & THEN + K(NSAV+1,1)=3 + K(NSAV+2,1)=3 + K(NSAV+3,1)=3 + KCP=PYCOMP(K(NSAV+1,2)) + KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2)) + JCON=4 + IF(KQP.LT.0) JCON=5 + K(NSAV+1,JCON)=MSTU(5)*(NSAV+2) + K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1) + K(NSAV+2,JCON)=MSTU(5)*(NSAV+3) + K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2) + MSTJ(92)=NSAV+1 + ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN + K(NSAV+1,1)=3 + K(NSAV+3,1)=3 + K(NSAV+1,4)=MSTU(5)*(NSAV+3) + K(NSAV+1,5)=MSTU(5)*(NSAV+3) + K(NSAV+3,4)=MSTU(5)*(NSAV+1) + K(NSAV+3,5)=MSTU(5)*(NSAV+1) + MSTJ(92)=NSAV+1 + ENDIF + +C...Mark decayed particle; special option for B-Bbar mixing. + IF(K(IP,1).EQ.5) K(IP,1)=15 + IF(K(IP,1).LE.10) K(IP,1)=11 + IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12 + K(IP,4)=NSAV+1 + K(IP,5)=N + + RETURN + END + + +C********************************************************************* + +C...PYDCYK +C...Handles flavour production in the decay of unstable particles +C...and small string clusters. + + SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ + + +C.. Call PYKFDI directly if no popcorn option is on + IF(MSTJ(12).LT.2) THEN + CALL PYKFDI(KFL1,KFL2,KFL3,KF) + MSTU(124)=KFL3 + RETURN + ENDIF + + KFL3=0 + KF=0 + IF(KFL1.EQ.0) RETURN + KF1A=IABS(KFL1) + KF2A=IABS(KFL2) + + NSTO=130 + NMAX=MIN(MSTU(125),10) + +C.. Identify rank 0 cluster qq + IRANK=1 + IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0 + + IF(KF2A.GT.0)THEN +C.. Join jets: Fails if store not empty + IF(MSTU(121).GT.0) THEN + MSTU(121)=0 + RETURN + ENDIF + CALL PYKFDI(KFL1,KFL2,KFL3,KF) + ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN +C.. Pick popcorn meson from store, return same qq, decrease store + KF=MSTU(NSTO+MSTU(121)) + KFL3=-KFL1 + MSTU(121)=MSTU(121)-1 + ELSE +C.. Generate new flavour. Then done if no diquark is generated + 100 CALL PYKFDI(KFL1,0,KFL3,KF) + IF(MSTU(121).EQ.-1) GOTO 100 + MSTU(124)=KFL3 + IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN + +C.. Simple case if no dynamical popcorn suppressions are considered + IF(MSTJ(12).LT.4) THEN + IF(MSTU(121).EQ.0) RETURN + NMES=1 + KFPREV=-KFL3 + CALL PYKFDI(KFPREV,0,KFL3,KFM) +C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q + IF(IABS(KFL3).LE.10)THEN + KFL3=-KFPREV + RETURN + ENDIF + GOTO 120 + ENDIF + +C test output qq against fake Gamma, then return if no popcorn. + GB=2D0 + IF(IRANK.NE.0)THEN + CALL PYZDIS(1,2103,5D0,Z) + GB=5D0*(1D0-Z)/Z + IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN + MSTU(121)=0 + GOTO 100 + ENDIF + ENDIF + IF(MSTU(121).EQ.0) RETURN + +C..Set store size memory. Pick fake dynamical variables of qq. + NMES=MSTU(121) + CALL PYPTDI(1,PX3,PY3) + X=1D0 + POPM=0D0 + G=GB + POPG=GB + +C.. Pick next popcorn meson, test with fake dynamical variables + 110 KFPREV=-KFL3 + PX1=-PX3 + PY1=-PY3 + CALL PYKFDI(KFPREV,0,KFL3,KFM) + IF(MSTU(121).EQ.-1) GOTO 100 + CALL PYPTDI(KFL3,PX3,PY3) + PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2 + CALL PYZDIS(KFPREV,KFL3,PM,Z) + G=(1D0-Z)*(G+PM/Z) + X=(1D0-Z)*X + + PTST=1D0 + GTST=1D0 + RTST=PYR(0) + IF(MSTJ(12).GT.4)THEN + POPMN=SQRT((1D0-X)*(G/X-GB)) + POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3) + PTST=EXP((POPM-POPMN)*PARF(193)) + POPM=POPMN + ENDIF + IF(IRANK.NE.0)THEN + POPGN=X*GB + GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG) + POPG=POPGN + ENDIF + IF(RTST.GT.PTST*GTST)THEN + MSTU(121)=0 + IF(RTST.GT.PTST) MSTU(121)=-1 + GOTO 100 + ENDIF + +C.. Store meson + 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM + IF(MSTU(121).GT.0) GOTO 110 + +C.. Test accepted system size. If OK set global popcorn size variable. + IF(NMES.GT.NMAX)THEN + KF=0 + KFL3=0 + RETURN + ENDIF + MSTU(121)=NMES + ENDIF + + RETURN + END + +C******************************************************************** + +C...PYKFDI +C...Generates a new flavour pair and combines off a hadron + + SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ +C...Local arrays. + DIMENSION PD(7) + + IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN + +C...Default flavour values. Input consistency checks. + KF1A=IABS(KFL1) + KF2A=IABS(KFL2) + KFL3=0 + KF=0 + IF(KF1A.EQ.0) RETURN + IF(KF2A.NE.0)THEN + IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN + IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN + IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN + ENDIF + +C...Check if tabulated flavour probabilities are to be used. + IF(MSTJ(15).EQ.1) THEN + IF(MSTJ(12).GE.5) CALL PYERRM(29, + & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' // + & ' together with MSTJ(12)>=5 modification') + KTAB1=-1 + IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A + KFL1A=MOD(KF1A/1000,10) + KFL1B=MOD(KF1A/100,10) + KFL1S=MOD(KF1A,10) + IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4) + & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2 + IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1 + IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A + KTAB2=0 + IF(KF2A.NE.0) THEN + KTAB2=-1 + IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A + KFL2A=MOD(KF2A/1000,10) + KFL2B=MOD(KF2A/100,10) + KFL2S=MOD(KF2A,10) + IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4) + & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2 + IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1 + ENDIF + IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140 + ENDIF + +C.. Recognize rank 0 diquark case + 100 IRANK=1 + KFDIQ=MAX(KF1A,KF2A) + IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0 + +C.. Join two flavours to meson or baryon. Test for popcorn. + IF(KF2A.GT.0)THEN + MBARY=0 + IF(KFDIQ.GT.10) THEN + IF(IRANK.EQ.0.AND.MSTJ(12).LT.5) + & CALL PYNMES(KFDIQ) + IF(MSTU(121).NE.0) THEN + MSTU(121)=0 + RETURN + ENDIF + MBARY=2 + ENDIF + KFQOLD=KF1A + KFQVER=KF2A + GOTO 130 + ENDIF + +C.. Separate incoming flavours, curtain flavour consistency check + KFIN=KFL1 + KFQOLD=KF1A + KFQPOP=KF1A/10000 + IF(KF1A.GT.10)THEN + KFIN=-KFL1 + KFL1A=MOD(KF1A/1000,10) + KFL1B=MOD(KF1A/100,10) + IF(IRANK.EQ.0)THEN + QAWT=1D0 + IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4) + IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4) + KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0)) + ENDIF + IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN + MSTU(121)=0 + RETURN + ENDIF + KFQOLD=KFL1A+KFL1B-KFQPOP + ENDIF + +C...Meson/baryon choice. Set number of mesons if starting a popcorn +C...system. + 110 MBARY=0 + IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN + IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN + MBARY=1 + CALL PYNMES(0) + ENDIF + ELSEIF(KF1A.GT.10)THEN + MBARY=2 + IF(IRANK.EQ.0) CALL PYNMES(KF1A) + IF(MSTU(121).GT.0) MBARY=-1 + ENDIF + +C..x->H+q: Choose single vertex quark. Jump to form hadron. + IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN + KFQVER=1+INT((2D0+PARJ(2))*PYR(0)) + KFL3=ISIGN(KFQVER,-KFIN) + GOTO 130 + ENDIF + +C..x->H+qq: (IDW=proper PARF position for diquark weights) + IDW=160 + IF(MBARY.EQ.1)THEN + IF(MSTU(121).EQ.0) IDW=150 + SQWT=PARF(IDW+1) + IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121) + KFQPOP=1+INT((2D0+SQWT)*PYR(0)) +C.. Shift to s-curtain parameters if needed + IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN + PARF(194)=PARF(138)*PARF(139) + PARF(193)=PARJ(8)+PARJ(9) + ENDIF + ENDIF + +C.. x->H+qq: Get vertex quark + IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN + IDW=MSTU(122) + MSTU(121)=MSTU(121)-1 + IF(IDW.EQ.170) THEN + IF(MSTU(121).EQ.0)THEN + IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2) + ELSE + IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2) + ENDIF + ELSE + IF(MSTU(121).EQ.0)THEN + IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4) + ELSE + IPOS=3*5+5*4+MIN(KFQOLD-1,4) + ENDIF + ENDIF + IPOS=200+30*IPOS+1 + + IMES=-1 + RMES=PYR(0)*PARF(194) + 120 IMES=IMES+1 + RMES=RMES-PARF(IPOS+IMES) + IF(IMES.EQ.30) THEN + MSTU(121)=-1 + KF=-111 + RETURN + ENDIF + IF(RMES.GT.0D0) GOTO 120 + KMUL=IMES/5 + KFJ=2*KMUL+1 + IF(KMUL.EQ.2) KFJ=10003 + IF(KMUL.EQ.3) KFJ=10001 + IF(KMUL.EQ.4) KFJ=20003 + IF(KMUL.EQ.5) KFJ=5 + IDIAG=0 + KFQVER=MOD(IMES,5)+1 + IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1 + IF(KFQVER.GT.3)THEN + IDIAG=KFQVER-3 + KFQVER=KFQOLD + ENDIF + ELSE + IF(MBARY.EQ.-1) IDW=170 + SQWT=PARF(IDW+2) + IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3) + IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0 + KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0))) + IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN + KFQVER=KFQPOP + IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP + ENDIF + ENDIF + +C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos + KFLDS=3 + IF(KFQPOP.NE.KFQVER)THEN + SWT=PARF(IDW+7) + IF(KFQVER.EQ.3) SWT=PARF(IDW+6) + IF(KFQPOP.GE.3) SWT=PARF(IDW+5) + IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1 + ENDIF + KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS + & +10000*KFQPOP + KFL3=ISIGN(KFDIQ,KFIN) + +C..x->M+y: flavour for meson. + 130 IF(MBARY.LE.0)THEN + KFLA=MAX(KFQOLD,KFQVER) + KFLB=MIN(KFQOLD,KFQVER) + KFS=ISIGN(1,KFL1) + IF(KFLA.NE.KFQOLD) KFS=-KFS +C... Form meson, with spin and flavour mixing for diagonal states. + IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN + IF(IDIAG.GT.0) KF=110*IDIAG+KFJ + IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA + RETURN + ENDIF + IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0)) + IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0)) + IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0)) + IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN + IF(PYR(0).LT.PARJ(14)) KMUL=2 + ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN + RMUL=PYR(0) + IF(RMUL.LT.PARJ(15)) KMUL=3 + IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4 + IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5 + ENDIF + KFLS=3 + IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1 + IF(KMUL.EQ.5) KFLS=5 + IF(KFLA.NE.KFLB)THEN + KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA + ELSE + RMIX=PYR(0) + IMIX=2*KFLA+10*KMUL + IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+ + & INT(RMIX+PARF(IMIX)))+KFLS + IF(KFLA.GE.4) KF=110*KFLA+KFLS + ENDIF + IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF) + IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF) + +C..Optional extra suppression of eta and eta'. +C..Allow shift to qq->B+q in old version (set IRANK to 0) + IF(KF.EQ.221.OR.KF.EQ.331)THEN + IF(PYR(0).GT.PARJ(25+KF/300))THEN + IF(KF2A.GT.0) GOTO 130 + IF(MSTJ(12).LT.4) IRANK=0 + GOTO 110 + ENDIF + ENDIF + MSTU(121)=0 + +C.. x->B+y: Flavour for baryon + ELSE + KFLA=KFQVER + IF(KF1A.LE.10) KFLA=KFQOLD + KFLB=MOD(KFDIQ/1000,10) + KFLC=MOD(KFDIQ/100,10) + KFLDS=MOD(KFDIQ,10) + KFLD=MAX(KFLA,KFLB,KFLC) + KFLF=MIN(KFLA,KFLB,KFLC) + KFLE=KFLA+KFLB+KFLC-KFLD-KFLF + +C... SU(6) factors for formation of baryon. + KBARY=3 + KDMAX=5 + KFLG=KFLB + IF(KFLB.NE.KFLC)THEN + KBARY=2*KFLDS-1 + KDMAX=1+KFLDS/2 + IF(KFLB.GT.2) KDMAX=KDMAX+2 + ENDIF + IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN + KBARY=KBARY+1 + KFLG=KFLA + ENDIF + + SU6MAX=PARF(140+KDMAX) + SU6DEC=PARJ(18) + SU6S =PARF(146) + IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN + SU6MAX=1D0 + SU6DEC=1D0 + SU6S =1D0 + ENDIF + SU6OCT=PARF(60+KBARY) + IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN + SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1) + IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1) + ELSE + IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1) + ENDIF + SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY) + +C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected. + IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN + MSTU(121)=0 + IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1 + GOTO 110 + ENDIF + +C.. Form baryon. Distinguish Lambda- and Sigmalike baryons. + KSIG=1 + KFLS=2 + IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4 + IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN + KSIG=KFLDS/3 + IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0)) + ENDIF + KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1) + IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1) + ENDIF + RETURN + +C...Use tabulated probabilities to select new flavour and hadron. + 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN + KT3L=1 + KT3U=6 + ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN + KT3L=1 + KT3U=6 + ELSEIF(KTAB2.EQ.0) THEN + KT3L=1 + KT3U=22 + ELSE + KT3L=KTAB2 + KT3U=KTAB2 + ENDIF + RFL=0D0 + DO 160 KTS=0,2 + DO 150 KT3=KT3L,KT3U + RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3) + 150 CONTINUE + 160 CONTINUE + RFL=PYR(0)*RFL + DO 180 KTS=0,2 + KTABS=KTS + DO 170 KT3=KT3L,KT3U + KTAB3=KT3 + RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3) + IF(RFL.LE.0D0) GOTO 190 + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE + +C...Reconstruct flavour of produced quark/diquark. + IF(KTAB3.LE.6) THEN + KFL3A=KTAB3 + KFL3B=0 + KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13)) + ELSE + KFL3A=1 + IF(KTAB3.GE.8) KFL3A=2 + IF(KTAB3.GE.11) KFL3A=3 + IF(KTAB3.GE.16) KFL3A=4 + KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2 + KFL3=1000*KFL3A+100*KFL3B+1 + IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3= + & KFL3+2 + KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1)) + ENDIF + +C...Reconstruct meson code. + IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR. + &KFL3B.NE.0)) THEN + RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+ + & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS)) + KF=110+2*KTABS+1 + IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1 + IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+ + & 25*KTABS)) KF=330+2*KTABS+1 + ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN + KFLA=MAX(KTAB1,KTAB3) + KFLB=MIN(KTAB1,KTAB3) + KFS=ISIGN(1,KFL1) + IF(KFLA.NE.KF1A) KFS=-KFS + KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA + ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN + KFS=ISIGN(1,KFL1) + IF(KFL1A.EQ.KFL3A) THEN + KFLA=MAX(KFL1B,KFL3B) + KFLB=MIN(KFL1B,KFL3B) + IF(KFLA.NE.KFL1B) KFS=-KFS + ELSEIF(KFL1A.EQ.KFL3B) THEN + KFLA=KFL3A + KFLB=KFL1B + KFS=-KFS + ELSEIF(KFL1B.EQ.KFL3A) THEN + KFLA=KFL1A + KFLB=KFL3B + ELSEIF(KFL1B.EQ.KFL3B) THEN + KFLA=MAX(KFL1A,KFL3A) + KFLB=MIN(KFL1A,KFL3A) + IF(KFLA.NE.KFL1A) KFS=-KFS + ELSE + CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq') + GOTO 100 + ENDIF + KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA + +C...Reconstruct baryon code. + ELSE + IF(KTAB1.GE.7) THEN + KFLA=KFL3A + KFLB=KFL1A + KFLC=KFL1B + ELSE + KFLA=KFL1A + KFLB=KFL3A + KFLC=KFL3B + ENDIF + KFLD=MAX(KFLA,KFLB,KFLC) + KFLF=MIN(KFLA,KFLB,KFLC) + KFLE=KFLA+KFLB+KFLC-KFLD-KFLF + IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1) + IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1) + ENDIF + +C...Check that constructed flavour code is an allowed one. + IF(KFL2.NE.0) KFL3=0 + KC=PYCOMP(KF) + IF(KC.EQ.0) THEN + CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '// + & 'failed') + GOTO 100 + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYNMES +C...Generates number of popcorn mesons and stores some relevant +C...parameters. + + SUBROUTINE PYNMES(KFDIQ) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ + + MSTU(121)=0 + IF(MSTJ(12).LT.2) RETURN + +C..Old version: Get 1 or 0 popcorn mesons + IF(MSTJ(12).LT.5)THEN + POPWT=PARF(131) + IF(KFDIQ.NE.0) THEN + KFDIQA=IABS(KFDIQ) + KFA=MOD(KFDIQA/1000,10) + KFB=MOD(KFDIQA/100,10) + KFS=MOD(KFDIQA,10) + POPWT=PARF(132) + IF(KFA.EQ.3) POPWT=PARF(133) + IF(KFB.EQ.3) POPWT=PARF(134) + IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4)) + ENDIF + MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0)) + RETURN + ENDIF + +C..New version: Store popcorn- or rank 0 diquark parameters + MSTU(122)=170 + PARF(193)=PARJ(8) + PARF(194)=PARF(139) + IF(KFDIQ.NE.0) THEN + MSTU(122)=180 + PARF(193)=PARJ(10) + PARF(194)=PARF(140) + ENDIF + IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN + IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9, + & '(PYNMES:) Neglecting too large popcorn possibility') + RETURN + ENDIF + +C..New version: Get number of popcorn mesons + 100 RTST=PYR(0) + MSTU(121)=-1 + 110 MSTU(121)=MSTU(121)+1 + RTST=RTST/PARF(194) + IF(RTST.LT.1D0) GOTO 110 + IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT. + & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100 + RETURN + END + +C*************************************************************** + +C...PYKFIN +C...Precalculates a set of diquark and popcorn weights. + + SUBROUTINE PYKFIN + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ + + DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14) + + + MSTU(123)=1 +C..Diquark indices for dimensional variables + IUD1=1 + IUU1=2 + IUS0=3 + ISU0=4 + IUS1=5 + ISU1=6 + ISS1=7 + +C.. *** SU(6) factors ** +C..Modify with decuplet- (and Sigma/Lambda-) suppression. + PARF(146)=1D0 + IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0) + IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9, + & '(PYKFIN:) PARJ(18)<1 combined with 0 B+B+.. + DO 120 I=1,7 + QBB(I)=QBB(I)*QBM(I) + 120 CONTINUE + + IF(MSTJ(12).GE.5)THEN +C..New version: tau for rank 0 diquark. + DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0) + DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0) + DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0) + DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1) + DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0) + DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1) + DMB(7+IUD1)=DMB(7+IUU1)/2D0 + +C..New version: curtain flavour ratios. +C.. s/u for q->B+M+... +C.. s/u for rank 0 diquark: su -> ...M+B+... +C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+... + WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1) + PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU + WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1) + PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU + PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))* + & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU + ELSE +C..Old version: reset unused rank 0 diquark weights and +C.. unused diquark SU(6) survival weights + DO 130 I=1,7 + IF(MSTJ(12).LT.3) DMB(I)=1D0 + DMB(7+I)=1D0 + 130 CONTINUE + +C..Old version: Shuffle PARJ(7) into tau + QBM(IUS0)=QBM(IUS0)*PARJ(7) + QBM(ISS1)=QBM(ISS1)*PARJ(7) + QBM(IUS1)=QBM(IUS1)*PARJ(7) + +C..Old version: curtain flavour ratios. +C.. s/u for q->B+M+... +C.. s/u for rank 0 diquark: su -> ...M+B+... +C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+... + WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1) + PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU + PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0) + PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU + ENDIF + +C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for: +C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B.. + DO 140 I=1,7 + DMB(7+I)=DMB(7+I)*DMB(I) + DMB(I)=DMB(I)*QBM(I) + QBM(I)=QBM(I)*SU6M(I)/SU6MUD + QBB(I)=QBB(I)*SU6M(I)/SU6MUD + 140 CONTINUE + +C.. *** Popcorn factors *** + + IF(MSTJ(12).LT.5)THEN +C.. Old version: Resulting popcorn weights. + PARF(138)=PARJ(6) + WS=PARF(135)*PARF(138) + WQ=WU*PARJ(5)/3D0 + PARF(132)=WQ*QBM(IUD1)/QBB(IUD1) + PARF(133)=WQ* + & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0 + PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1) + PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+ + & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/ + & (1D0+QBB(IUD1)+QBB(IUU1)+ + & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0) + ELSE +C..New version: Store weights for popcorn mesons, +C..get prel. popcorn weights. + DO 150 IPOS=201,1400 + PARF(IPOS)=0D0 + 150 CONTINUE + DO 160 I=138,140 + PARF(I)=0D0 + 160 CONTINUE + IPOS=200 + PARF(193)=PARJ(8) + DO 240 MR=0,7,7 + IF(MR.EQ.7) PARF(193)=PARJ(10) + SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/ + & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1)) + QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1)) + DO 230 NMES=0,1 + IF(NMES.EQ.1) SQWT=PARJ(2) + DO 220 KFQPOP=1,4 + IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220 + IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN + SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1)) + QQWT=0.5D0 + IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9) + IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0 + ENDIF + DO 210 KFQOLD =1,5 + IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210 + IF(NMES.EQ.1) THEN + IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210 + IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210 + ENDIF + WTTOT=0D0 + WTFAIL=0D0 + DO 190 KMUL=0,5 + PJWT=PARJ(12+KMUL) + IF(KMUL.EQ.0) PJWT=1D0-PARJ(14) + IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17) + IF(PJWT.LE.0D0) GOTO 190 + IF(PJWT.GT.1D0) PJWT=1D0 + IMES=5*KMUL + IMIX=2*KFQOLD+10*KMUL + KFJ=2*KMUL+1 + IF(KMUL.EQ.2) KFJ=10003 + IF(KMUL.EQ.3) KFJ=10001 + IF(KMUL.EQ.4) KFJ=20003 + IF(KMUL.EQ.5) KFJ=5 + DO 180 KFQVER =1,3 + KFLA=MAX(KFQOLD,KFQVER) + KFLB=MIN(KFQOLD,KFQVER) + SWT=PARJ(11+KFLA/3+KFLA/4) + IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT + SWT=SWT*PJWT + QWT=SQWT/(2D0+SQWT) + IF(KFQVER.LT.3)THEN + IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT + IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT) + ENDIF + IF(KFQVER.NE.KFQOLD)THEN + IMES=IMES+1 + KFM=100*KFLA+10*KFLB+KFJ + PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3) + PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM) + WTTOT=WTTOT+PARF(IPOS+IMES) + ELSE + DO 170 ID=3,5 + IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1) + IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX) + IF(ID.EQ.5) DWT=PARF(IMIX) + KFM=110*(ID-2)+KFJ + PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3) + PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM) + IF(KMUL.EQ.0.AND.ID.GT.3) THEN + WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID)) + PARF(IPOS+5*KMUL+ID)= + & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID) + ENDIF + WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID) + 170 CONTINUE + ENDIF + 180 CONTINUE + 190 CONTINUE + DO 200 IMES=1,30 + PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL) + 200 CONTINUE + IF(MR.EQ.7) PARF(140)= + & MAX(PARF(140),WTTOT/(1D0-WTFAIL)) + IF(MR.EQ.0) PARF(139-KFQPOP/3)= + & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL)) + IPOS=IPOS+30 + 210 CONTINUE + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE + IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139) + MSTU(121)=0 + + ENDIF + +C..Recombine diquark weights to flavour and spin ratios + PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/ + & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1)) + PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1)) + PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1)) + PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1)) + PARF(155)=QBB(ISU1)/QBB(ISU0) + PARF(156)=QBB(IUS1)/QBB(IUS0) + PARF(157)=QBB(IUD1) + + PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/ + & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)) + PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1)) + PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1)) + PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1)) + PARF(165)=QBM(ISU1)/QBM(ISU0) + PARF(166)=QBM(IUS1)/QBM(IUS0) + PARF(167)=QBM(IUD1) + + PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/ + & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1)) + PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1)) + PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1)) + PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1)) + PARF(175)=DMB(ISU1)/DMB(ISU0) + PARF(176)=DMB(IUS1)/DMB(IUS0) + PARF(177)=DMB(IUD1) + + PARF(185)=DMB(7+ISU1)/DMB(7+ISU0) + PARF(186)=DMB(7+IUS1)/DMB(7+IUS0) + PARF(187)=DMB(7+IUD1) + + RETURN + END + + +C********************************************************************* + +C...PYPTDI +C...Generates transverse momentum according to a Gaussian. + + SUBROUTINE PYPTDI(KFL,PX,PY) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + +C...Generate p_T and azimuthal angle, gives p_x and p_y. + KFLA=IABS(KFL) + PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0)))) + IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT + IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT + IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0 + PHI=PARU(2)*PYR(0) + PX=PT*COS(PHI) + PY=PT*SIN(PHI) + + RETURN + END + +C********************************************************************* + +C...PYZDIS +C...Generates the longitudinal splitting variable z. + + SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ + +C...Check if heavy flavour fragmentation. + KFLA=IABS(KFL1) + KFLB=IABS(KFL2) + KFLH=KFLA + IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10) + +C...Lund symmetric scaling function: determine parameters of shape. + IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR. + &MSTJ(11).GE.4) THEN + FA=PARJ(41) + IF(MSTJ(91).EQ.1) FA=PARJ(43) + IF(KFLB.GE.10) FA=FA+PARJ(45) + FBB=PARJ(42) + IF(MSTJ(91).EQ.1) FBB=PARJ(44) + FB=FBB*PR + FC=1D0 + IF(KFLA.GE.10) FC=FC-PARJ(45) + IF(KFLB.GE.10) FC=FC+PARJ(45) + IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN + FRED=PARJ(46) + IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47) + FC=FC+FRED*FBB*PARF(100+KFLH)**2 + ENDIF + MC=1 + IF(ABS(FC-1D0).GT.0.01D0) MC=2 + +C...Determine position of maximum. Special cases for a = 0 or a = c. + IF(FA.LT.0.02D0) THEN + MA=1 + ZMAX=1D0 + IF(FC.GT.FB) ZMAX=FB/FC + ELSEIF(ABS(FC-FA).LT.0.01D0) THEN + MA=2 + ZMAX=FB/(FB+FC) + ELSE + MA=3 + ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA) + IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB) + ENDIF + +C...Subdivide z range if distribution very peaked near endpoint. + MMAX=2 + IF(ZMAX.LT.0.1D0) THEN + MMAX=1 + ZDIV=2.75D0*ZMAX + IF(MC.EQ.1) THEN + FINT=1D0-LOG(ZDIV) + ELSE + ZDIVC=ZDIV**(1D0-FC) + FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0) + ENDIF + ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN + MMAX=3 + FSCB=SQRT(4D0+(FC/FB)**2) + ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB)) + IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX) + ZDIV=MIN(ZMAX,MAX(0D0,ZDIV)) + FINT=1D0+FB*(1D0-ZDIV) + ENDIF + +C...Choice of z, preweighted for peaks at low or high z. + 100 Z=PYR(0) + FPRE=1D0 + IF(MMAX.EQ.1) THEN + IF(FINT*PYR(0).LE.1D0) THEN + Z=ZDIV*Z + ELSEIF(MC.EQ.1) THEN + Z=ZDIV**Z + FPRE=ZDIV/Z + ELSE + Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC)) + FPRE=(ZDIV/Z)**FC + ENDIF + ELSEIF(MMAX.EQ.3) THEN + IF(FINT*PYR(0).LE.1D0) THEN + Z=ZDIV+LOG(Z)/FB + FPRE=EXP(FB*(Z-ZDIV)) + ELSE + Z=ZDIV+Z*(1D0-ZDIV) + ENDIF + ENDIF + +C...Weighting according to correct formula. + IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100 + FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z) + IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX)) + FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP))) + IF(FVAL.LT.PYR(0)*FPRE) GOTO 100 + +C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c. + ELSE + FC=PARJ(50+MAX(1,KFLH)) + IF(MSTJ(91).EQ.1) FC=PARJ(59) + 110 Z=PYR(0) + IF(FC.GE.0D0.AND.FC.LE.1D0) THEN + IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0) + ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN + IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2) + & GOTO 110 + ELSE + IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC) + IF(FC.LT.0D0) Z=Z**(-1D0/FC) + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSHOW +C...Generates timelike parton showers from given partons. + + SUBROUTINE PYSHOW(IP1,IP2,QMAX) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/ +C...Local arrays. + DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100), + &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100), + &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2), + &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140), + &IREF(1000) + +C...Check that QMAX not too low. + IF(MSTJ(41).LE.0) THEN + RETURN + ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN + IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN + ELSE + IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80) + & RETURN + ENDIF + +C...Store positions of shower initiating partons. + MPSPD=0 + IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN + NPA=1 + IPA(1)=IP1 + ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)- + & MSTU(32))) THEN + NPA=2 + IPA(1)=IP1 + IPA(2)=IP2 + ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0 + & .AND.IP2.GE.-80) THEN + NPA=IABS(IP2) + DO 100 I=1,NPA + IPA(I)=IP1+I-1 + 100 CONTINUE + ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND. + &IP2.EQ.-100) THEN + MPSPD=1 + NPA=2 + IPA(1)=IP1+6 + IPA(2)=IP1+7 + ELSE + CALL PYERRM(12, + & '(PYSHOW:) failed to reconstruct showering system') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Send off to PYPTFS for pT-ordered evolution if requested, +C...if at least 2 partons, and without predefined shower branchings. + IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND. + &MPSPD.EQ.0) THEN + NPART=NPA + DO 110 II=1,NPART + IPART(II)=IPA(II) + PTPART(II)=0.5D0*QMAX + 110 CONTINUE + CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN) + RETURN + ENDIF + +C...Initialization of cutoff masses etc. + DO 120 IFL=0,40 + ISCOL(IFL)=0 + ISCHG(IFL)=0 + KSH(IFL)=0 + 120 CONTINUE + ISCOL(21)=1 + KSH(21)=1 + PMTH(1,21)=PYMASS(21) + PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2) + PMTH(3,21)=2D0*PMTH(2,21) + PMTH(4,21)=PMTH(3,21) + PMTH(5,21)=PMTH(3,21) + PMTH(1,22)=PYMASS(22) + PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2) + PMTH(3,22)=2D0*PMTH(2,22) + PMTH(4,22)=PMTH(3,22) + PMTH(5,22)=PMTH(3,22) + PMQTH1=PARJ(82) + IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83)) + PMQT1E=MIN(PMQTH1,PARJ(90)) + PMQTH2=PMTH(2,21) + IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22)) + PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90)) + DO 130 IFL=1,5 + ISCOL(IFL)=1 + IF(MSTJ(41).GE.2) ISCHG(IFL)=1 + KSH(IFL)=1 + PMTH(1,IFL)=PYMASS(IFL) + PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2) + PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2 + PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21) + PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22) + 130 CONTINUE + DO 140 IFL=11,15,2 + IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1 + IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1 + PMTH(1,IFL)=PYMASS(IFL) + PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2) + PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90) + PMTH(4,IFL)=PMTH(3,IFL) + PMTH(5,IFL)=PMTH(3,IFL) + 140 CONTINUE + PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2 + ALAMS=PARJ(81)**2 + ALFM=LOG(PT2MIN/ALAMS) + +C...Check on phase space available for emission. + IREJ=0 + DO 150 J=1,5 + PS(J)=0D0 + 150 CONTINUE + PM=0D0 + KFLA(2)=0 + DO 170 I=1,NPA + KFLA(I)=IABS(K(IPA(I),2)) + PMA(I)=P(IPA(I),5) +C...Special cutoff masses for initial partons (may be a heavy quark, +C...squark, ..., and need not be on the mass shell). + IR=30+I + IF(NPA.LE.1) IREF(I)=IR + IF(NPA.GE.2) IREF(I+1)=IR + ISCOL(IR)=0 + ISCHG(IR)=0 + KSH(IR)=0 + IF(KFLA(I).LE.8) THEN + ISCOL(IR)=1 + IF(MSTJ(41).GE.2) ISCHG(IR)=1 + ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR. + & KFLA(I).EQ.17) THEN + IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1 + ELSEIF(KFLA(I).EQ.21) THEN + ISCOL(IR)=1 + ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR. + & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN + ISCOL(IR)=1 + ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN + ISCOL(IR)=1 +C...QUARKONIA+++ +C...same for QQ~[3S18] + ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR. + & KFLA(I).EQ.9900553)) THEN + ISCOL(IR)=1 +C...QUARKONIA--- + ENDIF + +C...Option to switch off radiation from particle KF = MSTJ(39) entirely +C...(only intended for studying the effects of switching such rad on/off) + IF (MSTJ(39).GT.0.AND.KFLA(I).EQ.MSTJ(39)) THEN + ISCOL(IR)=0 + ISCHG(IR)=0 + ENDIF + + IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1 + PMTH(1,IR)=PMA(I) + IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN + PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2) + PMTH(3,IR)=PMTH(2,IR)+PMQTH2 + PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21) + PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22) + ELSEIF(ISCOL(IR).EQ.1) THEN + PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2) + PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82) + PMTH(4,IR)=PMTH(3,IR) + PMTH(5,IR)=PMTH(3,IR) + ELSEIF(ISCHG(IR).EQ.1) THEN + PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2) + PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90) + PMTH(4,IR)=PMTH(3,IR) + PMTH(5,IR)=PMTH(3,IR) + ENDIF + IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR) + PM=PM+PMA(I) + IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1 + DO 160 J=1,4 + PS(J)=PS(J)+P(IPA(I),J) + 160 CONTINUE + 170 CONTINUE + IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN + PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2)) + IF(NPA.EQ.1) PS(5)=PS(4) + IF(PS(5).LE.PM+PMQT1E) RETURN + +C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0). + KFSRCE=0 + IF(IP2.LE.0) THEN + ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN + KFSRCE=IABS(K(K(IP1,3),2)) + ELSE + IPAR1=MAX(1,K(IP1,3)) + IPAR2=MAX(1,K(IP2,3)) + IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0) + & KFSRCE=IABS(K(K(IPAR1,3),2)) + ENDIF + ITYPES=0 + IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1 + IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2 + IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2 + IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3 + IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3 + IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4 + IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5 + IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6 + +C...Identify two primary showerers. + ITYPE1=0 + IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1 + IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2 + IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2 + IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3 + IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3 + IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4 + IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5 + IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6 + ITYPE2=0 + IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1 + IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2 + IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2 + IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3 + IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3 + IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4 + IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5 + IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6 + +C...Order of showerers. Presence of gluino. + ITYPMN=MIN(ITYPE1,ITYPE2) + ITYPMX=MAX(ITYPE1,ITYPE2) + IORD=1 + IF(ITYPE1.GT.ITYPE2) IORD=2 + IGLUI=0 + IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1 + +C...Check if 3-jet matrix elements to be used. + M3JC=0 + ALPHA=0.5D0 + IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN + IF(MSTJ(38).NE.0) THEN + M3JC=MSTJ(38) + ALPHA=PARJ(80) + MSTJ(38)=0 + ELSEIF(MSTJ(47).GE.6) THEN + M3JC=MSTJ(47) + ELSE + ICLASS=1 + ICOMBI=4 + +C...Vector/axial vector -> q + qbar; q -> q + V. + IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.3)) THEN + ICLASS=2 + IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN + ICOMBI=1 + ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND. + & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN +C...gamma*/Z0: assume e+e- initial state if unknown. + EI=-1D0 + IF(KFSRCE.EQ.23) THEN + IANNFL=K(K(IP1,3),3) + IF(IANNFL.NE.0) THEN + KANNFL=IABS(K(IANNFL,2)) + IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0 + ENDIF + ENDIF + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*PARU(102) + EF=KCHG(KFLA(1),1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*PARU(102) + XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102))) + SH=PS(5)**2 + SQMZ=PMAS(23,1)**2 + SQWZ=PS(5)*PMAS(23,2) + SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2) + VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+ + & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ + AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ + ICOMBI=3 + ALPHA=VECT/(VECT+AXIV) + ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN + ICOMBI=4 + ENDIF +C...For chi -> chi q qbar, use V/A -> q qbar as first approximation. + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN + ICLASS=2 + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.1)) THEN + ICLASS=3 + +C...Scalar/pseudoscalar -> q + qbar; q -> q + S. + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN + ICLASS=4 + IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN + ICOMBI=1 + ELSEIF(KFSRCE.EQ.36) THEN + ICOMBI=2 + ENDIF + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.1)) THEN + ICLASS=5 + +C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S. + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.3)) THEN + ICLASS=6 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.2)) THEN + ICLASS=7 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN + ICLASS=8 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.2)) THEN + ICLASS=9 + +C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi. + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.5)) THEN + ICLASS=10 + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.2)) THEN + ICLASS=11 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.1)) THEN + ICLASS=12 + +C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g. + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN + ICLASS=13 + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.2)) THEN + ICLASS=14 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.1)) THEN + ICLASS=15 + +C...g -> ~g + ~g (eikonal approximation). + ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN + ICLASS=16 + ENDIF + M3JC=5*ICLASS+ICOMBI + ENDIF + ENDIF + +C...Find if interference with initial state partons. + MIIS=0 + IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0 + &.AND.MPSPD.EQ.0) MIIS=MSTJ(50) + IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0) + &MIIS=MSTJ(50)-3 + IF(MIIS.NE.0) THEN + DO 190 I=1,2 + KCII(I)=0 + KCA=PYCOMP(KFLA(I)) + IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2)) + NIIS(I)=0 + IF(KCII(I).NE.0) THEN + DO 180 J=1,2 + ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5)) + IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND. + & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN + NIIS(I)=NIIS(I)+1 + IIIS(I,NIIS(I))=ICSI + ENDIF + 180 CONTINUE + ENDIF + 190 CONTINUE + IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0 + ENDIF + +C...Boost interfering initial partons to rest frame +C...and reconstruct their polar and azimuthal angles. + IF(MIIS.NE.0) THEN + DO 210 I=1,2 + DO 200 J=1,5 + K(N+I,J)=K(IPA(I),J) + P(N+I,J)=P(IPA(I),J) + V(N+I,J)=0D0 + 200 CONTINUE + 210 CONTINUE + DO 230 I=3,2+NIIS(1) + DO 220 J=1,5 + K(N+I,J)=K(IIIS(1,I-2),J) + P(N+I,J)=P(IIIS(1,I-2),J) + V(N+I,J)=0D0 + 220 CONTINUE + 230 CONTINUE + DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2) + DO 240 J=1,5 + K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J) + P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J) + V(N+I,J)=0D0 + 240 CONTINUE + 250 CONTINUE + CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4), + & -PS(2)/PS(4),-PS(3)/PS(4)) + PHI=PYANGL(P(N+1,1),P(N+1,2)) + CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0) + THE=PYANGL(P(N+1,3),P(N+1,1)) + CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0) + DO 260 I=3,2+NIIS(1) + THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2)) + PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2)) + 260 CONTINUE + DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2) + THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3), + & SQRT(P(N+I,1)**2+P(N+I,2)**2)) + PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2)) + 270 CONTINUE + ENDIF + +C...Boost 3 or more partons to their rest frame. + IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4), + &-PS(2)/PS(4),-PS(3)/PS(4)) + +C...Define imagined single initiator of shower for parton system. + NS=N + IF(N.GT.MSTU(4)-MSTU(32)-10) THEN + CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF + 280 N=NS + IF(NPA.GE.2) THEN + K(N+1,1)=11 + K(N+1,2)=21 + K(N+1,3)=0 + K(N+1,4)=0 + K(N+1,5)=0 + P(N+1,1)=0D0 + P(N+1,2)=0D0 + P(N+1,3)=0D0 + P(N+1,4)=PS(5) + P(N+1,5)=PS(5) + V(N+1,5)=PS(5)**2 + N=N+1 + IREF(1)=21 + ENDIF + +C...Loop over partons that may branch. + NEP=NPA + IM=NS + IF(NPA.EQ.1) IM=NS-1 + 290 IM=IM+1 + IF(N.GT.NS) THEN + IF(IM.GT.N) GOTO 600 + KFLM=IABS(K(IM,2)) + IR=IREF(IM-NS) + IF(KSH(IR).EQ.0) GOTO 290 + IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290 + IGM=K(IM,3) + ELSE + IGM=-1 + ENDIF + IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN + CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Position of aunt (sister to branching parton). +C...Origin and flavour of daughters. + IAU=0 + IF(IGM.GT.0) THEN + IF(K(IM-1,3).EQ.IGM) IAU=IM-1 + IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1 + ENDIF + IF(IGM.GE.0) THEN + K(IM,4)=N+1 + DO 300 I=1,NEP + K(N+I,3)=IM + 300 CONTINUE + ELSE + K(N+1,3)=IPA(1) + ENDIF + IF(IGM.LE.0) THEN + DO 310 I=1,NEP + K(N+I,2)=K(IPA(I),2) + 310 CONTINUE + ELSEIF(KFLM.NE.21) THEN + K(N+1,2)=K(IM,2) + K(N+2,2)=K(IM,5) + IREF(N+1-NS)=IREF(IM-NS) + IREF(N+2-NS)=IABS(K(N+2,2)) + ELSEIF(K(IM,5).EQ.21) THEN + K(N+1,2)=21 + K(N+2,2)=21 + IREF(N+1-NS)=21 + IREF(N+2-NS)=21 + ELSE + K(N+1,2)=K(IM,5) + K(N+2,2)=-K(IM,5) + IREF(N+1-NS)=IABS(K(N+1,2)) + IREF(N+2-NS)=IABS(K(N+2,2)) + ENDIF + +C...Reset flags on daughters and tries made. + DO 320 IP=1,NEP + K(N+IP,1)=3 + K(N+IP,4)=0 + K(N+IP,5)=0 + KFLD(IP)=IABS(K(N+IP,2)) + IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1 + ITRY(IP)=0 + ISL(IP)=0 + ISI(IP)=0 + IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1 + 320 CONTINUE + ISLM=0 + +C...Maximum virtuality of daughters. + IF(IGM.LE.0) THEN + DO 330 I=1,NPA + IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4) + P(N+I,5)=MIN(QMAX,PS(5)) + IR=IREF(N+I-NS) + IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR)) + IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5) + 330 CONTINUE + ELSE + IF(MSTJ(43).LE.2) PEM=V(IM,2) + IF(MSTJ(43).GE.3) PEM=P(IM,4) + P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM) + P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM) + IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22) + ENDIF + DO 340 I=1,NEP + PMSD(I)=P(N+I,5) + IF(ISI(I).EQ.1) THEN + IR=IREF(N+I-NS) + IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR) + ENDIF + V(N+I,5)=P(N+I,5)**2 + 340 CONTINUE + +C...Choose one of the daughters for evolution. + 350 INUM=0 + IF(NEP.EQ.1) INUM=1 + DO 360 I=1,NEP + IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I + 360 CONTINUE + DO 370 I=1,NEP + IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN + IR=IREF(N+I-NS) + IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I + ENDIF + 370 CONTINUE + IF(INUM.EQ.0) THEN + RMAX=0D0 + DO 380 I=1,NEP + IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN + RPM=P(N+I,5)/PMSD(I) + IR=IREF(N+I-NS) + IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN + RMAX=RPM + INUM=I + ENDIF + ENDIF + 380 CONTINUE + ENDIF + +C...Cancel choice of predetermined daughter already treated. + INUM=MAX(1,INUM) + INUMT=INUM + IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN + IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM + ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN + IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM + IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM + ENDIF + +C...Store information on choice of evolving daughter. + IEP(1)=N+INUM + DO 390 I=2,NEP + IEP(I)=IEP(I-1)+1 + IF(IEP(I).GT.N+NEP) IEP(I)=N+1 + 390 CONTINUE + DO 400 I=1,NEP + KFL(I)=IABS(K(IEP(I),2)) + 400 CONTINUE + ITRY(INUM)=ITRY(INUM)+1 + IF(ITRY(INUM).GT.200) THEN + CALL PYERRM(14,'(PYSHOW:) caught in infinite loop') + IF(MSTU(21).GE.1) RETURN + ENDIF + Z=0.5D0 + IR=IREF(IEP(1)-NS) + IF(KSH(IR).EQ.0) GOTO 450 + IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450 + +C...Check if evolution already predetermined for daughter. + IPSPD=0 + IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN + IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM + ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN + IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2 + IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3 + ENDIF + IF(INUM.EQ.1.OR.INUM.EQ.2) THEN + ISSET(INUM)=0 + IF(IPSPD.NE.0) ISSET(INUM)=1 + ENDIF + +C...Select side for interference with initial state partons. + IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN + III=IEP(1)-NS-1 + ISII(III)=0 + IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN + ISII(III)=1 + ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN + IF(PYR(0).GT.0.5D0) ISII(III)=1 + ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN + ISII(III)=1 + IF(PYR(0).GT.0.5D0) ISII(III)=2 + ENDIF + ENDIF + +C...Calculate allowed z range. + IF(NEP.EQ.1) THEN + PMED=PS(4) + ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN + PMED=P(IM,5) + ELSE + IF(INUM.EQ.1) PMED=V(IM,1)*PEM + IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM + ENDIF + IF(MOD(MSTJ(43),2).EQ.1) THEN + ZC=PMTH(2,21)/PMED + ZCE=PMTH(2,22)/PMED + IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED + ELSE + ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2))) + IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2 + PMTMPE=PMTH(2,22) + IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90) + ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2))) + IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2 + ENDIF + ZC=MIN(ZC,0.491D0) + ZCE=MIN(ZCE,0.49991D0) + IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND. + &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN + P(IEP(1),5)=PMTH(1,IR) + V(IEP(1),5)=P(IEP(1),5)**2 + GOTO 450 + ENDIF + +C...Integral of Altarelli-Parisi z kernel for QCD. +C...(Includes squark and gluino; with factor N_C/C_F extra for latter). + IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN + FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0 +C...QUARKONIA+++ +C...Evolution of QQ~[3S18] state if MSTP(148)=1. + ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND. + & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN + FBR=6D0*LOG((1D0-ZC)/ZC) +C...QUARKONIA--- + ELSEIF(MSTJ(49).EQ.0) THEN + FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC) + IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0) + +C...Integral of Altarelli-Parisi z kernel for scalar gluon. + ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN + FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC) + ELSEIF(MSTJ(49).EQ.1) THEN + FBR=(1D0-2D0*ZC)/3D0 + IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR + +C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon. + ELSEIF(KFL(1).EQ.21) THEN + FBR=6D0*MSTJ(45)*(0.5D0-ZC) + ELSE + FBR=2D0*LOG((1D0-ZC)/ZC) + ENDIF + +C...Reset QCD probability for colourless. + IF(ISCOL(IR).EQ.0) FBR=0D0 + +C...Integral of Altarelli-Parisi kernel for photon emission. + FBRE=0D0 + IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN + IF(KFL(1).LE.18) THEN + FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE) + ENDIF + IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE + ENDIF + +C...Inner veto algorithm starts. Find maximum mass for evolution. + 410 PMS=V(IEP(1),5) + IF(IGM.GE.0) THEN + PM2=0D0 + DO 420 I=2,NEP + PM=P(IEP(I),5) + IRI=IREF(IEP(I)-NS) + IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI) + PM2=PM2+PM + 420 CONTINUE + PMS=MIN(PMS,(P(IM,5)-PM2)**2) + ENDIF + +C...Select mass for daughter in QCD evolution. + B0=27D0/6D0 + DO 430 IFF=4,MSTJ(45) + IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0 + 430 CONTINUE +C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2. + PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2) +C...Already predetermined choice. + IF(IPSPD.NE.0) THEN + PMSQCD=P(IPSPD,5)**2 + ELSEIF(FBR.LT.1D-3) THEN + PMSQCD=0D0 + ELSEIF(MSTJ(44).LE.0) THEN + PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR))) + ELSEIF(MSTJ(44).EQ.1) THEN + PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR)) + ELSE + PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR)) + ENDIF +C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2. + IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2 + IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2 + V(IEP(1),5)=PMSQCD + MCE=1 + +C...Select mass for daughter in QED evolution. + IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN +C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2. + PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2) + IF(FBRE.LT.1D-3) THEN + PMSQED=0D0 + ELSE + PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/ + & (PARU(101)*FBRE))) + ENDIF +C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2. + PMSQED=PMSQED+PMTH(1,IR)**2 + IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED= + & PMTH(2,IR)**2 + IF(PMSQED.GT.PMSQCD) THEN + V(IEP(1),5)=PMSQED + MCE=2 + ENDIF + ENDIF + +C...Check whether daughter mass below cutoff. + P(IEP(1),5)=SQRT(V(IEP(1),5)) + IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN + P(IEP(1),5)=PMTH(1,IR) + V(IEP(1),5)=P(IEP(1),5)**2 + GOTO 450 + ENDIF + +C...Already predetermined choice of z, and flavour in g -> qqbar. + IF(IPSPD.NE.0) THEN + IPSGD1=K(IPSPD,4) + IPSGD2=K(IPSPD,5) + PMSGD1=P(IPSGD1,5)**2 + PMSGD2=P(IPSGD2,5)**2 + ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2- + & 4D0*PMSGD1*PMSGD2)) + Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS- + & PMSGD1+PMSGD2)/ALAMPS + Z=MAX(0.00001D0,MIN(0.99999D0,Z)) + IF(KFL(1).NE.21) THEN + K(IEP(1),5)=21 + ELSE + K(IEP(1),5)=IABS(K(IPSGD1,2)) + ENDIF + +C...Select z value of branching: q -> qgamma. + ELSEIF(MCE.EQ.2) THEN + Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0) + IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410 + K(IEP(1),5)=22 + +C...QUARKONIA+++ +C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g. + ELSEIF(MSTJ(49).EQ.0.AND. + & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN + Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0) +C...Select always the harder 'gluon' if the switch MSTP(149)<=0. + IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z + IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410 + K(IEP(1),5)=21 +C...QUARKONIA--- + +C...Select z value of branching: q -> qg, g -> gg, g -> qqbar. + ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN + Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0) +C...Only do z weighting when no ME correction afterwards. + IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410 + K(IEP(1),5)=21 + ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN + Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0) + IF(PYR(0).GT.0.5D0) Z=1D0-Z + IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410 + K(IEP(1),5)=21 + ELSEIF(MSTJ(49).NE.1) THEN + Z=PYR(0) + IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410 + KFLB=1+INT(MSTJ(45)*PYR(0)) + PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5) + IF(PMQ.GE.1D0) GOTO 410 + IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN + IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410 + PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5) + IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ) + & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410 + ELSE + IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410 + ENDIF + K(IEP(1),5)=KFLB + +C...Ditto for scalar gluon model. + ELSEIF(KFL(1).NE.21) THEN + Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC)) + K(IEP(1),5)=21 + ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN + Z=ZC+(1D0-2D0*ZC)*PYR(0) + K(IEP(1),5)=21 + ELSE + Z=ZC+(1D0-2D0*ZC)*PYR(0) + KFLB=1+INT(MSTJ(45)*PYR(0)) + PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5) + IF(PMQ.GE.1D0) GOTO 410 + K(IEP(1),5)=KFLB + ENDIF + +C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar). + IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN + IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND. + & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN + IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410 + ELSE + PT2APP=Z*(1D0-Z)*V(IEP(1),5) + IF(MSTJ(44).GE.4) PT2APP=PT2APP* + & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2 + IF(PT2APP.LT.PT2MIN) GOTO 410 + IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410 + ENDIF + ENDIF + +C...Check if z consistent with chosen m. + IF(KFL(1).EQ.21) THEN + IRGD1=IABS(K(IEP(1),5)) + IRGD2=IRGD1 + ELSE + IRGD1=IR + IRGD2=IABS(K(IEP(1),5)) + ENDIF + IF(NEP.EQ.1) THEN + PED=PS(4) + ELSEIF(NEP.GE.3) THEN + PED=P(IEP(1),4) + ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN + PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5) + ELSE + IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM + IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM + ENDIF + IF(MOD(MSTJ(43),2).EQ.1) THEN + PMQTH3=0.5D0*PARJ(82) + IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83) + IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90) + PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5) + PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5) + ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2- + & 4D0*PMQ1*PMQ2))) + ZH=1D0+PMQ1-PMQ2 + ELSE + ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2)) + ZH=1D0 + ENDIF + IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND. + &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN + ELSEIF(IPSPD.NE.0) THEN + ELSE + ZL=0.5D0*(ZH-ZD) + ZU=0.5D0*(ZH+ZD) + IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410 + ENDIF + IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL* + &(1D0-ZU))) + IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU)) + +C...Width suppression for q -> q + g. + IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN + IF(IGM.EQ.0) THEN + EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5)) + ELSE + EGLU=PMED*(1D0-Z) + ENDIF + CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2) + IF(MSTJ(40).EQ.1) THEN + IF(CHI.LT.PYR(0)) GOTO 410 + ELSEIF(MSTJ(40).EQ.2) THEN + IF(1D0-CHI.LT.PYR(0)) GOTO 410 + ENDIF + ENDIF + +C...Three-jet matrix element correction. + IF(M3JC.GE.1) THEN + WME=1D0 + WSHOW=1D0 + +C...QED matrix elements: only for massless case so far. + IF(MCE.EQ.2.AND.IGM.EQ.0) THEN + X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5)) + X2=1D0-V(IEP(1),5)/V(NS+1,5) + X3=(1D0-X1)+(1D0-X2) + KI1=K(IPA(INUM),2) + KI2=K(IPA(3-INUM),2) + QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0 + QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0 + WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+ + & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2) + WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2) + ELSEIF(MCE.EQ.2) THEN + +C...QCD matrix elements, including mass effects. + ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN + PS1ME=V(IEP(1),5) + PM1ME=PMTH(1,IR) + M3JCC=M3JC + IF(IR.GE.31.AND.IGM.EQ.0) THEN +C...QCD ME: original parton, first branching. + PM2ME=PMTH(1,63-IR) + ECMME=PS(5) + ELSEIF(IR.GE.31) THEN +C...QCD ME: original parton, subsequent branchings. + PM2ME=PMTH(1,63-IR) + PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5)) + ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2)) + ELSEIF(K(IM,2).EQ.21) THEN +C...QCD ME: secondary partons, first branching. + PM2ME=PM1ME + ZMME=V(IM,1) + IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME + PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2- + & 4D0*PS1ME*PM2ME**2)) + PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/ + & V(IM,5) + ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2)) + M3JCC=66 + ELSE +C...QCD ME: secondary partons, subsequent branchings. + PM2ME=PM1ME + PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5)) + ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2)) + M3JCC=66 + ENDIF +C...Construct ME variables. + R1ME=PM1ME/ECMME + R2ME=PM2ME/ECMME + X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME) + X2=1D0+R2ME**2-PS1ME/ECMME**2 +C...Call ME, with right order important for two inequivalent showerers. + IF(IR.EQ.IORD+30) THEN + WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA) + ELSE + WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA) + ENDIF +C...Split up total ME when two radiating partons. + ISPRAD=1 + IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR. + & (M3JCC.GE.26.AND.M3JCC.LE.29).OR. + & (M3JCC.GE.36.AND.M3JCC.LE.39).OR. + & (M3JCC.GE.46.AND.M3JCC.LE.49).OR. + & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0 + IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/ + & MAX(1D-10,2D0-X1-X2) +C...Evaluate shower rate to be compared with. + WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)* + & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2)) + IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW + ELSEIF(MSTJ(49).NE.1) THEN + +C...Toy model scalar theory matrix elements; no mass effects. + ELSE + X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5)) + X2=1D0-V(IEP(1),5)/V(NS+1,5) + X3=(1D0-X1)+(1D0-X2) + WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2) + WME=X3**2 + IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)* + & PARJ(171) + ENDIF + + IF(WME.LT.PYR(0)*WSHOW) GOTO 410 + ENDIF + +C...Impose angular ordering by rejection of nonordered emission. + IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN + PEMAO=V(IM,1)*P(IM,4) + IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4) + IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN + MAOD=0 + ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4 + & .OR.MSTJ(42).EQ.7)) THEN + MAOD=0 + ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3 + & .OR.MSTJ(42).EQ.6)) THEN + MAOD=1 + PMDAO=PMTH(2,K(IEP(1),5)) + THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2) + ELSE + MAOD=1 + THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5) + IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID* + & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2 + ENDIF + MAOM=1 + IAOM=IM + 440 IF(K(IAOM,5).EQ.22) THEN + IAOM=K(IAOM,3) + IF(K(IAOM,3).LE.NS) MAOM=0 + IF(MAOM.EQ.1) GOTO 440 + ENDIF + IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN + THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5) + IF(THE2ID.LT.THE2IM) GOTO 410 + ENDIF + ENDIF + +C...Impose user-defined maximum angle at first branching. + IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN + IF(NEP.EQ.1.AND.IM.EQ.NS) THEN + THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5) + IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410 + ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN + THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5) + IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410 + ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN + THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5) + IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410 + ENDIF + ENDIF + +C...Impose angular constraint in first branching from interference +C...with initial state partons. + IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN + THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2 + IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN + IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410 + ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN + IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410 + ENDIF + ENDIF + +C...End of inner veto algorithm. Check if only one leg evolved so far. + 450 V(IEP(1),1)=Z + ISL(1)=0 + ISL(2)=0 + IF(NEP.EQ.1) GOTO 490 + IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350 + DO 460 I=1,NEP + IR=IREF(N+I-NS) + IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN + IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350 + ENDIF + 460 CONTINUE + +C...Check if chosen multiplet m1,m2,z1,z2 is physical. + IF(NEP.GE.3) THEN + PMSUM=0D0 + DO 470 I=1,NEP + PMSUM=PMSUM+P(N+I,5) + 470 CONTINUE + IF(PMSUM.GE.PS(5)) GOTO 350 + ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN + DO 480 I1=N+1,N+2 + IRDA=IREF(I1-NS) + IF(KSH(IRDA).EQ.0) GOTO 480 + IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480 + IF(IRDA.EQ.21) THEN + IRGD1=IABS(K(I1,5)) + IRGD2=IRGD1 + ELSE + IRGD1=IRDA + IRGD2=IABS(K(I1,5)) + ENDIF + I2=2*N+3-I1 + IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN + PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5) + ELSE + IF(I1.EQ.N+1) ZM=V(IM,1) + IF(I1.EQ.N+2) ZM=1D0-V(IM,1) + PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2- + & 4D0*V(N+1,5)*V(N+2,5)) + PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/ + & V(IM,5) + ENDIF + IF(MOD(MSTJ(43),2).EQ.1) THEN + PMQTH3=0.5D0*PARJ(82) + IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83) + IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90) + PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5) + PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5) + ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2- + & 4D0*PMQ1*PMQ2))) + ZH=1D0+PMQ1-PMQ2 + ELSE + ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2)) + ZH=1D0 + ENDIF + IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND. + & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN + ELSE + ZL=0.5D0*(ZH-ZD) + ZU=0.5D0*(ZH+ZD) + IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND. + & ISSET(1).EQ.0) THEN + ISL(1)=1 + ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND. + & ISSET(2).EQ.0) THEN + ISL(2)=1 + ENDIF + ENDIF + IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20, + & ZL*(1D0-ZU))) + IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU)) + 480 CONTINUE + IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN + ISL(3-ISLM)=0 + ISLM=3-ISLM + ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN + ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0) + ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0) + IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0 + IF(ISL(1).EQ.1) ISL(2)=0 + IF(ISL(1).EQ.0) ISLM=1 + IF(ISL(2).EQ.0) ISLM=2 + ENDIF + IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350 + ENDIF + IRD1=IREF(N+1-NS) + IRD2=IREF(N+2-NS) + IF(IGM.GT.0) THEN + IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE. + & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN + PMQ1=V(N+1,5)/V(IM,5) + PMQ2=V(N+2,5)/V(IM,5) + ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2- + & 4D0*PMQ1*PMQ2))) + ZH=1D0+PMQ1-PMQ2 + ZL=0.5D0*(ZH-ZD) + ZU=0.5D0*(ZH+ZD) + IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350 + ENDIF + ENDIF + +C...Accepted branch. Construct four-momentum for initial partons. + 490 MAZIP=0 + MAZIC=0 + IF(NEP.EQ.1) THEN + P(N+1,1)=0D0 + P(N+1,2)=0D0 + P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)- + & P(N+1,5)))) + P(N+1,4)=P(IPA(1),4) + V(N+1,2)=P(N+1,4) + ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN + PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5) + P(N+1,1)=0D0 + P(N+1,2)=0D0 + P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5)))) + P(N+1,4)=PED1 + P(N+2,1)=0D0 + P(N+2,2)=0D0 + P(N+2,3)=-P(N+1,3) + P(N+2,4)=P(IM,5)-PED1 + V(N+1,2)=P(N+1,4) + V(N+2,2)=P(N+2,4) + ELSEIF(NEP.GE.3) THEN +C...Rescale all momenta for energy conservation. + LOOP=0 + PES=0D0 + PQS=0D0 + DO 510 I=1,NEP + DO 500 J=1,4 + P(N+I,J)=P(IPA(I),J) + 500 CONTINUE + PES=PES+P(N+I,4) + PQS=PQS+P(N+I,5)**2/P(N+I,4) + 510 CONTINUE + 520 LOOP=LOOP+1 + FAC=(PS(5)-PQS)/(PES-PQS) + PES=0D0 + PQS=0D0 + DO 540 I=1,NEP + DO 530 J=1,3 + P(N+I,J)=FAC*P(N+I,J) + 530 CONTINUE + P(N+I,4)=SQRT(P(N+I,5)**2+P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2) + V(N+I,2)=P(N+I,4) + PES=PES+P(N+I,4) + PQS=PQS+P(N+I,5)**2/P(N+I,4) + 540 CONTINUE + IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520 + +C...Construct transverse momentum for ordinary branching in shower. + ELSE + ZM=V(IM,1) + LOOPPT=0 + 550 LOOPPT=LOOPPT+1 + PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5)))) + PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5) + IF(PZM.LE.0D0) THEN + PTS=0D0 + ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND. + & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN + PTS=PMLS*ZM*(1D0-ZM)/V(IM,5) + ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN + PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)- + & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2 + ELSE + PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2 + ENDIF + IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN + ZM=0.05D0+0.9D0*ZM + GOTO 550 + ELSEIF(PTS.LT.0D0) THEN + GOTO 280 + ENDIF + PT=SQRT(MAX(0D0,PTS)) + +C...Global statistics. + MINT(353)=MINT(353)+1 + VINT(353)=VINT(353)+PT + IF (MINT(353).EQ.1) VINT(358)=PT + +C...Find coefficient of azimuthal asymmetry due to gluon polarization. + HAZIP=0D0 + IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21 + & .AND.IAU.NE.0) THEN + IF(K(IGM,3).NE.0) MAZIP=1 + ZAU=V(IGM,1) + IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1) + IF(MAZIP.EQ.0) ZAU=0D0 + IF(K(IGM,2).NE.21) THEN + HAZIP=2D0*ZAU/(1D0+ZAU**2) + ELSE + HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2 + ENDIF + IF(K(N+1,2).NE.21) THEN + HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM)) + ELSE + HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2 + ENDIF + ENDIF + +C...Find coefficient of azimuthal asymmetry due to soft gluon +C...interference. + HAZIC=0D0 + IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR. + & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN + IF(K(IGM,3).NE.0) MAZIC=N+1 + IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2 + IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND. + & ZM.GT.0.5D0) MAZIC=N+2 + IF(K(IAU,2).EQ.22) MAZIC=0 + ZS=ZM + IF(MAZIC.EQ.N+2) ZS=1D0-ZM + ZGM=V(IGM,1) + IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1) + IF(MAZIC.EQ.0) ZGM=1D0 + IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))* + & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM)) + HAZIC=MIN(0.95D0,HAZIC) + ENDIF + ENDIF + +C...Construct energies for ordinary branching in shower. + 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN + IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND. + & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN + P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+ + & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5) + ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN + P(N+1,4)=PEM*V(IM,1) + ELSE + P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+ + & SQRT(PMLS)*ZM)/V(IM,5) + ENDIF + +C...Already predetermined choice of phi angle or not + PHI=PARU(2)*PYR(0) + IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN + IPSPD=IP1+IM-NS-2 + IF(K(IPSPD,4).GT.0) THEN + IPSGD1=K(IPSPD,4) + IF(IM.EQ.NS+2) THEN + PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2)) + ELSE + PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2)) + ENDIF + ENDIF + ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN + IPSPD=IP1+IM-NS-2 + IF(K(IPSPD,4).GT.0) THEN + IPSGD1=K(IPSPD,4) + PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2)) + THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2)) + CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0) + CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0) + PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2)) + CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0) + ENDIF + ENDIF + +C...Construct momenta for ordinary branching in shower. + P(N+1,1)=PT*COS(PHI) + P(N+1,2)=PT*SIN(PHI) + IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND. + & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN + P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+ + & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5) + ELSEIF(PZM.GT.0D0) THEN + P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+ + & 2D0*PEM*P(N+1,4))/PZM + ELSE + P(N+1,3)=0D0 + ENDIF + P(N+2,1)=-P(N+1,1) + P(N+2,2)=-P(N+1,2) + P(N+2,3)=PZM-P(N+1,3) + P(N+2,4)=PEM-P(N+1,4) + IF(MSTJ(43).LE.2) THEN + V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5) + V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5) + ENDIF + ENDIF + +C...Rotate and boost daughters. + IF(IGM.GT.0) THEN + IF(MSTJ(43).LE.2) THEN + BEX=P(IGM,1)/P(IGM,4) + BEY=P(IGM,2)/P(IGM,4) + BEZ=P(IGM,3)/P(IGM,4) + GA=P(IGM,4)/P(IGM,5) + GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)- + & P(IM,4)) + ELSE + BEX=0D0 + BEY=0D0 + BEZ=0D0 + GA=1D0 + GABEP=0D0 + ENDIF + PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2) + THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB) + IF(PTIMB.GT.1D-4) THEN + PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY) + ELSE + PHI=0D0 + ENDIF + DO 570 I=N+1,N+2 + DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+ + & SIN(THE)*COS(PHI)*P(I,3) + DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+ + & SIN(THE)*SIN(PHI)*P(I,3) + DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3) + DP(4)=P(I,4) + DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3) + DGABP=GA*(GA*DBP/(1D0+GA)+DP(4)) + P(I,1)=DP(1)+DGABP*BEX + P(I,2)=DP(2)+DGABP*BEY + P(I,3)=DP(3)+DGABP*BEZ + P(I,4)=GA*(DP(4)+DBP) + 570 CONTINUE + ENDIF + +C...Weight with azimuthal distribution, if required. + IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN + DO 580 J=1,3 + DPT(1,J)=P(IM,J) + DPT(2,J)=P(IAU,J) + DPT(3,J)=P(N+1,J) + 580 CONTINUE + DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3) + DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3) + DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2 + DO 590 J=1,3 + DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM) + DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM) + 590 CONTINUE + DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2) + DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2) + IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN + CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+ + & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4)) + IF(MAZIP.NE.0) THEN + IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP))) + & GOTO 560 + ENDIF + IF(MAZIC.NE.0) THEN + IF(MAZIC.EQ.N+2) CAD=-CAD + IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD) + & .LT.PYR(0)) GOTO 560 + ENDIF + ENDIF + ENDIF + +C...Azimuthal anisotropy due to interference with initial state partons. + IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR. + &K(N+2,2).EQ.21)) THEN + III=IM-NS-1 + IF(ISII(III).GE.1) THEN + IAZIID=N+1 + IF(K(N+1,2).NE.21) IAZIID=N+2 + IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND. + & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2 + THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2)) + IF(III.EQ.2) THEIID=PARU(1)-THEIID + PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2)) + HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III))) + CAD=COS(PHIIID-PHIIIS(III,ISII(III))) + PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III))) + IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL + IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD) + & .LT.PYR(0)) GOTO 560 + ENDIF + ENDIF + +C...Continue loop over partons that may branch, until none left. + IF(IGM.GE.0) K(IM,1)=14 + N=N+NEP + NEP=2 + IF(N.GT.MSTU(4)-MSTU(32)-10) THEN + CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS') + IF(MSTU(21).GE.1) N=NS + IF(MSTU(21).GE.1) RETURN + ENDIF + GOTO 290 + +C...Set information on imagined shower initiator. + 600 IF(NPA.GE.2) THEN + K(NS+1,1)=11 + K(NS+1,2)=94 + K(NS+1,3)=IP1 + IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2 + K(NS+1,4)=NS+2 + K(NS+1,5)=NS+1+NPA + IIM=1 + ELSE + IIM=0 + ENDIF + +C...Reconstruct string drawing information. + DO 610 I=NS+1+IIM,N + KQ=KCHG(PYCOMP(K(I,2)),2) + IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN + K(I,1)=1 + ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND. + & IABS(K(I,2)).LE.18) THEN + K(I,1)=1 + ELSEIF(K(I,1).LE.10) THEN + K(I,4)=MSTU(5)*(K(I,4)/MSTU(5)) + K(I,5)=MSTU(5)*(K(I,5)/MSTU(5)) + ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN + ID1=MOD(K(I,4),MSTU(5)) + IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1 + IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND. + & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1 + ID2=2*MOD(K(I,4),MSTU(5))+1-ID1 + K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1 + K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2 + K(ID1,4)=K(ID1,4)+MSTU(5)*I + K(ID1,5)=K(ID1,5)+MSTU(5)*ID2 + K(ID2,4)=K(ID2,4)+MSTU(5)*ID1 + K(ID2,5)=K(ID2,5)+MSTU(5)*I + ELSE + ID1=MOD(K(I,4),MSTU(5)) + ID2=ID1+1 + K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1 + K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1 + IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN + K(ID1,4)=K(ID1,4)+MSTU(5)*I + K(ID1,5)=K(ID1,5)+MSTU(5)*I + ELSE + K(ID1,4)=0 + K(ID1,5)=0 + ENDIF + K(ID2,4)=0 + K(ID2,5)=0 + ENDIF + 610 CONTINUE + +C...Transformation from CM frame. + IF(NPA.EQ.1) THEN + THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2)) + PHI=PYANGL(P(IPA(1),1),P(IPA(1),2)) + MSTU(33)=1 + CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0) + ELSEIF(NPA.EQ.2) THEN + BEX=PS(1)/PS(4) + BEY=PS(2)/PS(4) + BEZ=PS(3)/PS(4) + GA=PS(4)/PS(5) + GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3)) + & /(1D0+GA)-P(IPA(1),4)) + THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1) + & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2)) + PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY) + MSTU(33)=1 + CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ) + ELSE + CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4), + & PS(3)/PS(4)) + MSTU(33)=1 + CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4)) + ENDIF + +C...Decay vertex of shower. + DO 630 I=NS+1,N + DO 620 J=1,5 + V(I,J)=V(IP1,J) + 620 CONTINUE + 630 CONTINUE + +C...Delete trivial shower, else connect initiators. + IF(N.LE.NS+NPA+IIM) THEN + N=NS + ELSE + DO 640 IP=1,NPA + K(IPA(IP),1)=14 + K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP + K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP + K(NS+IIM+IP,3)=IPA(IP) + IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1 + IF(K(NS+IIM+IP,1).NE.1) THEN + K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4) + K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5) + ENDIF + 640 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYPTFS +C...Generates pT-ordered timelike final-state parton showers. + +C...MODE defines how to find radiators and recoilers. +C... = 0 : based on colour flow between undecayed partons. +C... = 1 : for IPART <= NPARTD only consider primary partons, +C... whether decayed or not; else as above. +C... = 2 : based on common history, whether decayed or not. +C... = 3 : use (or create) MCT color information to shower partons + + SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Parameter statement for maximum size of showers. + PARAMETER (MAXNUR=1000) +C...Commonblocks. + COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR) + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYCTAG/NCT,MCT(4000,2) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + COMMON/PYINT1/MINT(400),VINT(400) + SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/, + &/PYINT1/ +C...Local arrays. + DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR), + &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR), + &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR), + &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4) +C...Statement functions. + SHAT(L,J)=(P(L,4)+P(J,4))**2-(P(L,1)+P(J,1))**2- + &(P(L,2)+P(J,2))**2-(P(L,3)+P(J,3))**2 + DOTP(L,J)=P(L,4)*P(J,4)-P(L,1)*P(J,1)-P(L,2)*P(J,2)-P(L,3)*P(J,3) + +C...Initial values. Check that valid system. + PTGEN=0D0 + IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND. + &MSTJ(41).NE.12) RETURN + IF(NPART.LE.0) THEN + CALL PYERRM(2,'(PYPTFS:) showering system too small') + RETURN + ENDIF + PT2CMX=PTMAX**2 + IORD=1 + +C...Mass thresholds and Lambda for QCD evolution. + PMB=PMAS(5,1) + PMC=PMAS(4,1) + ALAM5=PARJ(81) + ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0) + ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0) + PMBS=PMB**2 + PMCS=PMC**2 + ALAM5S=ALAM5**2 + ALAM4S=ALAM4**2 + ALAM3S=ALAM3**2 + +C...Cutoff scale for QCD evolution. Starting pT2. + NFLAV=MAX(0,MIN(5,MSTJ(45))) + PT0C=0.5D0*PARJ(82) + PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2 + +C...Parameters for QED evolution. + AEM2PI=PARU(101)/PARU(2) + PT0EQ=0.5D0*PARJ(83) + PT0EL=0.5D0*PARJ(90) + +C...Reset. Remove irrelevant colour tags. + NEVOL=0 + DO 100 J=1,4 + PSUM(J)=0D0 + 100 CONTINUE + DO 110 I=MINT(84)+1,N + IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN + K(I,5)=0 + MCT(I,2)=0 + ENDIF + IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN + K(I,4)=0 + MCT(I,1)=0 + ENDIF + 110 CONTINUE + NPARTS=NPART + +C...Begin loop to set up showering partons. Sum four-momenta. + DO 230 IP=1,NPART + I=IPART(IP) + IF(MODE.NE.1.OR.I.GT.NPARTD) THEN + IF(K(I,1).GT.10) GOTO 230 + ELSEIF(K(I,3).GT.MINT(84)) THEN + IF(K(I,3).GT.MINT(84)+2) GOTO 230 + ELSE + IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 230 + ENDIF + DO 120 J=1,4 + PSUM(J)=PSUM(J)+P(I,J) + 120 CONTINUE + +C...Find colour and charge, but skip diquarks. + IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 230 + KCOL=PYK(I,12) + KCHA=PYK(I,6) + +C...QUARKONIA++ + IF (IABS(K(I,2)).GE.9900101.AND.IABS(K(I,2)).LE.9910555) THEN + IF (MSTP(148).GE.1) THEN +C...Temporary: force no radiation from quarkonia since not yet treated + CALL PYERRM(11,'(PYPTFS:) quarkonia showers not yet in' + & //' PYPTFS, switched off') + CALL PYGIVE('MSTP(148)=0') + ENDIF + IF (MSTP(148).EQ.0) THEN +C...Skip quarkonia if radiation switched off + GOTO 230 + ENDIF + ENDIF +C...QUARKONIA-- + +C...Option to switch off radiation from particle KF = MSTJ(39) entirely +C...(only intended for studying the effects of switching such rad on/off) + IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) THEN + GOTO 230 + ENDIF + +C...Either colour or anticolour charge radiates; for gluon both. + DO 180 JSGCOL=1,-1,-2 + IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN + JCOL=4+(1-JSGCOL)/2 + JCOLR=9-JCOL + +C...Basic info about radiating parton. + NEVOL=NEVOL+1 + IPOS(NEVOL)=I + IFLG(NEVOL)=0 + ISCOL(NEVOL)=JSGCOL + ISCHG(NEVOL)=0 + PTSCA(NEVOL)=PTPART(IP) + +C...Begin search for colour recoiler when MODE = 0 or 1. + IF(MODE.LE.1) THEN +C...Find sister with matching anticolour to the radiating parton. + IROLD=I + IRNEW=K(IROLD,JCOL)/MSTU(5) + MOVE=1 + +C...Skip radiation off loose colour ends. + 130 IF(IRNEW.EQ.0) THEN + NEVOL=NEVOL-1 + GOTO 180 + +C...Optionally skip radiation on dipole to beam remnant. + ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN + NEVOL=NEVOL-1 + GOTO 180 + +C...For now always skip radiation on dipole to junction. + ELSEIF(K(IRNEW,2).EQ.88) THEN + NEVOL=NEVOL-1 + GOTO 180 + +C...For MODE=1: if reached primary then done. + ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND. + & IRNEW.LE.NPARTD) THEN + +C...If sister stable and points back then done. + ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD) + & THEN + IF(K(IRNEW,1).LT.10) THEN + +C...If sister unstable then go to her daughter. + ELSE + IROLD=IRNEW + IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5)) + MOVE=2 + GOTO 130 + ENDIF + +C...If found mother then look for aunt. + ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ. + & IROLD) THEN + IROLD=IRNEW + IRNEW=K(IROLD,JCOL)/MSTU(5) + GOTO 130 + +C...If daughter stable then done. + ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD) + & THEN + IF(K(IRNEW,1).LT.10) THEN + +C...If daughter unstable then go to granddaughter. + ELSE + IROLD=IRNEW + IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5)) + MOVE=2 + GOTO 130 + ENDIF + +C...If daughter points to another daughter then done or move up. + ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ. + & IROLD) THEN + IF(K(IRNEW,1).LT.10) THEN + ELSE + IROLD=IRNEW + IRNEW=K(IRNEW,JCOL)/MSTU(5) + MOVE=1 + GOTO 130 + ENDIF + ENDIF + +C...Begin search for colour recoiler when MODE = 2. + ELSEIF (MODE.EQ.2) THEN + IROLD=I + IRNEW=K(IROLD,JCOL)/MSTU(5) + 140 IF (IRNEW.LE.0.OR.IRNEW.GT.N) THEN +C...If no color partner found, pick at random among other primaries +C...(e.g., when the color line is traced all the way to the beam) + ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0)))) + IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART)) + ELSEIF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN +C...Step up to mother if radiating parton already branched. + IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN + IROLD=IRNEW + IRNEW=K(IROLD,JCOL)/MSTU(5) + GOTO 140 +C...Pick sister by history if no anticolour available. + ELSE + IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN + IRNEW=IROLD-1 + ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) + & THEN + IRNEW=IROLD+1 +C...Last resort: pick at random among other primaries. + ELSE + ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0)))) + IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART)) + ENDIF + ENDIF + ENDIF +C...Trace down if sister branched. + 150 IF(K(IRNEW,1).GT.10) THEN + IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5)) +C...If no correct color-daughter found, swap. + IF (IRTMP.EQ.0) THEN + JCOL=9-JCOL + JCOLR=9-JCOLR + IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5)) + ENDIF + IRNEW=IRTMP + GOTO 150 + ENDIF + ELSEIF (MODE.EQ.3) THEN +C...The following will add MCT colour tracing for unprepped events +C...If not done, trace Les Houches colour tags for this dipole + JCOLSV=JCOL + IF (MCT(I,JCOL-3).EQ.0) THEN +C...Special end code -1 : trace to color partner or 0, return in IEND + IEND=-1 + CALL PYCTTR(I,JCOL,IEND) +C...Clean up mother/daughter 'read' tags set by PYCTTR + JCOL=JCOLSV + DO 160 IR=1,N + K(IR,4)=MOD(K(IR,4),MSTU(5)**2) + K(IR,5)=MOD(K(IR,5),MSTU(5)**2) + MCT(IR,1)=0 + MCT(IR,2)=0 + 160 CONTINUE + ELSE + IEND=0 + DO 170 IR=1,N + IF (K(IR,1).GT.0.AND.MCT(IR,6-JCOL).EQ.MCT(I,JCOL-3)) + & IEND=IR + 170 CONTINUE + ENDIF +C...If no color partner, then we hit beam + IF (IEND.LE.0) THEN +C...For MSTP(72) <= 1, do not allow dipoles stretched to beam to radiate + IF (MSTP(72).LE.1) THEN + NEVOL=NEVOL-1 + GOTO 180 + ELSE +C...Else try a random partner + ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0)))) + IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART)) + ENDIF + ELSE +C...Else save recoiling colour partner + IRNEW=IEND + ENDIF + + ENDIF + +C...Now found other end of colour dipole. + IREC(NEVOL)=IRNEW + ENDIF + 180 CONTINUE + +C...Also electrical charge may radiate; so far only quarks and leptons. + IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND. + & IABS(K(I,2)).LE.18) THEN + +C...Basic info about radiating parton. + NEVOL=NEVOL+1 + IPOS(NEVOL)=I + IFLG(NEVOL)=0 + ISCOL(NEVOL)=0 + ISCHG(NEVOL)=KCHA + PTSCA(NEVOL)=PTPART(IP) + +C...Pick nearest (= smallest invariant mass) charged particle +C...as recoiler when MODE = 0 or 1 (but for latter among primaries). + IF(MODE.LE.1) THEN + IRNEW=0 + PM2MIN=VINT(2) + DO 190 IP2=1,NPART+N-MINT(53) + IF(IP2.EQ.IP) GOTO 190 + IF(IP2.LE.NPART) THEN + I2=IPART(IP2) + IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN + IF(K(I2,1).GT.10) GOTO 190 + ELSEIF(K(I2,3).GT.MINT(84)) THEN + IF(K(I2,3).GT.MINT(84)+2) GOTO 190 + ELSE + IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 190 + ENDIF + ELSE + I2=MINT(53)+IP2-NPART + ENDIF + IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 190 + PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2- + & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2 + IF(PM2INV.LT.PM2MIN) THEN + IRNEW=I2 + PM2MIN=PM2INV + ENDIF + 190 CONTINUE + IF(IRNEW.EQ.0) THEN + NEVOL=NEVOL-1 + GOTO 230 + ENDIF + +C...Begin search for charge recoiler when MODE = 2. + ELSE + IROLD=I +C...Pick sister by history; step up if parton already branched. + 200 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN + IROLD=K(IROLD,3) + GOTO 200 + ENDIF + IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN + IRNEW=IROLD-1 + ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN + IRNEW=IROLD+1 +C...Last resort: pick at random among other primaries. + ELSE + ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0)))) + IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART)) + ENDIF +C...Trace down if sister branched. + 210 IF(K(IRNEW,1).GT.10) THEN + DO 220 IR=IRNEW+1,N + IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN + IRNEW=IR + GOTO 210 + ENDIF + 220 CONTINUE + ENDIF + ENDIF + IREC(NEVOL)=IRNEW + ENDIF + +C...End loop to set up showering partons. System invariant mass. + 230 CONTINUE + IF(NEVOL.LE.0) RETURN + IF (MODE.EQ.3.AND.NEVOL.LE.1) RETURN + PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2)) + +C...Check if 3-jet matrix elements to be used. + M3JC=0 + ALPHA=0.5D0 + NMESYS=0 + IF(MSTJ(47).GE.1) THEN + +C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0). + KFSRCE=0 + IPART1=K(IPART(1),3) + IPART2=K(IPART(2),3) + 240 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN + KFSRCE=IABS(K(IPART1,2)) + ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN + IPART1=K(IPART1,3) + GOTO 240 + ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN + IPART2=K(IPART2,3) + GOTO 240 + ENDIF + ITYPES=0 + IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1 + IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2 + IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2 + IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3 + IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3 + IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4 + IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5 + IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6 + +C...Identify two primary showerers. + KFLA1=IABS(K(IPART(1),2)) + ITYPE1=0 + IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1 + IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2 + IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2 + IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3 + IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3 + IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4 + IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5 + IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6 + KFLA2=IABS(K(IPART(2),2)) + ITYPE2=0 + IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1 + IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2 + IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2 + IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3 + IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3 + IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4 + IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5 + IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6 + +C...Order of showerers. Presence of gluino. + ITYPMN=MIN(ITYPE1,ITYPE2) + ITYPMX=MAX(ITYPE1,ITYPE2) + IORD=1 + IF(ITYPE1.GT.ITYPE2) IORD=2 + IGLUI=0 + IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1 + +C...Require exactly two primary showerers for ME corrections. + NPRIM=0 + IF(IPART1.GT.0) THEN + DO 250 I=1,N + IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1 + 250 CONTINUE + ENDIF + IF(NPRIM.NE.2) THEN + +C...Predetermined and default matrix element kinds. + ELSEIF(MSTJ(38).NE.0) THEN + M3JC=MSTJ(38) + ALPHA=PARJ(80) + MSTJ(38)=0 + ELSEIF(MSTJ(47).GE.6) THEN + M3JC=MSTJ(47) + ELSE + ICLASS=1 + ICOMBI=4 + +C...Vector/axial vector -> q + qbar; q -> q + V. + IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.3)) THEN + ICLASS=2 + IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN + ICOMBI=1 + ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND. + & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN +C...gamma*/Z0: assume e+e- initial state if unknown. + EI=-1D0 + IF(KFSRCE.EQ.23) THEN + IANNFL=IPART1 + IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3) + IF(IANNFL.GT.0) THEN + IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3) + ENDIF + IF(IANNFL.NE.0) THEN + KANNFL=IABS(K(IANNFL,2)) + IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0 + ENDIF + ENDIF + AI=SIGN(1D0,EI+0.1D0) + VI=AI-4D0*EI*PARU(102) + EF=KCHG(KFLA1,1)/3D0 + AF=SIGN(1D0,EF+0.1D0) + VF=AF-4D0*EF*PARU(102) + XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102))) + SH=PSUM(5)**2 + SQMZ=PMAS(23,1)**2 + SQWZ=PSUM(5)*PMAS(23,2) + SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2) + VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+ + & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ + AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ + ICOMBI=3 + ALPHA=VECT/(VECT+AXIV) + ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN + ICOMBI=4 + ENDIF +C...For chi -> chi q qbar, use V/A -> q qbar as first approximation. + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN + ICLASS=2 + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.1)) THEN + ICLASS=3 + +C...Scalar/pseudoscalar -> q + qbar; q -> q + S. + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN + ICLASS=4 + IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN + ICOMBI=1 + ELSEIF(KFSRCE.EQ.36) THEN + ICOMBI=2 + ENDIF + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.1)) THEN + ICLASS=5 + +C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S. + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.3)) THEN + ICLASS=6 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.2)) THEN + ICLASS=7 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN + ICLASS=8 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.2)) THEN + ICLASS=9 + +C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi. + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.5)) THEN + ICLASS=10 + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.2)) THEN + ICLASS=11 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.1)) THEN + ICLASS=12 + +C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g. + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN + ICLASS=13 + ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.2)) THEN + ICLASS=14 + ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR. + & ITYPES.EQ.1)) THEN + ICLASS=15 + +C...g -> ~g + ~g (eikonal approximation). + ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN + ICLASS=16 + ENDIF + M3JC=5*ICLASS+ICOMBI + ENDIF + +C...Store pair that together define matrix element treatment. + IF(M3JC.NE.0) THEN + NMESYS=1 + MESYS(NMESYS,0)=M3JC + MESYS(NMESYS,1)=IPART(1) + MESYS(NMESYS,2)=IPART(2) + ENDIF + +C...Store qqbar or l+l- pairs for QED radiation. + IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN + NMESYS=NMESYS+1 + MESYS(NMESYS,0)=101 + IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102 + MESYS(NMESYS,1)=IPART(1) + MESYS(NMESYS,2)=IPART(2) + ENDIF + +C...Store other qqbar/l+l- pairs from g/gamma branchings. + DO 290 I1=1,N + IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 290 + I1M=K(I1,3) + 260 IF(I1M.GT.0) THEN + IF(K(I1M,2).EQ.K(I1,2)) THEN + I1M=K(I1M,3) + GOTO 260 + ENDIF + ENDIF +C...Move up this check to avoid out-of-bounds. + IF(I1M.EQ.0) GOTO 290 + IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 290 + DO 280 I2=I1+1,N + IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 280 + I2M=K(I2,3) + 270 IF(I2M.GT.0) THEN + IF(K(I2M,2).EQ.K(I2,2)) THEN + I2M=K(I2M,3) + GOTO 270 + ENDIF + ENDIF + IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN + NMESYS=NMESYS+1 + MESYS(NMESYS,0)=66 + MESYS(NMESYS,1)=I1 + MESYS(NMESYS,2)=I2 + NMESYS=NMESYS+1 + MESYS(NMESYS,0)=102 + MESYS(NMESYS,1)=I1 + MESYS(NMESYS,2)=I2 + ENDIF + 280 CONTINUE + 290 CONTINUE + ENDIF + +C..Loopback point for counting number of emissions. + NGEN=0 + 300 NGEN=NGEN+1 + +C...Begin loop to evolve all existing partons, if required. + 310 IMX=0 + PT2MX=0D0 + DO 380 IEVOL=1,NEVOL + IF(IFLG(IEVOL).EQ.0) THEN + +C...Basic info on radiator and recoil. + I=IPOS(IEVOL) + IR=IREC(IEVOL) + SHT=SHAT(I,IR) + PM2I=P(I,5)**2 + PM2R=P(IR,5)**2 + +C...Skip any particles that are "turned off" + IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) GOTO 380 + +C...Invariant mass of "dipole".Starting value for pT evolution. + SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I + PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2) + +C...Case of evolution by QCD branching. + IF(ISCOL(IEVOL).NE.0) THEN + +C...Parton-by-parton maximum scale from initial conditions. + IF(MSTP(72).EQ.0) THEN + DO 320 IPRT=1,NPARTS + IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2) + 320 CONTINUE + ENDIF + +C...If kinematically impossible then do not evolve. + IF(PT2.LT.PT2CMN) THEN + IFLG(IEVOL)=-1 + GOTO 380 + ENDIF + +C...Check if part of system for which ME corrections should be applied. + IMESYS=0 + DO 330 IME=1,NMESYS + IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND. + & MESYS(IME,0).LT.100) IMESYS=IME + 330 CONTINUE + +C...Special flag for colour octet states. +C...MOCT=1: can do gluon splitting g->qqbar; MOCT=2: cannot. + MOCT=0 + KC = PYCOMP(K(I,2)) + IF(K(I,2).EQ.21) THEN + MOCT=1 + ELSEIF(KCHG(KC,2).EQ.2) THEN + MOCT=2 + ENDIF +C...QUARKONIA++ + IF(MSTP(148).GE.1.AND.IABS(K(I,2)).EQ.9900101.AND. + & IABS(K(I,2)).LE.9910555) MOCT=2 +C...QUARKONIA-- + + +C...Upper estimate for matrix element weighting and colour factor. +C...Note that g->gg and g->qqbar is split on two sides = "dipoles". + WTPSGL=2D0 + COLFAC=4D0/3D0 + IF(MOCT.GE.1) COLFAC=3D0/2D0 + IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0 + WTPSQQ=0.5D0*0.5D0*NFLAV + +C...Determine overestimated z range: switch at c and b masses. + 340 IZRG=1 + PT2MNE=PT2CMN + B0=27D0/6D0 + ALAMS=ALAM3S + IF(PT2.GT.1.01D0*PMCS) THEN + IZRG=2 + PT2MNE=PMCS + B0=25D0/6D0 + ALAMS=ALAM4S + ENDIF + IF(PT2.GT.1.01D0*PMBS) THEN + IZRG=3 + PT2MNE=PMBS + B0=23D0/6D0 + ALAMS=ALAM5S + ENDIF + ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR)) + IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR + +C...Find evolution coefficients for q->qg/g->gg and g->qqbar. + EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0 + EVCOEF=EVEMGL + IF(MOCT.EQ.1) THEN + EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0 + EVCOEF=EVCOEF+EVEMQQ + ENDIF + +C...Pick pT2 (in overestimated z range). + 350 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF)) + +C...Loopback if crossed c/b mass thresholds. + IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN + PT2=PMBS + GOTO 340 + ENDIF + IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN + PT2=PMCS + GOTO 340 + ENDIF + +C...Finish if below lower cutoff. + IF(PT2.LT.PT2CMN) THEN + IFLG(IEVOL)=-1 + GOTO 380 + ENDIF + +C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar. +C...IFLAG=1: gluon emission; IFLAG=2: gluon splitting + IFLAG=1 + IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2 + +C...Pick z: dz/(1-z) or dz. + IF(IFLAG.EQ.1) THEN + Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0) + ELSE + Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT) + ENDIF + +C...Loopback if outside allowed range for given pT2. + ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR)) + IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR + IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350 + PM2=PM2I+PT2/(Z*(1D0-Z)) + IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350 + +C...No weighting for primary partons; to be done later on. + IF(IMESYS.GT.0) THEN + +C...Weighting of q->qg/X->Xg branching. + ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN + IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 350 + +C...Weighting of g->gg branching. + ELSEIF(IFLAG.EQ.1) THEN + IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 350 + +C...Flavour choice and weighting of g->qqbar branching. + ELSE + KFQ=MIN(5,1+INT(NFLAV*PYR(0))) + PMQ=PMAS(KFQ,1) + ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2)) + WTME=ROOTQQ*(Z**2+(1D0-Z)**2) + IF(WTME.LT.PYR(0)) GOTO 350 + IFLAG=10+KFQ + ENDIF + +C...Case of evolution by QED branching. + ELSEIF(ISCHG(IEVOL).NE.0) THEN + +C...If kinematically impossible then do not evolve. + PT2EMN=PT0EQ**2 + IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2 + IF(PT2.LT.PT2EMN) THEN + IFLG(IEVOL)=-1 + GOTO 380 + ENDIF + +C...Check if part of system for which ME corrections should be applied. + IMESYS=0 + DO 360 IME=1,NMESYS + IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND. + & MESYS(IME,0).GT.100) IMESYS=IME + 360 CONTINUE + +C...Charge. Matrix element weighting factor. + CHG=ISCHG(IEVOL)/3D0 + WTPSGA=2D0 + +C...Determine overestimated z range. Find evolution coefficient. + ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR)) + IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR + EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0) + +C...Pick pT2 (in overestimated z range). + 370 PT2=PT2*PYR(0)**(1D0/EVCOEF) + +C...Finish if below lower cutoff. + IF(PT2.LT.PT2EMN) THEN + IFLG(IEVOL)=-1 + GOTO 380 + ENDIF + +C...Pick z: dz/(1-z). + Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0) + +C...Loopback if outside allowed range for given pT2. + ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR)) + IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR + IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 370 + PM2=PM2I+PT2/(Z*(1D0-Z)) + IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 370 + +C...Weighting by branching kernel, except if ME weighting later. + IF(IMESYS.EQ.0) THEN + IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 370 + ENDIF + IFLAG=3 + ENDIF + +C...Save acceptable branching. + IFLG(IEVOL)=IFLAG + IMESAV(IEVOL)=IMESYS + PT2SAV(IEVOL)=PT2 + ZSAV(IEVOL)=Z + SHTSAV(IEVOL)=SHT + ENDIF + +C...Check if branching has highest pT. + IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN + IMX=IEVOL + PT2MX=PT2SAV(IEVOL) + ENDIF + 380 CONTINUE + +C...Finished if no more branchings to be done. + IF(IMX.EQ.0) GOTO 520 + +C...Restore info on hardest branching to be processed. + I=IPOS(IMX) + IR=IREC(IMX) + KCOL=ISCOL(IMX) + KCHA=ISCHG(IMX) + IMESYS=IMESAV(IMX) + PT2=PT2SAV(IMX) + Z=ZSAV(IMX) + SHT=SHTSAV(IMX) + PM2I=P(I,5)**2 + PM2R=P(IR,5)**2 + PM2=PM2I+PT2/(Z*(1D0-Z)) + +C...Special flag for colour octet states. + MOCT=0 + KC = PYCOMP(K(I,2)) + IF(K(I,2).EQ.21) THEN + MOCT=1 + ELSEIF(KCHG(KC,2).EQ.2) THEN + MOCT=2 + ENDIF +C...QUARKONIA++ + IF(MSTP(148).GE.1.AND.IABS(K(I,2)).GE.9900101.AND. + & IABS(K(I,2)).LE.9910555) MOCT=2 +C...QUARKONIA-- + +C...Restore further info for g->qqbar branching. + KFQ=0 + IF(IFLG(IMX).GT.10) THEN + KFQ=IFLG(IMX)-10 + PMQ=PMAS(KFQ,1) + ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2)) + ENDIF + +C...For branching g include azimuthal asymmetries from polarization. + ASYPOL=0D0 + IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN +C...Trace grandmother via intermediate recoil copies. + KFGM=0 + IM=I + 390 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND. + & K(IM,3).GT.0) THEN + IM=K(IM,3) + IF(IM.GT.MINT(84)) GOTO 390 + ENDIF + IGM=K(IM,3) + IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I) + & KFGM=IABS(K(IGM,2)) +C...Define approximate energy sharing by identifying aunt. + IAU=IM+1 + IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1 + IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN + ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4)) +C...Coefficient from gluon production. + IF(KFGM.LE.6) THEN + ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2) + ELSE + ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2 + ENDIF +C...Coefficient from gluon decay. + IF(KFQ.EQ.0) THEN + ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2 + ELSE + ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z)) + ENDIF + ENDIF + ENDIF + +C...Create new slots for branching products and recoil. + INEW=N+1 + IGNEW=N+2 + IRNEW=N+3 + N=N+3 + +C...Set status, flavour and mother of new ones. + K(INEW,1)=K(I,1) + K(IGNEW,1)=3 + IF(KCHA.NE.0) K(IGNEW,1)=1 + K(IRNEW,1)=K(IR,1) + IF(KFQ.EQ.0) THEN + K(INEW,2)=K(I,2) + K(IGNEW,2)=21 + IF(KCHA.NE.0) K(IGNEW,2)=22 + ELSE + K(INEW,2)=-ISIGN(KFQ,KCOL) + K(IGNEW,2)=-K(INEW,2) + ENDIF + K(IRNEW,2)=K(IR,2) + K(INEW,3)=I + K(IGNEW,3)=I + K(IRNEW,3)=IR + +C...Find rest frame and angles of branching+recoil. + DO 400 J=1,5 + P(INEW,J)=P(I,J) + P(IGNEW,J)=0D0 + P(IRNEW,J)=P(IR,J) + 400 CONTINUE + BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4)) + BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4)) + BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4)) + CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ) + PHI=PYANGL(P(INEW,1),P(INEW,2)) + THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2)) + +C...Derive kinematics of branching: generics (like g->gg). + DO 410 J=1,4 + P(INEW,J)=0D0 + P(IRNEW,J)=0D0 + 410 CONTINUE + PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT) + PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT) + PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2 + PTCOR=SQRT(MAX(0D0,PT2COR)) + PZN=(PEM**2*Z-0.5D0*PM2)/PZM + PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM +C...Specific kinematics reduction for q->qg with m_q > 0. + IF(MOCT.NE.1) THEN + PTCOR=(1D0-PM2I/PM2)*PTCOR + PZN=PZN+PM2I*PZG/PM2 + PZG=(1D0-PM2I/PM2)*PZG +C...Specific kinematics reduction for g->qqbar with m_q > 0. + ELSEIF(KFQ.NE.0) THEN + P(INEW,5)=PMQ + P(IGNEW,5)=PMQ + PTCOR=ROOTQQ*PTCOR + PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG) + PZG=PZM-PZN + ENDIF + +C...Pick phi and construct kinematics of branching. + 420 PHIROT=PARU(2)*PYR(0) + P(INEW,1)=PTCOR*COS(PHIROT) + P(INEW,2)=PTCOR*SIN(PHIROT) + P(INEW,3)=PZN + P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2) + P(IGNEW,1)=-P(INEW,1) + P(IGNEW,2)=-P(INEW,2) + P(IGNEW,3)=PZG + P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2) + P(IRNEW,1)=0D0 + P(IRNEW,2)=0D0 + P(IRNEW,3)=-PZM + P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT) + +C...Boost branching system to lab frame. + CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ) + +C...Renew choice of phi angle according to polarization asymmetry. + IF(ABS(ASYPOL).GT.1D-3) THEN + DO 430 J=1,3 + DPT(1,J)=P(I,J) + DPT(2,J)=P(IAU,J) + DPT(3,J)=P(INEW,J) + 430 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 440 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) + 440 CONTINUE + DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2) + DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2) + IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN + CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+ + & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4)) + IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL))) + & GOTO 420 + ENDIF + ENDIF + +C...Matrix element corrections for primary partons when requested. + IF(IMESYS.GT.0) THEN + M3JC=MESYS(IMESYS,0) + +C...Identify recoiling partner and set up three-body kinematics. + IRP=MESYS(IMESYS,1) + IF(IRP.EQ.I) IRP=MESYS(IMESYS,2) + IF(IRP.EQ.IR) IRP=IRNEW + DO 450 J=1,4 + PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J) + 450 CONTINUE + PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2- + & PSUM(3)**2)) + X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)- + & PSUM(3)*P(INEW,3))/PSUM(5)**2 + X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)- + & PSUM(3)*P(IRP,3))/PSUM(5)**2 + X3=2D0-X1-X2 + R1ME=P(INEW,5)/PSUM(5) + R2ME=P(IRP,5)/PSUM(5) + +C...Matrix elements for gluon emission. + IF(M3JC.LT.100) THEN + +C...Call ME, with right order important for two inequivalent showerers. + IF(MESYS(IMESYS,IORD).EQ.I) THEN + WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA) + ELSE + WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA) + ENDIF + +C...Split up total ME when two radiating partons. + ISPRAD=1 + IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29) + & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49) + & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0 + IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/ + & MAX(1D-10,2D0-X1-X2) + +C...Evaluate shower rate. + WPS=2D0/(MAX(1D-10,2D0-X1-X2)* + & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2)) + IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS + +C...Matrix elements for photon emission: still rather primitive. + ELSE + +C...For generic charge combination currently only massless expression. + IF(M3JC.EQ.101) THEN + CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0 + CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0 + WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2) + WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3) + +C...For flavour neutral system assume vector source and include masses. + ELSE + WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10, + & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2) + WPS=2D0/(MAX(1D-10,2D0-X1-X2)* + & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2)) + ENDIF + ENDIF + +C...Perform weighting with W_ME/W_PS. + IF(WME.LT.PYR(0)*WPS) THEN + N=N-3 + IFLG(IMX)=0 + PT2CMX=PT2 + GOTO 310 + ENDIF + ENDIF + +C...Now for sure accepted branching. Save highest pT. + IF(NGEN.EQ.1) PTGEN=SQRT(PT2) + +C...Update status for obsolete ones. Bookkkep the moved original parton +C...and new daughter (arbitrary choice for g->gg or g->qqbar). +C...Do not bookkeep radiated photon, since it cannot radiate further. + K(I,1)=K(I,1)+10 + K(IR,1)=K(IR,1)+10 + DO 460 IP=1,NPART + IF(IPART(IP).EQ.I) IPART(IP)=INEW + IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW + 460 CONTINUE + IF(KCHA.EQ.0) THEN + NPART=NPART+1 + IPART(NPART)=IGNEW + ENDIF + +C...Initialize colour flow of branching. +C...Use both old and new style colour tags for flexibility. + K(INEW,4)=0 + K(IGNEW,4)=0 + K(INEW,5)=0 + K(IGNEW,5)=0 + JCOLP=4+(1-KCOL)/2 + JCOLN=9-JCOLP + MCT(INEW,1)=0 + MCT(INEW,2)=0 + MCT(IGNEW,1)=0 + MCT(IGNEW,2)=0 + MCT(IRNEW,1)=0 + MCT(IRNEW,2)=0 + +C...Trivial colour flow for l->lgamma and q->qgamma. + IF(IABS(KCHA).EQ.3) THEN + K(I,4)=INEW + K(I,5)=IGNEW + ELSEIF(KCHA.NE.0) THEN + IF(K(I,4).NE.0) THEN + K(I,4)=K(I,4)+INEW + K(INEW,4)=MSTU(5)*I + MCT(INEW,1)=MCT(I,1) + ENDIF + IF(K(I,5).NE.0) THEN + K(I,5)=K(I,5)+INEW + K(INEW,5)=MSTU(5)*I + MCT(INEW,2)=MCT(I,2) + ENDIF + +C...Set colour flow for q->qg and g->gg. + ELSEIF(KFQ.EQ.0) THEN + K(I,JCOLP)=K(I,JCOLP)+IGNEW + K(IGNEW,JCOLP)=MSTU(5)*I + K(INEW,JCOLP)=MSTU(5)*IGNEW + K(IGNEW,JCOLN)=MSTU(5)*INEW + MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3) + NCT=NCT+1 + MCT(INEW,JCOLP-3)=NCT + MCT(IGNEW,JCOLN-3)=NCT + IF(MOCT.GE.1) THEN + K(I,JCOLN)=K(I,JCOLN)+INEW + K(INEW,JCOLN)=MSTU(5)*I + MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3) + ENDIF + +C...Set colour flow for g->qqbar. + ELSE + K(I,JCOLN)=K(I,JCOLN)+INEW + K(INEW,JCOLN)=MSTU(5)*I + K(I,JCOLP)=K(I,JCOLP)+IGNEW + K(IGNEW,JCOLP)=MSTU(5)*I + MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3) + MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3) + ENDIF + +C...Daughter info for colourless recoiling parton. + IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN + K(IR,4)=IRNEW + K(IR,5)=IRNEW + K(IRNEW,4)=0 + K(IRNEW,5)=0 + +C...Colour of recoiling parton sails through unchanged. + ELSE + IF(K(IR,4).NE.0) THEN + K(IR,4)=K(IR,4)+IRNEW + K(IRNEW,4)=MSTU(5)*IR + MCT(IRNEW,1)=MCT(IR,1) + ENDIF + IF(K(IR,5).NE.0) THEN + K(IR,5)=K(IR,5)+IRNEW + K(IRNEW,5)=MSTU(5)*IR + MCT(IRNEW,2)=MCT(IR,2) + ENDIF + ENDIF + +C...Vertex information trivial. + DO 470 J=1,5 + V(INEW,J)=V(I,J) + V(IGNEW,J)=V(I,J) + V(IRNEW,J)=V(IR,J) + 470 CONTINUE + +C...Update list of old radiators. + DO 480 IEVOL=1,NEVOL +C... A) radiator-recoiler mother pair for this branching + IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN + IPOS(IEVOL)=INEW +C... A2) QCD branching and color side matches, radiated parton follows recoiler + IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW + IREC(IEVOL)=IRNEW + IFLG(IEVOL)=0 + ELSEIF(IPOS(IEVOL).EQ.I) THEN +C... B) other dipoles with I as radiator simply get INEW as new radiator + IPOS(IEVOL)=INEW + IFLG(IEVOL)=0 + ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN +C... C) the "mirror image" of the parent dipole + IPOS(IEVOL)=IRNEW + IREC(IEVOL)=INEW +C... C2) QCD branching and color side matches, radiated parton follows recoiler + IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL.AND.ISCOL(IEVOL).NE.0) + & IREC(IEVOL)=IGNEW + IFLG(IEVOL)=0 + ELSEIF(IPOS(IEVOL).EQ.IR) THEN +C... D) other dipoles with IR as radiator simply get IRNEW as new radiator + IPOS(IEVOL)=IRNEW + IFLG(IEVOL)=0 + ENDIF +C... Update links of old connected partons. + IF(IREC(IEVOL).EQ.I) THEN + IREC(IEVOL)=INEW + IFLG(IEVOL)=0 + ELSEIF(IREC(IEVOL).EQ.IR) THEN + IREC(IEVOL)=IRNEW + IFLG(IEVOL)=0 + ENDIF + 480 CONTINUE + +C...q->qg or g->gg: create new gluon radiators. + IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN + NEVOL=NEVOL+1 + IPOS(NEVOL)=INEW + IREC(NEVOL)=IGNEW + IFLG(NEVOL)=0 + ISCOL(NEVOL)=KCOL + ISCHG(NEVOL)=0 + PTSCA(NEVOL)=SQRT(PT2) + NEVOL=NEVOL+1 + IPOS(NEVOL)=IGNEW + IREC(NEVOL)=INEW + IFLG(NEVOL)=0 + ISCOL(NEVOL)=-KCOL + ISCHG(NEVOL)=0 + PTSCA(NEVOL)=PTSCA(NEVOL-1) +C...g->qqbar: create new photon radiators. + ELSEIF(KCOL.EQ.2.AND.KFQ.NE.0) THEN + NEVOL=NEVOL+1 + IPOS(NEVOL)=INEW + IREC(NEVOL)=IGNEW + IFLG(NEVOL)=0 + ISCOL(NEVOL)=0 + ISCHG(NEVOL)=PYK(INEW,6) + PTSCA(NEVOL)=SQRT(PT2) + NEVOL=NEVOL+1 + IPOS(NEVOL)=IGNEW + IREC(NEVOL)=INEW + IFLG(NEVOL)=0 + ISCOL(NEVOL)=0 + ISCHG(NEVOL)=PYK(IGNEW,6) + PTSCA(NEVOL)=SQRT(PT2) + CALL PYLIST(4) + print*, 'created new QED dipole ',INEW,'<->',IGNEW + ENDIF + +C...Check color and charge connections, +C...Rewire if better partners can be found (screening, etc) + DO 500 IEVOL=1,NEVOL + KCOL = ISCOL(IEVOL) + KCHA = ISCHG(IEVOL) + IRTMP = IREC(IEVOL) + ITMP = IPOS(IEVOL) +C...Do not modify QED dipoles + IF (KCHA.NE.0) THEN + GOTO 500 +C...Also skip dipole ends that are switched off + ELSEIF (IFLG(IEVOL).LE.-1) THEN + GOTO 500 + ELSEIF (KCOL.NE.0) THEN +C...QCD dipoles. Check if current recoiler has appropriate color charge + KCOLR = PYK(IRTMP,12) + IF (KCOLR.EQ.2.OR.KCOLR.EQ.-KCOL) GOTO 500 +C...If not, look for closest recoiler with appropriate color charge + RM2MIN = PSUM(5)**2 + JMX = 0 + ISGOOD = 0 + DO 490 JEVOL=1,NEVOL +C...Skip self + IF (JEVOL.EQ.IEVOL) GOTO 490 + JTMP = IPOS(JEVOL) + IF (JTMP.EQ.ITMP) GOTO 490 + JCOL = ISCOL(JEVOL) +C...Skip dipole ends that are switched off + IF (IFLG(JEVOL).LE.-1) GOTO 490 +C...Skip QED dipole ends + IF (ISCHG(JEVOL).NE.0) GOTO 490 +C... Skip wrong-color if at least one correct-color partner already found + IF (ISGOOD.NE.0.AND.JCOL.NE.-KCOL.AND.JCOL.NE.2) GOTO 490 +C...Accept if smallest m2 so far, or if first with correct color + RM2 = DOTP(ITMP,JTMP) + ISGNOW = 0 + IF (JCOL.EQ.-KCOL.OR.JCOL.EQ.2) ISGNOW=1 + IF (RM2.LT.RM2MIN.OR.ISGNOW.GT.ISGOOD) THEN + ISGOOD = ISGNOW + RM2MIN = RM2 + JMX = JEVOL + ENDIF + 490 CONTINUE +C...Update recoiler and reset dipole if new best partner found + IF (JMX.NE.0) THEN + IREC(IEVOL) = IPOS(JMX) + IFLG(IEVOL) = 0 + ENDIF + ENDIF + 500 CONTINUE + +C...TMP! print out list of dipoles +C DO 580 IEVOL=1,NEVOL +C KCHA = ISCHG(IEVOL) +C IF (KCHA.NE.0) THEN +C print*, 'qed dip',IPOS(IEVOL),IREC(IEVOL) +C ELSE +C print*, 'qcd dip',IPOS(IEVOL),IREC(IEVOL) +C ENDIF +C 580 CONTINUE + +C...Update matrix elements parton list and add new for g/gamma->qqbar. + DO 510 IME=1,NMESYS + IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW + IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW + IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW + IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW + 510 CONTINUE + IF(KFQ.NE.0) THEN + NMESYS=NMESYS+1 + MESYS(NMESYS,0)=66 + MESYS(NMESYS,1)=INEW + MESYS(NMESYS,2)=IGNEW + NMESYS=NMESYS+1 + MESYS(NMESYS,0)=102 + MESYS(NMESYS,1)=INEW + MESYS(NMESYS,2)=IGNEW + ENDIF + +C...Global statistics. + MINT(353)=MINT(353)+1 + VINT(353)=VINT(353)+PTCOR + IF (MINT(353).EQ.1) VINT(358)=PTCOR + +C...Loopback for more emissions if enough space. + PT2CMX=PT2 + IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND. + &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN + GOTO 300 + ELSE + CALL PYERRM(11,'(PYPTFS:) no more memory left for shower') + ENDIF + +C...Done. + 520 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYMAEL +C...Auxiliary to PYSHOW and PYPTFS. +C...Matrix elements for gluon (or photon) emission from +C...a two-body state; to be used by the parton shower routine. +C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and +C...1/sigma_0 d(sigma)/d(x_1)d(x_2) = +C... = (alpha-strong/2 pi) * CF * PYMAEL, +C...i.e. normalization is such that one recovers the familiar +C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case. +C...Coupling structure: +C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent) +C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet) +C... = 16-19 : q -> q V +C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet) +C... = 26-29 : q -> q S +C... = 31-34 : V -> ~q ~qbar (~q = squark) +C... = 36-39 : ~q -> ~q V +C... = 41-44 : S -> ~q ~qbar +C... = 46-49 : ~q -> ~q S +C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino) +C... = 56-59 : ~q -> q chi +C... = 61-64 : q -> ~q chi +C... = 66-69 : ~g -> q ~qbar +C... = 71-74 : ~q -> q ~g +C... = 76-79 : q -> ~q ~g +C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g +C...Note that the order of the decay products is important. +C...In each set of four, the variants are ordered as: +C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/... +C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/.... +C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2) +C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2) + + FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...Check input values. Return zero outside allowed phase space. + PYMAEL=0D0 + IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN + IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN + IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN + IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE. + &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN + ALPCOR=MAX(0D0,MIN(1D0,ALPHA)) + +C...Initial values and flags. + ICLASS=NI/5 + ICOMBI=NI-5*ICLASS + ISSET1=0 + ISSET2=0 + ISSET4=0 + +C... Phase space. + PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2)) + +C...Eikonal expression; also acts as default. + IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN + RLO=PS + IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN + ANUM=0D0 + ELSEIF(ICOMBI.EQ.2) THEN + ANUM=(2D0-X1-X2)**2 + ELSEIF(ICOMBI.EQ.3) THEN + ANUM=ALPCOR*(2D0-X1-X2)**2 + ELSE + ANUM=0.5D0*(2D0-X1-X2)**2 + ENDIF + RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/ + & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))- + & R1**2/(1D0+R2**2-R1**2-X2)**2- + & R2**2/(1D0+R1**2-R2**2-X1)**2) + ICOMBI=0 + +C...V -> q qbar (V = gamma*/Z0/W+-/...). + ELSEIF(ICLASS.EQ.2) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0 + RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2 + & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1 + & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2) + & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2) + & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2) + & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2 + & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/ + & (-1+R1**2-R2**2+X2)**2 + RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2 + & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2 + & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1 + & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2) + & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2 + & -X1-X2)**2+X1*(2-X1-X2)**2)/ + & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2 + & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1 + & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2 + & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2* + & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2 + RFO1=RFO1/2.D0 + ISSET1=1 + ENDIF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0 + RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2 + & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1 + & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2) + & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2) + & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2 + & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2 + & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2 + RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2 + & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2 + & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1 + & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2) + & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2 + & -X1-X2)**2+X1*(2-X1-X2)**2)/ + & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2 + & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1 + & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1 + & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2) + & +X2)/(-1-R1**2+R2**2+X1)**2 + RFO2=RFO2/2.D0 + ISSET2=1 + ENDIF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0 + RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1 + & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2 + & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/ + & (-1-R1**2+R2**2+X1)**2 + RFO4=RFO4 + & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2 + & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2 + & -R1**2*X2**2+X1*X2**2)/ + & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2 + & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2 + & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/ + & (-1+R1**2-R2**2+X2)**2 + RFO4=RFO4/2.D0 + ISSET4=1 + ENDIF + +C...q -> q V. + ELSEIF(ICLASS.EQ.3) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2 + & +R1**2*R2**2-2D0*R2**4) + RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2 + & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1 + & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1 + & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2 + & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2 + & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2 + & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2) + RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2 + & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2 + & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2 + & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2 + & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2 + RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4 + & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1 + & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3 + & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2 + & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2 + & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2 + & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2 + ISSET1=1 + ENDIF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2 + & +R1**2*R2**2-2D0*R2**4) + RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2 + & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1 + & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1 + & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2 + & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2 + & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2 + & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) + RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2 + & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2 + & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2 + & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2 + & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2 + RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1 + & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1 + & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3 + & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2 + & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2 + & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2 + & +X1*X2**2)/(-2+X1+X2)**2 + ISSET2=1 + ENDIF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4) + RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1 + & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2 + & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2 + & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2 + & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) + RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1 + & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2 + & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2 + & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2 + RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1 + & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1 + & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2 + & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2 + & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2 + & +X1*X2**2)/(2-X1-X2)**2 + ISSET4=1 + ENDIF + +C...S -> q qbar (S = h0/H0/A0/H+-/...). + ELSEIF(ICLASS.EQ.4) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2) + RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 + & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2 + & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2 + & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3 + & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2 + & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 + & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2 + & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 + ISSET1=1 + ENDIF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2) + RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3 + & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2 + & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2 + & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3 + & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2 + & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 + & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2 + & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1 + & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/ + & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + ISSET2=1 + ENDIF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1D0-R1**2-R2**2) + RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2 + & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2 + & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1 + & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/ + & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1 + & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 + ISSET4=1 + ENDIF + +C...q -> q S. + ELSEIF(ICLASS.EQ.5) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1D0+R1**2-R2**2+2D0*R1) + RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2 + & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2 + & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1 + & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (1-R1**2+R2**2-X2)/(-2+X1+X2) + & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1 + & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (-1+R1**2-R2**2+X2)**2 + ISSET1=1 + ENDIF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1D0+R1**2-R2**2-2D0*R1) + RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2 + & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2 + & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1 + & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (1-R1**2+R2**2-X2)/(-2+X1+X2) + & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1 + & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (-1+R1**2-R2**2+X2)**2 + ISSET2=1 + ENDIF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1D0+R1**2-R2**2) + RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2 + & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2 + & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2 + & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2) + & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2 + & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2 + ISSET4=1 + ENDIF + +C...V -> ~q ~qbar (~q = squark). + ELSEIF(ICLASS.EQ.6) THEN + RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4) + RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/ + & (-1-R1**2+R2**2+X1)**2 + & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/ + & (-1-R1**2+R2**2+X1) + & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2) + & /(-1+R1**2-R2**2+X2)**2 + & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/ + & (-1+R1**2-R2**2+X2) + & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1 + & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2 + & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2 + & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + ISSET1=1 + +C...~q -> ~q V. + ELSEIF(ICLASS.EQ.7) THEN + RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4) + RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2 + & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)* + & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)* + & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1 + & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2 + & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)* + & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/ + & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4 + & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1 + & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/ + & (3*(-2+X1+X2)) + RFO1=3D0*RFO1/8D0 + ISSET1=1 + +C...S -> ~q ~qbar. + ELSEIF(ICLASS.EQ.8) THEN + RLO1=PS + RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1 + & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2 + & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2 + & -R1**2*X2**2+X1*X2**2)/ + & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2 + RFO1=2D0*RFO1 + ISSET1=1 + +C...~q -> ~q S. + ELSEIF(ICLASS.EQ.9) THEN + RLO1=PS + RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2 + & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) + & -(X1+X2)/(-2+X1+X2)**2 + ISSET1=1 + +C...chi -> q ~qbar (chi = neutralino/chargino). + ELSEIF(ICLASS.EQ.10) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1D0+R1**2-R2**2+2D0*R1) + RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2 + & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1 + & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/ + & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1 + & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (-1+R1**2-R2**2+X2)**2 + ISSET1=1 + ENDIF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1D0-2D0*R1+R1**2-R2**2) + RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2 + & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1 + & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/ + & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1 + & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (-1+R1**2-R2**2+X2)**2 + ISSET2=1 + ENDIF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1+R1**2-R2**2) + RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2 + & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2 + & +X2+R1**2*X2-X1*X2/2)/ + & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2) + & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2 + & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2 + ISSET4=1 + ENDIF + +C...~q -> q chi. + ELSEIF(ICLASS.EQ.11) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1D0-(R1+R2)**2) + RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2 + & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 + & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2 + & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 + & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4 + & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2 + & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) + ISSET1=1 + ENDIF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1D0-(R1-R2)**2) + RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/ + & (-2+X1+X2)**2 + & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3 + & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2 + & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2 + & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4 + & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2 + & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2) + ISSET2=1 + ENDIF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1D0-R1**2-R2**2) + RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2 + & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2 + & +3*R1**2*X2-R2**2*X2-X1*X2)/ + & (-1+R1**2-R2**2+X2)**2 + & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1 + & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/ + & (2-X1-X2)/(-1+R1**2-R2**2+X2) + ISSET4=1 + ENDIF + +C...q -> ~q chi. + ELSEIF(ICLASS.EQ.12) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1D0-R1**2+R2**2+2D0*R2) + RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2 + & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2 + & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/ + & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1 + & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/ + & (2-X1-X2)/(-1+R1**2-R2**2+X2) + ISSET1=1 + END IF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1D0-R1**2+R2**2-2D0*R2) + RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2 + & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2 + & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/ + & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1 + & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/ + & (2-X1-X2)/(-1+R1**2-R2**2+X2) + ISSET2=1 + END IF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1D0-R1**2+R2**2) + RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2 + & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2 + & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/ + & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2 + & +R1**2*X2-X1*X2/2-X2**2/2)/ + & (2-X1-X2)/(-1+R1**2-R2**2+X2) + ISSET4=1 + END IF + +C...~g -> q ~qbar. + ELSEIF(ICLASS.EQ.13) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1D0+R1**2-R2**2+2D0*R1) + RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2) + & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2 + & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2 + & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2 + & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/ + & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1 + & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2 + & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2 + & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2 + & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1 + & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1 + & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (3*(-1+R1**2-R2**2+X2)**2) + RFO1=3D0*RFO1/4D0 + ISSET1=1 + ENDIF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1D0+R1**2-R2**2-2D0*R1) + RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2) + & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2 + & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2)) + & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1 + & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/ + & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2 + & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2 + & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1 + & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2 + & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3 + & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2 + & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (3*(-1+R1**2-R2**2+X2)**2) + RFO2=3D0*RFO2/4D0 + ISSET2=1 + ENDIF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1D0+R1**2-R2**2) + RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1 + & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/ + & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1 + & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2 + & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1 + & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2 + & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1 + & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/ + & (3*(-1+R1**2-R2**2+X2)**2) + RFO4=3D0*RFO4/8D0 + ISSET4=1 + ENDIF + +C...~q -> q ~g. + ELSEIF(ICLASS.EQ.14) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2) + RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2) + & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 + & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2 + & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4 + & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4 + & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2 + & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2)) + & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3 + & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2 + & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2) + & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4 + & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2 + & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2)) + RFO1=RFO1 + & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4 + & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2 + & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) + RFO1=9D0*RFO1/64D0 + ISSET1=1 + ENDIF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2) + RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2) + & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3 + & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2 + & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4 + & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1 + & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2 + & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4 + & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1 + & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/ + & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2)) + RFO2=RFO2 + & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4 + & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2 + & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2)) + & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3 + & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2 + & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) + RFO2=9D0*RFO2/64D0 + ISSET2=1 + ENDIF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1-R1**2-R2**2) + RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1 + & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2 + & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2 + & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1 + & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/ + & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4 + & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2 + & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2) + & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2 + & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/ + & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2)) + RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1 + & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/ + & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2)) + RFO4=9D0*RFO4/128D0 + ISSET4=1 + ENDIF + +C...q -> ~q ~g. + ELSEIF(ICLASS.EQ.15) THEN + IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN + RLO1=PS*(1D0-R1**2+R2**2+2D0*R2) + RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2) + & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1 + & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/ + & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2 + & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1 + & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/ + & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1 + & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2 + & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2) + RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1 + & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/ + & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2 + & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2 + & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) + RFO1=9D0*RFO1/32D0 + ISSET1=1 + END IF + IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN + RLO2=PS*(1D0-R1**2+R2**2-2D0*R2) + RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2) + & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1 + & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/ + & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2 + & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1 + & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/ + & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2 + & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2 + & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2)) + RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1 + & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/ + & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1 + & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/ + & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) + RFO2=9D0*RFO2/32D0 + ISSET2=1 + END IF + IF(ICOMBI.EQ.4) THEN + RLO4=PS*(1D0-R1**2+R2**2) + RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2) + & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2 + & -R2**2*X2/2-X1*X2/2)/ + & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2 + & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2 + & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2)) + & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2 + & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2) + RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2 + & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2 + & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2 + & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2)) + RFO4=9D0*RFO4/64D0 + ISSET4=1 + END IF + +C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future. + ELSEIF(ICLASS.EQ.16) THEN + RLO=PS + IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN + ANUM=0D0 + ELSEIF(ICOMBI.EQ.2) THEN + ANUM=(2D0-X1-X2)**2 + ELSEIF(ICOMBI.EQ.3) THEN + ANUM=ALPCOR*(2D0-X1-X2)**2 + ELSE + ANUM=0.5D0*(2D0-X1-X2)**2 + ENDIF + RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/ + & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))- + & R1**2/(1D0+R2**2-R1**2-X2)**2- + & R2**2/(1D0+R1**2-R2**2-X1)**2) + RFO=9D0*RFO/4D0 + ICOMBI=0 + ENDIF + +C...Find relevant LO and FO expression. + IF(ICOMBI.EQ.0) THEN + ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN + RLO=RLO1 + RFO=RFO1 + ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN + RLO=RLO2 + RFO=RFO2 + ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN + RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2 + RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2 + ELSEIF(ISSET4.EQ.1) THEN + RLO=RLO4 + RFO=RFO4 + ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN + RLO=0.5D0*(RLO1+RLO2) + RFO=0.5D0*(RFO1+RFO2) + ELSEIF(ISSET1.EQ.1) THEN + RLO=RLO1 + RFO=RFO1 + ELSE + CALL PYERRM(16,'(PYMAEL:) not implemented ME code') + RLO=1D0 + RFO=0D0 + ENDIF + +C...Output. + PYMAEL=RFO/RLO + + RETURN + END + +C********************************************************************* + +C...PYBOEI +C...Modifies an event so as to approximately take into account +C...Bose-Einstein effects according to a simple phenomenological +C...parametrization. + + SUBROUTINE PYBOEI(NSAV) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYJETS/,/PYDAT1/ +C...Local character variable. + CHARACTER CHMESS*(*) + +C...Write first few warnings, then be silent. + IF(MERR.LE.10) THEN + MSTU(27)=MSTU(27)+1 + MSTU(28)=MERR + IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000) + & MERR,MSTU(31),CHMESS + +C...Write first few errors, then be silent or stop program. + ELSEIF(MERR.LE.20) THEN + IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1 + MSTU(30)=MSTU(30)+1 + MSTU(24)=MERR-10 + IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100) + & MERR-10,MSTU(31),CHMESS + IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN + WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS + WRITE(MSTU(11),5200) + IF(MERR.NE.17) CALL PYLIST(2) + CALL PYSTOP(3) + ENDIF + +C...Stop program in case of irreparable error. + ELSE + WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS + CALL PYSTOP(3) + ENDIF + +C...Formats for output. + 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9, + &' PYEXEC calls:'/5X,A) + 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9, + &' PYEXEC calls:'/5X,A) + 5200 FORMAT(5X,'Execution will be stopped after listing of last ', + &'event!') + 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9, + &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!') + + RETURN + END + +C********************************************************************* + +C...PYALEM +C...Calculates the running alpha_electromagnetic. + + FUNCTION PYALEM(Q2) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + +C...Calculate real part of photon vacuum polarization. +C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions. +C...For hadrons use parametrization of H. Burkhardt et al. +C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131. + AEMPI=PARU(101)/(3D0*PARU(1)) + IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN + RPIGG=0D0 + ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN + RPIGG=0D0 + ELSEIF(MSTU(101).EQ.2) THEN + RPIGG=1D0-PARU(101)/PARU(103) + ELSEIF(Q2.LT.0.09D0) THEN + RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2) + ELSEIF(Q2.LT.9D0) THEN + RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+ + & 0.00238D0*LOG(1D0+3.927D0*Q2) + ELSEIF(Q2.LT.1D4) THEN + RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+ + & 0.00299D0*LOG(1D0+Q2) + ELSE + RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+ + & 0.00293D0*LOG(1D0+Q2) + ENDIF + +C...Calculate running alpha_em. + PYALEM=PARU(101)/(1D0-RPIGG) + PARU(108)=PYALEM + + RETURN + END + +C********************************************************************* + +C...PYALPS +C...Gives the value of alpha_strong. + + FUNCTION PYALPS(Q2) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ +C...Coefficients for second-order threshold matching. +C...From W.J. Marciano, Phys. Rev. D29 (1984) 580. + DIMENSION STEPDN(6),STEPUP(6) +c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0), +c &(2D0*321D0/3703D0),0D0/ +c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0), +c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/ + DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/ + DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/ + +C...Constant alpha_strong trivial. Pick artificial Lambda. + IF(MSTU(111).LE.0) THEN + PYALPS=PARU(111) + MSTU(118)=MSTU(112) + PARU(117)=0.2D0 + IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/ + & ((33D0-2D0*MSTU(112))*PARU(111))) + PARU(118)=PARU(111) + RETURN + ENDIF + +C...Find effective Q2, number of flavours and Lambda. + Q2EFF=Q2 + IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114)) + NF=MSTU(112) + ALAM2=PARU(112)**2 + 100 IF(NF.GT.MAX(3,MSTU(113))) THEN + Q2THR=PARU(113)*PMAS(NF,1)**2 + IF(Q2EFF.LT.Q2THR) THEN + NF=NF-1 + Q2RAT=Q2THR/ALAM2 + ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF)) + IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF) + GOTO 100 + ENDIF + ENDIF + 110 IF(NF.LT.MIN(6,MSTU(114))) THEN + Q2THR=PARU(113)*PMAS(NF+1,1)**2 + IF(Q2EFF.GT.Q2THR) THEN + NF=NF+1 + Q2RAT=Q2THR/ALAM2 + ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF)) + IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF) + GOTO 110 + ENDIF + ENDIF + IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2 + PARU(117)=SQRT(ALAM2) + +C...Evaluate first or second order alpha_strong. + B0=(33D0-2D0*NF)/6D0 + ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2)) + IF(MSTU(111).EQ.1) THEN + PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)) + ELSE + B1=(153D0-19D0*NF)/6D0 + PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/ + & (B0**2*ALGQ))) + ENDIF + MSTU(118)=NF + PARU(118)=PYALPS + + RETURN + END + +C********************************************************************* + +C...PYANGL +C...Reconstructs an angle from given x and y coordinates. + + FUNCTION PYANGL(X,Y) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + + PYANGL=0D0 + R=SQRT(X**2+Y**2) + IF(R.LT.1D-20) RETURN + IF(ABS(X)/R.LT.0.8D0) THEN + PYANGL=SIGN(ACOS(X/R),Y) + ELSE + PYANGL=ASIN(Y/R) + IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN + PYANGL=PARU(1)-PYANGL + ELSEIF(X.LT.0D0) THEN + PYANGL=-PARU(1)-PYANGL + ENDIF + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYR +C...Generates random numbers uniformly distributed between +C...0 and 1, excluding the endpoints. + + FUNCTION PYR(IDUMMY) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDATR/MRPY(6),RRPY(100) + SAVE /PYDATR/ +C...Equivalence between commonblock and local variables. + EQUIVALENCE (MRPY1,MRPY(1)),(MRPY2,MRPY(2)),(MRPY3,MRPY(3)), + &(MRPY4,MRPY(4)),(MRPY5,MRPY(5)),(MRPY6,MRPY(6)), + &(RRPY98,RRPY(98)),(RRPY99,RRPY(99)),(RRPY00,RRPY(100)) + +C...Initialize generation from given seed. + IF(MRPY2.EQ.0) THEN + IJ=MOD(MRPY1/30082,31329) + KL=MOD(MRPY1,30082) + I=MOD(IJ/177,177)+2 + J=MOD(IJ,177)+2 + K=MOD(KL/169,178)+1 + L=MOD(KL,169) + DO 110 II=1,97 + S=0D0 + T=0.5D0 + DO 100 JJ=1,48 + M=MOD(MOD(I*J,179)*K,179) + I=J + J=K + K=M + L=MOD(53*L+1,169) + IF(MOD(L*M,64).GE.32) S=S+T + T=0.5D0*T + 100 CONTINUE + RRPY(II)=S + 110 CONTINUE + TWOM24=1D0 + DO 120 I24=1,24 + TWOM24=0.5D0*TWOM24 + 120 CONTINUE + RRPY98=362436D0*TWOM24 + RRPY99=7654321D0*TWOM24 + RRPY00=16777213D0*TWOM24 + MRPY2=1 + MRPY3=0 + MRPY4=97 + MRPY5=33 + ENDIF + +C...Generate next random number. + 130 RUNI=RRPY(MRPY4)-RRPY(MRPY5) + IF(RUNI.LT.0D0) RUNI=RUNI+1D0 + RRPY(MRPY4)=RUNI + MRPY4=MRPY4-1 + IF(MRPY4.EQ.0) MRPY4=97 + MRPY5=MRPY5-1 + IF(MRPY5.EQ.0) MRPY5=97 + RRPY98=RRPY98-RRPY99 + IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00 + RUNI=RUNI-RRPY98 + IF(RUNI.LT.0D0) RUNI=RUNI+1D0 + IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130 + +C...Update counters. Random number to output. + MRPY3=MRPY3+1 + IF(MRPY3.EQ.1000000000) THEN + MRPY2=MRPY2+1 + MRPY3=0 + ENDIF + PYR=RUNI + + RETURN + END + +C********************************************************************* + +C...PYRGET +C...Dumps the state of the random number generator on a file +C...for subsequent startup from this state onwards. + + SUBROUTINE PYRGET(LFN,MOVE) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDATR/MRPY(6),RRPY(100) + SAVE /PYDATR/ +C...Local character variable. + CHARACTER CHERR*8 + +C...Backspace required number of records (or as many as there are). + IF(MOVE.LT.0) THEN + NBCK=MIN(MRPY(6),-MOVE) + DO 100 IBCK=1,NBCK + BACKSPACE(LFN,ERR=110,IOSTAT=IERR) + 100 CONTINUE + MRPY(6)=MRPY(6)-NBCK + ENDIF + +C...Unformatted write on unit LFN. + WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5), + &(RRPY(I2),I2=1,100) + MRPY(6)=MRPY(6)+1 + RETURN + +C...Write error. + 110 WRITE(CHERR,'(I8)') IERR + CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='// + &CHERR) + + RETURN + END + +C********************************************************************* + +C...PYRSET +C...Reads a state of the random number generator from a file +C...for subsequent generation from this state onwards. + + SUBROUTINE PYRSET(LFN,MOVE) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDATR/MRPY(6),RRPY(100) + SAVE /PYDATR/ +C...Local character variable. + CHARACTER CHERR*8 + +C...Backspace required number of records (or as many as there are). + IF(MOVE.LT.0) THEN + NBCK=MIN(MRPY(6),-MOVE) + DO 100 IBCK=1,NBCK + BACKSPACE(LFN,ERR=120,IOSTAT=IERR) + 100 CONTINUE + MRPY(6)=MRPY(6)-NBCK + ENDIF + +C...Unformatted read from unit LFN. + NFOR=1+MAX(0,MOVE) + DO 110 IFOR=1,NFOR + READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5), + & (RRPY(I2),I2=1,100) + 110 CONTINUE + MRPY(6)=MRPY(6)+NFOR + RETURN + +C...Write error. + 120 WRITE(CHERR,'(I8)') IERR + CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='// + &CHERR) + + RETURN + END + +C********************************************************************* + +C...PYROBO +C...Performs rotations and boosts. + + SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYJETS/,/PYDAT1/ +C...Local arrays. + DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4) + +C...Find and check range of rotation/boost. + IMIN=IMI + IF(IMIN.LE.0) IMIN=1 + IF(MSTU(1).GT.0) IMIN=MSTU(1) + IMAX=IMA + IF(IMAX.LE.0) IMAX=N + IF(MSTU(2).GT.0) IMAX=MSTU(2) + IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN + CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory') + RETURN + ENDIF + +C...Optional resetting of V (when not set before.) + IF(MSTU(33).NE.0) THEN + DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4)) + DO 100 J=1,5 + V(I,J)=0D0 + 100 CONTINUE + 110 CONTINUE + MSTU(33)=0 + ENDIF + +C...Rotate, typically from z axis to direction (theta,phi). + IF(THE**2+PHI**2.GT.1D-20) THEN + ROT(1,1)=COS(THE)*COS(PHI) + ROT(1,2)=-SIN(PHI) + ROT(1,3)=SIN(THE)*COS(PHI) + ROT(2,1)=COS(THE)*SIN(PHI) + ROT(2,2)=COS(PHI) + ROT(2,3)=SIN(THE)*SIN(PHI) + ROT(3,1)=-SIN(THE) + ROT(3,2)=0D0 + ROT(3,3)=COS(THE) + DO 140 I=IMIN,IMAX + IF(K(I,1).LE.0) GOTO 140 + DO 120 J=1,3 + PR(J)=P(I,J) + VR(J)=V(I,J) + 120 CONTINUE + DO 130 J=1,3 + P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3) + V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3) + 130 CONTINUE + 140 CONTINUE + ENDIF + +C...Boost, typically from rest to momentum/energy=beta. + IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN + DBX=BEX + DBY=BEY + DBZ=BEZ + DB=SQRT(DBX**2+DBY**2+DBZ**2) + EPS1=1D0-1D-12 + IF(DB.GT.EPS1) THEN +C...Rescale boost vector if too close to unity. + CALL PYERRM(3,'(PYROBO:) boost vector too large') + DBX=DBX*(EPS1/DB) + DBY=DBY*(EPS1/DB) + DBZ=DBZ*(EPS1/DB) + DB=EPS1 + ENDIF + DGA=1D0/SQRT(1D0-DB**2) + DO 160 I=IMIN,IMAX + IF(K(I,1).LE.0) GOTO 160 + DO 150 J=1,4 + DP(J)=P(I,J) + DV(J)=V(I,J) + 150 CONTINUE + DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3) + DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4)) + P(I,1)=DP(1)+DGABP*DBX + P(I,2)=DP(2)+DGABP*DBY + P(I,3)=DP(3)+DGABP*DBZ + P(I,4)=DGA*(DP(4)+DBP) + DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3) + DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4)) + V(I,1)=DV(1)+DGABV*DBX + V(I,2)=DV(2)+DGABV*DBY + V(I,3)=DV(3)+DGABV*DBZ + V(I,4)=DGA*(DV(4)+DBV) + 160 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYEDIT +C...Performs global manipulations on the event record, in particular +C...to exclude unstable or undetectable partons/particles. + + SUBROUTINE PYEDIT(MEDIT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYCTAG/NCT,MCT(4000,2) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/ +C...Local arrays. + DIMENSION NS(2),PTS(2),PLS(2) + +C...Remove unwanted partons/particles. + IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN + IMAX=N + IF(MSTU(2).GT.0) IMAX=MSTU(2) + I1=MAX(1,MSTU(1))-1 + DO 110 I=MAX(1,MSTU(1)),IMAX + IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110 + IF(MEDIT.EQ.1) THEN + IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110 + ELSEIF(MEDIT.EQ.2) THEN + IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 110 + ELSEIF(MEDIT.EQ.3) THEN + IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 110 + IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110 + ELSEIF(MEDIT.EQ.5) THEN + IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110 + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0) GOTO 110 + IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND. + & KCHG(KC,2).EQ.0) GOTO 110 + ENDIF + +C...Pack remaining partons/particles. Origin no longer known. + I1=I1+1 + DO 100 J=1,5 + K(I1,J)=K(I,J) + P(I1,J)=P(I,J) + V(I1,J)=V(I,J) + 100 CONTINUE + K(I1,3)=0 + 110 CONTINUE + IF(I1.LT.N) MSTU(3)=0 + IF(I1.LT.N) MSTU(70)=0 + N=I1 + +C...Selective removal of class of entries. New position of retained. + ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN + I1=0 + DO 120 I=1,N + K(I,3)=MOD(K(I,3),MSTU(5)) + IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120 + IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120 + IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR. + & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120 + IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR. + & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120 + IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120 + I1=I1+1 + K(I,3)=K(I,3)+MSTU(5)*I1 + 120 CONTINUE + +C...Find new event history information and replace old. + DO 140 I=1,N + IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR. + & K(I,3)/MSTU(5).EQ.0) GOTO 140 + ID=I + 130 IM=MOD(K(ID,3),MSTU(5)) + IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN + IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR. + & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN + ID=IM + GOTO 130 + ENDIF + ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN + IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR. + & K(IM,2).EQ.94) THEN + ID=IM + GOTO 130 + ENDIF + ENDIF + K(I,3)=MSTU(5)*(K(I,3)/MSTU(5)) + IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5) + IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND. + & K(I,1).NE.42.AND.K(I,1).NE.52) THEN + IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)= + & K(K(I,4),3)/MSTU(5) + IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)= + & K(K(I,5),3)/MSTU(5) + ELSE + KCM=MOD(K(I,4)/MSTU(5),MSTU(5)) + IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND. + & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5) + KCD=MOD(K(I,4),MSTU(5)) + IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5) + K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD + KCM=MOD(K(I,5)/MSTU(5),MSTU(5)) + IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5) + KCD=MOD(K(I,5),MSTU(5)) + IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5) + K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD + ENDIF + 140 CONTINUE + +C...Pack remaining entries. + I1=0 + MSTU90=MSTU(90) + MSTU(90)=0 + DO 170 I=1,N + IF(K(I,3)/MSTU(5).EQ.0) GOTO 170 + I1=I1+1 + DO 150 J=1,5 + K(I1,J)=K(I,J) + P(I1,J)=P(I,J) + V(I1,J)=V(I,J) + 150 CONTINUE +C...Also update LHA1 colour tags + MCT(I1,1)=MCT(I,1) + MCT(I1,2)=MCT(I,2) + K(I1,3)=MOD(K(I1,3),MSTU(5)) + DO 160 IZ=1,MSTU90 + IF(I.EQ.MSTU(90+IZ)) THEN + MSTU(90)=MSTU(90)+1 + MSTU(90+MSTU(90))=I1 + PARU(90+MSTU(90))=PARU(90+IZ) + ENDIF + 160 CONTINUE + 170 CONTINUE + IF(I1.LT.N) MSTU(3)=0 + IF(I1.LT.N) MSTU(70)=0 + N=I1 + +C...Fill in some missing daughter pointers (lost in colour flow). + ELSEIF(MEDIT.EQ.16) THEN + DO 220 I=1,N + IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220 + IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220 +C...Find daughters who point to mother. + DO 180 I1=I+1,N + IF(K(I1,3).NE.I) THEN + ELSEIF(K(I,4).EQ.0) THEN + K(I,4)=I1 + ELSE + K(I,5)=I1 + ENDIF + 180 CONTINUE + IF(K(I,5).EQ.0) K(I,5)=K(I,4) + IF(K(I,4).NE.0) GOTO 220 +C...Find daughters who point to documentation version of mother. + IM=K(I,3) + IF(IM.LE.0.OR.IM.GE.I) GOTO 220 + IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220 + IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220 + DO 190 I1=I+1,N + IF(K(I1,3).NE.IM) THEN + ELSEIF(K(I,4).EQ.0) THEN + K(I,4)=I1 + ELSE + K(I,5)=I1 + ENDIF + 190 CONTINUE + IF(K(I,5).EQ.0) K(I,5)=K(I,4) + IF(K(I,4).NE.0) GOTO 220 +C...Find daughters who point to documentation daughters who, +C...in their turn, point to documentation mother. + ID1=IM + ID2=IM + DO 200 I1=IM+1,I-1 + IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN + ID2=I1 + IF(ID1.EQ.IM) ID1=I1 + ENDIF + 200 CONTINUE + DO 210 I1=I+1,N + IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN + ELSEIF(K(I,4).EQ.0) THEN + K(I,4)=I1 + ELSE + K(I,5)=I1 + ENDIF + 210 CONTINUE + IF(K(I,5).EQ.0) K(I,5)=K(I,4) + 220 CONTINUE + +C...Save top entries at bottom of PYJETS commonblock. + ELSEIF(MEDIT.EQ.21) THEN + IF(2*N.GE.MSTU(4)) THEN + CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS') + RETURN + ENDIF + DO 240 I=1,N + DO 230 J=1,5 + K(MSTU(4)-I,J)=K(I,J) + P(MSTU(4)-I,J)=P(I,J) + V(MSTU(4)-I,J)=V(I,J) + 230 CONTINUE + 240 CONTINUE + MSTU(32)=N + +C...Restore bottom entries of commonblock PYJETS to top. + ELSEIF(MEDIT.EQ.22) THEN + DO 260 I=1,MSTU(32) + DO 250 J=1,5 + K(I,J)=K(MSTU(4)-I,J) + P(I,J)=P(MSTU(4)-I,J) + V(I,J)=V(MSTU(4)-I,J) + 250 CONTINUE + 260 CONTINUE + N=MSTU(32) + +C...Mark primary entries at top of commonblock PYJETS as untreated. + ELSEIF(MEDIT.EQ.23) THEN + I1=0 + DO 270 I=1,N + KH=K(I,3) + IF(KH.GE.1) THEN + IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0 + ENDIF + IF(KH.NE.0) GOTO 280 + I1=I1+1 + IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10 + IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10 + 270 CONTINUE + 280 N=I1 + +C...Place largest axis along z axis and second largest in xy plane. + ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN + CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1), + & P(MSTU(61),2)),0D0,0D0,0D0) + CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3), + & P(MSTU(61),1)),0D0,0D0,0D0,0D0) + CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1), + & P(MSTU(61)+1,2)),0D0,0D0,0D0) + IF(MEDIT.EQ.31) RETURN + +C...Rotate to put slim jet along +z axis. + DO 290 IS=1,2 + NS(IS)=0 + PTS(IS)=0D0 + PLS(IS)=0D0 + 290 CONTINUE + DO 300 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 300 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)) + & .EQ.0) GOTO 300 + ENDIF + IS=2D0-SIGN(0.5D0,P(I,3)) + NS(IS)=NS(IS)+1 + PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2) + 300 CONTINUE + IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2) + & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0) + +C...Rotate to put second largest jet into -z,+x quadrant. + DO 310 I=1,N + IF(P(I,3).GE.0D0) GOTO 310 + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 310 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)) + & .EQ.0) GOTO 310 + ENDIF + IS=2D0-SIGN(0.5D0,P(I,1)) + PLS(IS)=PLS(IS)-P(I,3) + 310 CONTINUE + IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1), + & 0D0,0D0,0D0) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYLIST +C...Gives program heading, or lists an event, or particle +C...data, or current parameter values. + + SUBROUTINE PYLIST(MLIST) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) + +C...HEPEVT commonblock. + PARAMETER (NMXHEP=4000) + COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP), + &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP) + DOUBLE PRECISION PHEP,VHEP + SAVE /HEPEVT/ + +C...User process event common block. + INTEGER MAXNUP + PARAMETER (MAXNUP=500) + INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP + DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP + COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP), + &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP), + &VTIMUP(MAXNUP),SPINUP(MAXNUP) + SAVE /HEPEUP/ + +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYCTAG/NCT,MCT(4000,2) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/ +C...Local arrays, character variables and data. + CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4 + DIMENSION PS(6) + DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/ + +C...Initialization printout: version number and date of last change. + IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN + CALL PYLOGO + MSTU(12)=12345 + IF(MLIST.EQ.0) RETURN + ENDIF + +C...List event data, including additional lines after N. + IF(MLIST.GE.1.AND.MLIST.LE.4) THEN + IF(MLIST.EQ.1) WRITE(MSTU(11),5100) + IF(MLIST.EQ.2) WRITE(MSTU(11),5200) + IF(MLIST.EQ.3) WRITE(MSTU(11),5300) + IF(MLIST.EQ.4) WRITE(MSTU(11),5400) + LMX=12 + IF(MLIST.GE.2) LMX=16 + ISTR=0 + IMAX=N + IF(MSTU(2).GT.0) IMAX=MSTU(2) + DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3))) + IF(I.GT.IMAX.AND.I.LE.N) GOTO 120 + IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120 + IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120 + +C...Get particle name, pad it and check it is not too long. + CALL PYNAME(K(I,2),CHAP) + LEN=0 + DO 100 LEM=1,16 + IF(CHAP(LEM:LEM).NE.' ') LEN=LEM + 100 CONTINUE + MDL=(K(I,1)+19)/10 + LDL=0 + IF(MDL.EQ.2.OR.MDL.GE.8) THEN + CHAC=CHAP + IF(LEN.GT.LMX) CHAC(LMX:LMX)='?' + ELSE + LDL=1 + IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2 + IF(LEN.EQ.0) THEN + CHAC=CHDL(MDL)(1:2*LDL)//' ' + ELSE + CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))// + & CHDL(MDL)(LDL+1:2*LDL)//' ' + IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?' + ENDIF + ENDIF + +C...Add information on string connection. + IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12) + & THEN + KC=PYCOMP(K(I,2)) + KCC=0 + IF(KC.NE.0) KCC=KCHG(KC,2) + IF(IABS(K(I,2)).EQ.39) THEN + IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X' + ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN + ISTR=1 + IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A' + ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN + IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I' + ELSEIF(KCC.NE.0) THEN + ISTR=0 + IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V' + ENDIF + ENDIF + IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX) + & CHAC(LMX-1:LMX-1)='I' + +C...Write data for particle/jet. + IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN + WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3), + & (P(I,J2),J2=1,5) + ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN + WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3), + & (P(I,J2),J2=1,5) + ELSEIF(MLIST.EQ.1) THEN + WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3), + & (P(I,J2),J2=1,5) + ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR. + & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN + IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3), + & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000), + & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000), + & (P(I,J2),J2=1,5) + IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3), + & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000), + & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5) + & ,10000),MCT(I,1),MCT(I,2) + ELSE + IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5), + & (P(I,J2),J2=1,5) + IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5) + & ,MCT(I,1),MCT(I,2) + ENDIF + IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5) + +C...Insert extra separator lines specified by user. + IF(MSTU(70).GE.1) THEN + ISEP=0 + DO 110 J=1,MIN(10,MSTU(70)) + IF(I.EQ.MSTU(70+J)) ISEP=1 + 110 CONTINUE + IF(ISEP.EQ.1) THEN + IF(MLIST.EQ.1) WRITE(MSTU(11),6300) + IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400) + IF(MLIST.EQ.4) WRITE(MSTU(11),6500) + ENDIF + ENDIF + 120 CONTINUE + +C...Sum of charges and momenta. + DO 130 J=1,6 + PS(J)=PYP(0,J) + 130 CONTINUE + IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN + WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5) + ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN + WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5) + ELSEIF(MLIST.EQ.1) THEN + WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5) + ELSEIF(MLIST.LE.3) THEN + WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5) + ELSE + WRITE(MSTU(11),7000) PS(6) + ENDIF + +C...Simple listing of HEPEVT entries (mainly for test purposes). + ELSEIF(MLIST.EQ.5) THEN + WRITE(MSTU(11),7100) + DO 140 I=1,NHEP + IF(ISTHEP(I).EQ.0) GOTO 140 + WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I), + & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5) + 140 CONTINUE + + +C...Simple listing of user-process entries (mainly for test purposes). + ELSEIF(MLIST.EQ.7) THEN + WRITE(MSTU(11),7300) + DO 150 I=1,NUP + WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I), + & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5) + 150 CONTINUE + +C...Give simple list of KF codes defined in program. + ELSEIF(MLIST.EQ.11) THEN + WRITE(MSTU(11),7500) + DO 160 KF=1,80 + CALL PYNAME(KF,CHAP) + CALL PYNAME(-KF,CHAN) + IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP + IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN + 160 CONTINUE + DO 190 KFLS=1,3,2 + DO 180 KFLA=1,5 + DO 170 KFLB=1,KFLA-(3-KFLS)/2 + KF=1000*KFLA+100*KFLB+KFLS + CALL PYNAME(KF,CHAP) + CALL PYNAME(-KF,CHAN) + WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE + DO 220 KMUL=0,5 + KFLS=3 + IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1 + IF(KMUL.EQ.5) KFLS=5 + KFLR=0 + IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1 + IF(KMUL.EQ.4) KFLR=2 + DO 210 KFLB=1,5 + DO 200 KFLC=1,KFLB-1 + KF=10000*KFLR+100*KFLB+10*KFLC+KFLS + CALL PYNAME(KF,CHAP) + CALL PYNAME(-KF,CHAN) + WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN + IF(KF.EQ.311) THEN + KFK=130 + CALL PYNAME(KFK,CHAP) + WRITE(MSTU(11),7600) KFK,CHAP + KFK=310 + CALL PYNAME(KFK,CHAP) + WRITE(MSTU(11),7600) KFK,CHAP + ENDIF + 200 CONTINUE + KF=10000*KFLR+110*KFLB+KFLS + CALL PYNAME(KF,CHAP) + WRITE(MSTU(11),7600) KF,CHAP + 210 CONTINUE + 220 CONTINUE + KF=100443 + CALL PYNAME(KF,CHAP) + WRITE(MSTU(11),7600) KF,CHAP + KF=100553 + CALL PYNAME(KF,CHAP) + WRITE(MSTU(11),7600) KF,CHAP + DO 260 KFLSP=1,3 + KFLS=2+2*(KFLSP/3) + DO 250 KFLA=1,5 + DO 240 KFLB=1,KFLA + DO 230 KFLC=1,KFLB + IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC)) + & GOTO 230 + IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230 + IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS + IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS + CALL PYNAME(KF,CHAP) + CALL PYNAME(-KF,CHAN) + WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + DO 270 KC=1,500 + KF=KCHG(KC,4) + IF(KF.LT.1000000) GOTO 270 + CALL PYNAME(KF,CHAP) + CALL PYNAME(-KF,CHAN) + IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP + IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN + 270 CONTINUE + +C...List parton/particle data table. Check whether to be listed. + ELSEIF(MLIST.EQ.12) THEN + WRITE(MSTU(11),7700) + DO 300 KC=1,MSTU(6) + KF=KCHG(KC,4) + IF(KF.EQ.0) GOTO 300 + IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2))) + & GOTO 300 + +C...Find particle name and mass. Print information. + CALL PYNAME(KF,CHAP) + IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300 + CALL PYNAME(-KF,CHAN) + WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3), + & (PMAS(KC,J2),J2=1,4),MDCY(KC,1) + +C...Particle decay: channel number, branching ratios, matrix element, +C...decay products. + DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + DO 280 J=1,5 + CALL PYNAME(KFDP(IDC,J),CHAD(J)) + 280 CONTINUE + WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC), + & (CHAD(J),J=1,5) + 290 CONTINUE + 300 CONTINUE + +C...List parameter value table. + ELSEIF(MLIST.EQ.13) THEN + WRITE(MSTU(11),8000) + DO 310 I=1,200 + WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I) + 310 CONTINUE + ENDIF + +C...Format statements for output on unit MSTU(11) (by default 6). + 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS', + &5X,'KF orig p_x p_y p_z E m'/) + 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet', + &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)', + &' P(I,2) P(I,3) P(I,4) P(I,5)'/) + 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j', + &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)', + &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X, + &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/) + 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet', + & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X + & ,' C tag AC tag'/) + 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3) + 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2) + 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1) + 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5) + 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8) + 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5) + 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8) + 6200 FORMAT(66X,5(1X,F12.3)) + 6300 FORMAT(1X,78('=')) + 6400 FORMAT(1X,130('=')) + 6500 FORMAT(1X,65('=')) + 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3) + 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2) + 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1) + 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:', + &5F13.5) + 7000 FORMAT(19X,'sum charge:',F6.2) + 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)' + &//' I IST ID Mothers Daughters p_x p_y p_z', + &' E m') + 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3) + 7300 FORMAT(/10X,'Event listing of user process at input (simplified)' + &//' I IST ID Mothers Colours p_x p_y p_z', + &' E m') + 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3) + 7500 FORMAT(///20X,'List of KF codes in program'/) + 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16) + 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X, + &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X, + &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off', + &1X,'ME',3X,'Br.rat.',4X,'decay products') + 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5), + &1X,1P,E13.5,3X,I2) + 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16) + 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)', + &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)') + 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5) + + RETURN + END + +C********************************************************************* + +C...PYLOGO +C...Writes a logo for the program. + + SUBROUTINE PYLOGO + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter for length of information block. + PARAMETER (IREFER=19) +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 201x', + &' ', + &'Now is xx xxx 201x at xx:xx:xx ', + &' ', + &'Disclaimer: this program comes ', + &'without any guarantees. Beware ', + &'of errors and use common sense ', + &'when interpreting results. ', + &' ', + &'Copyright T. Sjostrand (2011) '/ + DATA (REFER(J),J=1,14)/ + &'An archive of program versions and d', + &'ocumentation is found on the web: ', + &'http://www.thep.lu.se/~torbjorn/Pyth', + &'ia.html ', + &' ', + &' ', + &'When you cite this program, the offi', + &'cial reference is to the 6.4 manual:', + &'T. Sjostrand, S. Mrenna and P. Skand', + &'s, JHEP05 (2006) 026 ', + &'(LU TP 06-13, FERMILAB-PUB-06-052-CD', + &'-T) [hep-ph/0603175]. ', + &' ', + &' '/ + DATA (REFER(J),J=15,32)/ + &'Also remember that the program, to a', + &' large extent, represents original ', + &'physics research. Other publications', + &' of special relevance to your ', + &'studies may therefore deserve separa', + &'te mention. ', + &' ', + &' ', + &'Main author: Torbjorn Sjostrand; Dep', + &'artment of Theoretical Physics, ', + &' Lund University, Solvegatan 14A, S', + &'-223 62 Lund, Sweden; ', + &' phone: + 46 - 46 - 222 48 16; e-ma', + &'il: torbjorn@thep.lu.se ', + &'Author: Stephen Mrenna; Computing Di', + &'vision, GDS Group, ', + &' Fermi National Accelerator Laborat', + &'ory, MS 234, Batavia, IL 60510, USA;'/ + DATA (REFER(J),J=33,2*IREFER)/ + &' phone: + 1 - 630 - 840 - 2556; e-m', + &'ail: mrenna@fnal.gov ', + &'Author: Peter Skands; CERN/PH-TH, CH', + &'-1211 Geneva, Switzerland ', + &' phone: + 41 - 22 - 767 24 47; e-ma', + &'il: peter.skands@cern.ch '/ + +C...Check that PYDATA linked (check we are in the year 20xx) + IF(MSTP(183)/100.NE.20) THEN + WRITE(*,'(1X,A)') + & 'Error: PYDATA has not been linked.' + WRITE(*,'(1X,A)') 'Execution stopped!' + CALL PYSTOP(8) + +C...Write current version number and current date+time. + ELSE + WRITE(VERS,'(I1)') MSTP(181) + LOGO(28)(24:24)=VERS + WRITE(SUBV,'(I3)') MSTP(182) + LOGO(28)(26:28)=SUBV + IF(MSTP(182).LT.100) LOGO(28)(26:26)='0' + WRITE(DATE,'(I2)') MSTP(185) + LOGO(29)(22:23)=DATE + LOGO(29)(25:27)=MONTH(MSTP(184)) + WRITE(YEAR,'(I4)') MSTP(183) + LOGO(29)(29:32)=YEAR + CALL PYTIME(IDATI) + IF(IDATI(1).LE.0) THEN + LOGO(31)=' ' + ELSE + WRITE(DATE,'(I2)') IDATI(3) + LOGO(31)(8:9)=DATE + LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2)))) + WRITE(YEAR,'(I4)') IDATI(1) + LOGO(31)(15:18)=YEAR + WRITE(HOUR,'(I2)') IDATI(4) + LOGO(31)(23:24)=HOUR + WRITE(MINU,'(I2)') IDATI(5) + LOGO(31)(26:27)=MINU + IF(IDATI(5).LT.10) LOGO(31)(26:26)='0' + WRITE(SECO,'(I2)') IDATI(6) + LOGO(31)(29:30)=SECO + IF(IDATI(6).LT.10) LOGO(31)(29:29)='0' + ENDIF + ENDIF + + + WRITE(MSTU(11),'(A79)') + &'+++++++++++++++++++++++++++++++++++++++++++++++++'// + &'+++++++++++++++++++++++++++++' + WRITE(MSTU(11),'(A79)') + &'++ This is a modified version of PYTHIA that may'// + & ' only be used with JEWEL. ++' + WRITE(MSTU(11),'(A79)') + &'+++++++++++++++++++++++++++++++++++++++++++++++++'// + &'+++++++++++++++++++++++++++++' + +C...Loop over lines in header. Define page feed and side borders. + DO 100 ILIN=1,29+IREFER + LINE=' ' + IF(ILIN.EQ.1) THEN + LINE(1:1)='1' + ELSE + LINE(2:3)='**' + LINE(78:79)='**' + ENDIF + +C...Separator lines and logos. + IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN + LINE(4:77)='***********************************************'// + & '***************************' + ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN + LINE(6:37)=LOGO(ILIN-5) + LINE(44:75)=LOGO(ILIN+14) + ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN + LINE(5:40)=REFER(2*ILIN-51) + LINE(41:76)=REFER(2*ILIN-50) + ENDIF + +C...Write lines to appropriate unit. + WRITE(MSTU(11),'(A79)') LINE + 100 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYUPDA +C...Facilitates the updating of particle and decay data +C...by allowing it to be done in an external file. + + SUBROUTINE PYUPDA(MUPDA,LFN) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + COMMON/PYDAT4/CHAF(500,2) + CHARACTER CHAF*16 + COMMON/PYINT4/MWID(500),WIDS(500,5) + SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/ +C...Local arrays, character variables and data. + CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72, + &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24 + DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)', + &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)', + &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ', + &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)', + &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/ + +C...Write header if not yet done. + IF(MSTU(12).NE.12345) CALL PYLIST(0) + +C...Write information on file for editing. + IF(MUPDA.EQ.1) THEN + DO 110 KC=1,500 + WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2), + & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4), + & MWID(KC),MDCY(KC,1) + DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC), + & (KFDP(IDC,J),J=1,5) + 100 CONTINUE + 110 CONTINUE + +C...Read complete set of information from edited file or +C...read partial set of new or updated information from edited file. + ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN + +C...Reset counters. + KCC=100 + NDC=0 + CHKF=' ' + IF(MUPDA.EQ.2) THEN + DO 120 I=1,MSTU(6) + KCHG(I,4)=0 + 120 CONTINUE + ELSE + DO 130 KC=1,MSTU(6) + IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC + NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1) + 130 CONTINUE + ENDIF + +C...Begin of loop: read new line; unknown whether particle or +C...decay data. + 140 READ(LFN,5200,END=190) CHINL + +C...Identify particle code and whether already defined (for MUPDA=3). + IF(CHINL(2:10).NE.' ') THEN + CHKF=CHINL(2:10) + READ(CHKF,5300) KF + IF(MUPDA.EQ.2) THEN + IF(KF.LE.100) THEN + KC=KF + ELSE + KCC=KCC+1 + KC=KCC + ENDIF + ELSE + KCREP=0 + IF(KF.LE.100) THEN + KCREP=KF + ELSE + DO 150 KCR=101,KCC + IF(KCHG(KCR,4).EQ.KF) KCREP=KCR + 150 CONTINUE + ENDIF +C...Remove duplicate old decay data. + IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN + IDCREP=MDCY(KCREP,2) + NDCREP=MDCY(KCREP,3) + DO 160 I=1,KCC + IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP + 160 CONTINUE + DO 180 I=IDCREP,NDC-NDCREP + MDME(I,1)=MDME(I+NDCREP,1) + MDME(I,2)=MDME(I+NDCREP,2) + BRAT(I)=BRAT(I+NDCREP) + DO 170 J=1,5 + KFDP(I,J)=KFDP(I+NDCREP,J) + 170 CONTINUE + 180 CONTINUE + NDC=NDC-NDCREP + KC=KCREP + ELSEIF(KCREP.NE.0) THEN + KC=KCREP + ELSE + KCC=KCC+1 + KC=KCC + ENDIF + ENDIF + +C...Study line with particle data. + IF(KC.GT.MSTU(6)) CALL PYERRM(27, + & '(PYUPDA:) Particle arrays full by KF ='//CHKF) + READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2), + & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4), + & MWID(KC),MDCY(KC,1) + MDCY(KC,2)=0 + MDCY(KC,3)=0 + +C...Study line with decay data. + ELSE + NDC=NDC+1 + IF(NDC.GT.MSTU(7)) CALL PYERRM(27, + & '(PYUPDA:) Decay data arrays full by KF ='//CHKF) + IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC + MDCY(KC,3)=MDCY(KC,3)+1 + READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC), + & (KFDP(NDC,J),J=1,5) + ENDIF + +C...End of loop; ensure that PYCOMP tables are updated. + GOTO 140 + 190 CONTINUE + MSTU(20)=0 + +C...Perform possible tests that new information is consistent. + DO 220 KC=1,MSTU(6) + KF=KCHG(KC,4) + IF(KF.EQ.0) GOTO 220 + WRITE(CHKF,5300) KF + IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3), + & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17, + & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF) + BRSUM=0D0 + DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1 + IF(MDME(IDC,2).GT.80) GOTO 210 + KQ=KCHG(KC,1) + PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64) + MERR=0 + DO 200 J=1,5 + KP=KFDP(IDC,J) + IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN + IF(KP.EQ.81) KQ=0 + ELSEIF(PYCOMP(KP).EQ.0) THEN + MERR=3 + ELSE + KQ=KQ-PYCHGE(KP) + KPC=PYCOMP(KP) + PMS=PMS-PMAS(KPC,1) + IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2), + & PMAS(KPC,3)) + ENDIF + 200 CONTINUE + IF(KQ.NE.0) MERR=MAX(2,MERR) + IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0) + & MERR=MAX(1,MERR) + IF(MERR.EQ.3) CALL PYERRM(17, + & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF) + IF(MERR.EQ.2) CALL PYERRM(17, + & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF) + IF(MERR.EQ.1) CALL PYERRM(7, + & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF) + BRSUM=BRSUM+BRAT(IDC) + 210 CONTINUE + WRITE(CHTMP,5500) BRSUM + IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0) + & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '// + & CHTMP(9:16)//' for KF ='//CHKF) + 220 CONTINUE + +C...Write DATA statements for inclusion in program. + ELSEIF(MUPDA.EQ.4) THEN + +C...Find out how many codes and decay channels are actually used. + KCC=0 + NDC=0 + DO 230 I=1,MSTU(6) + IF(KCHG(I,4).NE.0) THEN + KCC=I + NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1) + ENDIF + 230 CONTINUE + +C...Initialize writing of DATA statements for inclusion in program. + DO 300 IVAR=1,22 + NDIM=MSTU(6) + IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7) + NLIN=1 + CHLIN=' ' + CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/' + LLIN=35 + CHOLD='START' + +C...Loop through variables for conversion to characters. + DO 280 IDIM=1,NDIM + IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1) + IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2) + IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3) + IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4) + IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1) + IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2) + IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3) + IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4) + IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1) + IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2) + IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3) + IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1) + IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2) + IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM) + IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1) + IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2) + IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3) + IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4) + IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5) + IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1) + IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2) + IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM) + +C...Replace variables beyond what is properly defined. + IF(IVAR.LE.4) THEN + IF(IDIM.GT.KCC) CHTMP=' 0' + ELSEIF(IVAR.LE.8) THEN + IF(IDIM.GT.KCC) CHTMP=' 0.0' + ELSEIF(IVAR.LE.11) THEN + IF(IDIM.GT.KCC) CHTMP=' 0' + ELSEIF(IVAR.LE.13) THEN + IF(IDIM.GT.NDC) CHTMP=' 0' + ELSEIF(IVAR.LE.14) THEN + IF(IDIM.GT.NDC) CHTMP=' 0.0' + ELSEIF(IVAR.LE.19) THEN + IF(IDIM.GT.NDC) CHTMP=' 0' + ELSEIF(IVAR.LE.21) THEN + IF(IDIM.GT.KCC) CHTMP=' ' + ELSE + IF(IDIM.GT.KCC) CHTMP=' 0' + ENDIF + +C...Length of variable, trailing decimal zeros, quotation marks. + LLOW=1 + LHIG=1 + DO 240 LL=1,16 + IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL + IF(CHTMP(LL:LL).NE.' ') LHIG=LL + 240 CONTINUE + CHNEW=CHTMP(LLOW:LHIG)//' ' + LNEW=1+LHIG-LLOW + IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN + LNEW=LNEW+1 + 250 LNEW=LNEW-1 + IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250 + IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1 + IF(LNEW.EQ.0) THEN + CHNEW(1:3)='0D0' + LNEW=3 + ELSE + CHNEW(LNEW+1:LNEW+2)='D0' + LNEW=LNEW+2 + ENDIF + ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN + DO 260 LL=LNEW,1,-1 + IF(CHNEW(LL:LL).EQ.'''') THEN + CHTMP=CHNEW + CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11) + LNEW=LNEW+1 + ENDIF + 260 CONTINUE + LNEW=MIN(14,LNEW) + CHTMP=CHNEW + CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//'''' + LNEW=LNEW+2 + ENDIF + +C...Form composite character string, often including repetition counter. + IF(CHNEW.NE.CHOLD) THEN + NRPT=1 + CHOLD=CHNEW + CHCOM=CHNEW + LCOM=LNEW + ELSE + LRPT=LNEW+1 + IF(NRPT.GE.2) LRPT=LNEW+3 + IF(NRPT.GE.10) LRPT=LNEW+4 + IF(NRPT.GE.100) LRPT=LNEW+5 + IF(NRPT.GE.1000) LRPT=LNEW+6 + LLIN=LLIN-LRPT + NRPT=NRPT+1 + WRITE(CHTMP,5400) NRPT + LRPT=1 + IF(NRPT.GE.10) LRPT=2 + IF(NRPT.GE.100) LRPT=3 + IF(NRPT.GE.1000) LRPT=4 + CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW) + LCOM=LRPT+1+LNEW + ENDIF + +C...Add characters to end of line, to new line (after storing old line), +C...or to new block of lines (after writing old block). + IF(LLIN+LCOM.LE.70) THEN + CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//',' + LLIN=LLIN+LCOM+1 + ELSEIF(NLIN.LE.19) THEN + CHLIN(LLIN+1:72)=' ' + CHBLK(NLIN)=CHLIN + NLIN=NLIN+1 + CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//',' + LLIN=6+LCOM+1 + ELSE + CHLIN(LLIN:72)='/'//' ' + CHBLK(NLIN)=CHLIN + WRITE(CHTMP,5400) IDIM-NRPT + CHBLK(1)(30:33)=CHTMP(13:16) + DO 270 ILIN=1,NLIN + WRITE(LFN,5700) CHBLK(ILIN) + 270 CONTINUE + NLIN=1 + CHLIN=' ' + CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)// + & ',I= , )/'//CHCOM(1:LCOM)//',' + WRITE(CHTMP,5400) IDIM-NRPT+1 + CHLIN(25:28)=CHTMP(13:16) + LLIN=35+LCOM+1 + ENDIF + 280 CONTINUE + +C...Write final block of lines. + CHLIN(LLIN:72)='/'//' ' + CHBLK(NLIN)=CHLIN + WRITE(CHTMP,5400) NDIM + CHBLK(1)(30:33)=CHTMP(13:16) + DO 290 ILIN=1,NLIN + WRITE(LFN,5700) CHBLK(ILIN) + 290 CONTINUE + 300 CONTINUE + ENDIF + +C...Formats for reading and writing particle data. + 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3) + 5100 FORMAT(10X,2I5,F12.6,5I10) + 5200 FORMAT(A120) + 5300 FORMAT(I9) + 5400 FORMAT(I16) + 5500 FORMAT(F16.5) + 5600 FORMAT(F16.6) + 5700 FORMAT(A72) + + RETURN + END + +C********************************************************************* + +C...PYK +C...Provides various integer-valued event related data. + + FUNCTION PYK(I,J) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ +C...Local array. + DIMENSION PSUM(4) + +C...Set default value. For I = 0 sum of momenta or charges, +C...or invariant mass of system. + PYP=0D0 + IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN + ELSEIF(I.EQ.0.AND.J.LE.4) THEN + DO 100 I1=1,N + IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J) + 100 CONTINUE + ELSEIF(I.EQ.0.AND.J.EQ.5) THEN + DO 120 J1=1,4 + PSUM(J1)=0D0 + DO 110 I1=1,N + IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+ + & P(I1,J1) + 110 CONTINUE + 120 CONTINUE + PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2)) + ELSEIF(I.EQ.0.AND.J.EQ.6) THEN + DO 130 I1=1,N + IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0 + 130 CONTINUE + ELSEIF(I.EQ.0) THEN + +C...Direct readout of P matrix. + ELSEIF(J.LE.5) THEN + PYP=P(I,J) + +C...Charge, total momentum, transverse momentum, transverse mass. + ELSEIF(J.LE.12) THEN + IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0 + IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2 + IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2 + IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2 + IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP) + +C...Theta and phi angle in radians or degrees. + ELSEIF(J.LE.16) THEN + IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2)) + IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2)) + IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1) + +C...True rapidity, rapidity with pion mass, pseudorapidity. + ELSEIF(J.LE.19) THEN + PMR=0D0 + IF(J.EQ.17) PMR=P(I,5) + IF(J.EQ.18) PMR=PYMASS(211) + PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2) + PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR), + & 1D20)),P(I,3)) + +C...Energy and momentum fractions (only to be used in CM frame). + ELSEIF(J.LE.25) THEN + IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21) + IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21) + IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21) + IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21) + IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21) + IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21) + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYSPHE +C...Performs sphericity tensor analysis to give sphericity, +C...aplanarity and the related event axes. + + SUBROUTINE PYSPHE(SPH,APL) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ +C...Local arrays. + DIMENSION SM(3,3),SV(3,3) + +C...Calculate matrix to be diagonalized. + NP=0 + DO 110 J1=1,3 + DO 100 J2=J1,3 + SM(J1,J2)=0D0 + 100 CONTINUE + 110 CONTINUE + PS=0D0 + DO 140 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 140 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) + & GOTO 140 + ENDIF + NP=NP+1 + PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + PWT=1D0 + IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT= + & MAX(1D-10,PA)**(PARU(41)-2D0) + DO 130 J1=1,3 + DO 120 J2=J1,3 + SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2) + 120 CONTINUE + 130 CONTINUE + PS=PS+PWT*PA**2 + 140 CONTINUE + +C...Very low multiplicities (0 or 1) not considered. + IF(NP.LE.1) THEN + CALL PYERRM(8,'(PYSPHE:) too few particles for analysis') + SPH=-1D0 + APL=-1D0 + RETURN + ENDIF + DO 160 J1=1,3 + DO 150 J2=J1,3 + SM(J1,J2)=SM(J1,J2)/PS + 150 CONTINUE + 160 CONTINUE + +C...Find eigenvalues to matrix (third degree equation). + SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)- + &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0 + SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+ + &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+ + &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0 + SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0) + P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP) + P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP) + P(N+2,4)=1D0-P(N+1,4)-P(N+3,4) + IF(P(N+2,4).LT.1D-5) THEN + CALL PYERRM(8,'(PYSPHE:) all particles back-to-back') + SPH=-1D0 + APL=-1D0 + RETURN + ENDIF + +C...Find first and last eigenvector by solving equation system. + DO 240 I=1,3,2 + DO 180 J1=1,3 + SV(J1,J1)=SM(J1,J1)-P(N+I,4) + DO 170 J2=J1+1,3 + SV(J1,J2)=SM(J1,J2) + SV(J2,J1)=SM(J1,J2) + 170 CONTINUE + 180 CONTINUE + SMAX=0D0 + DO 200 J1=1,3 + DO 190 J2=1,3 + IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190 + JA=J1 + JB=J2 + SMAX=ABS(SV(J1,J2)) + 190 CONTINUE + 200 CONTINUE + SMAX=0D0 + DO 220 J3=JA+1,JA+2 + J1=J3-3*((J3-1)/3) + RL=SV(J1,JB)/SV(JA,JB) + DO 210 J2=1,3 + SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2) + IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210 + JC=J1 + SMAX=ABS(SV(J1,J2)) + 210 CONTINUE + 220 CONTINUE + JB1=JB+1-3*(JB/3) + JB2=JB+2-3*((JB+1)/3) + P(N+I,JB1)=-SV(JC,JB2) + P(N+I,JB2)=SV(JC,JB1) + P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/ + & SV(JA,JB) + PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2) + SGN=(-1D0)**INT(PYR(0)+0.5D0) + DO 230 J=1,3 + P(N+I,J)=SGN*P(N+I,J)/PA + 230 CONTINUE + 240 CONTINUE + +C...Middle axis orthogonal to other two. Fill other codes. + SGN=(-1D0)**INT(PYR(0)+0.5D0) + P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2)) + P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3)) + P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1)) + DO 260 I=1,3 + K(N+I,1)=31 + K(N+I,2)=95 + K(N+I,3)=I + K(N+I,4)=0 + K(N+I,5)=0 + P(N+I,5)=0D0 + DO 250 J=1,5 + V(I,J)=0D0 + 250 CONTINUE + 260 CONTINUE + +C...Calculate sphericity and aplanarity. Select storing option. + SPH=1.5D0*(P(N+2,4)+P(N+3,4)) + APL=1.5D0*P(N+3,4) + MSTU(61)=N+1 + MSTU(62)=NP + IF(MSTU(43).LE.1) MSTU(3)=3 + IF(MSTU(43).GE.2) N=N+3 + + RETURN + END + +C********************************************************************* + +C...PYTHRU +C...Performs thrust analysis to give thrust, oblateness +C...and the related event axes. + + SUBROUTINE PYTHRU(THR,OBL) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ +C...Local arrays. + DIMENSION TDI(3),TPR(3) + +C...Take copy of particles that are to be considered in thrust analysis. + NP=0 + PS=0D0 + DO 100 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 100 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) + & GOTO 100 + ENDIF + IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS') + THR=-2D0 + OBL=-2D0 + RETURN + ENDIF + NP=NP+1 + K(N+NP,1)=23 + P(N+NP,1)=P(I,1) + P(N+NP,2)=P(I,2) + P(N+NP,3)=P(I,3) + P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + P(N+NP,5)=1D0 + IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)= + & P(N+NP,4)**(PARU(42)-1D0) + PS=PS+P(N+NP,4)*P(N+NP,5) + 100 CONTINUE + +C...Very low multiplicities (0 or 1) not considered. + IF(NP.LE.1) THEN + CALL PYERRM(8,'(PYTHRU:) too few particles for analysis') + THR=-1D0 + OBL=-1D0 + RETURN + ENDIF + +C...Loop over thrust and major. T axis along z direction in latter case. + DO 320 ILD=1,2 + IF(ILD.EQ.2) THEN + K(N+NP+1,1)=31 + PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2)) + MSTU(33)=1 + CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0) + THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1)) + CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0) + ENDIF + +C...Find and order particles with highest p (pT for major). + DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4 + P(ILF,4)=0D0 + 110 CONTINUE + DO 160 I=N+1,N+NP + IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2) + DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1 + IF(P(I,4).LE.P(ILF,4)) GOTO 140 + DO 120 J=1,5 + P(ILF+1,J)=P(ILF,J) + 120 CONTINUE + 130 CONTINUE + ILF=N+NP+3 + 140 DO 150 J=1,5 + P(ILF+1,J)=P(I,J) + 150 CONTINUE + 160 CONTINUE + +C...Find and order initial axes with highest thrust (major). + DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15 + P(ILG,4)=0D0 + 170 CONTINUE + NC=2**(MIN(MSTU(44),NP)-1) + DO 250 ILC=1,NC + DO 180 J=1,3 + TDI(J)=0D0 + 180 CONTINUE + DO 200 ILF=1,MIN(MSTU(44),NP) + SGN=P(N+NP+ILF+3,5) + IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN + DO 190 J=1,4-ILD + TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J) + 190 CONTINUE + 200 CONTINUE + TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2 + DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1 + IF(TDS.LE.P(ILG,4)) GOTO 230 + DO 210 J=1,4 + P(ILG+1,J)=P(ILG,J) + 210 CONTINUE + 220 CONTINUE + ILG=N+NP+MSTU(44)+4 + 230 DO 240 J=1,3 + P(ILG+1,J)=TDI(J) + 240 CONTINUE + P(ILG+1,4)=TDS + 250 CONTINUE + +C...Iterate direction of axis until stable maximum. + P(N+NP+ILD,4)=0D0 + ILG=0 + 260 ILG=ILG+1 + THP=0D0 + 270 THPS=THP + DO 280 J=1,3 + IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J) + IF(THP.GT.1D-10) TDI(J)=TPR(J) + TPR(J)=0D0 + 280 CONTINUE + DO 300 I=N+1,N+NP + SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3)) + DO 290 J=1,4-ILD + TPR(J)=TPR(J)+SGN*P(I,J) + 290 CONTINUE + 300 CONTINUE + THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS + IF(THP.GE.THPS+PARU(48)) GOTO 270 + +C...Save good axis. Try new initial axis until a number of tries agree. + IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260 + IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN + IAGR=0 + SGN=(-1D0)**INT(PYR(0)+0.5D0) + DO 310 J=1,3 + P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP) + 310 CONTINUE + P(N+NP+ILD,4)=THP + P(N+NP+ILD,5)=0D0 + ENDIF + IAGR=IAGR+1 + IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260 + 320 CONTINUE + +C...Find minor axis and value by orthogonality. + SGN=(-1D0)**INT(PYR(0)+0.5D0) + P(N+NP+3,1)=-SGN*P(N+NP+2,2) + P(N+NP+3,2)=SGN*P(N+NP+2,1) + P(N+NP+3,3)=0D0 + THP=0D0 + DO 330 I=N+1,N+NP + THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2)) + 330 CONTINUE + P(N+NP+3,4)=THP/PS + P(N+NP+3,5)=0D0 + +C...Fill axis information. Rotate back to original coordinate system. + DO 350 ILD=1,3 + K(N+ILD,1)=31 + K(N+ILD,2)=96 + K(N+ILD,3)=ILD + K(N+ILD,4)=0 + K(N+ILD,5)=0 + DO 340 J=1,5 + P(N+ILD,J)=P(N+NP+ILD,J) + V(N+ILD,J)=0D0 + 340 CONTINUE + 350 CONTINUE + CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0) + +C...Calculate thrust and oblateness. Select storing option. + THR=P(N+1,4) + OBL=P(N+2,4)-P(N+3,4) + MSTU(61)=N+1 + MSTU(62)=NP + IF(MSTU(43).LE.1) MSTU(3)=3 + IF(MSTU(43).GE.2) N=N+3 + + RETURN + END + +C********************************************************************* + +C...PYCLUS +C...Subdivides the particle content of an event into jets/clusters. + + SUBROUTINE PYCLUS(NJET) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,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))/MAX(1D-10,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))/MAX(1D-10,P(I1,5)*P(I2,5))) + +C...If first time, reset. If reentering, skip preliminaries. + IF(MSTU(48).LE.0) THEN + NP=0 + DO 100 J=1,5 + PS(J)=0D0 + 100 CONTINUE + PSS=0D0 + PIMASS=PMAS(PYCOMP(211),1) + ELSE + NJET=NSAV + IF(MSTU(43).GE.2) N=N-NJET + DO 110 I=N+1,N+NJET + P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + 110 CONTINUE + IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN + R2ACC=PARU(44)**2 + ELSE + R2ACC=PARU(45)*PS(5)**2 + ENDIF + NLOOP=0 + GOTO 300 + ENDIF + +C...Find which particles are to be considered in cluster search. + DO 140 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 140 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) + & GOTO 140 + ENDIF + IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS') + NJET=-1 + RETURN + ENDIF + +C...Take copy of these particles, with space left for jets later on. + NP=NP+1 + K(N+NP,3)=I + DO 120 J=1,5 + P(N+NP,J)=P(I,J) + 120 CONTINUE + IF(MSTU(42).EQ.0) P(N+NP,5)=0D0 + IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS + P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + DO 130 J=1,4 + PS(J)=PS(J)+P(N+NP,J) + 130 CONTINUE + PSS=PSS+P(N+NP,5) + 140 CONTINUE + DO 160 I=N+1,N+NP + K(I+NP,3)=K(I,3) + DO 150 J=1,5 + P(I+NP,J)=P(I,J) + 150 CONTINUE + 160 CONTINUE + PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2)) + +C...Very low multiplicities not considered. + IF(NP.LT.MSTU(47)) THEN + CALL PYERRM(8,'(PYCLUS:) too few particles for analysis') + NJET=-1 + RETURN + ENDIF + +C...Find precluster configuration. If too few jets, make harder cuts. + NLOOP=0 + IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN + R2ACC=PARU(44)**2 + ELSE + R2ACC=PARU(45)*PS(5)**2 + ENDIF + RINIT=1.25D0*PARU(43) + IF(NP.LE.MSTU(47)+2) RINIT=0D0 + 170 RINIT=0.8D0*RINIT + NPRE=0 + NREM=NP + DO 180 I=N+NP+1,N+2*NP + K(I,4)=0 + 180 CONTINUE + +C...Sum up small momentum region. Jet if enough absolute momentum. + IF(MSTU(46).LE.2) THEN + DO 190 J=1,4 + P(N+1,J)=0D0 + 190 CONTINUE + DO 210 I=N+NP+1,N+2*NP + IF(P(I,5).GT.2D0*RINIT) GOTO 210 + NREM=NREM-1 + K(I,4)=1 + DO 200 J=1,4 + P(N+1,J)=P(N+1,J)+P(I,J) + 200 CONTINUE + 210 CONTINUE + P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2) + IF(P(N+1,5).GT.2D0*RINIT) NPRE=1 + IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170 + IF(NREM.EQ.0) GOTO 170 + ENDIF + +C...Find fastest remaining particle. + 220 NPRE=NPRE+1 + PMAX=0D0 + DO 230 I=N+NP+1,N+2*NP + IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230 + IMAX=I + PMAX=P(I,5) + 230 CONTINUE + DO 240 J=1,5 + P(N+NPRE,J)=P(IMAX,J) + 240 CONTINUE + NREM=NREM-1 + K(IMAX,4)=NPRE + +C...Sum up precluster around it according to pT separation. + IF(MSTU(46).LE.2) THEN + DO 260 I=N+NP+1,N+2*NP + IF(K(I,4).NE.0) GOTO 260 + R2=R2T(I,IMAX) + IF(R2.GT.RINIT**2) GOTO 260 + NREM=NREM-1 + K(I,4)=NPRE + DO 250 J=1,4 + P(N+NPRE,J)=P(N+NPRE,J)+P(I,J) + 250 CONTINUE + 260 CONTINUE + P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2) + +C...Sum up precluster around it according to mass or +C...Durham pT separation. + ELSE + 270 IMIN=0 + R2MIN=RINIT**2 + DO 280 I=N+NP+1,N+2*NP + IF(K(I,4).NE.0) GOTO 280 + IF(MSTU(46).LE.4) THEN + R2=R2M(I,N+NPRE) + ELSE + R2=R2D(I,N+NPRE) + ENDIF + IF(R2.GE.R2MIN) GOTO 280 + IMIN=I + R2MIN=R2 + 280 CONTINUE + IF(IMIN.NE.0) THEN + DO 290 J=1,4 + P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J) + 290 CONTINUE + P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2) + NREM=NREM-1 + K(IMIN,4)=NPRE + GOTO 270 + ENDIF + ENDIF + +C...Check if more preclusters to be found. Start over if too few. + IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170 + IF(NREM.GT.0) GOTO 220 + NJET=NPRE + +C...Reassign all particles to nearest jet. Sum up new jet momenta. + 300 TSAV=0D0 + PSJT=0D0 + 310 IF(MSTU(46).LE.1) THEN + DO 330 I=N+1,N+NJET + DO 320 J=1,4 + V(I,J)=0D0 + 320 CONTINUE + 330 CONTINUE + DO 360 I=N+NP+1,N+2*NP + R2MIN=PSS**2 + DO 340 IJET=N+1,N+NJET + IF(P(IJET,5).LT.RINIT) GOTO 340 + R2=R2T(I,IJET) + IF(R2.GE.R2MIN) GOTO 340 + IMIN=IJET + R2MIN=R2 + 340 CONTINUE + K(I,4)=IMIN-N + DO 350 J=1,4 + V(IMIN,J)=V(IMIN,J)+P(I,J) + 350 CONTINUE + 360 CONTINUE + PSJT=0D0 + DO 380 I=N+1,N+NJET + DO 370 J=1,4 + P(I,J)=V(I,J) + 370 CONTINUE + P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + PSJT=PSJT+P(I,5) + 380 CONTINUE + ENDIF + +C...Find two closest jets. + R2MIN=2D0*MAX(R2ACC,PS(5)**2) + DO 400 ITRY1=N+1,N+NJET-1 + DO 390 ITRY2=ITRY1+1,N+NJET + IF(MSTU(46).LE.2) THEN + R2=R2T(ITRY1,ITRY2) + ELSEIF(MSTU(46).LE.4) THEN + R2=R2M(ITRY1,ITRY2) + ELSE + R2=R2D(ITRY1,ITRY2) + ENDIF + IF(R2.GE.R2MIN) GOTO 390 + IMIN1=ITRY1 + IMIN2=ITRY2 + R2MIN=R2 + 390 CONTINUE + 400 CONTINUE + +C...If allowed, join two closest jets and start over. + IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN + IREC=MIN(IMIN1,IMIN2) + IDEL=MAX(IMIN1,IMIN2) + DO 410 J=1,4 + P(IREC,J)=P(IMIN1,J)+P(IMIN2,J) + 410 CONTINUE + P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2) + DO 430 I=IDEL+1,N+NJET + DO 420 J=1,5 + P(I-1,J)=P(I,J) + 420 CONTINUE + 430 CONTINUE + IF(MSTU(46).GE.2) THEN + DO 440 I=N+NP+1,N+2*NP + IORI=N+K(I,4) + IF(IORI.EQ.IDEL) K(I,4)=IREC-N + IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1 + 440 CONTINUE + ENDIF + NJET=NJET-1 + GOTO 300 + +C...Divide up broad jet if empty cluster in list of final ones. + ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN + DO 450 I=N+1,N+NJET + K(I,5)=0 + 450 CONTINUE + DO 460 I=N+NP+1,N+2*NP + K(N+K(I,4),5)=K(N+K(I,4),5)+1 + 460 CONTINUE + IEMP=0 + DO 470 I=N+1,N+NJET + IF(K(I,5).EQ.0) IEMP=I + 470 CONTINUE + IF(IEMP.NE.0) THEN + NLOOP=NLOOP+1 + ISPL=0 + R2MAX=0D0 + DO 480 I=N+NP+1,N+2*NP + IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480 + IJET=N+K(I,4) + R2=R2T(I,IJET) + IF(R2.LE.R2MAX) GOTO 480 + ISPL=I + R2MAX=R2 + 480 CONTINUE + IF(ISPL.NE.0) THEN + IJET=N+K(ISPL,4) + DO 490 J=1,4 + P(IEMP,J)=P(ISPL,J) + P(IJET,J)=P(IJET,J)-P(ISPL,J) + 490 CONTINUE + P(IEMP,5)=P(ISPL,5) + P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2) + IF(NLOOP.LE.2) GOTO 300 + ENDIF + ENDIF + ENDIF + +C...If generalized thrust has not yet converged, continue iteration. + IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48)) + &THEN + TSAV=PSJT/PSS + GOTO 310 + ENDIF + +C...Reorder jets according to energy. + DO 510 I=N+1,N+NJET + DO 500 J=1,5 + V(I,J)=P(I,J) + 500 CONTINUE + 510 CONTINUE + DO 540 INEW=N+1,N+NJET + PEMAX=0D0 + DO 520 ITRY=N+1,N+NJET + IF(V(ITRY,4).LE.PEMAX) GOTO 520 + IMAX=ITRY + PEMAX=V(ITRY,4) + 520 CONTINUE + K(INEW,1)=31 + K(INEW,2)=97 + K(INEW,3)=INEW-N + K(INEW,4)=0 + DO 530 J=1,5 + P(INEW,J)=V(IMAX,J) + 530 CONTINUE + V(IMAX,4)=-1D0 + K(IMAX,5)=INEW + 540 CONTINUE + +C...Clean up particle-jet assignments and jet information. + DO 550 I=N+NP+1,N+2*NP + IORI=K(N+K(I,4),5) + K(I,4)=IORI-N + IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N + K(IORI,4)=K(IORI,4)+1 + 550 CONTINUE + IEMP=0 + PSJT=0D0 + DO 570 I=N+1,N+NJET + K(I,5)=0 + PSJT=PSJT+P(I,5) + P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0)) + DO 560 J=1,5 + V(I,J)=0D0 + 560 CONTINUE + IF(K(I,4).EQ.0) IEMP=I + 570 CONTINUE + +C...Select storing option. Output variables. Check for failure. + MSTU(61)=N+1 + MSTU(62)=NP + MSTU(63)=NPRE + PARU(61)=PS(5) + PARU(62)=PSJT/PSS + PARU(63)=SQRT(R2MIN) + IF(NJET.LE.1) PARU(63)=0D0 + IF(IEMP.NE.0) THEN + CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested') + NJET=-1 + RETURN + ENDIF + IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET) + IF(MSTU(43).GE.2) N=N+MAX(0,NJET) + NSAV=NJET + + RETURN + END + +C********************************************************************* + +C...PYCELL +C...Provides a simple way of jet finding in eta-phi-ET coordinates, +C...as used for calorimeters at hadron colliders. + + SUBROUTINE PYCELL(NJET) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Loop over all particles. Find cell that was hit by given particle. + PTLRAT=1D0/SINH(PARU(51))**2 + NP=0 + NC=N + DO 110 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110 + IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 110 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) + & GOTO 110 + ENDIF + NP=NP+1 + PT=SQRT(P(I,1)**2+P(I,2)**2) + ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3)) + IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0* + & (ETA/PARU(51)+1D0)))) + PHI=PYANGL(P(I,1),P(I,2)) + IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0* + & (PHI/PARU(1)+1D0)))) + IETPH=MSTU(52)*IETA+IPHI + +C...Add to cell already hit, or book new cell. + DO 100 IC=N+1,NC + IF(IETPH.EQ.K(IC,3)) THEN + K(IC,4)=K(IC,4)+1 + P(IC,5)=P(IC,5)+PT + GOTO 110 + ENDIF + 100 CONTINUE + IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS') + NJET=-2 + RETURN + ENDIF + NC=NC+1 + K(NC,3)=IETPH + K(NC,4)=1 + K(NC,5)=2 + P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51)) + P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52)) + P(NC,5)=PT + 110 CONTINUE + +C...Smear true bin content by calorimeter resolution. + IF(MSTU(53).GE.1) THEN + DO 130 IC=N+1,NC + PEI=P(IC,5) + IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1)) + 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)* + & COS(PARU(2)*PYR(0)) + IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120 + P(IC,5)=PEF + IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1)) + 130 CONTINUE + ENDIF + +C...Remove cells below threshold. + IF(PARU(58).GT.0D0) THEN + NCC=NC + NC=N + DO 140 IC=N+1,NCC + IF(P(IC,5).GT.PARU(58)) THEN + NC=NC+1 + K(NC,3)=K(IC,3) + K(NC,4)=K(IC,4) + K(NC,5)=K(IC,5) + P(NC,1)=P(IC,1) + P(NC,2)=P(IC,2) + P(NC,5)=P(IC,5) + ENDIF + 140 CONTINUE + ENDIF + +C...Find initiator cell: the one with highest pT of not yet used ones. + NJ=NC + 150 ETMAX=0D0 + DO 160 IC=N+1,NC + IF(K(IC,5).NE.2) GOTO 160 + IF(P(IC,5).LE.ETMAX) GOTO 160 + ICMAX=IC + ETA=P(IC,1) + PHI=P(IC,2) + ETMAX=P(IC,5) + 160 CONTINUE + IF(ETMAX.LT.PARU(52)) GOTO 220 + IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS') + NJET=-2 + RETURN + ENDIF + K(ICMAX,5)=1 + NJ=NJ+1 + K(NJ,4)=0 + K(NJ,5)=1 + P(NJ,1)=ETA + P(NJ,2)=PHI + P(NJ,3)=0D0 + P(NJ,4)=0D0 + P(NJ,5)=0D0 + +C...Sum up unused cells within required distance of initiator. + DO 170 IC=N+1,NC + IF(K(IC,5).EQ.0) GOTO 170 + IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170 + DPHIA=ABS(P(IC,2)-PHI) + IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170 + PHIC=P(IC,2) + IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI) + IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170 + K(IC,5)=-K(IC,5) + K(NJ,4)=K(NJ,4)+K(IC,4) + P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1) + P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC + P(NJ,5)=P(NJ,5)+P(IC,5) + 170 CONTINUE + +C...Reject cluster below minimum ET, else accept. + IF(P(NJ,5).LT.PARU(53)) THEN + NJ=NJ-1 + DO 180 IC=N+1,NC + IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5) + 180 CONTINUE + ELSEIF(MSTU(54).LE.2) THEN + P(NJ,3)=P(NJ,3)/P(NJ,5) + P(NJ,4)=P(NJ,4)/P(NJ,5) + IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2), + & P(NJ,4)) + DO 190 IC=N+1,NC + IF(K(IC,5).LT.0) K(IC,5)=0 + 190 CONTINUE + ELSE + DO 200 J=1,4 + P(NJ,J)=0D0 + 200 CONTINUE + DO 210 IC=N+1,NC + IF(K(IC,5).GE.0) GOTO 210 + P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2)) + P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2)) + P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1)) + P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1)) + K(IC,5)=0 + 210 CONTINUE + ENDIF + GOTO 150 + +C...Arrange clusters in falling ET sequence. + 220 DO 250 I=1,NJ-NC + ETMAX=0D0 + DO 230 IJ=NC+1,NJ + IF(K(IJ,5).EQ.0) GOTO 230 + IF(P(IJ,5).LT.ETMAX) GOTO 230 + IJMAX=IJ + ETMAX=P(IJ,5) + 230 CONTINUE + K(IJMAX,5)=0 + K(N+I,1)=31 + K(N+I,2)=98 + K(N+I,3)=I + K(N+I,4)=K(IJMAX,4) + K(N+I,5)=0 + DO 240 J=1,5 + P(N+I,J)=P(IJMAX,J) + V(N+I,J)=0D0 + 240 CONTINUE + 250 CONTINUE + NJET=NJ-NC + +C...Convert to massless or massive four-vectors. + IF(MSTU(54).EQ.2) THEN + DO 260 I=N+1,N+NJET + ETA=P(I,3) + P(I,1)=P(I,5)*COS(P(I,4)) + P(I,2)=P(I,5)*SIN(P(I,4)) + P(I,3)=P(I,5)*SINH(ETA) + P(I,4)=P(I,5)*COSH(ETA) + P(I,5)=0D0 + 260 CONTINUE + ELSEIF(MSTU(54).GE.3) THEN + DO 270 I=N+1,N+NJET + P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2)) + 270 CONTINUE + ENDIF + +C...Information about storage. + MSTU(61)=N+1 + MSTU(62)=NP + MSTU(63)=NC-N + IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET) + IF(MSTU(43).GE.2) N=N+MAX(0,NJET) + + RETURN + END + +C********************************************************************* + +C...PYJMAS +C...Determines, approximately, the two jet masses that minimize +C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler. + + SUBROUTINE PYJMAS(PMH,PML) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ +C...Local arrays. + DIMENSION SM(3,3),SAX(3),PS(3,5) + +C...Reset. + NP=0 + DO 120 J1=1,3 + DO 100 J2=J1,3 + SM(J1,J2)=0D0 + 100 CONTINUE + DO 110 J2=1,4 + PS(J1,J2)=0D0 + 110 CONTINUE + 120 CONTINUE + PSS=0D0 + PIMASS=PMAS(PYCOMP(211),1) + +C...Take copy of particles that are to be considered in mass analysis. + DO 170 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 170 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) + & GOTO 170 + ENDIF + IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS') + PMH=-2D0 + PML=-2D0 + RETURN + ENDIF + NP=NP+1 + DO 130 J=1,5 + P(N+NP,J)=P(I,J) + 130 CONTINUE + IF(MSTU(42).EQ.0) P(N+NP,5)=0D0 + IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS + P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + +C...Fill information in sphericity tensor and total momentum vector. + DO 150 J1=1,3 + DO 140 J2=J1,3 + SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2) + 140 CONTINUE + 150 CONTINUE + PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2) + DO 160 J=1,4 + PS(3,J)=PS(3,J)+P(N+NP,J) + 160 CONTINUE + 170 CONTINUE + +C...Very low multiplicities (0 or 1) not considered. + IF(NP.LE.1) THEN + CALL PYERRM(8,'(PYJMAS:) too few particles for analysis') + PMH=-1D0 + PML=-1D0 + RETURN + ENDIF + PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2- + &PS(3,3)**2)) + +C...Find largest eigenvalue to matrix (third degree equation). + DO 190 J1=1,3 + DO 180 J2=J1,3 + SM(J1,J2)=SM(J1,J2)/PSS + 180 CONTINUE + 190 CONTINUE + SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)- + &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0 + SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+ + &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+ + &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0 + SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0) + SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP) + +C...Find largest eigenvector by solving equation system. + DO 210 J1=1,3 + SM(J1,J1)=SM(J1,J1)-SMA + DO 200 J2=J1+1,3 + SM(J2,J1)=SM(J1,J2) + 200 CONTINUE + 210 CONTINUE + SMAX=0D0 + DO 230 J1=1,3 + DO 220 J2=1,3 + IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220 + JA=J1 + JB=J2 + SMAX=ABS(SM(J1,J2)) + 220 CONTINUE + 230 CONTINUE + SMAX=0D0 + DO 250 J3=JA+1,JA+2 + J1=J3-3*((J3-1)/3) + RL=SM(J1,JB)/SM(JA,JB) + DO 240 J2=1,3 + SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2) + IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240 + JC=J1 + SMAX=ABS(SM(J1,J2)) + 240 CONTINUE + 250 CONTINUE + JB1=JB+1-3*(JB/3) + JB2=JB+2-3*((JB+1)/3) + SAX(JB1)=-SM(JC,JB2) + SAX(JB2)=SM(JC,JB1) + SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB) + +C...Divide particles into two initial clusters by hemisphere. + DO 270 I=N+1,N+NP + PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3) + IS=1 + IF(PSAX.LT.0D0) IS=2 + K(I,3)=IS + DO 260 J=1,4 + PS(IS,J)=PS(IS,J)+P(I,J) + 260 CONTINUE + 270 CONTINUE + PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+ + &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2) + +C...Reassign one particle at a time; find maximum decrease of m^2 sum. + 280 PMD=0D0 + IM=0 + DO 290 J=1,4 + PS(3,J)=PS(1,J)-PS(2,J) + 290 CONTINUE + DO 300 I=N+1,N+NP + PPS=P(I,4)*PS(3,4)-P(I,1)*PS(3,1)-P(I,2)*PS(3,2)-P(I,3)*PS(3,3) + IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS) + IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS) + IF(PMDI.LT.PMD) THEN + PMD=PMDI + IM=I + ENDIF + 300 CONTINUE + +C...Loop back if significant reduction in sum of m^2. + IF(PMD.LT.-PARU(48)*PMS) THEN + PMS=PMS+PMD + IS=K(IM,3) + DO 310 J=1,4 + PS(IS,J)=PS(IS,J)-P(IM,J) + PS(3-IS,J)=PS(3-IS,J)+P(IM,J) + 310 CONTINUE + K(IM,3)=3-IS + GOTO 280 + ENDIF + +C...Final masses and output. + MSTU(61)=N+1 + MSTU(62)=NP + PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)) + PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)) + PMH=MAX(PS(1,5),PS(2,5)) + PML=MIN(PS(1,5),PS(2,5)) + + RETURN + END + +C********************************************************************* + +C...PYFOWO +C...Calculates the first few Fox-Wolfram moments. + + SUBROUTINE PYFOWO(H10,H20,H30,H40) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Copy momenta for particles and calculate H0. + NP=0 + H0=0D0 + HD=0D0 + DO 110 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 110 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) + & GOTO 110 + ENDIF + IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN + CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS') + H10=-1D0 + H20=-1D0 + H30=-1D0 + H40=-1D0 + RETURN + ENDIF + NP=NP+1 + DO 100 J=1,3 + P(N+NP,J)=P(I,J) + 100 CONTINUE + P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2) + H0=H0+P(N+NP,4) + HD=HD+P(N+NP,4)**2 + 110 CONTINUE + H0=H0**2 + +C...Very low multiplicities (0 or 1) not considered. + IF(NP.LE.1) THEN + CALL PYERRM(8,'(PYFOWO:) too few particles for analysis') + H10=-1D0 + H20=-1D0 + H30=-1D0 + H40=-1D0 + RETURN + ENDIF + +C...Calculate H1 - H4. + H10=0D0 + H20=0D0 + H30=0D0 + H40=0D0 + DO 130 I1=N+1,N+NP + DO 120 I2=I1+1,N+NP + CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/ + & (P(I1,4)*P(I2,4)) + H10=H10+P(I1,4)*P(I2,4)*CTHE + H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0) + H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE) + H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+ + & 0.375D0) + 120 CONTINUE + 130 CONTINUE + +C...Calculate H1/H0 - H4/H0. Output. + MSTU(61)=N+1 + MSTU(62)=NP + H10=(HD+2D0*H10)/H0 + H20=(HD+2D0*H20)/H0 + H30=(HD+2D0*H30)/H0 + H40=(HD+2D0*H40)/H0 + + RETURN + END + +C********************************************************************* + +C...PYTABU +C...Evaluates various properties of an event, with statistics +C...accumulated during the course of the run and +C...printed at the end. + + SUBROUTINE PYTABU(MTABU) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Parameter statement to help give large particle numbers. + PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000, + &KEXCIT=4000000,KDIMEN=5000000) +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/ +C...Local arrays, character variables, saved variables and data. + DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4), + &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4), + &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25), + &KFDM(8),KFDC(200,0:8),NPDC(200) + SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS, + &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA, + &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC + CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12 + DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/, + &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/, + &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/, + &NEVDC/0/,NKFDC/0/,NREDC/0/ + +C...Reset statistics on initial parton state. + IF(MTABU.EQ.10) THEN + NEVIS=0 + NKFIS=0 + +C...Identify and order flavour content of initial state. + ELSEIF(MTABU.EQ.11) THEN + NEVIS=NEVIS+1 + KFM1=2*IABS(MSTU(161)) + IF(MSTU(161).GT.0) KFM1=KFM1-1 + KFM2=2*IABS(MSTU(162)) + IF(MSTU(162).GT.0) KFM2=KFM2-1 + KFMN=MIN(KFM1,KFM2) + KFMX=MAX(KFM1,KFM2) + DO 100 I=1,NKFIS + IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN + IKFIS=-I + GOTO 110 + ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND. + & KFMX.LT.KFIS(I,2))) THEN + IKFIS=I + GOTO 110 + ENDIF + 100 CONTINUE + IKFIS=NKFIS+1 + 110 IF(IKFIS.LT.0) THEN + IKFIS=-IKFIS + ELSE + IF(NKFIS.GE.100) RETURN + DO 130 I=NKFIS,IKFIS,-1 + KFIS(I+1,1)=KFIS(I,1) + KFIS(I+1,2)=KFIS(I,2) + DO 120 J=0,10 + NPIS(I+1,J)=NPIS(I,J) + 120 CONTINUE + 130 CONTINUE + NKFIS=NKFIS+1 + KFIS(IKFIS,1)=KFMN + KFIS(IKFIS,2)=KFMX + DO 140 J=0,10 + NPIS(IKFIS,J)=0 + 140 CONTINUE + ENDIF + NPIS(IKFIS,0)=NPIS(IKFIS,0)+1 + +C...Count number of partons in initial state. + NP=0 + DO 160 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN + ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN + ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0) + & THEN + ELSE + IM=I + 150 IM=K(IM,3) + IF(IM.LE.0.OR.IM.GT.N) THEN + NP=NP+1 + ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN + NP=NP+1 + ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN + ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10) + & .NE.0) THEN + ELSE + GOTO 150 + ENDIF + ENDIF + 160 CONTINUE + NPCO=MAX(NP,1) + IF(NP.GE.6) NPCO=6 + IF(NP.GE.8) NPCO=7 + IF(NP.GE.11) NPCO=8 + IF(NP.GE.16) NPCO=9 + IF(NP.GE.26) NPCO=10 + NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1 + MSTU(62)=NP + +C...Write statistics on initial parton state. + ELSEIF(MTABU.EQ.12) THEN + FAC=1D0/MAX(1,NEVIS) + WRITE(MSTU(11),5000) NEVIS + DO 170 I=1,NKFIS + KFMN=KFIS(I,1) + IF(KFMN.EQ.0) KFMN=KFIS(I,2) + KFM1=(KFMN+1)/2 + IF(2*KFM1.EQ.KFMN) KFM1=-KFM1 + CALL PYNAME(KFM1,CHAU) + CHIS(1)=CHAU(1:12) + IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?' + KFMX=KFIS(I,2) + IF(KFIS(I,1).EQ.0) KFMX=0 + KFM2=(KFMX+1)/2 + IF(2*KFM2.EQ.KFMX) KFM2=-KFM2 + CALL PYNAME(KFM2,CHAU) + CHIS(2)=CHAU(1:12) + IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?' + WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0), + & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10) + 170 CONTINUE + +C...Copy statistics on initial parton state into /PYJETS/. + ELSEIF(MTABU.EQ.13) THEN + FAC=1D0/MAX(1,NEVIS) + DO 190 I=1,NKFIS + KFMN=KFIS(I,1) + IF(KFMN.EQ.0) KFMN=KFIS(I,2) + KFM1=(KFMN+1)/2 + IF(2*KFM1.EQ.KFMN) KFM1=-KFM1 + KFMX=KFIS(I,2) + IF(KFIS(I,1).EQ.0) KFMX=0 + KFM2=(KFMX+1)/2 + IF(2*KFM2.EQ.KFMX) KFM2=-KFM2 + K(I,1)=32 + K(I,2)=99 + K(I,3)=KFM1 + K(I,4)=KFM2 + K(I,5)=NPIS(I,0) + DO 180 J=1,5 + P(I,J)=FAC*NPIS(I,J) + V(I,J)=FAC*NPIS(I,J+5) + 180 CONTINUE + 190 CONTINUE + N=NKFIS + DO 200 J=1,5 + K(N+1,J)=0 + P(N+1,J)=0D0 + V(N+1,J)=0D0 + 200 CONTINUE + K(N+1,1)=32 + K(N+1,2)=99 + K(N+1,5)=NEVIS + MSTU(3)=1 + +C...Reset statistics on number of particles/partons. + ELSEIF(MTABU.EQ.20) THEN + NEVFS=0 + NPRFS=0 + NFIFS=0 + NCHFS=0 + NKFFS=0 + +C...Identify whether particle/parton is primary or not. + ELSEIF(MTABU.EQ.21) THEN + NEVFS=NEVFS+1 + MSTU(62)=0 + DO 260 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260 + MSTU(62)=MSTU(62)+1 + KC=PYCOMP(K(I,2)) + MPRI=0 + IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN + MPRI=1 + ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN + MPRI=1 + ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN + MPRI=1 + ELSEIF(KC.EQ.0) THEN + ELSEIF(K(K(I,3),1).EQ.13) THEN + IM=K(K(I,3),3) + IF(IM.LE.0.OR.IM.GT.N) THEN + MPRI=1 + ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN + MPRI=1 + ENDIF + ELSEIF(KCHG(KC,2).EQ.0) THEN + KCM=PYCOMP(K(K(I,3),2)) + IF(KCM.NE.0) THEN + IF(KCHG(KCM,2).NE.0) MPRI=1 + ENDIF + ENDIF + IF(KC.NE.0.AND.MPRI.EQ.1) THEN + IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1 + ENDIF + IF(K(I,1).LE.10) THEN + NFIFS=NFIFS+1 + IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1 + ENDIF + +C...Fill statistics on number of particles/partons in event. + KFA=IABS(K(I,2)) + KFS=3-ISIGN(1,K(I,2))-MPRI + DO 210 IP=1,NKFFS + IF(KFA.EQ.KFFS(IP)) THEN + IKFFS=-IP + GOTO 220 + ELSEIF(KFA.LT.KFFS(IP)) THEN + IKFFS=IP + GOTO 220 + ENDIF + 210 CONTINUE + IKFFS=NKFFS+1 + 220 IF(IKFFS.LT.0) THEN + IKFFS=-IKFFS + ELSE + IF(NKFFS.GE.400) RETURN + DO 240 IP=NKFFS,IKFFS,-1 + KFFS(IP+1)=KFFS(IP) + DO 230 J=1,4 + NPFS(IP+1,J)=NPFS(IP,J) + 230 CONTINUE + 240 CONTINUE + NKFFS=NKFFS+1 + KFFS(IKFFS)=KFA + DO 250 J=1,4 + NPFS(IKFFS,J)=0 + 250 CONTINUE + ENDIF + NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1 + 260 CONTINUE + +C...Write statistics on particle/parton composition of events. + ELSEIF(MTABU.EQ.22) THEN + FAC=1D0/MAX(1,NEVFS) + WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS + DO 270 I=1,NKFFS + CALL PYNAME(KFFS(I),CHAU) + KC=PYCOMP(KFFS(I)) + MDCYF=0 + IF(KC.NE.0) MDCYF=MDCY(KC,1) + WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4), + & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)) + 270 CONTINUE + +C...Copy particle/parton composition information into /PYJETS/. + ELSEIF(MTABU.EQ.23) THEN + FAC=1D0/MAX(1,NEVFS) + DO 290 I=1,NKFFS + K(I,1)=32 + K(I,2)=99 + K(I,3)=KFFS(I) + K(I,4)=0 + K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4) + DO 280 J=1,4 + P(I,J)=FAC*NPFS(I,J) + V(I,J)=0D0 + 280 CONTINUE + P(I,5)=FAC*K(I,5) + V(I,5)=0D0 + 290 CONTINUE + N=NKFFS + DO 300 J=1,5 + K(N+1,J)=0 + P(N+1,J)=0D0 + V(N+1,J)=0D0 + 300 CONTINUE + K(N+1,1)=32 + K(N+1,2)=99 + K(N+1,5)=NEVFS + P(N+1,1)=FAC*NPRFS + P(N+1,2)=FAC*NFIFS + P(N+1,3)=FAC*NCHFS + MSTU(3)=1 + +C...Reset factorial moments statistics. + ELSEIF(MTABU.EQ.30) THEN + NEVFM=0 + NMUFM=0 + DO 330 IM=1,3 + DO 320 IB=1,10 + DO 310 IP=1,4 + FM1FM(IM,IB,IP)=0D0 + FM2FM(IM,IB,IP)=0D0 + 310 CONTINUE + 320 CONTINUE + 330 CONTINUE + +C...Find particles to include, with (pion,pseudo)rapidity and azimuth. + ELSEIF(MTABU.EQ.31) THEN + NEVFM=NEVFM+1 + NLOW=N+MSTU(3) + NUPP=NLOW + DO 410 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 410 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND. + & PYCHGE(K(I,2)).EQ.0) GOTO 410 + ENDIF + PMR=0D0 + IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211) + IF(MSTU(42).GE.2) PMR=P(I,5) + PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2) + YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR), + & 1D20)),P(I,3)) + IF(ABS(YETA).GT.PARU(57)) GOTO 410 + PHI=PYANGL(P(I,1),P(I,2)) + IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57)) + IYETA=MAX(0,MIN(511,IYETA)) + IPHI=512D0*(PHI+PARU(1))/PARU(2) + IPHI=MAX(0,MIN(511,IPHI)) + IYEP=0 + DO 340 IB=0,9 + IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2)) + 340 CONTINUE + +C...Order particles in (pseudo)rapidity and/or azimuth. + IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN + CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS') + RETURN + ENDIF + NUPP=NUPP+1 + IF(NUPP.EQ.NLOW+1) THEN + K(NUPP,1)=IYETA + K(NUPP,2)=IPHI + K(NUPP,3)=IYEP + ELSE + DO 350 I1=NUPP-1,NLOW+1,-1 + IF(IYETA.GE.K(I1,1)) GOTO 360 + K(I1+1,1)=K(I1,1) + 350 CONTINUE + 360 K(I1+1,1)=IYETA + DO 370 I1=NUPP-1,NLOW+1,-1 + IF(IPHI.GE.K(I1,2)) GOTO 380 + K(I1+1,2)=K(I1,2) + 370 CONTINUE + 380 K(I1+1,2)=IPHI + DO 390 I1=NUPP-1,NLOW+1,-1 + IF(IYEP.GE.K(I1,3)) GOTO 400 + K(I1+1,3)=K(I1,3) + 390 CONTINUE + 400 K(I1+1,3)=IYEP + ENDIF + 410 CONTINUE + K(NUPP+1,1)=2**10 + K(NUPP+1,2)=2**10 + K(NUPP+1,3)=4**10 + +C...Calculate sum of factorial moments in event. + DO 480 IM=1,3 + DO 430 IB=1,10 + DO 420 IP=1,4 + FEVFM(IB,IP)=0D0 + 420 CONTINUE + 430 CONTINUE + DO 450 IB=1,10 + IF(IM.LE.2) IBIN=2**(10-IB) + IF(IM.EQ.3) IBIN=4**(10-IB) + IAGR=K(NLOW+1,IM)/IBIN + NAGR=1 + DO 440 I=NLOW+2,NUPP+1 + ICUT=K(I,IM)/IBIN + IF(ICUT.EQ.IAGR) THEN + NAGR=NAGR+1 + ELSE + IF(NAGR.EQ.1) THEN + ELSEIF(NAGR.EQ.2) THEN + FEVFM(IB,1)=FEVFM(IB,1)+2D0 + ELSEIF(NAGR.EQ.3) THEN + FEVFM(IB,1)=FEVFM(IB,1)+6D0 + FEVFM(IB,2)=FEVFM(IB,2)+6D0 + ELSEIF(NAGR.EQ.4) THEN + FEVFM(IB,1)=FEVFM(IB,1)+12D0 + FEVFM(IB,2)=FEVFM(IB,2)+24D0 + FEVFM(IB,3)=FEVFM(IB,3)+24D0 + ELSE + FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0) + FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0) + FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)* + & (NAGR-3D0) + FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)* + & (NAGR-3D0)*(NAGR-4D0) + ENDIF + IAGR=ICUT + NAGR=1 + ENDIF + 440 CONTINUE + 450 CONTINUE + +C...Add results to total statistics. + DO 470 IB=10,1,-1 + DO 460 IP=1,4 + IF(FEVFM(1,IP).LT.0.5D0) THEN + FEVFM(IB,IP)=0D0 + ELSEIF(IM.LE.2) THEN + FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP) + ELSE + FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP) + ENDIF + FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP) + FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2 + 460 CONTINUE + 470 CONTINUE + 480 CONTINUE + NMUFM=NMUFM+(NUPP-NLOW) + MSTU(62)=NUPP-NLOW + +C...Write accumulated statistics on factorial moments. + ELSEIF(MTABU.EQ.32) THEN + FAC=1D0/MAX(1,NEVFM) + IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta' + IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi' + IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y ' + DO 510 IM=1,3 + WRITE(MSTU(11),5500) + DO 500 IB=1,10 + BYETA=2D0*PARU(57) + IF(IM.NE.2) BYETA=BYETA/2**(IB-1) + BPHI=PARU(2) + IF(IM.NE.1) BPHI=BPHI/2**(IB-1) + IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1)) + IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1)) + DO 490 IP=1,4 + FMOMA(IP)=FAC*FM1FM(IM,IB,IP) + FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)- + & FMOMA(IP)**2))) + 490 CONTINUE + WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP), + & IP=1,4) + 500 CONTINUE + 510 CONTINUE + +C...Copy statistics on factorial moments into /PYJETS/. + ELSEIF(MTABU.EQ.33) THEN + FAC=1D0/MAX(1,NEVFM) + DO 540 IM=1,3 + DO 530 IB=1,10 + I=10*(IM-1)+IB + K(I,1)=32 + K(I,2)=99 + K(I,3)=1 + IF(IM.NE.2) K(I,3)=2**(IB-1) + K(I,4)=1 + IF(IM.NE.1) K(I,4)=2**(IB-1) + K(I,5)=0 + P(I,1)=2D0*PARU(57)/K(I,3) + V(I,1)=PARU(2)/K(I,4) + DO 520 IP=1,4 + P(I,IP+1)=FAC*FM1FM(IM,IB,IP) + V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)- + & P(I,IP+1)**2))) + 520 CONTINUE + 530 CONTINUE + 540 CONTINUE + N=30 + DO 550 J=1,5 + K(N+1,J)=0 + P(N+1,J)=0D0 + V(N+1,J)=0D0 + 550 CONTINUE + K(N+1,1)=32 + K(N+1,2)=99 + K(N+1,5)=NEVFM + MSTU(3)=1 + +C...Reset statistics on Energy-Energy Correlation. + ELSEIF(MTABU.EQ.40) THEN + NEVEE=0 + DO 560 J=1,25 + FE1EC(J)=0D0 + FE2EC(J)=0D0 + FE1EC(51-J)=0D0 + FE2EC(51-J)=0D0 + FE1EA(J)=0D0 + FE2EA(J)=0D0 + 560 CONTINUE + +C...Find particles to include, with proper assumed mass. + ELSEIF(MTABU.EQ.41) THEN + NEVEE=NEVEE+1 + NLOW=N+MSTU(3) + NUPP=NLOW + ECM=0D0 + DO 570 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570 + IF(MSTU(41).GE.2) THEN + KC=PYCOMP(K(I,2)) + IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR. + & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR. + & K(I,2).EQ.KSUSY1+39) GOTO 570 + IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND. + & PYCHGE(K(I,2)).EQ.0) GOTO 570 + ENDIF + PMR=0D0 + IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211) + IF(MSTU(42).GE.2) PMR=P(I,5) + IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN + CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS') + RETURN + ENDIF + NUPP=NUPP+1 + P(NUPP,1)=P(I,1) + P(NUPP,2)=P(I,2) + P(NUPP,3)=P(I,3) + P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2) + P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)) + ECM=ECM+P(NUPP,4) + 570 CONTINUE + IF(NUPP.EQ.NLOW) RETURN + +C...Analyze Energy-Energy Correlation in event. + FAC=(2D0/ECM**2)*50D0/PARU(1) + DO 580 J=1,50 + FEVEE(J)=0D0 + 580 CONTINUE + DO 600 I1=NLOW+2,NUPP + DO 590 I2=NLOW+1,I1-1 + CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/ + & (P(I1,5)*P(I2,5)) + THE=ACOS(MAX(-1D0,MIN(1D0,CTHE))) + ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1)))) + FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4) + 590 CONTINUE + 600 CONTINUE + DO 610 J=1,25 + FE1EC(J)=FE1EC(J)+FEVEE(J) + FE2EC(J)=FE2EC(J)+FEVEE(J)**2 + FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J) + FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2 + FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J)) + FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2 + 610 CONTINUE + MSTU(62)=NUPP-NLOW + +C...Write statistics on Energy-Energy Correlation. + ELSEIF(MTABU.EQ.42) THEN + FAC=1D0/MAX(1,NEVEE) + WRITE(MSTU(11),5700) NEVEE + DO 620 J=1,25 + FEEC1=FAC*FE1EC(J) + FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2))) + FEEC2=FAC*FE1EC(51-J) + FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2))) + FEECA=FAC*FE1EA(J) + FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2))) + WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1, + & FEEC2,FEES2,FEECA,FEESA + 620 CONTINUE + +C...Copy statistics on Energy-Energy Correlation into /PYJETS/. + ELSEIF(MTABU.EQ.43) THEN + FAC=1D0/MAX(1,NEVEE) + DO 630 I=1,25 + K(I,1)=32 + K(I,2)=99 + K(I,3)=0 + K(I,4)=0 + K(I,5)=0 + P(I,1)=FAC*FE1EC(I) + V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2))) + P(I,2)=FAC*FE1EC(51-I) + V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2))) + P(I,3)=FAC*FE1EA(I) + V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2))) + P(I,4)=PARU(1)*(I-1)/50D0 + P(I,5)=PARU(1)*I/50D0 + V(I,4)=3.6D0*(I-1) + V(I,5)=3.6D0*I + 630 CONTINUE + N=25 + DO 640 J=1,5 + K(N+1,J)=0 + P(N+1,J)=0D0 + V(N+1,J)=0D0 + 640 CONTINUE + K(N+1,1)=32 + K(N+1,2)=99 + K(N+1,5)=NEVEE + MSTU(3)=1 + +C...Reset statistics on decay channels. + ELSEIF(MTABU.EQ.50) THEN + NEVDC=0 + NKFDC=0 + NREDC=0 + +C...Identify and order flavour content of final state. + ELSEIF(MTABU.EQ.51) THEN + NEVDC=NEVDC+1 + NDS=0 + DO 670 I=1,N + IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670 + NDS=NDS+1 + IF(NDS.GT.8) THEN + NREDC=NREDC+1 + RETURN + ENDIF + KFM=2*IABS(K(I,2)) + IF(K(I,2).LT.0) KFM=KFM-1 + DO 650 IDS=NDS-1,1,-1 + IIN=IDS+1 + IF(KFM.LT.KFDM(IDS)) GOTO 660 + KFDM(IDS+1)=KFDM(IDS) + 650 CONTINUE + IIN=1 + 660 KFDM(IIN)=KFM + 670 CONTINUE + +C...Find whether old or new final state. + DO 690 IDC=1,NKFDC + IF(NDS.LT.KFDC(IDC,0)) THEN + IKFDC=IDC + GOTO 700 + ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN + DO 680 I=1,NDS + IF(KFDM(I).LT.KFDC(IDC,I)) THEN + IKFDC=IDC + GOTO 700 + ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN + GOTO 690 + ENDIF + 680 CONTINUE + IKFDC=-IDC + GOTO 700 + ENDIF + 690 CONTINUE + IKFDC=NKFDC+1 + 700 IF(IKFDC.LT.0) THEN + IKFDC=-IKFDC + ELSEIF(NKFDC.GE.200) THEN + NREDC=NREDC+1 + RETURN + ELSE + DO 720 IDC=NKFDC,IKFDC,-1 + NPDC(IDC+1)=NPDC(IDC) + DO 710 I=0,8 + KFDC(IDC+1,I)=KFDC(IDC,I) + 710 CONTINUE + 720 CONTINUE + NKFDC=NKFDC+1 + KFDC(IKFDC,0)=NDS + DO 730 I=1,NDS + KFDC(IKFDC,I)=KFDM(I) + 730 CONTINUE + NPDC(IKFDC)=0 + ENDIF + NPDC(IKFDC)=NPDC(IKFDC)+1 + +C...Write statistics on decay channels. + ELSEIF(MTABU.EQ.52) THEN + FAC=1D0/MAX(1,NEVDC) + WRITE(MSTU(11),5900) NEVDC + DO 750 IDC=1,NKFDC + DO 740 I=1,KFDC(IDC,0) + KFM=KFDC(IDC,I) + KF=(KFM+1)/2 + IF(2*KF.NE.KFM) KF=-KF + CALL PYNAME(KF,CHAU) + CHDC(I)=CHAU(1:12) + IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?' + 740 CONTINUE + WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0)) + 750 CONTINUE + IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC + +C...Copy statistics on decay channels into /PYJETS/. + ELSEIF(MTABU.EQ.53) THEN + FAC=1D0/MAX(1,NEVDC) + DO 780 IDC=1,NKFDC + K(IDC,1)=32 + K(IDC,2)=99 + K(IDC,3)=0 + K(IDC,4)=0 + K(IDC,5)=KFDC(IDC,0) + DO 760 J=1,5 + P(IDC,J)=0D0 + V(IDC,J)=0D0 + 760 CONTINUE + DO 770 I=1,KFDC(IDC,0) + KFM=KFDC(IDC,I) + KF=(KFM+1)/2 + IF(2*KF.NE.KFM) KF=-KF + IF(I.LE.5) P(IDC,I)=KF + IF(I.GE.6) V(IDC,I-5)=KF + 770 CONTINUE + V(IDC,5)=FAC*NPDC(IDC) + 780 CONTINUE + N=NKFDC + DO 790 J=1,5 + K(N+1,J)=0 + P(N+1,J)=0D0 + V(N+1,J)=0D0 + 790 CONTINUE + K(N+1,1)=32 + K(N+1,2)=99 + K(N+1,5)=NEVDC + V(N+1,5)=FAC*NREDC + MSTU(3)=1 + ENDIF + +C...Format statements for output on unit MSTU(11) (default 6). + 5000 FORMAT(///20X,'Event statistics - initial state'/ + &20X,'based on an analysis of ',I6,' events'// + &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ', + &'according to fragmenting system multiplicity'/ + &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5', + &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/) + 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4) + 5200 FORMAT(///20X,'Event statistics - final state'/ + &20X,'based on an analysis of ',I7,' events'// + &5X,'Mean primary multiplicity =',F10.4/ + &5X,'Mean final multiplicity =',F10.4/ + &5X,'Mean charged multiplicity =',F10.4// + &5X,'Number of particles produced per event (directly and via ', + &'decays/branchings)'/ + &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles', + &8X,'Total'/35X,'prim seco prim seco'/) + 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6)) + 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/ + &20X,'based on an analysis of ',I6,' events'// + &3X,'delta-',A3,' delta-phi /bin',10X,'',18X,'', + &18X,'',18X,''/35X,4(' value error ')) + 5500 FORMAT(10X) + 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4)) + 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/ + &20X,'based on an analysis of ',I6,' events'// + &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X, + &'EECA(theta)'/2X,'in degrees ',3(' value error')/) + 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4)) + 5900 FORMAT(///20X,'Decay channel analysis - final state'/ + &20X,'based on an analysis of ',I6,' events'// + &2X,'Probability',10X,'Complete final state'/) + 6000 FORMAT(2X,F9.5,5X,8(A12,1X)) + 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ', + &'or table overflow)') + + RETURN + END + +C********************************************************************* + +C...PYEEVT +C...Handles the generation of an e+e- annihilation jet event. + + SUBROUTINE PYEEVT(KFL,ECM) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Check input parameters. + IF(MSTU(12).NE.12345) CALL PYLIST(0) + IF(KFL.LT.0.OR.KFL.GT.8) THEN + CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code') + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL)) + IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1) + IF(ECM.LT.ECMMIN) THEN + CALL PYERRM(16,'(PYEEVT:) called with too small CM energy') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Check consistency of MSTJ options set. + IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN + CALL PYERRM(6, + & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1') + MSTJ(110)=1 + ENDIF + IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN + CALL PYERRM(6, + & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0') + MSTJ(111)=0 + ENDIF + +C...Initialize alpha_strong and total cross-section. + MSTU(111)=MSTJ(108) + IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1)) + &MSTU(111)=1 + PARU(112)=PARJ(121) + IF(MSTU(111).EQ.2) PARU(112)=PARJ(122) + IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE. + &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM, + &XTOT) + IF(MSTJ(116).GE.3) MSTJ(116)=1 + PARJ(171)=0D0 + +C...Add initial e+e- to event record (documentation only). + NTRY=0 + 100 NTRY=NTRY+1 + IF(NTRY.GT.100) THEN + CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop') + RETURN + ENDIF + MSTU(24)=0 + NC=0 + IF(MSTJ(115).GE.2) THEN + NC=NC+2 + CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0) + K(NC-1,1)=21 + CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0) + K(NC,1)=21 + ENDIF + +C...Radiative photon (in initial state). + MK=0 + ECMC=ECM + IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK, + &THEK,PHIK,ALPK) + IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK)) + IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN + NC=NC+1 + CALL PY1ENT(NC,22,PAK,THEK,PHIK) + K(NC,3)=MIN(MSTJ(115)/2,1) + ENDIF + +C...Virtual exchange boson (gamma or Z0). + IF(MSTJ(115).GE.3) THEN + NC=NC+1 + KF=22 + IF(MSTJ(102).EQ.2) KF=23 + MSTU10=MSTU(10) + MSTU(10)=1 + P(NC,5)=ECMC + CALL PY1ENT(NC,KF,ECMC,0D0,0D0) + K(NC,1)=21 + K(NC,3)=1 + MSTU(10)=MSTU10 + ENDIF + +C...Choice of flavour and jet configuration. + CALL PYXKFL(KFL,ECM,ECMC,KFLC) + IF(KFLC.EQ.0) GOTO 100 + CALL PYXJET(ECMC,NJET,CUT) + KFLN=21 + IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4, + &X12,X14) + IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3) + IF(NJET.EQ.2) MSTJ(120)=1 + +C...Fill jet configuration and origin. + IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC) + IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC, + &ECMC) + IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3) + IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN, + &-KFLC,ECMC,X1,X2,X4,X12,X14) + IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN, + &-KFLC,ECMC,X1,X2,X4,X12,X14) + IF(MSTU(24).NE.0) GOTO 100 + DO 110 IP=NC+1,N + K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1) + 110 CONTINUE + +C...Angular orientation according to matrix element. + IF(MSTJ(106).EQ.1) THEN + CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI) + CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0) + CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0) + ENDIF + +C...Rotation and boost from radiative photon. + IF(MK.EQ.1) THEN + DBEK=-PAK/(ECM-PAK) + NMIN=NC+1-MSTJ(115)/3 + CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0) + CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK)) + CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0) + ENDIF + +C...Generate parton shower. Rearrange along strings and check. + IF(MSTJ(101).EQ.5) THEN + CALL PYSHOW(N-1,N,ECMC) + MSTJ14=MSTJ(14) + IF(MSTJ(105).EQ.-1) MSTJ(14)=-1 + IF(MSTJ(105).GE.0) MSTU(28)=0 + CALL PYPREP(0) + MSTJ(14)=MSTJ14 + IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100 + ENDIF + +C...Fragmentation/decay generation. Information for PYTABU. + IF(MSTJ(105).EQ.1) CALL PYEXEC + MSTU(161)=KFLC + MSTU(162)=-KFLC + + RETURN + END + +C********************************************************************* + +C...PYXTEE +C...Calculates total cross-section, including initial state +C...radiation effects. + + SUBROUTINE PYXTEE(KFL,ECM,XTOT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ + +C...Status, (optimized) Q^2 scale, alpha_strong. + PARJ(151)=ECM + MSTJ(119)=10*MSTJ(102)+KFL + IF(MSTJ(111).EQ.0) THEN + Q2R=ECM**2 + ELSEIF(MSTU(111).EQ.0) THEN + PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/ + & ((33D0-2D0*MSTU(112))*PARU(111))))) + Q2R=PARJ(168)*ECM**2 + ELSE + PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM, + & (2D0*PARU(112)/ECM)**2)) + Q2R=PARJ(168)*ECM**2 + ENDIF + ALSPI=PYALPS(Q2R)/PARU(1) + +C...QCD corrections factor in R. + IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN + RQCD=1D0 + ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN + RQCD=1D0+ALSPI + ELSEIF(MSTJ(109).EQ.0) THEN + RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2 + IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0* + & LOG(PARJ(168))*ALSPI**2) + ELSEIF(IABS(MSTJ(101)).EQ.1) THEN + RQCD=1D0+(3D0/4D0)*ALSPI + ELSE + RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2 + ENDIF + +C...Calculate Z0 width if default value not acceptable. + IF(MSTJ(102).GE.3) THEN + RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+ + & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2) + DO 100 KFLC=5,6 + VQ=1D0 + IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0- + & (2D0*PYMASS(KFLC)/ ECM)**2)) + IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0 + IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0 + RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3) + 100 CONTINUE + PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)* + & (1D0-PARU(102))) + ENDIF + +C...Calculate propagator and related constants for QFD case. + POLL=1D0-PARJ(131)*PARJ(132) + IF(MSTJ(102).GE.2) THEN + SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102))) + SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2) + SFI=SFW*(1D0-(PARJ(123)/ECM)**2) + VE=4D0*PARU(102)-1D0 + SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131)) + SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131))) + HF1I=SFI*SF1I + HF1W=SFW*SF1W + ENDIF + +C...Loop over different flavours: charge, velocity. + RTOT=0D0 + RQQ=0D0 + RQV=0D0 + RVA=0D0 + DO 110 KFLC=1,MAX(MSTJ(104),KFL) + IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110 + MSTJ(93)=1 + PMQ=PYMASS(KFLC) + IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110 + QF=KCHG(KFLC,1)/3D0 + VQ=1D0 + IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2) + +C...Calculate R and sum of charges for QED or QFD case. + RQQ=RQQ+3D0*QF**2*POLL + IF(MSTJ(102).LE.1) THEN + RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL + ELSE + VF=SIGN(1D0,QF)-4D0*QF*PARU(102) + RQV=RQV-6D0*QF*VF*SF1I + RVA=RVA+3D0*(VF**2+1D0)*SF1W + RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL- + & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W) + ENDIF + 110 CONTINUE + RSUM=RQQ + IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA + +C...Calculate cross-section, including QCD corrections. + PARJ(141)=RQQ + PARJ(142)=RTOT + PARJ(143)=RTOT*RQCD + PARJ(144)=PARJ(143) + PARJ(145)=PARJ(141)*86.8D0/ECM**2 + PARJ(146)=PARJ(142)*86.8D0/ECM**2 + PARJ(147)=PARJ(143)*86.8D0/ECM**2 + PARJ(148)=PARJ(147) + PARJ(157)=RSUM*RQCD + PARJ(158)=0D0 + PARJ(159)=0D0 + XTOT=PARJ(147) + IF(MSTJ(107).LE.0) RETURN + +C...Virtual cross-section. + XKL=PARJ(135) + XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2) + ALE=2D0*LOG(ECM/PYMASS(11))-1D0 + SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+ + &1.526D0*LOG(ECM**2/0.932D0) + +C...Soft and hard radiative cross-section in QED case. + IF(MSTJ(102).LE.1) THEN + SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV + SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL) + SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL)) + +C...Soft and hard radiative cross-section in QFD case. + ELSE + SZM=1D0-(PARJ(123)/ECM)**2 + SZW=PARJ(123)*PARJ(124)/ECM**2 + PARJ(161)=-RQQ/RSUM + PARJ(162)=-(RQQ+RQV+RVA)/RSUM + PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM + PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2- + & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM) + SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/ + & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0 + SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+ + & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+ + & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW))) + SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/ + & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)* + & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+ + & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW))) + ENDIF + +C...Total cross-section and fraction of hard photon events. + PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH) + PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD + PARJ(144)=PARJ(157) + PARJ(148)=PARJ(144)*86.8D0/ECM**2 + XTOT=PARJ(148) + + RETURN + END + +C********************************************************************* + +C...PYRADK +C...Generates initial state photon radiation. + + SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + +C...Function: cumulative hard photon spectrum in QFD case. + FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+ + &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW) + +C...Determine whether radiative photon or not. + MK=0 + PAK=0D0 + IF(PARJ(160).LT.PYR(0)) RETURN + MK=1 + +C...Photon energy range. Find photon momentum in QED case. + XKL=PARJ(135) + XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2) + IF(MSTJ(102).LE.1) THEN + 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0)) + IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100 + +C...Ditto in QFD case, by numerical inversion of integrated spectrum. + ELSE + SZM=1D0-(PARJ(123)/ECM)**2 + SZW=PARJ(123)*PARJ(124)/ECM**2 + FXKL=FXK(XKL) + FXKU=FXK(XKU) + FXKD=1D-4*(FXKU-FXKL) + FXKR=FXKL+PYR(0)*(FXKU-FXKL) + NXK=0 + 110 NXK=NXK+1 + XK=0.5D0*(XKL+XKU) + FXKV=FXK(XK) + IF(FXKV.GT.FXKR) THEN + XKU=XK + FXKU=FXKV + ELSE + XKL=XK + FXKL=FXKV + ENDIF + IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110 + XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL) + ENDIF + PAK=0.5D0*ECM*XK + +C...Photon polar and azimuthal angle. + PME=2D0*(PYMASS(11)/ECM)**2 + 120 CTHM=PME*(2D0/PME)**PYR(0) + IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME, + &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120 + CTHE=1D0-CTHM + IF(PYR(0).GT.0.5D0) CTHE=-CTHE + STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM))) + THEK=PYANGL(CTHE,STHE) + PHIK=PARU(2)*PYR(0) + +C...Rotation angle for hadronic system. + SGN=1D0 + IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT. + &PYR(0)) SGN=-1D0 + ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/ + &(2D0-XK*(1D0-SGN*CTHE))) + + RETURN + END + +C********************************************************************* + +C...PYXKFL +C...Selects flavour for produced qqbar pair. + + SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYDAT1/,/PYDAT2/ + +C...Calculate maximum weight in QED or QFD case. + IF(MSTJ(102).LE.1) THEN + RFMAX=4D0/9D0 + ELSE + POLL=1D0-PARJ(131)*PARJ(132) + SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102))) + SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2) + SFI=SFW*(1D0-(PARJ(123)/ECMC)**2) + VE=4D0*PARU(102)-1D0 + HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131)) + HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131))) + RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+ + & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0* + & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+ + & 1D0)*HF1W) + ENDIF + +C...Choose flavour. Gives charge and velocity. + NTRY=0 + 100 NTRY=NTRY+1 + IF(NTRY.GT.100) THEN + CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop') + KFLC=0 + RETURN + ENDIF + KFLC=KFL + IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0)) + MSTJ(93)=1 + PMQ=PYMASS(KFLC) + IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100 + QF=KCHG(KFLC,1)/3D0 + VQ=1D0 + IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2)) + +C...Calculate weight in QED or QFD case. + IF(MSTJ(102).LE.1) THEN + RF=QF**2 + RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2 + ELSE + VF=SIGN(1D0,QF)-4D0*QF*PARU(102) + RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W + RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+ + & VQ**3*HF1W + IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV) + ENDIF + +C...Weighting or new event (radiative photon). Cross-section update. + IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100 + PARJ(158)=PARJ(158)+1D0 + IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0 + IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100 + IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0 + PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158) + PARJ(148)=PARJ(144)*86.8D0/ECM**2 + + RETURN + END + +C********************************************************************* + +C...PYXJET +C...Selects number of jets in matrix element approach. + + SUBROUTINE PYXJET(ECM,NJET,CUT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ +C...Local array and data. + DIMENSION ZHUT(5) + DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/ + +C...Trivial result for two-jets only, including parton shower. + IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN + CUT=0D0 + +C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R. + ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN + CF=4D0/3D0 + IF(MSTJ(109).EQ.2) CF=1D0 + IF(MSTJ(111).EQ.0) THEN + Q2=ECM**2 + Q2R=ECM**2 + ELSEIF(MSTU(111).EQ.0) THEN + PARJ(169)=MIN(1D0,PARJ(129)) + Q2=PARJ(169)*ECM**2 + PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/ + & ((33D0-2D0*MSTU(112))*PARU(111))))) + Q2R=PARJ(168)*ECM**2 + ELSE + PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2)) + Q2=PARJ(169)*ECM**2 + PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM, + & (2D0*PARU(112)/ECM)**2)) + Q2R=PARJ(168)*ECM**2 + ENDIF + +C...alpha_strong for R and R itself. + ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1) + IF(IABS(MSTJ(101)).EQ.1) THEN + RQCD=1D0+ALSPI + ELSEIF(MSTJ(109).EQ.0) THEN + RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2 + IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+ + & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2) + ELSE + RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2 + ENDIF + +C...alpha_strong for jet rate. Initial value for y cut. + ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1) + CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2) + IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0)) + & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0) + IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT)) + +C...Parametrization of first order three-jet cross-section. + 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN + PARJ(152)=0D0 + ELSE + PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))* + & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)* + & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0* + & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD + IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2)) + & PARJ(152)=0D0 + ENDIF + +C...Parametrization of second order three-jet cross-section. + IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR. + & CUT.GE.0.25D0) THEN + PARJ(153)=0D0 + ELSEIF(MSTJ(110).LE.1) THEN + CT=LOG(1D0/CUT-2D0) + PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2- + & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD + +C...Interpolation in second/first order ratio for Zhu parametrization. + ELSEIF(MSTJ(110).EQ.2) THEN + IZA=0 + DO 110 IY=1,5 + IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY + 110 CONTINUE + IF(IZA.NE.0) THEN + ZHURAT=ZHUT(IZA) + ELSE + IZ=100D0*CUT + ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ)) + ENDIF + PARJ(153)=ALSPI*PARJ(152)*ZHURAT + ENDIF + +C...Shift in second order three-jet cross-section with optimized Q^2. + IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3 + & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+ + & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152) + +C...Parametrization of second order four-jet cross-section. + IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN + PARJ(154)=0D0 + ELSE + CT=LOG(1D0/CUT-5D0) + IF(CUT.LE.0.018D0) THEN + XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2 + IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+ + & 0.4059D0*CT**2) + XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2) + IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ + ELSE + XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3 + IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+ + & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3) + XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+ + & 0.002093D0*CT**3) + IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ + ENDIF + PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD + PARJ(155)=XQQQQ/(XQQGG+XQQQQ) + ENDIF + +C...If negative three-jet rate, change y' optimization parameter. + IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND. + & PARJ(169).LT.0.99D0) THEN + PARJ(169)=MIN(1D0,1.2D0*PARJ(169)) + Q2=PARJ(169)*ECM**2 + ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1) + GOTO 100 + ENDIF + +C...If too high cross-section, use harder cuts, or fail. + IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN + IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND. + & PARJ(169).LT.0.99D0) THEN + PARJ(169)=MIN(1D0,1.2D0*PARJ(169)) + Q2=PARJ(169)*ECM**2 + ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1) + GOTO 100 + ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN + CALL PYERRM(26, + & '(PYXJET:) no allowed y cut value for Zhu parametrization') + ENDIF + CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+ + & PARJ(154))**(-1D0/3D0) + IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT)) + GOTO 100 + ENDIF + +C...Scalar gluon (first order only). + ELSE + ALSPI=PYALPS(ECM**2)/PARU(1) + CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI)) + PARJ(152)=0D0 + IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)* + & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0)) + PARJ(153)=0D0 + PARJ(154)=0D0 + ENDIF + +C...Select number of jets. + PARJ(150)=CUT + IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN + NJET=2 + ELSEIF(MSTJ(101).LE.0) THEN + NJET=MIN(4,2-MSTJ(101)) + ELSE + RNJ=PYR(0) + NJET=2 + IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3 + IF(PARJ(154).GT.RNJ) NJET=4 + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYX3JT +C...Selects the kinematical variables of three-jet events. + + SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ +C...Local array. + DIMENSION ZHUP(5,12) + +C...Coefficients of Zhu second order parametrization. + DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/ + &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0, + &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0, + &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0, + &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0, + &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0, + &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0, + &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0, + &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0, + &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0, + &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/ + +C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick). + DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+ + &X**7/49D0 + +C...Event type. Mass effect factors and other common constants. + MSTJ(120)=2 + MSTJ(121)=0 + PMQ=PYMASS(KFL) + QME=(2D0*PMQ/ECM)**2 + IF(MSTJ(109).NE.1) THEN + CUTL=LOG(CUT) + CUTD=LOG(1D0/CUT-2D0) + IF(MSTJ(109).EQ.0) THEN + CF=4D0/3D0 + CN=3D0 + TR=2D0 + WTMX=MIN(20D0,37D0-6D0*CUTD) + IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT) + ELSE + CF=1D0 + CN=0D0 + TR=12D0 + WTMX=0D0 + ENDIF + +C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight. + ALS2PI=PARU(118)/PARU(2) + WTOPT=0D0 + IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0* + & LOG(PARJ(169))*ALS2PI + WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX) + +C...Choose three-jet events in allowed region. + 100 NJET=3 + 110 Y13L=CUTL+CUTD*PYR(0) + Y23L=CUTL+CUTD*PYR(0) + Y13=EXP(Y13L) + Y23=EXP(Y23L) + Y12=1D0-Y13-Y23 + IF(Y12.LE.CUT) GOTO 110 + IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110 + +C...Second order corrections. + IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN + Y12L=LOG(Y12) + Y13M=LOG(1D0-Y13) + Y23M=LOG(1D0-Y23) + Y12M=LOG(1D0-Y12) + IF(Y13.LE.0.5D0) Y13I=DILOG(Y13) + IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13) + IF(Y23.LE.0.5D0) Y23I=DILOG(Y23) + IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23) + IF(Y12.LE.0.5D0) Y12I=DILOG(Y12) + IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12) + WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23) + WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+ + & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+ + & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2- + & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+ + & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+ + & TR*(2D0*CUTL/3D0-10D0/9D0)+ + & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+ + & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/ + & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+ + & Y13*Y23)/(Y12+Y13)**2)/WT1+ + & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)* + & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L* + & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)* + & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/ + & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))- + & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1- + & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I) + IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1 + IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110 + PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2) + + ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN +C...Second order corrections; Zhu parametrization of ERT. + ZX=(Y23-Y13)**2 + ZY=1D0-Y12 + IZA=0 + DO 120 IY=1,5 + IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY + 120 CONTINUE + IF(IZA.NE.0) THEN + IZ=IZA + WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+ + & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ + & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+ + & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY + ELSE + IZ=100D0*CUT + WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+ + & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ + & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+ + & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY + IZ=IZ+1 + WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+ + & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+ + & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+ + & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY + WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ) + ENDIF + IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1 + IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110 + PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2) + ENDIF + +C...Impose mass cuts (gives two jets). For fixed jet number new try. + X1=1D0-Y23 + X2=1D0-Y13 + X3=1D0-Y12 + IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2 + IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+ + & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+ + & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2 + IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100 + +C...Scalar gluon model (first order only, no mass effects). + ELSE + 130 NJET=3 + 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2)) + IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140 + YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0) + X1=1D0-0.5D0*(X3+YD) + X2=1D0-0.5D0*(X3-YD) + IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2 + IF(MSTJ(102).GE.2) THEN + IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT. + & X3**2*PYR(0)) NJET=2 + ENDIF + IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130 + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYX4JT +C...Selects the kinematical variables of four-jet events. + + SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ +C...Local arrays. + DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4) + +C...Common constants. Colour factors for QCD and Abelian gluon theory. + PMQ=PYMASS(KFL) + QME=(2D0*PMQ/ECM)**2 + CT=LOG(1D0/CUT-5D0) + IF(MSTJ(109).EQ.0) THEN + CF=4D0/3D0 + CN=3D0 + TR=2.5D0 + ELSE + CF=1D0 + CN=0D0 + TR=15D0 + ENDIF + +C...Choice of process (qqbargg or qqbarqqbar). + 100 NJET=4 + IT=1 + IF(PARJ(155).GT.PYR(0)) IT=2 + IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2 + IF(IT.EQ.1) WTMX=0.7D0/CUT**2 + IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2 + IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2 + ID=1 + +C...Sample the five kinematical variables (for qqgg preweighted in y34). + 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0) + Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0) + IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0)) + IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0) + IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110 + VT=PYR(0) + CP=COS(PARU(1)*PYR(0)) + Y14=(Y134-Y34)*VT + Y13=Y134-Y14-Y34 + VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34)) + Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)* + &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB)) + Y23=Y234-Y34-Y24 + Y12=1D0-Y134-Y23-Y24 + IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110 + Y123=Y12+Y13+Y23 + Y124=Y12+Y14+Y24 + +C...Calculate matrix elements for qqgg or qqqq process. + IC=0 + WTTOT=0D0 + 120 IC=IC+1 + IF(IT.EQ.1) THEN + WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+ + & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24- + & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12* + & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+ + & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/ + & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24- + & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/ + & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24) + WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12* + & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14* + & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+ + & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24) + WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+ + & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+ + & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24- + & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23- + & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+ + & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+ + & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+ + & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24- + & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+ + & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+ + & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2- + & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34) + WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+ + & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34- + & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+ + & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+ + & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+ + & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/ + & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34- + & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+ + & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24- + & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14- + & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2- + & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34- + & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34- + & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23- + & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14- + & Y12*Y13**2)/(4D0*Y34**2*Y134**2) + WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+ + & CN*WTC(IC))/8D0 + ELSE + WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12* + & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2* + & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12* + & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14* + & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+ + & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+ + & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24* + & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24- + & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123) + WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13* + & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23* + & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13* + & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+ + & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+ + & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134* + & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14* + & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124) + WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0 + ENDIF + +C...Permutations of momenta in matrix element. Weighting. + 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN + YSAV=Y13 + Y13=Y14 + Y14=YSAV + YSAV=Y23 + Y23=Y24 + Y24=YSAV + YSAV=Y123 + Y123=Y124 + Y124=YSAV + ENDIF + IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN + YSAV=Y13 + Y13=Y23 + Y23=YSAV + YSAV=Y14 + Y14=Y24 + Y24=YSAV + YSAV=Y134 + Y134=Y234 + Y234=YSAV + ENDIF + IF(IC.LE.3) GOTO 120 + IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110 + IC=5 + +C...qqgg events: string configuration and event type. + IF(IT.EQ.1) THEN + IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN + PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+ + & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT) + IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+ + & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2 + IF(ID.EQ.2) GOTO 130 + ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN + PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT) + IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2 + IF(ID.EQ.2) GOTO 130 + ENDIF + MSTJ(120)=3 + IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+ + & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4 + KFLN=21 + +C...Mass cuts. Kinematical variables out. + IF(Y12.LE.CUT+QME) NJET=2 + IF(NJET.EQ.2) GOTO 150 + Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12)) + X1=1D0-(1D0-Q12)*Y234-Q12*Y134 + X4=1D0-(1D0-Q12)*Y134-Q12*Y234 + X2=1D0-Y124 + X12=(1D0-Q12)*Y13+Q12*Y23 + X14=Y12-0.5D0*QME + IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2 + +C...qqbarqqbar events: string configuration, choose new flavour. + ELSE + IF(ID.EQ.1) THEN + WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4)) + IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2 + IF(WTR.LT.WTD(3)+WTD(4)) ID=3 + IF(WTR.LT.WTD(4)) ID=4 + IF(ID.GE.2) GOTO 130 + ENDIF + MSTJ(120)=5 + PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT) + 140 KFLN=1+INT(5D0*PYR(0)) + IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140 + IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140 + IF(KFLN.GT.MSTJ(104)) NJET=2 + PMQN=PYMASS(KFLN) + QMEN=(2D0*PMQN/ECM)**2 + +C...Mass cuts. Kinematical variables out. + IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2 + IF(NJET.EQ.2) GOTO 150 + Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24)) + Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13)) + X1=1D0-(1D0-Q24)*Y123-Q24*Y134 + X4=1D0-(1D0-Q24)*Y134-Q24*Y123 + X2=1D0-(1D0-Q13)*Y234-Q13*Y124 + X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+ + & Q13*Y23) + X14=Y24-0.5D0*QME + X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+ + & Q13*Y14) + IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE. + & (PARJ(127)+PMQ+PMQN)**2) NJET=2 + IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2 + ENDIF + 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100 + + RETURN + END + +C********************************************************************* + +C...PYXDIF +C...Gives the angular orientation of events. + + SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,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(23000,5),P(23000,5),V(23000,5) + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4) + SAVE /PYJETS/,/PYDAT1/,/PYDAT2/ + +C...Printout. Check input parameters. + IF(MSTU(12).NE.12345) CALL PYLIST(0) + IF(KFL.LT.0.OR.KFL.GT.8) THEN + CALL PYERRM(16,'(PYONIA:) called with unknown flavour code') + IF(MSTU(21).GE.1) RETURN + ENDIF + IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN + CALL PYERRM(16,'(PYONIA:) called with too small CM energy') + IF(MSTU(21).GE.1) RETURN + ENDIF + +C...Initial e+e- and onium state (optional). + NC=0 + IF(MSTJ(115).GE.2) THEN + NC=NC+2 + CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0) + K(NC-1,1)=21 + CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0) + K(NC,1)=21 + ENDIF + KFLC=IABS(KFL) + IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN + NC=NC+1 + KF=110*KFLC+3 + MSTU10=MSTU(10) + MSTU(10)=1 + P(NC,5)=ECM + CALL PY1ENT(NC,KF,ECM,0D0,0D0) + K(NC,1)=21 + K(NC,3)=1 + MSTU(10)=MSTU10 + ENDIF + +C...Choose x1 and x2 according to matrix element. + NTRY=0 + 100 X1=PYR(0) + X2=PYR(0) + X3=2D0-X1-X2 + IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+ + &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100 + NTRY=NTRY+1 + NJET=3 + IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3) + IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3) + +C...Photon-gluon-gluon events. Small system modifications. Jet origin. + MSTU(111)=MSTJ(108) + IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1)) + &MSTU(111)=1 + PARU(112)=PARJ(121) + IF(MSTU(111).EQ.2) PARU(112)=PARJ(122) + QF=0D0 + IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0 + RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2) + MK=0 + ECMC=ECM + IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN + IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125))) + & NJET=2 + IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM) + IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM) + ELSE + MK=1 + ECMC=SQRT(1D0-X1)*ECM + IF(ECMC.LT.2D0*PARJ(127)) GOTO 100 + K(NC+1,1)=1 + K(NC+1,2)=22 + K(NC+1,4)=0 + K(NC+1,5)=0 + IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3) + IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3) + IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2) + IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2) + NJET=2 + IF(ECMC.LT.4D0*PARJ(127)) THEN + MSTU10=MSTU(10) + MSTU(10)=1 + P(NC+2,5)=ECMC + CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0) + MSTU(10)=MSTU10 + NJET=0 + ENDIF + ENDIF + DO 110 IP=NC+1,N + K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1) + 110 CONTINUE + +C...Differential cross-sections. Upper limit for cross-section. + IF(MSTJ(106).EQ.1) THEN + SQ2=SQRT(2D0) + HF1=1D0-PARJ(131)*PARJ(132) + HF3=PARJ(133)**2 + CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3) + ST13=SQRT(1D0-CT13**2) + SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2 + SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL + SIGT=0.5D0*SIGL + SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2 + SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+ + & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI) + +C...Angular orientation of event. + 120 CHI=PARU(2)*PYR(0) + CTHE=2D0*PYR(0)-1D0 + PHI=PARU(2)*PYR(0) + CCHI=COS(CHI) + SCHI=SIN(CHI) + C2CHI=COS(2D0*CHI) + S2CHI=SIN(2D0*CHI) + THE=ACOS(CTHE) + STHE=SIN(THE) + C2PHI=COS(2D0*(PHI-PARJ(134))) + S2PHI=SIN(2D0*(PHI-PARJ(134))) + SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1- + & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)* + & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT- + & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE* + & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI + IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120 + CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0) + CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0) + ENDIF + +C...Generate parton shower. Rearrange along strings and check. + IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN + CALL PYSHOW(NC+MK+1,-NJET,ECMC) + MSTJ14=MSTJ(14) + IF(MSTJ(105).EQ.-1) MSTJ(14)=-1 + IF(MSTJ(105).GE.0) MSTU(28)=0 + CALL PYPREP(0) + MSTJ(14)=MSTJ14 + IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100 + ENDIF + +C...Generate fragmentation. Information for PYTABU: + IF(MSTJ(105).EQ.1) CALL PYEXEC + MSTU(161)=110*KFLC+3 + MSTU(162)=0 + + RETURN + END + +C********************************************************************* + +C...PYBOOK +C...Books a histogram. + + SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Commonblock. + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + SAVE /PYBINS/ +C...Local character variables. + CHARACTER TITLE*(*), TITFX*60 + +C...Check that input is sensible. Find initial address in memory. + IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28, + &'(PYBOOK:) not allowed histogram number') + IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28, + &'(PYBOOK:) not allowed number of bins') + IF(XL.GE.XU) CALL PYERRM(28, + &'(PYBOOK:) x limits in wrong order') + INDX(ID)=IHIST(4) + IHIST(4)=IHIST(4)+28+NX + IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28, + &'(PYBOOK:) out of histogram space') + IS=INDX(ID) + +C...Store histogram size and reset contents. + BIN(IS+1)=NX + BIN(IS+2)=XL + BIN(IS+3)=XU + BIN(IS+4)=(XU-XL)/NX + CALL PYNULL(ID) + +C...Store title by conversion to integer to double precision. + TITFX=TITLE//' ' + DO 100 IT=1,20 + BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+ + & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT)) + 100 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYFILL +C...Fills entry in histogram. + + SUBROUTINE PYFILL(ID,X,W) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Commonblock. + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + SAVE /PYBINS/ + +C...Find initial address in memory. Increase number of entries. + IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28, + &'(PYFILL:) not allowed histogram number') + IS=INDX(ID) + IF(IS.EQ.0) CALL PYERRM(28, + &'(PYFILL:) filling unbooked histogram') + BIN(IS+5)=BIN(IS+5)+1D0 + +C...Find bin in x, including under/overflow, and fill. + IF(X.LT.BIN(IS+2)) THEN + BIN(IS+6)=BIN(IS+6)+W + ELSEIF(X.GE.BIN(IS+3)) THEN + BIN(IS+8)=BIN(IS+8)+W + ELSE + BIN(IS+7)=BIN(IS+7)+W + IX=(X-BIN(IS+2))/BIN(IS+4) + IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX)) + BIN(IS+9+IX)=BIN(IS+9+IX)+W + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYFACT +C...Multiplies histogram contents by factor. + + SUBROUTINE PYFACT(ID,F) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Commonblock. + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + SAVE /PYBINS/ + +C...Find initial address in memory. Multiply all contents bins. + IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28, + &'(PYFACT:) not allowed histogram number') + IS=INDX(ID) + IF(IS.EQ.0) CALL PYERRM(28, + &'(PYFACT:) scaling unbooked histogram') + DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1)) + BIN(IX)=F*BIN(IX) + 100 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYOPER +C...Performs operations between histograms. + + SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Commonblock. + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + SAVE /PYBINS/ +C...Character variable. + CHARACTER OPER*(*) + +C...Find initial addresses in memory, and histogram size. + IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28, + &'(PYFACT:) not allowed histogram number') + IS1=INDX(ID1) + IS2=INDX(MIN(IHIST(1),MAX(1,ID2))) + IS3=INDX(MIN(IHIST(1),MAX(1,ID3))) + NX=NINT(BIN(IS3+1)) + IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1)) + +C...Update info on number of histogram entries. + IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN + BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5) + ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN + BIN(IS3+5)=BIN(IS1+5) + ENDIF + +C...Operations on pair of histograms: addition, subtraction, +C...multiplication, division. + IF(OPER.EQ.'+') THEN + DO 100 IX=6,8+NX + BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX) + 100 CONTINUE + ELSEIF(OPER.EQ.'-') THEN + DO 110 IX=6,8+NX + BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX) + 110 CONTINUE + ELSEIF(OPER.EQ.'*') THEN + DO 120 IX=6,8+NX + BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX) + 120 CONTINUE + ELSEIF(OPER.EQ.'/') THEN + DO 130 IX=6,8+NX + FA2=F2*BIN(IS2+IX) + IF(ABS(FA2).LE.1D-20) THEN + BIN(IS3+IX)=0D0 + ELSE + BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2 + ENDIF + 130 CONTINUE + +C...Operations on single histogram: multiplication+addition, +C...square root+addition, logarithm+addition. + ELSEIF(OPER.EQ.'A') THEN + DO 140 IX=6,8+NX + BIN(IS3+IX)=F1*BIN(IS1+IX)+F2 + 140 CONTINUE + ELSEIF(OPER.EQ.'S') THEN + DO 150 IX=6,8+NX + BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2 + 150 CONTINUE + ELSEIF(OPER.EQ.'L') THEN + ZMIN=1D20 + DO 160 IX=9,8+NX + IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20) + & ZMIN=0.8D0*BIN(IS1+IX) + 160 CONTINUE + DO 170 IX=6,8+NX + BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2 + 170 CONTINUE + +C...Operation on two or three histograms: average and +C...standard deviation. + ELSEIF(OPER.EQ.'M') THEN + DO 180 IX=6,8+NX + IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN + BIN(IS2+IX)=0D0 + ELSE + BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX) + ENDIF + IF(ID3.NE.0) THEN + IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN + BIN(IS3+IX)=0D0 + ELSE + BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)- + & BIN(IS2+IX)**2)) + ENDIF + ENDIF + BIN(IS1+IX)=F1*BIN(IS1+IX) + 180 CONTINUE + ENDIF + + RETURN + END + +C********************************************************************* + +C...PYHIST +C...Prints and resets all histograms. + + SUBROUTINE PYHIST + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Commonblock. + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + SAVE /PYBINS/ + +C...Loop over histograms, print and reset used ones. + DO 100 ID=1,IHIST(1) + IS=INDX(ID) + IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN + CALL PYPLOT(ID) + CALL PYNULL(ID) + ENDIF + 100 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYPLOT +C...Prints a histogram (but does not reset it). + + SUBROUTINE PYPLOT(ID) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + SAVE /PYDAT1/,/PYBINS/ +C...Local arrays and character variables. + DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10) + CHARACTER TITLE*60, OUT*100, CHA(0:11)*1 + +C...Steps in histogram scale. Character sequence. + DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/ + DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/ + +C...Find initial address in memory; skip if empty histogram. + IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN + IS=INDX(ID) + IF(IS.EQ.0) RETURN + IF(NINT(BIN(IS+5)).LE.0) THEN + WRITE(MSTU(11),5000) ID + RETURN + ENDIF + +C...Number of histogram lines and x bins. + LIN=IHIST(3)-18 + NX=NINT(BIN(IS+1)) + +C...Extract title by conversion from double precision via integer. + DO 100 IT=1,20 + IEQ=NINT(BIN(IS+8+NX+IT)) + TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256) + & //CHAR(MOD(IEQ,256)) + 100 CONTINUE + +C...Find time; print title. + CALL PYTIME(IDATI) + IF(IDATI(1).GT.0) THEN + WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5) + ELSE + WRITE(MSTU(11),5200) ID, TITLE + ENDIF + +C...Find minimum and maximum bin content. + YMIN=BIN(IS+9) + YMAX=BIN(IS+9) + DO 110 IX=IS+10,IS+8+NX + IF(BIN(IX).LT.YMIN) YMIN=BIN(IX) + IF(BIN(IX).GT.YMAX) YMAX=BIN(IX) + 110 CONTINUE + +C...Determine scale and step size for y axis. + IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN + IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0 + IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0 + IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10 + IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1 + IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1 + DELY=DYAC(1) + DO 120 IDEL=1,9 + IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1) + 120 CONTINUE + DY=DELY*10D0**IPOT + +C...Convert bin contents to integer form; fractional fill in top row. + DO 130 IX=1,NX + CTA=ABS(BIN(IS+8+IX))/DY + IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX)) + IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0))) + 130 CONTINUE + IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN) + IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX) + +C...Print histogram row by row. + DO 150 IR=IRMA,IRMI,-1 + IF(IR.EQ.0) GOTO 150 + OUT=' ' + DO 140 IX=1,NX + IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX)) + IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10) + 140 CONTINUE + WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT + 150 CONTINUE + +C...Print sign and value of bin contents. + IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10 + OUT=' ' + DO 160 IX=1,NX + IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11) + IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX))) + 160 CONTINUE + WRITE(MSTU(11),5400) OUT + DO 180 IR=4,1,-1 + DO 170 IX=1,NX + OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1)) + 170 CONTINUE + WRITE(MSTU(11),5500) IPOT+IR-4, OUT + 180 CONTINUE + +C...Print sign and value of lower bin edge. + IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+ + & 10.0001D0)-10 + OUT=' ' + DO 190 IX=1,NX + IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3)) + & OUT(IX:IX)=CHA(11) + IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4))) + 190 CONTINUE + WRITE(MSTU(11),5600) OUT + DO 210 IR=3,1,-1 + DO 200 IX=1,NX + OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1)) + 200 CONTINUE + WRITE(MSTU(11),5500) IPOT+IR-3, OUT + 210 CONTINUE + ENDIF + +C...Calculate and print statistics. + CSUM=0D0 + CXSUM=0D0 + CXXSUM=0D0 + DO 220 IX=1,NX + CTA=ABS(BIN(IS+8+IX)) + X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4) + CSUM=CSUM+CTA + CXSUM=CXSUM+CTA*X + CXXSUM=CXXSUM+CTA*X**2 + 220 CONTINUE + XMEAN=CXSUM/MAX(CSUM,1D-20) + XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2)) + WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6), + &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3) + +C...Formats for output. + 5000 FORMAT(/5X,'Histogram no',I5,' : no entries') + 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X, + &I2,':',I2/) + 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/) + 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100) + 5400 FORMAT(/8X,'Contents',3X,A100) + 5500 FORMAT(9X,'*10**',I2,3X,A100) + 5600 FORMAT(/8X,'Low edge',3X,A100) + 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow =' + &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X, + &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4) + + RETURN + END + +C********************************************************************* + +C...PYNULL +C...Resets bin contents of a histogram. + + SUBROUTINE PYNULL(ID) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Commonblock. + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + SAVE /PYBINS/ + + IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN + IS=INDX(ID) + IF(IS.EQ.0) RETURN + DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1)) + BIN(IX)=0D0 + 100 CONTINUE + + RETURN + END + +C********************************************************************* + +C...PYDUMP +C...Dumps histogram contents on file for reading by other program. +C...Can also read back own dump. + + SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI) + +C...Double precision declaration. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) +C...Commonblock. + COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000) + SAVE /PYBINS/ +C...Local arrays and character variables. + DIMENSION IHI(*),ISS(100),VAL(5) + CHARACTER TITLE*60,FORMAT*13 + +C...Dump all histograms that have been booked, +C...including titles and ranges, one after the other. + IF(MDUMP.EQ.1) THEN + +C...Loop over histograms and find which are wanted and booked. + IF(NHI.LE.0) THEN + NW=IHIST(1) + ELSE + NW=NHI + ENDIF + DO 130 IW=1,NW + IF(NHI.EQ.0) THEN + ID=IW + ELSE + ID=IHI(IW) + ENDIF + IS=INDX(ID) + IF(IS.NE.0) THEN + +C...Write title, histogram size, filling statistics. + NX=NINT(BIN(IS+1)) + DO 100 IT=1,20 + IEQ=NINT(BIN(IS+8+NX+IT)) + TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)// + & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256)) + 100 CONTINUE + WRITE(LFN,5100) ID,TITLE + WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3) + WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7), + & BIN(IS+8) + + +C...Write histogram contents, in groups of five. + DO 120 IXG=1,(NX+4)/5 + DO 110 IXV=1,5 + IX=5*IXG+IXV-5 + IF(IX.LE.NX) THEN + VAL(IXV)=BIN(IS+8+IX) + ELSE + VAL(IXV)=0D0 + ENDIF + 110 CONTINUE + WRITE(LFN,5400) (VAL(IXV),IXV=1,5) + 120 CONTINUE + +C...Go to next histogram; finish. + ELSEIF(NHI.GT.0) THEN + CALL PYERRM(8,'(PYDUMP:) unknown histogram number') + ENDIF + 130 CONTINUE + +C...Read back in histograms dumped MDUMP=1. + ELSEIF(MDUMP.EQ.2) THEN + +C...Read histogram number, title and range, and book. + 140 READ(LFN,5100,END=170) ID,TITLE + READ(LFN,5200) NX,XL,XU + CALL PYBOOK(ID,TITLE,NX,XL,XU) + IS=INDX(ID) + +C...Read filling statistics. + READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8) + BIN(IS+5)=DBLE(NENTRY) + +C...Read histogram contents, in groups of five. + DO 160 IXG=1,(NX+4)/5 + READ(LFN,5400) (VAL(IXV),IXV=1,5) + DO 150 IXV=1,5 + IX=5*IXG+IXV-5 + IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV) + 150 CONTINUE + 160 CONTINUE + +C...Go to next histogram; finish. + GOTO 140 + 170 CONTINUE + +C...Write histogram contents in column format, +C...convenient e.g. for GNUPLOT input. + ELSEIF(MDUMP.EQ.3) THEN + +C...Find addresses to wanted histograms. + NSS=0 + IF(NHI.LE.0) THEN + NW=IHIST(1) + ELSE + NW=NHI + ENDIF + DO 180 IW=1,NW + IF(NHI.EQ.0) THEN + ID=IW + ELSE + ID=IHI(IW) + ENDIF + IS=INDX(ID) + IF(IS.NE.0.AND.NSS.LT.100) THEN + NSS=NSS+1 + ISS(NSS)=IS + ELSEIF(NSS.GE.100) THEN + CALL PYERRM(8,'(PYDUMP:) too many histograms requested') + ELSEIF(NHI.GT.0) THEN + CALL PYERRM(8,'(PYDUMP:) unknown histogram number') + ENDIF + 180 CONTINUE + +C...Check that they have common number of x bins. Fix format. + NX=NINT(BIN(ISS(1)+1)) + DO 190 IW=2,NSS + IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN + CALL PYERRM(8,'(PYDUMP:) different number of bins') + RETURN + ENDIF + 190 CONTINUE + FORMAT='(1P,000E12.4)' + WRITE(FORMAT(5:7),'(I3)') NSS+1 + +C...Write histogram contents; first column x values. + DO 200 IX=1,NX + X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4) + WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS) + 200 CONTINUE + + ENDIF + +C...Formats for output. + 5100 FORMAT(I5,5X,A60) + 5200 FORMAT(I5,1P,2D12.4) + 5300 FORMAT(I12,1P,3D12.4) + 5400 FORMAT(1P,5D12.4) + + RETURN + END + +C********************************************************************* + +C...PYSTOP +C...Allows users to handle STOP statemens + + SUBROUTINE PYSTOP(MCOD) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + SAVE /PYDAT1/ + + +C...Write message, then stop + WRITE(MSTU(11),5000) MCOD + STOP + + +C...Formats for output. + 5000 FORMAT(/5X,'PYSTOP called with code: ',I4) + END + +C********************************************************************* + +C...PYKCUT +C...Dummy routine, which the user can replace in order to make cuts on +C...the kinematics on the parton level before the matrix elements are +C...evaluated and the event is generated. The cross-section estimates +C...will automatically take these cuts into account, so the given +C...values are for the allowed phase space region only. MCUT=0 means +C...that the event has passed the cuts, MCUT=1 that it has failed. + + SUBROUTINE PYKCUT(MCUT) + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + INTEGER PYK,PYCHGE,PYCOMP +C...Commonblocks. + COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) + COMMON/PYINT1/MINT(400),VINT(400) + COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) + SAVE /PYDAT1/,/PYINT1/,/PYINT2/ + +C...Set default value (accepting event) for MCUT. + MCUT=0 + +C...Read out subprocess number. + ISUB=MINT(1) + ISTSB=ISET(ISUB) + +C...Read out tau, y*, cos(theta), tau' (where defined, else =0). + TAU=VINT(21) + YST=VINT(22) + CTH=0D0 + IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23) + TAUP=0D0 + IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26) + +C...Calculate x_1, x_2, x_F. + IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN + X1=SQRT(TAU)*EXP(YST) + X2=SQRT(TAU)*EXP(-YST) + ELSE + X1=SQRT(TAUP)*EXP(YST) + X2=SQRT(TAUP)*EXP(-YST) + ENDIF + XF=X1-X2 + +C...Calculate shat, that, uhat, p_T^2. + SHAT=TAU*VINT(2) + SQM3=VINT(63) + SQM4=VINT(64) + RM3=SQM3/SHAT + RM4=SQM4/SHAT + BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4)) + RPTS=4D0*VINT(71)**2/SHAT + BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS)) + RM34=2D0*RM3*RM4 + RSQM=1D0+RM34 + RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L) + THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH) + UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH) + PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2)) + +C...Decisions by user to be put here. + +C...Stop program if this routine is ever called. +C...You should not copy these lines to your own routine. + WRITE(MSTU(11),5000) + CALL PYSTOP(6) + +C...Format for error printout. + 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ', + &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/ + &1X,'Execution stopped!') + + RETURN + END + +! C********************************************************************* +! +! C...PYEVWT +! C...Dummy routine, which the user can replace in order to multiply the +! C...standard PYTHIA differential cross-section by a process- and +! C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds +! C...to generation of weighted events, with weight 1/WTXS, while for +! C...MSTP(142)=2 it corresponds to a modification of the underlying +! C...physics. +! +! SUBROUTINE PYEVWT(WTXS) +! +! C...Double precision and integer declarations. +! IMPLICIT DOUBLE PRECISION(A-H, O-Z) +! IMPLICIT INTEGER(I-N) +! INTEGER PYK,PYCHGE,PYCOMP +! C...Commonblocks. +! COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) +! COMMON/PYINT1/MINT(400),VINT(400) +! COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2) +! SAVE /PYDAT1/,/PYINT1/,/PYINT2/ +! +! C...Set default weight for WTXS. +! WTXS=1D0 +! +! C...Read out subprocess number. +! ISUB=MINT(1) +! ISTSB=ISET(ISUB) +! +! C...Read out tau, y*, cos(theta), tau' (where defined, else =0). +! TAU=VINT(21) +! YST=VINT(22) +! CTH=0D0 +! IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23) +! TAUP=0D0 +! IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26) +! +! C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2. +! X1=VINT(41) +! X2=VINT(42) +! XF=X1-X2 +! SHAT=VINT(44) +! THAT=VINT(45) +! UHAT=VINT(46) +! PT2=VINT(48) +! +! C...Modifications by user to be put here. +! +! C...Stop program if this routine is ever called. +! C...You should not copy these lines to your own routine. +! WRITE(MSTU(11),5000) +! CALL PYSTOP(4) +! +! C...Format for error printout. +! 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ', +! &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/ +! &1X,'Execution stopped!') +! +! RETURN +! END + + + 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--event weight exponent + COMMON/WEXPO/WEIGHTEX + DOUBLE PRECISION WEIGHTEX + +C...Read out p_T^2 + PT2=VINT(48) + WTXS=PT2**(WEIGHTEX/2.d0) + RETURN + END + +C********************************************************************* + +C...UPINIT +C...Dummy routine, to be replaced by a user implementing external +C...processes. Is supposed to fill the HEPRUP commonblock with info +C...on incoming beams and allowed processes. + +C...New example: handles a standard Les Houches Events File. + + SUBROUTINE UPINIT + +C...Double precision and integer declarations. + IMPLICIT DOUBLE PRECISION(A-H, O-Z) + IMPLICIT INTEGER(I-N) + +C...PYTHIA commonblock: only used to provide read unit MSTP(161). + COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) + SAVE /PYPARS/ + +C...User process initialization commonblock. + INTEGER MAXPUP + PARAMETER (MAXPUP=100) + INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP + DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP + COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2), + &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP), + &LPRUP(MAXPUP) + SAVE /HEPRUP/ + +C...Lines to read in assumed never longer than 200 characters. + PARAMETER (MAXLEN=200) + CHARACTER*(MAXLEN) STRING + +C...Format for reading lines. + CHARACTER*6 STRFMT + STRFMT='(A000)' + WRITE(STRFMT(3:5),'(I3)') MAXLEN + +C...Loop until finds line beginning with "" or "'.AND. + &STRING(IBEG:IBEG+5).NE.'" or "'.AND. + &STRING(IBEG:IBEG+6).NE.' 0 ) C ============================================ C IMPLICIT DOUBLE PRECISION (A-H,O-Z) IF (X.EQ.0.0) THEN EI=-1.0D+300 ELSE IF (X.LE.40.0) THEN EI=1.0D0 R=1.0D0 DO 15 K=1,100 R=R*K*X/(K+1.0D0)**2 EI=EI+R IF (DABS(R/EI).LE.1.0D-15) GO TO 20 15 CONTINUE 20 GA=0.5772156649015328D0 EI=GA+DLOG(X)+X*EI ELSE EI=1.0D0 R=1.0D0 DO 25 K=1,20 R=R*K/X -25 EI=EI+R + EI=EI+R +25 CONTINUE EI=DEXP(X)/X*EI ENDIF RETURN END Index: branches/rel-2.3.0/jewel-2.3.0.f =================================================================== --- branches/rel-2.3.0/jewel-2.3.0.f (revision 483) +++ branches/rel-2.3.0/jewel-2.3.0.f (revision 484) @@ -1,7551 +1,7491 @@ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C++ Copyright (C) 2021 Korinna C. Zapp [Korinna.Zapp@thep.lu.se] ++ +C++ Copyright (C) 2022 Korinna C. Zapp [Korinna.Zapp@thep.lu.se] ++ C++ ++ C++ This file is part of JEWEL 2.3.0 ++ C++ ++ C++ The JEWEL homepage is jewel.hepforge.org ++ C++ ++ C++ The medium model was partly implemented by Jochen Klein. ++ C++ Raghav Kunnawalkam Elayavalli helped with the implementation ++ C++ of the V+jet processes. ++ C++ ++ C++ Please follow the MCnet GUIDELINES and cite Eur.Phys.J. C74 ++ C++ (2014) no.2, 2762 [arXiv:1311.0048] for the code and ++ C++ JHEP 1303 (2013) 080 [arXiv:1212.1599] and ++ C++ optionally EPJC 60 (2009) 617 [arXiv:0804.3568] for the ++ C++ physics. The reference for V+jet processes is EPJC 76 (2016) ++ C++ no.12 695 [arXiv:1608.03099] and for recoil effects it is ++ C++ JHEP 07 (2017) 141 [arXiv:1707.01539]. ++ C++ ++ C++ JEWEL relies heavily on PYTHIA 6 for the event generation. The ++ C++ modified version of PYTHIA 6.4.25 that is distributed with ++ C++ JEWEL is, however, not an official PYTHIA release and must not ++ C++ be used for anything else. Please refer to results as ++ C++ "JEWEL+PYTHIA". ++ C++ ++ C++ JEWEL also uses code provided by S. Zhang and J. M. Jing ++ C++ (Computation of Special Functions, John Wiley & Sons, New York, ++ C++ 1996 and http://jin.ece.illinois.edu) for computing the ++ C++ exponential integral Ei(x). ++ C++ ++ C++ ++ C++ JEWEL is free software; you can redistribute it and/or ++ C++ modify it under the terms of the GNU General Public License ++ C++ as published by the Free Software Foundation; either version 2 ++ C++ of the License, or (at your option) any later version. ++ C++ ++ C++ JEWEL is distributed in the hope that it will be useful, ++ C++ but WITHOUT ANY WARRANTY; without even the implied warranty of ++ C++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++ C++ GNU General Public License for more details. ++ C++ ++ C++ You should have received a copy of the GNU General Public ++ C++ License along with this program; if not, write to the Free ++ C++ Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, ++ C++ MA 02110-1301 USA ++ C++ ++ C++ Linking JEWEL statically or dynamically with other modules is ++ C++ making a combined work based on JEWEL. Thus, the terms and ++ C++ conditions of the GNU General Public License cover the whole ++ C++ combination. ++ C++ ++ C++ In addition, as a special exception, I give you permission to ++ C++ combine JEWEL with the code for the computation of special ++ C++ functions provided by S. Zhang and J. M. Jing. You may copy and ++ C++ distribute such a system following the terms of the GNU GPL for ++ C++ JEWEL and the licenses of the other code concerned, provided ++ C++ that you include the source code of that other code when and as ++ C++ the GNU GPL requires distribution of source code. ++ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ PROGRAM JEWEL IMPLICIT NONE C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) INTEGER MSTU,MSTJ DOUBLE PRECISION PARU,PARJ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) INTEGER MDCY,MDME,KFDP DOUBLE PRECISION BRAT COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) INTEGER MSEL,MSELPD,MSUB,KFIN DOUBLE PRECISION CKIN COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) INTEGER MSTP,MSTI DOUBLE PRECISION PARP,PARI COMMON/PYDATR/MRPY(6),RRPY(100) INTEGER MRPY DOUBLE PRECISION RRPY C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid -C--use nuclear pdf? - COMMON/NPDF/MASS,NSET,EPS09,INITSTR - INTEGER NSET - DOUBLE PRECISION MASS - LOGICAL EPS09 - CHARACTER*10 INITSTR C--number of protons - common/np/nproton - integer nproton + common/np/nproton,mass + integer nproton,mass C--organisation of event record common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro, &shorthepmc,channel,isochannel integer nsim,npart,offset,hadrotype double precision sqrts character*4 collider,channel character*2 isochannel logical hadro,shorthepmc C--discard event flag COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD LOGICAL DISCARD INTEGER NDISC,NSTRANGE,NGOOD,errcount double precision wdisc C--event weight COMMON/WEIGHT/EVWEIGHT,sumofweights double precision EVWEIGHT,sumofweights C--number of scattering events COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT C--number of extrapolations in tables common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf, &ntotxsec,noverxsec,ntotsuda,noversuda integer ntotspliti,noverspliti,ntotpdf,noverpdf, &ntotxsec,noverxsec,ntotsuda,noversuda C--local variables integer j,i,kk,poissonian integer nsimpp,nsimpn,nsimnp,nsimnn,nsimsum,nsimchn double precision sumofweightstot,wdisctot,scalefac double precision gettemp,r,tau character*2 b1,b2 call init() SUMOFWEIGHTSTOT=0.d0 WDISCTOT=0.d0 C--e+ + e- event generation if (collider.eq.'EEJJ') then b1 = 'e+' b2 = 'e-' write(logfid,*) write(logfid,*) &'####################################################' write(logfid,*) write(logfid,*)'generating ',nsim,' events in ',b1,' + ',b2, &' channel' write(logfid,*) write(logfid,*) &'####################################################' write(logfid,*) SUMOFWEIGHTS=0.d0 WDISC=0.d0 call initpythia(b1,b2) write(logfid,*) C--e+ + e- event loop DO 100 J=1,NSIM call genevent(j,b1,b2) 100 CONTINUE sumofweightstot = sumofweightstot+sumofweights wdisctot = wdisctot + wdisc write(logfid,*) write(logfid,*)'cross section in e+ + e- channel:',PARI(1),'mb' write(logfid,*)'sum of event weights in e+ + e- channel:', & sumofweights-wdisc write(logfid,*) else C--hadronic event generation if (isochannel.eq.'PP') then nsimpp = nsim nsimpn = 0 nsimnp = 0 nsimnn = 0 elseif (isochannel.eq.'PN') then nsimpp = 0 nsimpn = nsim nsimnp = 0 nsimnn = 0 elseif (isochannel.eq.'NP') then nsimpp = 0 nsimpn = 0 nsimnp = nsim nsimnn = 0 elseif (isochannel.eq.'NN') then nsimpp = 0 nsimpn = 0 nsimnp = 0 nsimnn = nsim else - nsimpp = poissonian(nsim*nproton**2/mass**2) - nsimpn = poissonian(nsim*nproton*(mass-nproton*1.d0)/mass**2) - nsimnp = poissonian(nsim*nproton*(mass-nproton*1.d0)/mass**2) - nsimnn = poissonian(nsim*(mass-nproton*1.d0)**2/mass**2) + nsimpp = poissonian(1.d0*nsim*nproton**2/mass**2) + nsimpn = poissonian(1.d0*nsim*nproton*(mass-nproton)/mass**2) + nsimnp = poissonian(1.d0*nsim*nproton*(mass-nproton)/mass**2) + nsimnn = poissonian(1.d0*nsim*(mass-nproton)**2/mass**2) nsimsum = nsimpp + nsimpn + nsimnp + nsimnn scalefac = nsim*1.d0/(nsimsum*1.d0) nsimpp = int(nsimpp*scalefac) nsimpn = int(nsimpn*scalefac) nsimnp = int(nsimnp*scalefac) nsimnn = int(nsimnn*scalefac) nsimsum = nsimpp + nsimpn + nsimnp + nsimnn endif C--loop over channels do 101 kk=1,4 if (kk.eq.1) then b1 = 'p+' b2 = 'p+' nsimchn = nsimpp elseif (kk.eq.2) then b1 = 'p+' b2 = 'n0' nsimchn = nsimpn elseif (kk.eq.3) then b1 = 'n0' b2 = 'p+' nsimchn = nsimnp else b1 = 'n0' b2 = 'n0' nsimchn = nsimnn endif write(logfid,*) write(logfid,*) &'####################################################' write(logfid,*) write(logfid,*)'generating ',nsimchn,' events in ', &b1,' + ',b2,' channel' write(logfid,*) write(logfid,*) &'####################################################' write(logfid,*) SUMOFWEIGHTS=0.d0 WDISC=0.d0 call initpythia(b1,b2) write(logfid,*) C--event loop DO 102 J=1,nsimchn call genevent(j,b1,b2) 102 CONTINUE sumofweightstot = sumofweightstot+sumofweights wdisctot = wdisctot + wdisc write(logfid,*) write(logfid,*)'cross section in ',b1,' + ',b2,' channel:', & PARI(1),'mb' write(logfid,*)'sum of event weights in ',b1,' + ',b2, & ' channel:',sumofweights-wdisc write(logfid,*) 101 continue endif C--finish WRITE(HPMCFID,'(A)')'HepMC::IO_GenEvent-END_EVENT_LISTING' WRITE(HPMCFID,*) CLOSE(HPMCFID,status='keep') write(logfid,*) write(logfid,*)'mean number of scatterings:', & NSCAT/(SUMOFWEIGHTSTOT-WDISCTOT) write(logfid,*)'mean number of effective scatterings:', & NSCATEFF/(SUMOFWEIGHTSTOT-WDISCTOT) write(logfid,*)'mean number of splittings:', & NSPLIT/(SUMOFWEIGHTSTOT-WDISCTOT) write(logfid,*) write(logfid,*)'number of extrapolations in splitting integral: ', & noverspliti,' (',(noverspliti*1.d0)/(ntotspliti*1.d0),'%)' write(logfid,*) & 'number of extrapolations in splitting partonic PDFs: ', & noverpdf,' (',(noverpdf*1.d0)/(ntotpdf*1.d0),'%)' write(logfid,*) & 'number of extrapolations in splitting cross sections: ', & noverxsec,' (',(noverxsec*1.d0)/(ntotxsec*1.d0),'%)' write(logfid,*) & 'number of extrapolations in Sudakov form factor: ', & noversuda,' (',(noversuda*1.d0)/(ntotsuda*1.d0),'%)' write(logfid,*) write(logfid,*)'number of good events: ',ngood write(logfid,*)'total number of discarded events: ',NDISC write(logfid,*)'number of events for which conversion '// &'to hepmc failed: ',NSTRANGE call printtime close(logfid,status='keep') END *********************************************************************** *********************************************************************** *** END OF MAIN PROGRAM - NOW COME THE SUBROUTINES **************** *********************************************************************** *********************************************************************** *********************************************************************** *** subroutine init *********************************************************************** subroutine init() implicit none INTEGER PYCOMP INTEGER NMXHEP C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) INTEGER MSTU,MSTJ DOUBLE PRECISION PARU,PARJ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) INTEGER MDCY,MDME,KFDP DOUBLE PRECISION BRAT COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) INTEGER MSEL,MSELPD,MSUB,KFIN DOUBLE PRECISION CKIN COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) INTEGER MSTP,MSTI DOUBLE PRECISION PARP,PARI COMMON/PYDATR/MRPY(6),RRPY(100) INTEGER MRPY DOUBLE PRECISION RRPY -C--use nuclear pdf? - COMMON/NPDF/MASS,NSET,EPS09,INITSTR - INTEGER NSET - DOUBLE PRECISION MASS - LOGICAL EPS09 - CHARACTER*10 INITSTR C--pdfset common/pdf/pdfset integer pdfset C--number of protons - common/np/nproton - integer nproton + common/np/nproton,mass + integer nproton,mass C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--splitting integral COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000), &SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT INTEGER NPOINT DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV, &QVAL,ZMVAL,QMAX,ZMMIN C--pdf common block COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000), &GINGX(2,1000) DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX C--cross secttion common block COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101), &INTG1(1001,101),INTG2(1001,101) DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2 C--Sudakov common block COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2) &,SUDAGC(1000,2) DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC C--exponential integral for negative arguments COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL INTEGER NVAL DOUBLE PRECISION EIXS,VALMAX C--discard event flag COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD LOGICAL DISCARD INTEGER NDISC,NSTRANGE,NGOOD,errcount double precision wdisc C--factor in front of formation times COMMON/FTIMEFAC/FTFAC DOUBLE PRECISION FTFAC C--factor in front of alphas argument COMMON/ALPHASFAC/PTFAC DOUBLE PRECISION PTFAC C--number of scattering events COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT C--number of extrapolations in tables common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf, &ntotxsec,noverxsec,ntotsuda,noversuda integer ntotspliti,noverspliti,ntotpdf,noverpdf, &ntotxsec,noverxsec,ntotsuda,noversuda C--event weight COMMON/WEIGHT/EVWEIGHT,sumofweights double precision EVWEIGHT,sumofweights C--event weight exponent COMMON/WEXPO/WEIGHTEX DOUBLE PRECISION WEIGHTEX C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--max rapidity common/rapmax/etamax double precision etamax C--memory for error message from getdeltat common/errline/errl integer errl C--organisation of event record common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro, &shorthepmc,channel,isochannel integer nsim,npart,offset,hadrotype double precision sqrts character*4 collider,channel character*2 isochannel logical hadro,shorthepmc C--extra storage for scattering centres before interactions common/storescatcen/nscatcen,maxnscatcen,scatflav(23000), &scatcen(23000,5),writescatcen,writedummies integer nscatcen,maxnscatcen,scatflav double precision scatcen logical writescatcen,writedummies C--Pythia parameters common/pythiaparams/PTMIN,PTMAX,weighted double precision PTMIN,PTMAX LOGICAL WEIGHTED C--Variables local to this program INTEGER NJOB,ios,pos,i,j,jj,intmass DOUBLE PRECISION GETLTIMEMAX,EOVEST,r,pyr character firstchar CHARACTER*2 SNSET CHARACTER*80 PDFFILE,XSECFILE,FILEMED,FILESPLIT,buffer, &label,value CHARACTER*120 HEPMCFILE,LOGFILE,FILENAME2 CHARACTER(LEN=100) filename LOGICAL PDFEXIST,SPLITIEXIST,XSECEXIST data maxnscatcen/22990/ HPMCFID = 4 logfid = 3 C--default settings nsim = 10000 njob = 0 logfile = 'out.log' hepmcfile = 'out.hepmc' filesplit = 'splitint.dat' pdffile = 'pdfs.dat' xsecfile = 'xsecs.dat' filemed = 'medium-params.dat' nf = 3 lqcd = 0.4 q0 = 1.5 ptmin = 5. ptmax = 350. etamax = 3.1 collider = 'PPJJ' isochannel = 'XX' channel = 'MUON' sqrts = 2760 pdfset = 10042 - nset = 1 - mass = 208. + mass = 208 nproton = 82 weighted = .true. weightex = 5. angord = .true. allhad = .false. hadro = .true. hadrotype = 0 shorthepmc = .true. compress = .true. writescatcen = .false. writedummies = .false. scatrecoil = .false. recsoftcut = 0. rechardcut = 5. kinmode = 1 recmode = 0 if (iargc().eq.0) then write(*,*)'No parameter file given, '// &'will run with default settings.' else call getarg(1,filename) write(*,*)'Reading parameters from ',filename open(unit=1,file=filename,status='old',err=110) do 120 i=1,1000 read(1, '(A)', iostat=ios) buffer if(ios.ne.0) goto 130 firstchar = buffer(1:1) if (firstchar.eq.'#') goto 120 pos=scan(buffer,' ') label=buffer(1:pos) value=buffer(pos+1:) if(label.eq."NEVENT")then read(value,*,iostat=ios) nsim elseif(label.eq."NJOB")then read(value,*,iostat=ios) njob elseif(label.eq."LOGFILE")then read(value,'(a)',iostat=ios) logfile elseif(label.eq."HEPMCFILE")then read(value,'(a)',iostat=ios) hepmcfile elseif(label.eq."SPLITINTFILE")then read(value,'(a)',iostat=ios) filesplit elseif(label.eq."PDFFILE")then read(value,'(a)',iostat=ios) pdffile elseif(label.eq."XSECFILE")then read(value,'(a)',iostat=ios) xsecfile elseif(label.eq."MEDIUMPARAMS")then read(value,'(a)',iostat=ios) filemed elseif(label.eq."NF")then read(value,*,iostat=ios) nf elseif(label.eq."LAMBDAQCD")then read(value,*,iostat=ios) lqcd elseif(label.eq."Q0")then read(value,*,iostat=ios) q0 elseif(label.eq."PTMIN")then read(value,*,iostat=ios) ptmin elseif(label.eq."PTMAX")then read(value,*,iostat=ios) ptmax elseif(label.eq."ETAMAX")then read(value,*,iostat=ios) etamax elseif(label.eq."PROCESS")then read(value,*,iostat=ios) collider elseif(label.eq."ISOCHANNEL")then read(value,*,iostat=ios) isochannel elseif(label.eq."CHANNEL")then read(value,*,iostat=ios) channel elseif(label.eq."SQRTS")then read(value,*,iostat=ios) sqrts elseif(label.eq."PDFSET")then read(value,*,iostat=ios) pdfset - elseif(label.eq."NSET")then - read(value,*,iostat=ios) nset elseif(label.eq."MASS")then read(value,*,iostat=ios) mass elseif(label.eq."NPROTON")then read(value,*,iostat=ios) nproton elseif(label.eq."WEIGHTED")then read(value,*,iostat=ios) weighted elseif(label.eq."WEXPO")then read(value,*,iostat=ios) weightex elseif(label.eq."ANGORD")then read(value,*,iostat=ios) angord elseif(label.eq."KEEPRECOILS")then read(value,*,iostat=ios) allhad elseif(label.eq."SCATRECOIL")then read(value,*,iostat=ios) scatrecoil elseif(label.eq."HADRO")then read(value,*,iostat=ios) hadro elseif(label.eq."HADROTYPE")then read(value,*,iostat=ios) hadrotype elseif(label.eq."SHORTHEPMC")then read(value,*,iostat=ios) shorthepmc elseif(label.eq."COMPRESS")then read(value,*,iostat=ios) compress elseif(label.eq."WRITESCATCEN")then read(value,*,iostat=ios) writescatcen elseif(label.eq."WRITEDUMMIES")then read(value,*,iostat=ios) writedummies elseif(label.eq."RECSOFTCUT")then read(value,*,iostat=ios) recsoftcut elseif(label.eq."RECHARDCUT")then read(value,*,iostat=ios) rechardcut elseif(label.eq."KINMODE")then read(value,*,iostat=ios) kinmode elseif(label.eq."RECMODE")then read(value,*,iostat=ios) recmode else write(*,*)'unknown label ',label endif 120 continue 110 write(*,*) & 'Unable to open parameter file, will exit the run.' call exit(1) 130 close(1,status='keep') write(*,*)'...done' endif lps = lqcd ! scatrecoil = .false. ! if (.not.hadro) shorthepmc = .true. if (recmode.eq.2) then allhad = .false. scatrecoil = .false. endif SCALEFACM=1. ptfac=1. ftfac=1.d0 if (ptmin.lt.3.d0) ptmin = 3.d0 if (.not.writescatcen) writedummies = .false. OPEN(unit=logfid,file=LOGFILE,status='unknown') MSTU(11)=logfid call printtime call printlogo(logfid) write(logfid,*) write(logfid,*)'parameters of the run:' write(logfid,*)'NEVENT = ',nsim write(logfid,*)'NJOB = ',njob write(logfid,*)'LOGFILE = ',logfile write(logfid,*)'HEPMCFILE = ',hepmcfile write(logfid,*)'SPLITINTFILE = ',filesplit write(logfid,*)'PDFFILE = ',pdffile write(logfid,*)'XSECFILE = ',xsecfile write(logfid,*)'MEDIUMPARAMS = ',filemed write(logfid,*)'NF = ',nf write(logfid,*)'LAMBDAQCD = ',lqcd write(logfid,*)'Q0 = ',q0 write(logfid,*)'PTMIN = ',ptmin write(logfid,*)'PTMAX = ',ptmax write(logfid,*)'ETAMAX = ',etamax write(logfid,*)'PROCESS = ',collider write(logfid,*)'ISOCHANNEL = ',isochannel write(logfid,*)'CHANNEL = ',channel write(logfid,*)'SQRTS = ',sqrts write(logfid,*)'PDFSET = ',pdfset - write(logfid,*)'NSET = ',nset write(logfid,*)'MASS = ',mass write(logfid,*)'NPROTON = ',nproton write(logfid,*)'WEIGHTED = ',weighted write(logfid,*)'WEXPO = ',weightex write(logfid,*)'ANGORD = ',angord write(logfid,*)'HADRO = ',hadro write(logfid,*)'HADROTYPE = ',hadrotype write(logfid,*)'SHORTHEPMC = ',shorthepmc write(logfid,*)'COMPRESS = ',compress write(logfid,*)'KEEPRECOILS = ',allhad write(logfid,*)'SCATRECOIL = ',scatrecoil write(logfid,*)'RECSOFTCUT = ',recsoftcut write(logfid,*)'RECHARDCUT = ',rechardcut write(logfid,*)'WRITESCATCEN = ',writescatcen write(logfid,*)'WRITEDUMMIES = ',writedummies write(logfid,*)'KINMODE = ',kinmode write(logfid,*)'RECMODE = ',recmode write(logfid,*) call flush(logfid) if ((collider.ne.'PPJJ').and.(collider.ne.'EEJJ') & .and.(collider.ne.'PPYJ').and.(collider.ne.'PPYQ') & .and.(collider.ne.'PPYG') & .and.(collider.ne.'PPZJ').and.(collider.ne.'PPZQ') & .and.(collider.ne.'PPZG').and.(collider.ne.'PPWJ') & .and.(collider.ne.'PPWQ').and.(collider.ne.'PPWG') & .and.(collider.ne.'PPDY')) then write(logfid,*)'Fatal error: colliding system unknown, '// & 'will exit now' call exit(1) endif C--initialize medium intmass = int(mass) CALL MEDINIT(FILEMED,logfid,etamax,intmass) CALL MEDNEXTEVT OPEN(unit=HPMCFID,file=HEPMCFILE,status='unknown') WRITE(HPMCFID,*) WRITE(HPMCFID,'(A)')'HepMC::Version 2.06.05' WRITE(HPMCFID,'(A)')'HepMC::IO_GenEvent-START_EVENT_LISTING' NPART=2 if(ptmax.gt.0.)then EOVEST=MIN(1.5*(PTMAX+50.)*COSH(ETAMAX),sqrts/2.) else EOVEST=sqrts/2. endif CALL EIXINT CALL INSUDAINT(EOVEST) write(logfid,*) INQUIRE(file=FILESPLIT,exist=SPLITIEXIST) IF(SPLITIEXIST)THEN write(logfid,*)'read splitting integrals from ',FILESPLIT OPEN(unit=10,file=FILESPLIT,status='old') READ(10,*)QMAX,ZMMIN,NPOINT DO 893 I=1,NPOINT+1 READ(10,*) QVAL(I),ZMVAL(I) 893 CONTINUE DO 891 I=1,NPOINT+1 DO 892 J=1,NPOINT+1 READ(10,*)SPLITIGGV(I,J),SPLITIQQV(I,J),SPLITIQGV(I,J) 892 CONTINUE 891 CONTINUE CLOSE(10,status='keep') ELSE write(logfid,*)'have to integrate splitting functions, '// &'this may take some time' CALL SPLITFNCINT(EOVEST) INQUIRE(file=FILESPLIT,exist=SPLITIEXIST) IF(.NOT.SPLITIEXIST)THEN write(logfid,*)'write splitting integrals to ',FILESPLIT OPEN(unit=10,file=FILESPLIT,status='new') WRITE(10,*)QMAX,ZMMIN,NPOINT DO 896 I=1,NPOINT+1 WRITE(10,*) QVAL(I),ZMVAL(I) 896 CONTINUE DO 897 I=1,NPOINT+1 DO 898 J=1,NPOINT+1 WRITE(10,*)SPLITIGGV(I,J),SPLITIQQV(I,J),SPLITIQGV(I,J) 898 CONTINUE 897 CONTINUE CLOSE(10,status='keep') ENDIF ENDIF write(logfid,*) INQUIRE(file=PDFFILE,exist=PDFEXIST) IF(PDFEXIST)THEN write(logfid,*)'read pdfs from ',PDFFILE OPEN(unit=10,file=PDFFILE,status='old') DO 872 I=1,2 DO 873 J=1,1000 READ(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J) 873 CONTINUE 872 CONTINUE CLOSE(10,status='keep') ELSE write(logfid,*)'have to integrate pdfs, this may take some time' CALL PDFINT(EOVEST) INQUIRE(file=PDFFILE,exist=PDFEXIST) IF(.NOT.PDFEXIST)THEN write(logfid,*)'write pdfs to ',PDFFILE OPEN(unit=10,file=PDFFILE,status='new') DO 876 I=1,2 DO 877 J=1,1000 WRITE(10,*)QINQX(I,J),GINQX(I,J),QINGX(I,J),GINGX(I,J) 877 CONTINUE 876 CONTINUE CLOSE(10,status='keep') ENDIF ENDIF write(logfid,*) INQUIRE(file=XSECFILE,exist=XSECEXIST) IF(XSECEXIST)THEN write(logfid,*)'read cross sections from ',XSECFILE OPEN(unit=10,file=XSECFILE,status='old') DO 881 J=1,1001 DO 885 JJ=1,101 READ(10,*)INTQ1(J,JJ),INTQ2(J,JJ), &INTG1(J,JJ),INTG2(J,JJ) 885 CONTINUE 881 CONTINUE CLOSE(10,status='keep') ELSE write(logfid,*)'have to integrate cross sections, '// &'this may take some time' CALL XSECINT(EOVEST) INQUIRE(file=XSECFILE,exist=XSECEXIST) IF(.NOT.XSECEXIST)THEN write(logfid,*)'write cross sections to ',XSECFILE OPEN(unit=10,file=XSECFILE,status='new') DO 883 J=1,1001 DO 884 JJ=1,101 WRITE(10,*)INTQ1(J,JJ),INTQ2(J,JJ), &INTG1(J,JJ),INTG2(J,JJ) 884 CONTINUE 883 CONTINUE CLOSE(10,status='keep') ENDIF ENDIF write(logfid,*) CALL FLUSH(3) C--initialise random number generator status IF(NJOB.GT.0)THEN MRPY(1)=NJOB*1000 MRPY(2)=0 ENDIF C--Call PYR once for initialization R=PYR(0) NDISC=0 NGOOD=0 NSTRANGE=0 ERRCOUNT=0 errl = 0 NSCAT=0.d0 NSCATEFF=0.d0 NSPLIT=0.d0 ntotspliti=0 noverspliti=0 ntotpdf=0 noverpdf=0 ntotxsec=0 noverxsec=0 ntotsuda=0 noversuda=0 - IF(NSET.EQ.0)THEN - EPS09=.FALSE. - ELSE - EPS09=.TRUE. - IF(NSET.LT.10)THEN - WRITE(SNSET,'(i1)') NSET - ELSE - WRITE(SNSET,'(i2)') NSET - ENDIF - INITSTR='EPS09LO,'//SNSET - ENDIF - end *********************************************************************** *** subroutine initpythia *********************************************************************** subroutine initpythia(beam1,beam2) implicit none INTEGER PYCOMP INTEGER NMXHEP C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) INTEGER MSTU,MSTJ DOUBLE PRECISION PARU,PARJ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) INTEGER MDCY,MDME,KFDP DOUBLE PRECISION BRAT COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) INTEGER MSEL,MSELPD,MSUB,KFIN DOUBLE PRECISION CKIN COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) INTEGER MSTP,MSTI DOUBLE PRECISION PARP,PARI COMMON/PYDATR/MRPY(6),RRPY(100) INTEGER MRPY DOUBLE PRECISION RRPY -C--use nuclear pdf? - COMMON/NPDF/MASS,NSET,EPS09,INITSTR - INTEGER NSET - DOUBLE PRECISION MASS - LOGICAL EPS09 - CHARACTER*10 INITSTR C--pdfset common/pdf/pdfset integer pdfset C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--discard event flag COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD LOGICAL DISCARD INTEGER NDISC,NSTRANGE,NGOOD,errcount double precision wdisc C--event weight COMMON/WEIGHT/EVWEIGHT,sumofweights double precision EVWEIGHT,sumofweights C--event weight exponent COMMON/WEXPO/WEIGHTEX DOUBLE PRECISION WEIGHTEX C--memory for error message from getdeltat common/errline/errl integer errl C--organisation of event record common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro, &shorthepmc,channel,isochannel integer nsim,npart,offset,hadrotype double precision sqrts character*4 collider,channel character*2 isochannel logical hadro,shorthepmc C--Pythia parameters common/pythiaparams/PTMIN,PTMAX,weighted double precision PTMIN,PTMAX LOGICAL WEIGHTED C--Variables local to this program character*2 beam1,beam2 C--initialise PYTHIA C--no multiple interactions MSTP(81) = 0 C--initial state radiation MSTP(61)=1 C--switch off final state radiation MSTP(71)=0 C--No hadronisation (yet) MSTP(111)=0 C--parameter affecting treatment of string corners PARU(14)=1. C--Min shat in simulation CKIN(1)=2. C--pT-cut CKIN(3)=PTMIN CKIN(4)=PTMAX C--use LHAPDF MSTP(52)=2 C--choose pdf: CTEQ6ll (LO fit/LO alphas) - 10042 C MSTW2008 (LO central) - 21000 MSTP(51)=PDFSET IF(COLLIDER.EQ.'PPYQ')THEN MSEL=0 MSUB(29)=1 ELSEIF(COLLIDER.EQ.'PPYG')THEN MSEL=0 MSUB(14)=1 MSUB(115)=1 ELSEIF(COLLIDER.EQ.'PPYJ')THEN MSEL=0 MSUB(14)=1 MSUB(29)=1 MSUB(115)=1 ELSEIF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZQ') & .or.(COLLIDER.EQ.'PPZG') & .or.(collider.eq.'PPDY'))THEN MSEL=0 IF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZQ')) MSUB(30)=1 IF((COLLIDER.EQ.'PPZJ').or.(COLLIDER.EQ.'PPZG')) MSUB(15)=1 IF(COLLIDER.EQ.'PPDY') MSUB(1)=1 MDME(174,1)=0 !Z decay into d dbar', MDME(175,1)=0 !Z decay into u ubar', MDME(176,1)=0 !Z decay into s sbar', MDME(177,1)=0 !Z decay into c cbar', MDME(178,1)=0 !Z decay into b bbar', MDME(179,1)=0 !Z decay into t tbar', MDME(182,1)=0 !Z decay into e- e+', MDME(183,1)=0 !Z decay into nu_e nu_ebar', MDME(184,1)=0 !Z decay into mu- mu+', MDME(185,1)=0 !Z decay into nu_mu nu_mubar', MDME(186,1)=0 !Z decay into tau- tau+', MDME(187,1)=0 !Z decay into nu_tau nu_taubar', if (channel.EQ.'ELEC')THEN MDME(182,1)=1 ELSEIF(channel.EQ.'MUON')THEN MDME(184,1)=1 ENDIF ELSEIF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWQ') & .or.(COLLIDER.EQ.'PPWG'))THEN MSEL=0 IF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWQ')) MSUB(31)=1 IF((COLLIDER.EQ.'PPWJ').or.(COLLIDER.EQ.'PPWG')) MSUB(16)=1 MDME(190,1)=0 ! W+ decay into dbar u, MDME(191,1)=0 ! W+ decay into dbar c, MDME(192,1)=0 ! W+ decay into dbar t, MDME(194,1)=0 ! W+ decay into sbar u, MDME(195,1)=0 ! W+ decay into sbar c, MDME(196,1)=0 ! W+ decay into sbar t, MDME(198,1)=0 ! W+ decay into bbar u, MDME(199,1)=0 ! W+ decay into bbar c, MDME(200,1)=0 ! W+ decay into bbar t, MDME(202,1)=0 ! W+ decay into b'bar u, MDME(203,1)=0 ! W+ decay into b'bar c, MDME(204,1)=0 ! W+ decay into b'bar t, MDME(206,1)=0 ! W+ decay into e+ nu_e, MDME(207,1)=0 ! W+ decay into mu+ nu_mu, MDME(208,1)=0 ! W+ decay into tau+ nu_tau, MDME(209,1)=0 ! W+ decay into tau'+ nu'_tau, if (channel.EQ.'ELEC')THEN MDME(206,1)=1 ELSEIF(channel.EQ.'MUON')THEN MDME(207,1)=1 ENDIF ELSE C--All QCD processes are active MSEL=1 ENDIF ! MSEL=0 ! MSUB(11)=1 ! MSUB(12)=1 ! MSUB(53)=1 ! MSUB(13)=1 ! MSUB(68)=1 ! MSUB(28)=1 C--weighted events IF(WEIGHTED) MSTP(142)=1 C--number of errors to be printed MSTU(22)=MAX(10,INT(5.*NSIM/100.)) C--number of lines in event record MSTU(4)=23000 MSTU(5)=23000 C--switch off pi0 decay MDCY(PYCOMP(111),1)=0 C--initialisation call IF(COLLIDER.EQ.'EEJJ')THEN OFFSET=9 CALL PYINIT('CMS',beam1,beam2,sqrts) ELSEIF((COLLIDER.EQ.'PPJJ').OR.(COLLIDER.EQ.'PPYJ').OR. & (COLLIDER.EQ.'PPYG').OR.(COLLIDER.EQ.'PPYQ'))THEN OFFSET=8 CALL PYINIT('CMS',beam1,beam2,sqrts) ELSEIF((COLLIDER.EQ.'PPWJ').OR.(COLLIDER.EQ.'PPZJ').or. & (COLLIDER.EQ.'PPWQ').OR.(COLLIDER.EQ.'PPZQ').or. & (COLLIDER.EQ.'PPWG').OR.(COLLIDER.EQ.'PPZG'))THEN OFFSET=10 CALL PYINIT('CMS',beam1,beam2,sqrts) elseif (collider.eq.'PPDY') then CALL PYINIT('CMS',beam1,beam2,sqrts) ENDIF end *********************************************************************** *** subroutine genevent *********************************************************************** subroutine genevent(j,b1,b2) implicit none C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid INTEGER PYCOMP INTEGER NMXHEP C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) INTEGER MSTU,MSTJ DOUBLE PRECISION PARU,PARJ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) INTEGER MDCY,MDME,KFDP DOUBLE PRECISION BRAT COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200) INTEGER MSEL,MSELPD,MSUB,KFIN DOUBLE PRECISION CKIN COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) INTEGER MSTP,MSTI DOUBLE PRECISION PARP,PARI COMMON/PYDATR/MRPY(6),RRPY(100) INTEGER MRPY DOUBLE PRECISION RRPY C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--discard event flag COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD LOGICAL DISCARD INTEGER NDISC,NSTRANGE,NGOOD,errcount double precision wdisc C--variables for angular ordering COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) DOUBLE PRECISION ZA,ZD,THETAA LOGICAL QQBARD C--factor in front of formation times COMMON/FTIMEFAC/FTFAC DOUBLE PRECISION FTFAC C--time common block COMMON/TIME/MV(23000,5) DOUBLE PRECISION MV C--colour index common block COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX INTEGER TRIP,ANTI,COLMAX C--number of scattering events COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT C--event weight COMMON/WEIGHT/EVWEIGHT,sumofweights double precision EVWEIGHT,sumofweights C--event weight exponent COMMON/WEXPO/WEIGHTEX DOUBLE PRECISION WEIGHTEX C--max rapidity common/rapmax/etamax double precision etamax C--production point common/jetpoint/x0,y0 double precision x0,y0 C--organisation of event record common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro, &shorthepmc,channel,isochannel integer nsim,npart,offset,hadrotype double precision sqrts character*4 collider,channel character*2 isochannel logical hadro,shorthepmc C--extra storage for scattering centres before interactions common/storescatcen/nscatcen,maxnscatcen,scatflav(23000), &scatcen(23000,5),writescatcen,writedummies integer nscatcen,maxnscatcen,scatflav double precision scatcen logical writescatcen,writedummies C--Variables local to this program INTEGER NOLD,PID,IPART,LME1,LME2,j,i,LME1ORIG,LME2ORIG,llep1, &llep2,lv DOUBLE PRECISION PYR,ENI,QMAX1,R,GETMASS,PYP,Q1,Q2,P21,P22,ETOT, &QMAX2,POLD,EN1,EN2,BETA(3),ENEW1,ENEW2,emax,lambda,x1,x2,x3, &MEWEIGHT,PSWEIGHT,WEIGHT,EPS1,EPS2,THETA1,THETA2,Z1,Z2, &getltimemax,pi,m1,m2 character*2 b1,b2 CHARACTER*2 TYPE1,TYPE2 LOGICAL FIRSTTRIP,WHICH1,WHICH2,ISDIQUARK DATA PI/3.141592653589793d0/ N=0 COLMAX=600 DISCARD=.FALSE. DO 91 I=1,23000 MV(I,1)=0.d0 MV(I,2)=0.d0 MV(I,3)=0.d0 MV(I,4)=0.d0 MV(I,5)=0.d0 + ZA(I)=0.d0 + ZD(I)=0.d0 + THETAA(I)=0.d0 + QQBARD(I)=.FALSE. 91 CONTINUE nscatcen = 0 CALL MEDNEXTEVT C--initialisation with matrix element C--production vertex CALL PICKVTX(X0,Y0) LTIME=GETLTIMEMAX() 99 CALL PYEVNT NPART=N-OFFSET EVWEIGHT=PARI(10) SUMOFWEIGHTS=SUMOFWEIGHTS+EVWEIGHT IF((COLLIDER.EQ.'EEJJ').AND.(ABS(K(8,2)).GT.6))THEN WDISC=WDISC+EVWEIGHT NDISC=NDISC+1 GOTO 102 ELSE NGOOD=NGOOD+1 ENDIF C--DY: don't have to do anything if (collider.eq.'PPDY') then CALL PYEXEC call CONVERTTOHEPMC(HPMCFID,NGOOD,PID,b1,b2) goto 102 endif C-- prepare event record if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or. & (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or. & (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN LME1ORIG=7 LME2ORIG=8 if(abs(k(7,2)).gt.21) then lv=7 else lv=8 endif ELSE LME1ORIG=OFFSET-1 LME2ORIG=OFFSET ENDIF DO 180 IPART=OFFSET+1, OFFSET+NPART C--find decay leptons in V+jet events if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or. & (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or. & (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN if(k(ipart,3).eq.offset-1) llep1=ipart if(k(ipart,3).eq.offset) llep2=ipart endif IF(K(IPART,3).EQ.(LME1ORIG))THEN LME1=IPART IF(K(IPART,2).EQ.21)THEN TYPE1='GC' ELSE TYPE1='QQ' ENDIF ELSEIF(K(IPART,3).EQ.LME2ORIG)THEN LME2=IPART IF(K(IPART,2).EQ.21)THEN TYPE2='GC' ELSE TYPE2='QQ' ENDIF ELSE TRIP(IPART)=0 ANTI(IPART)=0 ZD(IPART)=0.d0 THETAA(IPART)=0.d0 ENDIF C--assign colour indices IF(K(IPART,1).EQ.2)THEN IF(K(IPART-1,1).EQ.2)THEN C--in middle of colour singlet IF(FIRSTTRIP)THEN TRIP(IPART)=COLMAX+1 ANTI(IPART)=TRIP(IPART-1) ELSE TRIP(IPART)=ANTI(IPART-1) ANTI(IPART)=COLMAX+1 ENDIF COLMAX=COLMAX+1 ELSE C--beginning of colour singlet IF(((ABS(K(IPART,2)).LT.10).AND.(K(IPART,2).GT.0)) & .OR.(ISDIQUARK(K(IPART,2)).AND.(K(IPART,2).LT.0)))THEN TRIP(IPART)=COLMAX+1 ANTI(IPART)=0 FIRSTTRIP=.TRUE. ELSE TRIP(IPART)=0 ANTI(IPART)=COLMAX+1 FIRSTTRIP=.FALSE. ENDIF COLMAX=COLMAX+1 ENDIF ENDIF IF(K(IPART,1).EQ.1)THEN C--end of colour singlet IF(FIRSTTRIP)THEN TRIP(IPART)=0 ANTI(IPART)=TRIP(IPART-1) ELSE TRIP(IPART)=ANTI(IPART-1) ANTI(IPART)=0 ENDIF ENDIF 180 CONTINUE if (k(lme1,1).lt.11) K(LME1,1)=1 if (k(lme2,1).lt.11) K(LME2,1)=1 PID=K(LME1,2) ENI=MAX(P(LME1,4),P(LME2,4)) DO 183 IPART=OFFSET+1, OFFSET+NPART IF((IPART.NE.LME1).AND.(IPART.NE.LME2).AND.(K(IPART,1).LT.11)) & K(IPART,1)=4 if (k(ipart,2).eq.22) k(ipart,1)=4 183 CONTINUE C--find virtualities and adapt four-vectors if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or. & (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or. & (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN if (abs(k(lme1,2)).gt.21) then QMAX1=0.d0 QMAX2=sqrt(pari(18)+p(lme1,5)**2) else QMAX1=sqrt(pari(18)+p(lme2,5)**2) QMAX2=0.d0 endif EMAX=P(LME1,4)+P(LME2,4) THETA1=-1.d0 THETA2=-1.d0 ELSEIF(COLLIDER.EQ.'PPJJ'.OR.COLLIDER.EQ.'PPYJ' & .OR.COLLIDER.EQ.'PPYQ'.OR.COLLIDER.EQ.'PPYG')THEN if (k(lme1,1).eq.4) then qmax1 = 0.d0 else QMAX1=pari(17) endif if (k(lme2,1).eq.4) then qmax2 = 0.d0 else QMAX2=pari(17) endif ! QMAX1=PYP(LME1,10)*exp(0.3*abs(pyp(lme1,17)-pyp(lme2,17))/2.)/2. ! QMAX2=PYP(LME2,10)*exp(0.3*abs(pyp(lme1,17)-pyp(lme2,17))/2.)/2. EMAX=P(LME1,4)+P(LME2,4) THETA1=-1.d0 THETA2=-1.d0 ENDIF EN1=P(LME1,4) EN2=P(LME2,4) BETA(1)=(P(LME1,1)+P(LME2,1))/(P(LME1,4)+P(LME2,4)) BETA(2)=(P(LME1,2)+P(LME2,2))/(P(LME1,4)+P(LME2,4)) BETA(3)=(P(LME1,3)+P(LME2,3))/(P(LME1,4)+P(LME2,4)) CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) ETOT=P(LME1,4)+P(LME2,4) IF(COLLIDER.EQ.'EEJJ')THEN QMAX1=ETOT QMAX2=ETOT EMAX=P(LME1,4)+P(LME2,4) THETA1=-1.d0 THETA2=-1.d0 ENDIF C-- find virtuality Q1=GETMASS(0.d0,QMAX1,THETA1,EMAX,TYPE1,EMAX,.FALSE., & Z1,WHICH1) Q2=GETMASS(0.d0,QMAX2,THETA2,EMAX,TYPE2,EMAX,.FALSE., & Z2,WHICH2) 182 if (abs(k(lme1,2)).gt.21) then m1=p(lme1,5) else m1=q1 endif if (abs(k(lme2,2)).gt.21) then m2=p(lme2,5) else m2=q2 endif ENEW1=ETOT/2.d0 + (m1**2-m2**2)/(2.*ETOT) ENEW2=ETOT/2.d0 - (m1**2-m2**2)/(2.*ETOT) P21 = (ETOT/2.d0 + (m1**2-m2**2)/(2.*ETOT))**2 - m1**2 P22 = (ETOT/2.d0 - (m1**2-m2**2)/(2.*ETOT))**2 - m2**2 WEIGHT=1.d0 IF((PYR(0).GT.WEIGHT).OR.(P21.LT.0.d0).OR.(P22.LT.0.d0) & .OR.(ENEW1.LT.0.d0).OR.(ENEW2.LT.0.d0) & )THEN IF(Q1.GT.Q2)THEN Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE., & Z1,WHICH1) ELSE Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE., & Z2,WHICH2) ENDIF GOTO 182 ENDIF POLD=PYP(LME1,8) P(LME1,1)=P(LME1,1)*SQRT(P21)/POLD P(LME1,2)=P(LME1,2)*SQRT(P21)/POLD P(LME1,3)=P(LME1,3)*SQRT(P21)/POLD P(LME1,4)=ENEW1 P(LME1,5)=m1 POLD=PYP(LME2,8) P(LME2,1)=P(LME2,1)*SQRT(P22)/POLD P(LME2,2)=P(LME2,2)*SQRT(P22)/POLD P(LME2,3)=P(LME2,3)*SQRT(P22)/POLD P(LME2,4)=ENEW2 P(LME2,5)=m2 CALL PYROBO(LME1,LME1,0d0,0d0,BETA(1),BETA(2),BETA(3)) CALL PYROBO(LME2,LME2,0d0,0d0,BETA(1),BETA(2),BETA(3)) C--correct for overestimated energy IF(Q1.GT.0.d0)THEN EPS1=0.5-0.5*SQRT(1.-Q0**2/Q1**2) & *SQRT(1.-Q1**2/P(LME1,4)**2) IF((Z1.LT.EPS1).OR.(Z1.GT.(1.-EPS1)))THEN Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE., & Z1,WHICH1) CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) GOTO 182 ENDIF ENDIF IF(Q2.GT.0.d0)THEN EPS2=0.5-0.5*SQRT(1.-Q0**2/Q2**2) & *SQRT(1.-Q2**2/P(LME2,4)**2) IF((Z2.LT.EPS2).OR.(Z2.GT.(1.-EPS2)))THEN Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE., & Z2,WHICH2) CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) GOTO 182 ENDIF ENDIF C--correct to ME for first parton IF(COLLIDER.EQ.'EEJJ')THEN BETA(1)=(P(LME1,1)+P(LME2,1))/(P(LME1,4)+P(LME2,4)) BETA(2)=(P(LME1,2)+P(LME2,2))/(P(LME1,4)+P(LME2,4)) BETA(3)=(P(LME1,3)+P(LME2,3))/(P(LME1,4)+P(LME2,4)) CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) IF(Q1.GT.0.d0)THEN C--generate z value X1=Z1*(ETOT**2+Q1**2)/ETOT**2 X2=(ETOT**2-Q1**2)/ETOT**2 X3=(1.-Z1)*(ETOT**2+Q1**2)/ETOT**2 PSWEIGHT=(1.-X1)*(1.+(X1/(2.-X2))**2)/X3 & + (1.-X2)*(1.+(X2/(2.-X1))**2)/X3 MEWEIGHT=X1**2+X2**2 WEIGHT=MEWEIGHT/PSWEIGHT IF(PYR(0).GT.WEIGHT)THEN 184 Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE., & Z1,WHICH1) ENDIF ENDIF C--correct to ME for second parton IF(Q2.GT.0.d0)THEN C--generate z value X1=(ETOT**2-Q2**2)/ETOT**2 X2=Z2*(ETOT**2+Q2**2)/ETOT**2 X3=(1.-Z2)*(ETOT**2+Q2**2)/ETOT**2 PSWEIGHT=(1.-X1)*(1.+(X1/(2.-X2))**2)/X3 & + (1.-X2)*(1.+(X2/(2.-X1))**2)/X3 MEWEIGHT=X1**2+X2**2 WEIGHT=MEWEIGHT/PSWEIGHT IF(PYR(0).GT.WEIGHT)THEN 185 Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE., & Z2,WHICH2) ENDIF ENDIF 186 ENEW1=ETOT/2.d0 + (Q1**2-Q2**2)/(2.*ETOT) ENEW2=ETOT/2.d0 - (Q1**2-Q2**2)/(2.*ETOT) P21 = (ETOT/2.d0 + (Q1**2-Q2**2)/(2.*ETOT))**2 - Q1**2 P22 = (ETOT/2.d0 - (Q1**2-Q2**2)/(2.*ETOT))**2 - Q2**2 POLD=PYP(LME1,8) P(LME1,1)=P(LME1,1)*SQRT(P21)/POLD P(LME1,2)=P(LME1,2)*SQRT(P21)/POLD P(LME1,3)=P(LME1,3)*SQRT(P21)/POLD P(LME1,4)=ENEW1 P(LME1,5)=Q1 POLD=PYP(LME2,8) P(LME2,1)=P(LME2,1)*SQRT(P22)/POLD P(LME2,2)=P(LME2,2)*SQRT(P22)/POLD P(LME2,3)=P(LME2,3)*SQRT(P22)/POLD P(LME2,4)=ENEW2 P(LME2,5)=Q2 CALL PYROBO(LME1,LME1,0d0,0d0,BETA(1),BETA(2),BETA(3)) CALL PYROBO(LME2,LME2,0d0,0d0,BETA(1),BETA(2),BETA(3)) C--correct for overestimated energy IF(Q1.GT.0.d0)THEN EPS1=0.5-0.5*SQRT(1.-Q0**2/Q1**2) & *SQRT(1.-Q1**2/P(LME1,4)**2) IF((Z1.LT.EPS1).OR.(Z1.GT.(1.-EPS1)))THEN Q1=GETMASS(0.d0,Q1,THETA1,EMAX,TYPE1,EMAX,.FALSE., & Z1,WHICH1) CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) GOTO 186 ENDIF ENDIF IF(Q2.GT.0.d0)THEN EPS2=0.5-0.5*SQRT(1.-Q0**2/Q2**2) & *SQRT(1.-Q2**2/P(LME2,4)**2) IF((Z2.LT.EPS2).OR.(Z2.GT.(1.-EPS2)))THEN Q2=GETMASS(0.d0,Q2,THETA2,EMAX,TYPE2,EMAX,.FALSE., & Z2,WHICH2) CALL PYROBO(LME1,LME1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) CALL PYROBO(LME2,LME2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) GOTO 186 ENDIF ENDIF ENDIF C--transfer recoil to decay leptons in V+jet if((COLLIDER.EQ.'PPZJ').OR.(COLLIDER.EQ.'PPZQ').or. & (COLLIDER.EQ.'PPZG').or.(COLLIDER.EQ.'PPWJ').or. & (COLLIDER.EQ.'PPWQ').or.(COLLIDER.EQ.'PPWG'))THEN beta(1)=p(lv,1)/p(lv,4) beta(2)=p(lv,2)/p(lv,4) beta(3)=p(lv,3)/p(lv,4) CALL PYROBO(llep1,llep1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) CALL PYROBO(llep2,llep2,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) if (abs(k(lme1,2)).gt.21) then beta(1)=p(lme1,1)/p(lme1,4) beta(2)=p(lme1,2)/p(lme1,4) beta(3)=p(lme1,3)/p(lme1,4) else beta(1)=p(lme2,1)/p(lme2,4) beta(2)=p(lme2,2)/p(lme2,4) beta(3)=p(lme2,3)/p(lme2,4) endif CALL PYROBO(llep1,llep1,0d0,0d0,BETA(1),BETA(2),BETA(3)) CALL PYROBO(llep2,llep2,0d0,0d0,BETA(1),BETA(2),BETA(3)) endif ZA(LME1)=1.d0 ZA(LME2)=1.d0 THETAA(LME1)=P(LME1,5)/(SQRT(Z1*(1.-Z1))*P(LME1,4)) THETAA(LME2)=P(LME2,5)/(SQRT(Z2*(1.-Z2))*P(LME2,4)) ZD(LME1)=Z1 ZD(LME2)=Z2 QQBARD(LME1)=WHICH1 QQBARD(LME2)=WHICH2 MV(LME1,1)=X0 MV(LME1,2)=Y0 MV(LME1,3)=0.d0 MV(LME1,4)=0.d0 IF(P(LME1,5).GT.0.d0)THEN LAMBDA=1.d0/(FTFAC*P(LME1,4)*0.2/Q1**2) MV(LME1,5)=-LOG(1.d0-PYR(0))/LAMBDA ELSE MV(LME1,5)=LTIME ENDIF MV(LME2,1)=X0 MV(LME2,2)=Y0 MV(LME2,3)=0.d0 MV(LME2,4)=0.d0 IF(P(LME2,5).GT.0.d0)THEN LAMBDA=1.d0/(FTFAC*P(LME2,4)*0.2/Q2**2) MV(LME2,5)=-LOG(1.d0-PYR(0))/LAMBDA ELSE MV(LME2,5)=LTIME ENDIF C--develop parton shower CALL MAKECASCADE IF(DISCARD) THEN NGOOD=NGOOD-1 WDISC=WDISC+EVWEIGHT NDISC=NDISC+1 write(logfid,*)'discard event',J GOTO 102 ENDIF IF(.NOT.ALLHAD)THEN DO 86 I=1,N IF(K(I,1).EQ.3) K(I,1)=22 86 CONTINUE ENDIF IF(HADRO)THEN CALL MAKESTRINGS(HADROTYPE) IF(DISCARD) THEN write(logfid,*)'discard event',J WDISC=WDISC+EVWEIGHT NDISC=NDISC+1 NGOOD=NGOOD-1 GOTO 102 ENDIF CALL PYEXEC IF(MSTU(30).NE.ERRCOUNT)THEN write(logfid,*)'PYTHIA discards event',J, & ' (error number',MSTU(30),')' ERRCOUNT=MSTU(30) WDISC=WDISC+EVWEIGHT NDISC=NDISC+1 NGOOD=NGOOD-1 GOTO 102 ENDIF ENDIF IF(MSTU(30).NE.ERRCOUNT)THEN ERRCOUNT=MSTU(30) ELSE CALL CONVERTTOHEPMC(HPMCFID,NGOOD,PID,b1,b2) ENDIF C--write message to log-file 102 IF(NSIM.GT.100)THEN IF(MOD(J,NSIM/100).EQ.0)THEN write(logfid,*) 'done with event number ',J ENDIF else write(logfid,*) 'done with event number ',J ENDIF call flush(logfid) end *********************************************************************** *** subroutine makestrings *********************************************************************** SUBROUTINE MAKESTRINGS(WHICH) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid INTEGER WHICH IF(WHICH.EQ.0)THEN CALL MAKESTRINGS_VAC ELSEIF(WHICH.EQ.1)THEN CALL MAKESTRINGS_MINL ELSE WRITE(logfid,*)'error: unknown hadronisation type in MAKESTRINGS' ENDIF END *********************************************************************** *** subroutine makestrings_vac *********************************************************************** SUBROUTINE MAKESTRINGS_VAC IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--colour index common block COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX INTEGER TRIP,ANTI,COLMAX C--discard event flag COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD LOGICAL DISCARD INTEGER NDISC,NSTRANGE,NGOOD,errcount double precision wdisc C--local variables INTEGER NOLD,I,J,LQUARK,LMATCH,LLOOSE,NOLD1 DOUBLE PRECISION EADDEND,PYR,DIR LOGICAL ISDIQUARK,compressevent,roomleft DATA EADDEND/10.d0/ i = 0 if (compress) roomleft = compressevent(i) NOLD1=N C--remove all active lines that are leptons, gammas, hadrons etc. DO 52 I=1,NOLD1 IF((K(I,1).EQ.4).AND.(TRIP(I).EQ.0).AND.(ANTI(I).EQ.0))THEN C--copy line to end of event record N=N+1 IF(N.GT.22990) THEN write(logfid,*)'event too long for event record' DISCARD=.TRUE. RETURN ENDIF K(N,1)=11 K(N,2)=K(I,2) K(N,3)=I K(N,4)=0 K(N,5)=0 P(N,1)=P(I,1) P(N,2)=P(I,2) P(N,3)=P(I,3) P(N,4)=P(I,4) P(N,5)=P(I,5) K(I,1)=17 K(I,4)=N K(I,5)=N TRIP(N)=TRIP(I) ANTI(N)=ANTI(I) ENDIF 52 CONTINUE NOLD=N C--first do strings with existing (anti)triplets C--find string end (=quark or antiquark) 43 LQUARK=0 DO 40 I=1,NOLD IF((K(I,1).EQ.11).OR.(K(I,1).EQ.12).OR.(K(I,1).EQ.13) & .OR.(K(I,1).EQ.14)) K(I,1)=17 IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4).OR. & (K(I,1).EQ.5)).AND.((K(I,2).LT.6).OR.ISDIQUARK(K(I,2))))THEN LQUARK=I GOTO 41 ENDIF 40 CONTINUE GOTO 50 41 CONTINUE C--copy string end to end of event record N=N+1 IF(N.GT.22990) THEN write(logfid,*)'event too long for event record' DISCARD=.TRUE. RETURN ENDIF K(N,1)=2 K(N,2)=K(LQUARK,2) K(N,3)=LQUARK K(N,4)=0 K(N,5)=0 P(N,1)=P(LQUARK,1) P(N,2)=P(LQUARK,2) P(N,3)=P(LQUARK,3) P(N,4)=P(LQUARK,4) P(N,5)=P(LQUARK,5) K(LQUARK,1)=16 K(LQUARK,4)=N K(LQUARK,5)=N TRIP(N)=TRIP(LQUARK) ANTI(N)=ANTI(LQUARK) C--append matching colour partner LMATCH=0 DO 44 J=1,10000000 DO 42 I=1,NOLD IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4) & .OR.(K(I,1).EQ.5)) & .AND.(((TRIP(I).EQ.ANTI(N)).AND.(TRIP(I).NE.0)) & .OR.((ANTI(I).EQ.TRIP(N)).AND.(ANTI(I).NE.0))))THEN N=N+1 IF(N.GT.22990) THEN write(logfid,*)'event too long for event record' DISCARD=.TRUE. RETURN ENDIF K(N,2)=K(I,2) K(N,3)=I K(N,4)=0 K(N,5)=0 P(N,1)=P(I,1) P(N,2)=P(I,2) P(N,3)=P(I,3) P(N,4)=P(I,4) P(N,5)=P(I,5) TRIP(N)=TRIP(I) ANTI(N)=ANTI(I) K(I,1)=16 K(I,4)=N K(I,5)=N IF(K(I,2).EQ.21)THEN K(N,1)=2 GOTO 44 ELSE K(N,1)=1 GOTO 43 ENDIF ENDIF 42 CONTINUE C--no matching colour partner found write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '// &'colour singlet system, will discard event' discard = .true. return 44 CONTINUE C--now take care of purely gluonic remainder system C----------------------------------------- C--find gluon where anti-triplet is not matched 50 LLOOSE=0 DO 45 I=1,NOLD IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4) & .OR.(K(I,1).EQ.5)))THEN DO 46 J=1,NOLD IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4) & .OR.(K(I,1).EQ.5)))THEN IF(ANTI(I).EQ.TRIP(J)) GOTO 45 ENDIF 46 CONTINUE LLOOSE=I GOTO 47 ENDIF 45 CONTINUE GOTO 51 47 CONTINUE C--generate artificial triplet end write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '// &'colour singlet system, will discard event' discard = .true. return C--copy loose gluon to end of event record N=N+1 IF(N.GT.22990) THEN write(logfid,*)'event too long for event record' DISCARD=.TRUE. RETURN ENDIF K(N,1)=2 K(N,2)=K(LLOOSE,2) K(N,3)=LLOOSE K(N,4)=0 K(N,5)=0 P(N,1)=P(LLOOSE,1) P(N,2)=P(LLOOSE,2) P(N,3)=P(LLOOSE,3) P(N,4)=P(LLOOSE,4) P(N,5)=P(LLOOSE,5) K(LLOOSE,1)=16 K(LLOOSE,4)=N K(LLOOSE,5)=N TRIP(N)=TRIP(LLOOSE) ANTI(N)=ANTI(LLOOSE) C--append matching colour partner LMATCH=0 DO 48 J=1,10000000 DO 49 I=1,NOLD IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4) & .OR.(K(I,1).EQ.5)) & .AND.(ANTI(I).EQ.TRIP(N)))THEN N=N+1 IF(N.GT.22990) THEN write(logfid,*)'event too long for event record' DISCARD=.TRUE. RETURN ENDIF K(N,2)=K(I,2) K(N,3)=I K(N,4)=0 K(N,5)=0 P(N,1)=P(I,1) P(N,2)=P(I,2) P(N,3)=P(I,3) P(N,4)=P(I,4) P(N,5)=P(I,5) TRIP(N)=TRIP(I) ANTI(N)=ANTI(I) K(I,1)=16 K(I,4)=N K(I,5)=N K(N,1)=2 GOTO 48 ENDIF 49 CONTINUE C--no matching colour partner found, add artificial end point write(logfid,*)'Error in MAKESTRINGS_VAC: failed to reconstruct '// &'colour singlet system, will discard event' discard = .true. return 48 CONTINUE 51 CONTINUE CALL CLEANUP(NOLD1) END *********************************************************************** *** subroutine makestrings_minl *********************************************************************** SUBROUTINE MAKESTRINGS_MINL IMPLICIT NONE C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--colour index common block COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX INTEGER TRIP,ANTI,COLMAX C--local variables INTEGER NOLD,I,J,LMAX,LMIN,LEND,nold1 DOUBLE PRECISION EMAX,MINV,MMIN,Z,GENERATEZ,MCUT,EADDEND,PYR,DIR, &pyp DATA MCUT/1.d8/ DATA EADDEND/10.d0/ C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--discard event flag COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD LOGICAL DISCARD INTEGER NDISC,NSTRANGE,NGOOD,errcount double precision wdisc logical compressevent,roomleft i = 0 if (compress) roomleft = compressevent(i) NOLD1=N C--remove all active lines that are leptons, gammas, hadrons etc. DO 52 I=1,NOLD1 IF((K(I,1).EQ.4).AND.(TRIP(I).EQ.0).AND.(ANTI(I).EQ.0))THEN C--copy line to end of event record N=N+1 IF(N.GT.22990) THEN write(logfid,*)'event too long for event record' DISCARD=.TRUE. RETURN ENDIF K(N,1)=11 K(N,2)=K(I,2) K(N,3)=I K(N,4)=0 K(N,5)=0 P(N,1)=P(I,1) P(N,2)=P(I,2) P(N,3)=P(I,3) P(N,4)=P(I,4) P(N,5)=P(I,5) K(I,1)=17 K(I,4)=N K(I,5)=N TRIP(N)=TRIP(I) ANTI(N)=ANTI(I) ENDIF 52 CONTINUE NOLD=N C--find most energetic unfragmented parton in event 43 EMAX=0 LMAX=0 DO 40 I=1,NOLD IF((K(I,1).EQ.11).OR.(K(I,1).EQ.12).OR.(K(I,1).EQ.13) & .OR.(K(I,1).EQ.14)) K(I,1)=17 if (abs(pyp(I,17)).gt.4.d0) k(i,1)=17 IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1).EQ.4) & .OR.(K(I,1).EQ.5)).AND.(P(I,4).GT.EMAX))THEN EMAX=P(I,4) LMAX=I ENDIF 40 CONTINUE C--if there is non, we are done IF(LMAX.EQ.0) GOTO 50 C--check if highest energy parton is (anti)quark or gluon IF(K(LMAX,2).EQ.21)THEN C--split gluon in qqbar pair and store one temporarily in line 1 C--make new line in event record for string end N=N+2 IF(N.GT.22990) THEN write(logfid,*)'event too long for event record' DISCARD=.TRUE. RETURN ENDIF IF((N-2).GT.NOLD)THEN DO 47 J=NOLD,N-3 K(N+NOLD-J,1)=K(N+NOLD-J-2,1) K(N+NOLD-J,2)=K(N+NOLD-J-2,2) IF(K(N+NOLD-J-2,3).GT.NOLD) THEN K(N+NOLD-J,3)=K(N+NOLD-J-2,3)+2 ELSE K(N+NOLD-J,3)=K(N+NOLD-J-2,3) ENDIF K(N+NOLD-J,4)=0 K(N+NOLD-J,5)=0 P(N+NOLD-J,1)=P(N+NOLD-J-2,1) P(N+NOLD-J,2)=P(N+NOLD-J-2,2) P(N+NOLD-J,3)=P(N+NOLD-J-2,3) P(N+NOLD-J,4)=P(N+NOLD-J-2,4) P(N+NOLD-J,5)=P(N+NOLD-J-2,5) K(K(N+NOLD-J-2,3),4)=K(K(N+NOLD-J-2,3),4)+2 K(K(N+NOLD-J-2,3),5)=K(K(N+NOLD-J-2,3),5)+2 47 CONTINUE ENDIF NOLD=NOLD+2 K(LMAX,1)=18 Z=GENERATEZ(0.d0,0.d0,1.d-3,'QG') IF(Z.GT.0.5)THEN K(NOLD-1,2)=1 K(NOLD,2)=-1 ELSE Z=1.-Z K(NOLD-1,2)=-1 K(NOLD,2)=1 ENDIF K(NOLD-1,1)=1 K(NOLD-1,3)=LMAX K(NOLD-1,4)=0 K(NOLD-1,5)=0 P(NOLD-1,1)=(1.-Z)*P(LMAX,1) P(NOLD-1,2)=(1.-Z)*P(LMAX,2) P(NOLD-1,3)=(1.-Z)*P(LMAX,3) P(NOLD-1,4)=(1.-Z)*P(LMAX,4) P(NOLD-1,5)=P(LMAX,5) K(NOLD,1)=1 K(NOLD,3)=LMAX K(NOLD,4)=0 K(NOLD,5)=0 P(NOLD,1)=Z*P(LMAX,1) P(NOLD,2)=Z*P(LMAX,2) P(NOLD,3)=Z*P(LMAX,3) P(NOLD,4)=Z*P(LMAX,4) P(NOLD,5)=P(LMAX,5) K(LMAX,1)=18 K(LMAX,4)=NOLD-1 K(LMAX,5)=NOLD LMAX=NOLD ENDIF N=N+1 IF(N.GT.22990) THEN write(logfid,*)'event too long for event record' DISCARD=.TRUE. RETURN ENDIF K(N,1)=2 K(N,2)=K(LMAX,2) K(N,3)=LMAX K(N,4)=0 K(N,5)=0 P(N,1)=P(LMAX,1) P(N,2)=P(LMAX,2) P(N,3)=P(LMAX,3) P(N,4)=P(LMAX,4) P(N,5)=P(LMAX,5) K(LMAX,1)=16 K(LMAX,4)=N K(LMAX,5)=N LEND=LMAX C--find closest partner 42 MMIN=1.d10 LMIN=0 DO 41 I=1,NOLD IF(((K(I,1).EQ.1).OR.(K(I,1).EQ.3).OR.(K(I,1) & .EQ.4).OR.(K(I,1).EQ.5)) & .AND.((K(I,2).EQ.21).OR.((K(I,2)*K(LEND,2).LT.0.d0).AND. & (K(I,3).NE.K(LEND,3)))) & .AND.(P(I,1)*P(LEND,1).GT.0.d0))THEN MINV=P(I,4)*P(LMAX,4)-P(I,1)*P(LMAX,1)-P(I,2)*P(LMAX,2) & -P(I,3)*P(LMAX,3) IF((MINV.LT.MMIN).AND.(MINV.GT.0.d0).AND.(MINV.LT.MCUT))THEN MMIN=MINV LMIN=I ENDIF ENDIF 41 CONTINUE C--if no closest partner can be found, generate artificial end point for string IF(LMIN.EQ.0)THEN N=N+1 IF(N.GT.22990) THEN write(logfid,*)'event too long for event record' DISCARD=.TRUE. RETURN ENDIF K(N,1)=1 K(N,2)=-K(LEND,2) K(N,3)=0 K(N,4)=0 K(N,5)=0 P(N,1)=0.d0 P(N,2)=0.d0 IF(PYR(0).LT.0.5)THEN DIR=1.d0 ELSE DIR=-1.d0 ENDIF P(N,3)=DIR*EADDEND P(N,4)=EADDEND P(N,5)=0.d0 GOTO 43 ELSE C--else build closest partner in string N=N+1 IF(N.GT.22990) THEN write(logfid,*)'event too long for event record' DISCARD=.TRUE. RETURN ENDIF K(N,2)=K(LMIN,2) K(N,3)=LMIN K(N,4)=0 K(N,5)=0 P(N,1)=P(LMIN,1) P(N,2)=P(LMIN,2) P(N,3)=P(LMIN,3) P(N,4)=P(LMIN,4) P(N,5)=P(LMIN,5) K(LMIN,1)=16 K(LMIN,4)=N K(LMIN,5)=N IF(K(LMIN,2).EQ.21)THEN K(N,1)=2 LMAX=LMIN GOTO 42 ELSE K(N,1)=1 GOTO 43 ENDIF ENDIF 50 CONTINUE CALL CLEANUP(NOLD) END *********************************************************************** *** subroutine cleanup *********************************************************************** SUBROUTINE CLEANUP(NFIRST) IMPLICIT NONE C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--local variables INTEGER NFIRST,NLAST,I,J NLAST=N DO 21 I=1,NLAST-NFIRST DO 22 J=1,5 K(I,J)=K(NFIRST+I,J) P(I,J)=P(NFIRST+I,J) V(I,J)=V(NFIRST+I,J) 22 CONTINUE K(I,3)=0 21 CONTINUE N=NLAST-NFIRST END *********************************************************************** *** subroutine makecascade *********************************************************************** SUBROUTINE MAKECASCADE IMPLICIT NONE C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--time common block COMMON/TIME/MV(23000,5) DOUBLE PRECISION MV C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--discard event flag COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD LOGICAL DISCARD INTEGER NDISC,NSTRANGE,NGOOD,errcount double precision wdisc C--local variables INTEGER NOLD,I LOGICAL CONT 10 NOLD=N CONT=.FALSE. DO 11 I=2,NOLD if (i.gt.n) goto 10 C--check if parton may evolve, i.e. do splitting or scattering IF((K(I,1).EQ.1).OR.(K(I,1).EQ.2))THEN CONT=.TRUE. CALL MAKEBRANCH(I) IF(DISCARD) GOTO 12 ENDIF 11 CONTINUE IF(CONT) GOTO 10 12 END *********************************************************************** *** subroutine makebranch *********************************************************************** SUBROUTINE MAKEBRANCH(L) IMPLICIT NONE C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--time common block COMMON/TIME/MV(23000,5) DOUBLE PRECISION MV C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--discard event flag COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD LOGICAL DISCARD INTEGER NDISC,NSTRANGE,NGOOD,errcount double precision wdisc C--variables for angular ordering COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) DOUBLE PRECISION ZA,ZD,THETAA LOGICAL QQBARD C--number of scattering events COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT C--variables for coherent scattering COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10), &QSUMVEC(4),QSUM2 INTEGER NSTART,NEND DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2 C--event weight COMMON/WEIGHT/EVWEIGHT,sumofweights double precision EVWEIGHT,sumofweights C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--extra storage for scattering centres before interactions common/storescatcen/nscatcen,maxnscatcen,scatflav(23000), & scatcen(23000,5),writescatcen,writedummies integer nscatcen,maxnscatcen,scatflav double precision scatcen logical writescatcen,writedummies C--local variables INTEGER L,LINE,NOLD,TYPI,LINEOLD,LKINE,nendold,nscatcenold integer oldstcode DOUBLE PRECISION THETA,PHI,PYP,FORMTIME,STARTTIME,TLEFT, &TSUM,DELTAT,NEWMASS,GETMASS,Q,GETMS,ZDEC,X,DTCORR LOGICAL OVERQ0,QQBARDEC CHARACTER TYP LOGICAL RADIATION,RETRYSPLIT,MEDIND,roomleft,compressevent LINE=L NSTART=0 NEND=0 STARTTIME=MV(LINE,4) TSUM=0.d0 QSUM2=0.d0 QSUMVEC(1)=0.d0 QSUMVEC(2)=0.d0 QSUMVEC(3)=0.d0 QSUMVEC(4)=0.d0 RETRYSPLIT=.FALSE. MEDIND=.FALSE. X=0.d0 Q=0.d0 TYPI=0 20 IF(DISCARD) RETURN IF ((N.GT.20000).and.compress) roomleft = compressevent(line) IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0)) & .OR.((K(LINE,1).EQ.2).AND.(zd(line).gt.0.d0)))THEN IF(MEDIND)THEN FORMTIME=starttime ELSE FORMTIME=MIN(MV(LINE,5),LTIME) ENDIF RADIATION=.TRUE. ELSE FORMTIME=LTIME RADIATION=.FALSE. ENDIF TLEFT=FORMTIME-STARTTIME IF(K(LINE,2).EQ.21)THEN TYP='G' ELSE TYP='Q' ENDIF MEDIND=.FALSE. IF(TLEFT.LE.1.d-10)THEN C--no scattering IF(RADIATION)THEN C--if there is radiation associated with the parton then form it now C--rotate such that momentum points in z-direction NOLD=N nscatcenold=nscatcen THETA=PYP(LINE,13) PHI=PYP(LINE,15) CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0) CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0) CALL MAKESPLITTING(LINE) C--rotate back CALL PYROBO(LINE,LINE,THETA,0d0,0d0,0d0,0d0) CALL PYROBO(LINE,LINE,0d0,PHI,0d0,0d0,0d0) IF(DISCARD) RETURN CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0) CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0) C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother MV(N-1,1)=MV(LINE,1) & +(MV(N-1,4)-MV(LINE,4))*P(LINE,1)/max(pyp(line,8),P(LINE,4)) MV(N-1,2)=MV(LINE,2) & +(MV(N-1,4)-MV(LINE,4))*P(LINE,2)/max(pyp(line,8),P(LINE,4)) MV(N-1,3)=MV(LINE,3) & +(MV(N-1,4)-MV(LINE,4))*P(LINE,3)/max(pyp(line,8),P(LINE,4)) MV(N, 1)=MV(LINE,1) & +(MV(N, 4)-MV(LINE,4))*P(LINE,1)/max(pyp(line,8),P(LINE,4)) MV(N, 2)=MV(LINE,2) & +(MV(N, 4)-MV(LINE,4))*P(LINE,2)/max(pyp(line,8),P(LINE,4)) MV(N, 3)=MV(LINE,3) & +(MV(N, 4)-MV(LINE,4))*P(LINE,3)/max(pyp(line,8),P(LINE,4)) LINE=N NSTART=0 NEND=0 STARTTIME=MV(N,4) QSUMVEC(1)=0.d0 QSUMVEC(2)=0.d0 QSUMVEC(3)=0.d0 QSUMVEC(4)=0.d0 QSUM2=0.d0 TSUM=0.d0 GOTO 21 ELSE NSTART=0 NEND=0 STARTTIME=FORMTIME QSUMVEC(1)=0.d0 QSUMVEC(2)=0.d0 QSUMVEC(3)=0.d0 QSUMVEC(4)=0.d0 QSUM2=0.d0 TSUM=0.d0 GOTO 21 ENDIF ELSE C--do scattering C--find delta t for the scattering DELTAT=TLEFT OVERQ0=.FALSE. CALL DOINSTATESCAT(LINE,X,TYPI,Q,STARTTIME+TSUM,DELTAT, & OVERQ0,.FALSE.) TSUM=TSUM+DELTAT TLEFT=TLEFT-DELTAT C--do initial state splitting if there is one NOLD=N LINEOLD=LINE oldstcode=k(line,1) ZDEC=ZD(LINE) QQBARDEC=QQBARD(LINE) nscatcenold=nscatcen 25 IF(X.LT.1.d0) THEN CALL MAKEINSPLIT(LINE,X,QSUM2,Q,TYPI,STARTTIME+TSUM,DELTAT) IF(DISCARD) RETURN IF(X.LT.1.d0)THEN LINE=N LKINE=N IF(K(LINE,2).EQ.21)THEN NEWMASS=GETMASS(0.d0,SCALEFACM*SQRT(-QSUM2),-1.d0,P(LINE,4), & 'GC',SQRT(-QSUM2),.FALSE.,ZDEC,QQBARDEC) IF(ZDEC.GT.0.d0)THEN THETAA(LINE)=NEWMASS/(SQRT(ZDEC*(1.-ZDEC))*P(LINE,4)) ELSE THETAA(LINE)=0.d0 ENDIF ZD(LINE)=ZDEC QQBARD(LINE)=QQBARDEC ELSE NEWMASS=GETMASS(0.d0,SCALEFACM*SQRT(-QSUM2),-1.d0,P(LINE,4), & 'QQ',SQRT(-QSUM2),.FALSE.,ZDEC,QQBARDEC) IF(ZDEC.GT.0.d0)THEN THETAA(LINE)=NEWMASS/(SQRT(ZDEC*(1.-ZDEC))*P(LINE,4)) ELSE THETAA(LINE)=0.d0 ENDIF ZD(LINE)=ZDEC QQBARD(LINE)=QQBARDEC ENDIF ZDEC=ZD(LINE) QQBARDEC=QQBARD(LINE) ELSE LKINE=LINE NEND=NSTART QSUM2=ALLQS(NEND,1) QSUMVEC(1)=ALLQS(NEND,2) QSUMVEC(2)=ALLQS(NEND,3) QSUMVEC(3)=ALLQS(NEND,4) QSUMVEC(4)=ALLQS(NEND,5) IF(-ALLQS(NEND,1).GT.Q0**2/SCALEFACM**2)THEN OVERQ0=.TRUE. ELSE OVERQ0=.FALSE. ENDIF tleft = starttime+tsum+tleft-allqs(1,6) tsum = allqs(1,6)-starttime ENDIF ENDIF IF(X.EQ.1.d0)THEN NEWMASS=0.d0 IF(NEND.GT.0)THEN CALL DOFISTATESCAT(LINE,STARTTIME+TSUM,TLEFT,DELTAT, & NEWMASS,OVERQ0,ZDEC,QQBARDEC) IF(NEWMASS.GT.(P(LINE,5)*(1.d0+1.d-6)))THEN MEDIND=.TRUE. ELSE MEDIND=.FALSE. ZDEC=ZD(LINE) QQBARDEC=QQBARD(LINE) ENDIF TSUM=TSUM+DELTAT TLEFT=TLEFT-DELTAT LKINE=LINE ENDIF ENDIF C--do kinematics RETRYSPLIT=.FALSE. IF(NEND.GT.0) THEN nendold=nend CALL DOKINEMATICS(LKINE,lineold,NSTART,NEND,NEWMASS,RETRYSPLIT, & STARTTIME+TSUM,X,ZDEC,QQBARDEC) IF(RETRYSPLIT) THEN tleft = starttime+tsum+tleft-allqs(1,6) tsum = allqs(1,6)-starttime if (x.lt.1.d0) then NEND=NSTART QSUM2=ALLQS(NEND,1) QSUMVEC(1)=ALLQS(NEND,2) QSUMVEC(2)=ALLQS(NEND,3) QSUMVEC(3)=ALLQS(NEND,4) QSUMVEC(4)=ALLQS(NEND,5) TYPI=K(L,2) IF(-ALLQS(NEND,1).GT.Q0**2/SCALEFACM**2)THEN OVERQ0=.TRUE. ELSE OVERQ0=.FALSE. ENDIF N=NOLD LINE=LINEOLD X=1.d0 K(LINE,1)=oldstcode ! K(LINE,1)=1 nscatcen=nscatcenold NSPLIT=NSPLIT-EVWEIGHT GOTO 25 else LINE=N STARTTIME=STARTTIME+TSUM TSUM=0.d0 endif ELSE LINE=N STARTTIME=STARTTIME+TSUM TSUM=0.d0 ENDIF ELSE STARTTIME=STARTTIME+TSUM TSUM=0.d0 ENDIF ! IF(P(LINE,5).GT.0.d0) RADIATION=.TRUE. IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0)) & .OR.((K(LINE,1).EQ.2).AND.(zd(line).gt.0.d0))) RADIATION=.TRUE. ENDIF 21 IF(((K(LINE,1).EQ.1).AND.(P(LINE,5).GT.0.d0)) & .OR.((K(LINE,1).EQ.2).AND.(zd(line).gt.0.d0)) & .OR.(STARTTIME.LT.LTIME))THEN GOTO 20 ENDIF IF((K(LINE,1).EQ.1).AND.(P(LINE,5).EQ.0.d0)) K(LINE,1)=4 IF((K(LINE,1).EQ.2).AND.(zd(line).lt.0.d0)) K(LINE,1)=5 END *********************************************************************** *** subroutine makesplitting *********************************************************************** SUBROUTINE MAKESPLITTING(L) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--time common block COMMON/TIME/MV(23000,5) DOUBLE PRECISION MV C--factor in front of formation times COMMON/FTIMEFAC/FTFAC DOUBLE PRECISION FTFAC C--colour index common block COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX INTEGER TRIP,ANTI,COLMAX C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--discard event flag COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD LOGICAL DISCARD INTEGER NDISC,NSTRANGE,NGOOD,errcount double precision wdisc C--variables for angular ordering COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) DOUBLE PRECISION ZA,ZD,THETAA LOGICAL QQBARD C--number of scattering events COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT C--event weight COMMON/WEIGHT/EVWEIGHT,sumofweights double precision EVWEIGHT,sumofweights C--local variables INTEGER L,DIR DOUBLE PRECISION PHIQ,PYR,PI,GENERATEZ,BMAX1,CMAX1,PTS,MB,MC, &GETMASS,PZ,EPS,QH,Z,R,LAMBDA,WEIGHT,ZDECB,ZDECC,XDEC(3),THETA, &GETTEMP LOGICAL QUARK,QQBAR,QQBARDECB,QQBARDECC integer bin DATA PI/3.141592653589793d0/ IF((N+2).GT.22990) THEN write(logfid,*)'event too long for event record' DISCARD=.TRUE. RETURN ENDIF XDEC(1)=MV(L,1)+(MV(L,5)-MV(L,4))*P(L,1)/P(L,4) XDEC(2)=MV(L,2)+(MV(L,5)-MV(L,4))*P(L,2)/P(L,4) XDEC(3)=MV(L,3)+(MV(L,5)-MV(L,4))*P(L,3)/P(L,4) IF(GETTEMP(XDEC(1),XDEC(2),XDEC(3),MV(L,5)).GT.0.d0)THEN THETA=-1.d0 ELSE THETA=THETAA(L) ENDIF C--on-shell partons cannot split IF((P(L,5).EQ.0d0).OR.(K(L,1).EQ.11).OR.(K(L,1).EQ.12) & .OR.(K(L,1).EQ.13).OR.(K(L,1).EQ.14).OR.(K(L,1).EQ.3) & .or.(zd(l).lt.0.d0)) GOTO 31 C--quark or gluon? IF(K(L,2).EQ.21)THEN QUARK=.FALSE. ELSE QUARK=.TRUE. QQBAR=.FALSE. ENDIF C--if gluon decide on kind of splitting QQBAR=QQBARD(L) C--if g->gg splitting decide on colour order IF(QUARK.OR.QQBAR)THEN DIR=0 ELSE IF(PYR(0).LT.0.5)THEN DIR=1 ELSE DIR=-1 ENDIF ENDIF Z=ZD(L) IF(Z.EQ.0.d0)THEN write(logfid,*)'makesplitting: z=0',L goto 36 ENDIF GOTO 35 C--generate z value 36 IF(ANGORD.AND.(ZA(L).NE.1.d0))THEN C--additional z constraint due to angular ordering QH=4.*P(L,5)**2*(1.-ZA(L))/(ZA(L)*P(K(L,3),5)**2) IF(QH.GT.1)THEN write(logfid,*)L,': reject event: angular ordering & conflict in medium' CALL PYLIST(3) DISCARD=.TRUE. GOTO 31 ENDIF EPS=0.5-0.5*SQRT(1.-QH) ELSE EPS=0d0 ENDIF IF(QUARK)THEN Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'QQ') ELSE IF(QQBAR)THEN Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'QG') ELSE Z=GENERATEZ(P(L,5)**2,P(L,4),EPS,'GG') ENDIF ENDIF 35 CONTINUE C--maximum virtualities for daughters BMAX1=MIN(P(L,5),Z*P(L,4)) CMAX1=MIN(P(L,5),(1.-Z)*P(L,4)) C--generate mass of quark or gluon (particle b) from Sudakov FF 30 IF(QUARK.OR.QQBAR)THEN MB=GETMASS(0.d0,BMAX1,THETA,Z*P(L,4),'QQ', & BMAX1,.FALSE.,ZDECB,QQBARDECB) ELSE MB=GETMASS(0.d0,BMAX1,THETA,Z*P(L,4),'GC', & BMAX1,.FALSE.,ZDECB,QQBARDECB) ENDIF C--generate mass gluon (particle c) from Sudakov FF IF(QUARK.OR.(.NOT.QQBAR))THEN MC=GETMASS(0.d0,CMAX1,THETA,(1.-Z)*P(L,4),'GC', & CMAX1,.FALSE.,ZDECC,QQBARDECC) ELSE MC=GETMASS(0.d0,CMAX1,THETA,(1.-Z)*P(L,4),'QQ', & CMAX1,.FALSE.,ZDECC,QQBARDECC) ENDIF C--quark (parton b) momentum 182 PZ=(2.*Z*P(L,4)**2-P(L,5)**2-MB**2+MC**2)/(2.*P(L,3)) PTS=Z**2*(P(L,4)**2)-PZ**2-MB**2 C--if kinematics doesn't work out, generate new virtualities C for daughters C--massive phase space weight IF((MB.EQ.0.d0).AND.(MC.EQ.0.d0).AND.(PTS.LT.0.d0)) GOTO 36 WEIGHT=1.d0 IF((PYR(0).GT.WEIGHT).OR.(PTS.LT.0.d0) & .OR.((MB+MC).GT.P(L,5)))THEN IF(MB.GT.MC)THEN IF(QUARK.OR.QQBAR)THEN MB=GETMASS(0.d0,MB,THETA,Z*P(L,4),'QQ', & BMAX1,.FALSE.,ZDECB,QQBARDECB) ELSE MB=GETMASS(0.d0,MB,THETA,Z*P(L,4),'GC', & BMAX1,.FALSE.,ZDECB,QQBARDECB) ENDIF ELSE IF(QUARK.OR.(.NOT.QQBAR))THEN MC=GETMASS(0.d0,MC,THETA,(1.-Z)*P(L,4),'GC', & CMAX1,.FALSE.,ZDECC,QQBARDECC) ELSE MC=GETMASS(0.d0,MC,THETA,(1.-Z)*P(L,4),'QQ', & CMAX1,.FALSE.,ZDECC,QQBARDECC) ENDIF ENDIF GOTO 182 ENDIF N=N+2 C--take care of first daughter (radiated gluon or antiquark) ! K(N-1,1)=K(L,1) K(N-1,1)=1 IF(QQBAR)THEN K(N-1,2)=-1 TRIP(N-1)=0 ANTI(N-1)=ANTI(L) ELSE K(N-1,2)=21 IF((K(L,2).GT.0).AND.(DIR.GE.0))THEN TRIP(N-1)=TRIP(L) ANTI(N-1)=COLMAX+1 ELSE TRIP(N-1)=COLMAX+1 ANTI(N-1)=ANTI(L) ENDIF COLMAX=COLMAX+1 ENDIF K(N-1,3)=L K(N-1,4)=0 K(N-1,5)=0 P(N-1,4)=(1-Z)*P(L,4) P(N-1,5)=MC ZA(N-1)=1.-Z IF(ZDECC.GT.0.d0)THEN THETAA(N-1)=P(N-1,5)/(SQRT(ZDECC*(1.-ZDECC))*P(N-1,4)) ELSE THETAA(N-1)=0.d0 ENDIF ZD(N-1)=ZDECC QQBARD(N-1)=QQBARDECC C--take care of second daughter (final quark or gluon or quark from C gluon splitting) ! K(N,1)=K(L,1) K(N,1)=1 IF(QUARK)THEN K(N,2)=K(L,2) IF(K(N,2).GT.0)THEN TRIP(N)=ANTI(N-1) ANTI(N)=0 ELSE TRIP(N)=0 ANTI(N)=TRIP(N-1) ENDIF ELSEIF(QQBAR)THEN K(N,2)=1 TRIP(N)=TRIP(L) ANTI(N)=0 ELSE K(N,2)=21 IF(DIR.EQ.1)THEN TRIP(N)=ANTI(N-1) ANTI(N)=ANTI(L) ELSE TRIP(N)=TRIP(L) ANTI(N)=TRIP(N-1) ENDIF ENDIF K(N,3)=L K(N,4)=0 K(N,5)=0 P(N,3)=PZ P(N,4)=Z*P(L,4) P(N,5)=MB ZA(N)=Z IF(ZDECB.GT.0.d0)THEN THETAA(N)=P(N,5)/(SQRT(ZDECB*(1.-ZDECB))*P(N,4)) ELSE THETAA(N)=0.d0 ENDIF ZD(N)=ZDECB QQBARD(N)=QQBARDECB C--azimuthal angle PHIQ=2*PI*PYR(0) P(N,1)=SQRT(PTS)*COS(PHIQ) P(N,2)=SQRT(PTS)*SIN(PHIQ) C--gluon momentum P(N-1,1)=P(L,1)-P(N,1) P(N-1,2)=P(L,2)-P(N,2) P(N-1,3)=P(L,3)-P(N,3) MV(N-1,4)=MV(L,5) IF(P(N-1,5).GT.0.d0)THEN LAMBDA=1.d0/(FTFAC*P(N-1,4)*0.2/P(N-1,5)**2) MV(N-1,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA ELSE MV(N-1,5)=0.d0 ENDIF MV(N,4)=MV(L,5) IF(P(N,5).GT.0.d0)THEN LAMBDA=1.d0/(FTFAC*P(N,4)*0.2/P(N,5)**2) MV(N,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA ELSE MV(N,5)=0.d0 ENDIF C--take care of initial quark (or gluon) IF(K(L,1).EQ.2)THEN K(L,1)=13 ELSE K(L,1)=11 ENDIF K(L,4)=N-1 K(L,5)=N NSPLIT=NSPLIT+EVWEIGHT 31 CONTINUE END *********************************************************************** *** subroutine makeinsplit *********************************************************************** SUBROUTINE MAKEINSPLIT(L,X,TSUM,VIRT,TYPI,TIME,TAURAD) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--time common block COMMON/TIME/MV(23000,5) DOUBLE PRECISION MV C--factor in front of formation times COMMON/FTIMEFAC/FTFAC DOUBLE PRECISION FTFAC C--colour index common block COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX INTEGER TRIP,ANTI,COLMAX C--variables for angular ordering COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) DOUBLE PRECISION ZA,ZD,THETAA LOGICAL QQBARD C--discard event flag COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD LOGICAL DISCARD INTEGER NDISC,NSTRANGE,NGOOD,errcount double precision wdisc C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--number of scattering events COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT C--event weight COMMON/WEIGHT/EVWEIGHT,sumofweights double precision EVWEIGHT,sumofweights C--local variables INTEGER L,TYPI,NOLD,DIR DOUBLE PRECISION X,VIRT,MB2,MC2,GETMASS,PZ,KT2,THETA,PHI,PI, &PHIQ,PYP,PYR,R,TIME,TSUM,TAURAD,LAMBDA,ZDEC LOGICAL QQBARDEC CHARACTER*2 TYP2,TYPC integer bin DATA PI/3.141592653589793d0/ IF((N+2).GT.22990) THEN write(logfid,*)'event too long for event record' DISCARD=.TRUE. RETURN ENDIF IF(K(L,2).EQ.21)THEN IF(TYPI.EQ.21)THEN TYP2='GG' TYPC='GC' ELSE TYP2='QG' TYPC='QQ' ENDIF ELSE IF(TYPI.EQ.21)THEN TYP2='GQ' TYPC='QQ' ELSE TYP2='QQ' TYPC='GC' ENDIF ENDIF C--if g->gg decide on colour configuration IF(TYP2.EQ.'GG')THEN IF(PYR(0).LT.0.5)THEN DIR=1 ELSE DIR=-1 ENDIF ELSE DIR=0 ENDIF MB2=VIRT**2 MB2=P(L,5)**2-MB2 MC2=GETMASS(0.d0,SCALEFACM*SQRT(-TSUM),-1.d0, & (1.-X)*P(L,4),TYPC,(1.-X)*P(L,4), & .FALSE.,ZDEC,QQBARDEC)**2 C--rotate such that momentum points in z-direction NOLD=N THETA=PYP(L,13) PHI=PYP(L,15) CALL PYROBO(L,L,0d0,-PHI,0d0,0d0,0d0) CALL PYROBO(L,L,-THETA,0d0,0d0,0d0,0d0) PZ=(2*X*P(L,4)**2-P(L,5)**2-MB2+MC2)/(2*P(L,3)) KT2=X**2*(P(L,4)**2)-PZ**2-MB2 IF(KT2.LT.0.d0)THEN MC2=0.d0 IF(K(L,1).EQ.2) zdec = -1.d0 PZ=(2*X*P(L,4)**2-P(L,5)**2-MB2+MC2)/(2*P(L,3)) KT2=X**2*(P(L,4)**2)-PZ**2-MB2 IF(KT2.LT.0.d0)THEN CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0) CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0) X=1.d0 RETURN ENDIF ENDIF N=N+2 C--take care of first daughter (radiated gluon or antiquark) ! K(N-1,1)=K(L,1) K(N-1,1)=1 IF(TYP2.EQ.'QG')THEN K(N-1,2)=-TYPI IF(K(N-1,2).GT.0)THEN TRIP(N-1)=TRIP(L) ANTI(N-1)=0 ELSE TRIP(N-1)=0 ANTI(N-1)=ANTI(L) ENDIF ELSEIF(TYP2.EQ.'GQ')THEN K(N-1,2)=K(L,2) IF(K(N-1,2).GT.0)THEN TRIP(N-1)=COLMAX+1 ANTI(N-1)=0 ELSE TRIP(N-1)=0 ANTI(N-1)=COLMAX+1 ENDIF COLMAX=COLMAX+1 ELSE K(N-1,2)=21 IF((K(L,2).GT.0).AND.(DIR.GE.0))THEN TRIP(N-1)=TRIP(L) ANTI(N-1)=COLMAX+1 ELSE TRIP(N-1)=COLMAX+1 ANTI(N-1)=ANTI(L) ENDIF COLMAX=COLMAX+1 ENDIF K(N-1,3)=L K(N-1,4)=0 K(N-1,5)=0 P(N-1,4)=(1.-X)*P(L,4) P(N-1,5)=SQRT(MC2) C--take care of second daughter (final quark or gluon or quark from C gluon splitting) ! K(N,1)=K(L,1) K(N,1)=1 IF(TYP2.EQ.'QG')THEN K(N,2)=TYPI IF(K(N,2).GT.0)THEN TRIP(N)=TRIP(L) ANTI(N)=0 ELSE TRIP(N)=0 ANTI(N)=ANTI(L) ENDIF ELSEIF(TYPI.NE.21)THEN K(N,2)=K(L,2) IF(K(N,2).GT.0)THEN TRIP(N)=ANTI(N-1) ANTI(N)=0 ELSE TRIP(N)=0 ANTI(N)=TRIP(N-1) ENDIF ELSE K(N,2)=21 IF(K(N-1,2).EQ.21)THEN IF(DIR.EQ.1)THEN TRIP(N)=ANTI(N-1) ANTI(N)=ANTI(L) ELSE TRIP(N)=TRIP(L) ANTI(N)=TRIP(N-1) ENDIF ELSEIF(K(N-1,2).GT.0)THEN TRIP(N)=TRIP(L) ANTI(N)=TRIP(N-1) ELSE TRIP(N)=ANTI(N-1) ANTI(N)=ANTI(L) ENDIF ENDIF K(N,3)=L K(N,4)=0 K(N,5)=0 P(N,3)=PZ P(N,4)=X*P(L,4) IF(MB2.LT.0.d0)THEN P(N,5)=-SQRT(-MB2) ELSE P(N,5)=SQRT(MB2) ENDIF C--azimuthal angle PHIQ=2*PI*PYR(0) P(N,1)=SQRT(KT2)*COS(PHIQ) P(N,2)=SQRT(KT2)*SIN(PHIQ) C--gluon momentum P(N-1,1)=P(L,1)-P(N,1) P(N-1,2)=P(L,2)-P(N,2) P(N-1,3)=P(L,3)-P(N,3) MV(L,5)=TIME-TAURAD MV(N-1,4)=MV(L,5) IF(P(N-1,5).GT.0.d0)THEN LAMBDA=1.d0/(FTFAC*P(N-1,4)*0.2/P(N-1,5)**2) MV(N-1,5)=MV(L,5)-LOG(1.d0-PYR(0))/LAMBDA ELSE MV(N-1,5)=0.d0 ENDIF MV(N,4)=MV(L,5) IF(P(N,5).GT.0.d0)THEN MV(N,5)=TIME ELSE MV(N,5)=0.d0 ENDIF ZA(N-1)=1.d0 THETAA(N-1)=-1.d0 ZD(N-1)=ZDEC QQBARD(N-1)=QQBARDEC ZA(N)=1.d0 THETAA(N)=-1.d0 ZD(N)=0.d0 QQBARD(N)=.FALSE. C--take care of initial quark (or gluon) IF(K(L,1).EQ.2)THEN K(L,1)=13 ELSE K(L,1)=11 ENDIF K(L,4)=N-1 K(L,5)=N NSPLIT=NSPLIT+EVWEIGHT CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0) CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0) CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0) CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0) C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother MV(N-1,1)=MV(L,1)+(MV(N-1,4)-MV(L,4))*P(L,1)/max(pyp(l,8),P(L,4)) MV(N-1,2)=MV(L,2)+(MV(N-1,4)-MV(L,4))*P(L,2)/max(pyp(l,8),P(L,4)) MV(N-1,3)=MV(L,3)+(MV(N-1,4)-MV(L,4))*P(L,3)/max(pyp(l,8),P(L,4)) MV(N, 1)=MV(L,1)+(MV(N, 4)-MV(L,4))*P(L,1)/max(pyp(l,8),P(L,4)) MV(N, 2)=MV(L,2)+(MV(N, 4)-MV(L,4))*P(L,2)/max(pyp(l,8),P(L,4)) MV(N, 3)=MV(L,3)+(MV(N, 4)-MV(L,4))*P(L,3)/max(pyp(l,8),P(L,4)) END *********************************************************************** *** subroutine doinstatescat *********************************************************************** SUBROUTINE DOINSTATESCAT(L,X,TYPI,Q,TSTART,DELTAT,OVERQ0, & RETRYSPLIT) IMPLICIT NONE C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--time common block COMMON/TIME/MV(23000,5) DOUBLE PRECISION MV C--factor in front of formation times COMMON/FTIMEFAC/FTFAC DOUBLE PRECISION FTFAC C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--discard event flag COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD LOGICAL DISCARD INTEGER NDISC,NSTRANGE,NGOOD,errcount double precision wdisc C--variables for coherent scattering COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10), &QSUMVEC(4),QSUM2 INTEGER NSTART,NEND DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2 C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--local variables INTEGER L,TYPI,COUNTER,COUNTMAX,COUNT2 DOUBLE PRECISION X,DELTAT,DELTAL,PYR,R,PNORAD,GETPNORAD1,GETNOSCAT, &WEIGHT,LOW,FMAX,GETPDF,SIGMATOT,GETSSCAT,PFCHANGE,PI,TNOW,TLEFT, &XMAX,PQQ,PQG,PGQ,PGG,ALPHAS,TSTART,TSUM,Q,QOLD,Q2OLD,GETNEWMASS, &GENERATEZ,TMAX,TMAXNEW,DT,XSC,YSC,ZSC,TSC,MS1,MD1,GETMS,GETMD, &GETTEMP,GETNEFF,LAMBDA,RTAU,PHI,TAUEST,QSUMVECOLD(4),ZDUM,WEIGHT, &pyp LOGICAL FCHANGE,NORAD,OVERQ0,NOSCAT,GETDELTAT,RETRYSPLIT, &QQBARDUM CHARACTER TYP CHARACTER*2 TYP2 DATA PI/3.141592653589793d0/ DATA COUNTMAX/10000/ COUNTER=0 XSC=MV(L,1)+(TSTART-MV(L,4))*P(L,1)/P(L,4) YSC=MV(L,2)+(TSTART-MV(L,4))*P(L,2)/P(L,4) ZSC=MV(L,3)+(TSTART-MV(L,4))*P(L,3)/P(L,4) TSC=TSTART MD1=GETMD(XSC,YSC,ZSC,TSC) MS1=GETMS(XSC,YSC,ZSC,TSC) IF(MD1.LE.1.D-4.OR.MS1.LE.1.D-4)THEN write(logfid,*)'problem!',GETTEMP(XSC,YSC,ZSC,TSC), &GETNEFF(XSC,YSC,ZSC,TSC) ENDIF C--check for scattering NOSCAT=.NOT.GETDELTAT(L,TSTART,DELTAT,DT) IF(NOSCAT.AND.(.NOT.RETRYSPLIT)) GOTO 116 C--decide whether there will be radiation PNORAD=GETPNORAD1(L,xsc,ysc,zsc,tsc) IF((PYR(0).LT.PNORAD).OR.(P(L,4).LT.1.001*Q0))THEN NORAD=.TRUE. ELSE NORAD=.FALSE. ENDIF C--decide whether q or g is to be scattered IF(K(L,2).EQ.21)THEN TYP='G' TYP2='GC' SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), & Q0,'G','C',xsc,ysc,zsc,tsc,0) IF((SIGMATOT.EQ.0.d0).OR.(PNORAD.EQ.1.d0))THEN PFCHANGE=0.d0 ELSE PFCHANGE=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), & Q0,'G','Q',xsc,ysc,zsc,tsc,0) & /SIGMATOT ENDIF SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), & 0.d0,'G','C',xsc,ysc,zsc,tsc,0) ELSE TYP='Q' TYP2='QQ' SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), & Q0,'Q','C',xsc,ysc,zsc,tsc,0) IF((SIGMATOT.EQ.0.d0).OR.(PNORAD.EQ.1.d0))THEN PFCHANGE=0.d0 ELSE PFCHANGE=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), & Q0,'Q','G',xsc,ysc,zsc,tsc,0) & /SIGMATOT ENDIF SIGMATOT=GETSSCAT(P(L,4),p(l,1),p(l,2),p(l,3),P(L,5), & 0.d0,'Q','C',xsc,ysc,zsc,tsc,0) ENDIF IF((PFCHANGE.LT.-1.d-4).OR.(PFCHANGE.GT.1.d0+1.d-4)) THEN write(logfid,*)'error: flavour change probability=', & PFCHANGE,'for ',TYP ENDIF IF(PYR(0).LT.PFCHANGE)THEN FCHANGE=.TRUE. ELSE FCHANGE=.FALSE. ENDIF IF (NORAD) FCHANGE=.FALSE. C--set TYPI IF(TYP.EQ.'G')THEN IF(FCHANGE)THEN TYPI=INT(SIGN(2.d0,PYR(0)-0.5)) ELSE TYPI=K(L,2) ENDIF ELSE IF(FCHANGE)THEN TYPI=21 ELSE TYPI=K(L,2) ENDIF ENDIF LOW=Q0**2/SCALEFACM**2 TMAX=4.*(P(L,4)**2-P(L,5)**2) XMAX=1.-Q0**2/(SCALEFACM**2*4.*TMAX) IF(SIGMATOT.EQ.0.d0) GOTO 116 RTAU=PYR(0) C--generate a trial emission C--pick a x value from splitting function 112 COUNTER=COUNTER+1 IF(TYP.EQ.'G')THEN IF(FCHANGE)THEN X=GENERATEZ(0.d0,0.d0,1.-XMAX,'QG') ELSE X=GENERATEZ(0.d0,0.d0,1.-XMAX,'GG') ENDIF ELSE IF(FCHANGE)THEN X=1.-GENERATEZ(0.d0,0.d0,1.-XMAX,'QQ') ELSE X=GENERATEZ(0.d0,0.d0,1.-XMAX,'QQ') ENDIF ENDIF IF(NORAD) X=1.d0 C--initialisation TMAXNEW=(X*P(L,4))**2 PHI=0.d0 TLEFT=DELTAT TNOW=TSTART QSUMVEC(1)=0.d0 QSUMVEC(2)=0.d0 QSUMVEC(3)=0.d0 QSUMVEC(4)=0.d0 QSUM2=-1.d-10 OVERQ0=.FALSE. Q=P(L,5) QOLD=P(L,5) TAUEST=DELTAT C--generate first momentum transfer DELTAL=DT NSTART=1 NEND=1 TNOW=TNOW+DELTAL TSUM=DELTAL TLEFT=TLEFT-DELTAL ALLQS(NEND,6)=TNOW Q2OLD=QSUM2 C--get new momentum transfer COUNT2=0 118 CALL GETQVEC(L,NEND,TNOW-MV(L,4),X) IF(-QSUM2.GT.P(L,4)**2)THEN QSUMVEC(1)=0.d0 QSUMVEC(2)=0.d0 QSUMVEC(3)=0.d0 QSUMVEC(4)=0.d0 QSUM2=Q2OLD IF(COUNT2.LT.100)THEN COUNT2=COUNT2+1 GOTO 118 ELSE ALLQS(NEND,1)=0.d0 ALLQS(NEND,2)=0.d0 ALLQS(NEND,3)=0.d0 ALLQS(NEND,4)=0.d0 ALLQS(NEND,5)=0.d0 ENDIF ENDIF C--update OVERQ0 IF(-ALLQS(NEND,1).GT.LOW) OVERQ0=.TRUE. C--get new virtuality IF(OVERQ0.AND.(.NOT.NORAD))THEN Q=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,0.d0, & .TRUE.,X,ZDUM,QQBARDUM) ELSE Q=0.d0 ENDIF C--estimate formation time 111 IF((Q.EQ.0.d0).OR.(Q.EQ.P(L,5)))THEN TAUEST=DELTAT ELSE TAUEST=FTFAC*(1.-PHI)*0.2*X*P(L,4)/Q**2 ENDIF LAMBDA=1.d0/TAUEST TAUEST=-LOG(1.d0-RTAU)/LAMBDA C--find number, position and momentum transfers of further scatterings NOSCAT=.NOT.GETDELTAT(L,TNOW,MIN(TLEFT,TAUEST),DELTAL) IF((.NOT.NOSCAT).AND.(.NOT.NORAD))THEN C--add a momentum transfer NEND=NEND+1 IF(NEND.GE.100)THEN nend=nend-1 goto 114 ENDIF TNOW=TNOW+DELTAL TSUM=TSUM+DELTAL TLEFT=TLEFT-DELTAL C--update phase IF((Q.NE.0.d0).AND.(Q.NE.P(L,5)))THEN PHI=PHI+5.*DELTAL*Q**2/(1.*X*P(L,4)) ENDIF C--get new momentum transfer ALLQS(NEND,6)=TNOW Q2OLD=QSUM2 QSUMVECOLD(1)=QSUMVEC(1) QSUMVECOLD(2)=QSUMVEC(2) QSUMVECOLD(3)=QSUMVEC(3) QSUMVECOLD(4)=QSUMVEC(4) COUNT2=0 119 CALL GETQVEC(L,NEND,TNOW-MV(L,4),X) IF(-QSUM2.GT.P(L,4)**2)THEN QSUMVEC(1)=QSUMVECOLD(1) QSUMVEC(2)=QSUMVECOLD(2) QSUMVEC(3)=QSUMVECOLD(3) QSUMVEC(4)=QSUMVECOLD(4) QSUM2=Q2OLD IF(COUNT2.LT.100)THEN COUNT2=COUNT2+1 GOTO 119 ELSE ALLQS(NEND,1)=0.d0 ALLQS(NEND,2)=0.d0 ALLQS(NEND,3)=0.d0 ALLQS(NEND,4)=0.d0 ALLQS(NEND,5)=0.d0 ENDIF ENDIF C--update OVERQ0 IF((-QSUM2.GT.LOW) & .OR.(-ALLQS(NEND,1).GT.LOW)) OVERQ0=.TRUE. C--get new virtuality QOLD=Q IF(OVERQ0.AND.(.NOT.NORAD))THEN Q=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD,0.d0, & .TRUE.,X,ZDUM,QQBARDUM) ELSE Q=0.d0 ENDIF GOTO 111 ENDIF C--do reweighting 114 TMAXNEW=X**2*P(L,4)**2 IF(NORAD)THEN WEIGHT=1.d0 Q=0.d0 X=1.d0 ELSEIF((-QSUM2.LT.LOW).OR.(Q.EQ.0.d0))THEN WEIGHT=0.d0 ELSEIF(-QSUM2.GT.P(L,4)**2)THEN WEIGHT=0.d0 ELSE IF(TYP.EQ.'G')THEN FMAX=2.*LOG(-SCALEFACM**2*QSUM2/Q0**2) & *ALPHAS(Q0**2/4.,LPS)/(2.*PI) IF(QSUM2.EQ.0.d0)THEN WEIGHT=0.d0 NORAD=.TRUE. ELSE IF(FCHANGE)THEN WEIGHT=2.*GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QG')/(PQG(X)*FMAX) IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X, & SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QG'),'qg', & FMAX ENDIF ELSE WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GG')/(PGG(X)*FMAX) IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X, & SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GG'),'gg', & FMAX ENDIF ENDIF ENDIF ELSE FMAX=LOG(-SCALEFACM**2*QSUM2/Q0**2) & *ALPHAS(Q0**2/4.,LPS)/(2.*PI) IF(QSUM2.EQ.0.d0)THEN WEIGHT=0.d0 NORAD=.TRUE. ELSE IF(FCHANGE)THEN WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GQ')/(PGQ(X)*FMAX) IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN write(logfid,*)'x,sqrt(qsum^2),getpdf:,fmax',X, & SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'GQ'),'gq', & FMAX ENDIF ELSE WEIGHT=GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QQ')/(PQQ(X)*FMAX) IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4))THEN write(logfid,*)'x,sqrt(qsum^2),getpdf,fmax:',X, & SQRT(-QSUM2),GETPDF(X,SCALEFACM*SQRT(-QSUM2),'QQ'),'qq', & FMAX ENDIF ENDIF ENDIF ENDIF ENDIF IF((WEIGHT.GT.1.d0+1.d-4).OR.(WEIGHT.LT.-1.d-4)) & write(logfid,*)'error: weight=',WEIGHT 115 IF(PYR(0).GT.WEIGHT)THEN IF(COUNTER.LT.COUNTMAX)THEN GOTO 112 ELSE Q=0.d0 X=1.d0 NEND=NSTART QSUM2=ALLQS(NEND,1) QSUMVEC(1)=ALLQS(NEND,2) QSUMVEC(2)=ALLQS(NEND,3) QSUMVEC(3)=ALLQS(NEND,4) QSUMVEC(4)=ALLQS(NEND,5) TYPI=K(L,2) IF(-ALLQS(NEND,1).GT.LOW)THEN OVERQ0=.TRUE. ELSE OVERQ0=.FALSE. ENDIF DELTAT=ALLQS(NEND,6)-TSTART TNOW=ALLQS(1,6) RETURN ENDIF ENDIF C--found meaningful configuration, now do final checks C--check if phase is unity and weight with 1/Nscat IF(((TLEFT.LT.TAUEST).OR.(PYR(0).GT.1.d0/(NEND*1.d0))) & .AND.(.NOT.NORAD))THEN Q=0.d0 X=1.d0 NEND=NSTART QSUM2=ALLQS(NEND,1) QSUMVEC(1)=ALLQS(NEND,2) QSUMVEC(2)=ALLQS(NEND,3) QSUMVEC(3)=ALLQS(NEND,4) QSUMVEC(4)=ALLQS(NEND,5) TYPI=K(L,2) IF(-ALLQS(NEND,1).GT.LOW)THEN OVERQ0=.TRUE. ELSE OVERQ0=.FALSE. ENDIF DELTAT=ALLQS(NEND,6)-TSTART TNOW=ALLQS(1,6) ELSE IF(.NOT.NORAD)THEN TLEFT=TLEFT-TAUEST TNOW=TNOW+TAUEST TSUM=TSUM+TAUEST ENDIF DELTAT=TSUM ENDIF RETURN C--exit in case of failure 116 Q=0.d0 X=1.d0 NSTART=0 NEND=0 QSUMVEC(1)=0.d0 QSUMVEC(2)=0.d0 QSUMVEC(3)=0.d0 QSUMVEC(4)=0.d0 QSUM2=0.d0 OVERQ0=.FALSE. TYPI=K(L,2) RETURN END *********************************************************************** *** subroutine dofistatescat *********************************************************************** SUBROUTINE DOFISTATESCAT(L,TNOW,DTLEFT,DELTAT,NEWMASS, & OVERQ0,Z,QQBAR) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--time common block COMMON/TIME/MV(23000,5) DOUBLE PRECISION MV C--factor in front of formation times COMMON/FTIMEFAC/FTFAC DOUBLE PRECISION FTFAC C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--discard event flag COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD LOGICAL DISCARD INTEGER NDISC,NSTRANGE,NGOOD,errcount double precision wdisc C--variables for coherent scattering COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10), &QSUMVEC(4),QSUM2 INTEGER NSTART,NEND DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2 C--local variables INTEGER L,COUNTER,COUNTMAX,COUNT2 DOUBLE PRECISION TNOW,DELTAT,NEWMASS,TLEFT,DELTAL,Q2OLD, &GETNEWMASS,PYR,TSUM,QSUMVECOLD(4),RTAU,LAMBDA,DTLEFT,PHI, &TAUEST,LOW,Z,pyp LOGICAL OVERQ0,NOSCAT,GETDELTAT,QQBAR CHARACTER TYP DATA COUNTMAX/100/ DELTAL=0.d0 IF(-QSUM2.GT.P(L,4)**2) & write(logfid,*) 'DOFISTATESCAT has a problem:',-QSUM2,P(L,4)**2 IF(K(L,2).EQ.21)THEN TYP='G' ELSE TYP='Q' ENDIF LOW=Q0**2/SCALEFACM**2 TSUM=0.d0 PHI=0.d0 DELTAT=0.d0 C--check for radiation with first (given) momentum transfer Q2OLD=0.d0 IF(OVERQ0.OR.(-QSUM2.GT.LOW))THEN NEWMASS=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD, & NEWMASS,.FALSE.,1.d0,Z,QQBAR) OVERQ0=.TRUE. ELSE NEWMASS=P(L,5) ENDIF RTAU=PYR(0) TLEFT=DTLEFT 222 IF((NEWMASS.EQ.0.d0).OR.(NEWMASS.EQ.P(L,5)))THEN TAUEST=TLEFT ELSE TAUEST=FTFAC*(1.-PHI)*0.2*P(L,4)/NEWMASS**2 ENDIF LAMBDA=1.d0/TAUEST TAUEST=-LOG(1.d0-RTAU)/LAMBDA NOSCAT=.NOT.GETDELTAT(L,TNOW+TSUM,MIN(TAUEST,TLEFT),DELTAL) IF(.NOT.NOSCAT)THEN C--do scattering NEND=NEND+1 IF(NEND.gt.countmax)THEN nend=nend-1 goto 218 ENDIF IF(NSTART.EQ.0) NSTART=1 TSUM=TSUM+DELTAL TLEFT=TLEFT-DELTAL IF((NEWMASS.NE.0.d0).AND.(NEWMASS.NE.P(L,5)))THEN PHI=PHI+5.*DELTAL*NEWMASS**2/(1.*P(L,4)) ENDIF ALLQS(NEND,6)=TNOW+TSUM QSUMVECOLD(1)=QSUMVEC(1) QSUMVECOLD(2)=QSUMVEC(2) QSUMVECOLD(3)=QSUMVEC(3) QSUMVECOLD(4)=QSUMVEC(4) Q2OLD=QSUM2 C--get new momentum transfer COUNT2=0 219 CALL GETQVEC(L,NEND,TNOW+TSUM-MV(L,4),1.d0) IF(-QSUM2.GT.P(L,4)**2)THEN QSUMVEC(1)=QSUMVECOLD(1) QSUMVEC(2)=QSUMVECOLD(2) QSUMVEC(3)=QSUMVECOLD(3) QSUMVEC(4)=QSUMVECOLD(4) QSUM2=Q2OLD IF(COUNT2.LT.100)THEN COUNT2=COUNT2+1 GOTO 219 ELSE ALLQS(NEND,1)=0.d0 ALLQS(NEND,2)=0.d0 ALLQS(NEND,3)=0.d0 ALLQS(NEND,4)=0.d0 ALLQS(NEND,5)=0.d0 ENDIF ENDIF C--figure out new virtuality IF(OVERQ0.OR.(-QSUM2.GT.LOW))THEN NEWMASS=GETNEWMASS(L,SCALEFACM**2*QSUM2,SCALEFACM**2*Q2OLD, & NEWMASS,.FALSE.,1.d0,Z,QQBAR) OVERQ0=.TRUE. ENDIF GOTO 222 ENDIF C--no more scattering 218 if ((newmass**2.gt.low).and.(newmass.ne.p(l,5))) then if ((TLEFT.LT.TAUEST).OR.(PYR(0).GT.1.d0/(NEND*1.d0))) then if (nend.eq.countmax) then deltat=tsum else if (TLEFT.LT.TAUEST) then DELTAT=TSUM+tleft else DELTAT=TSUM+tauest endif NEWMASS=P(L,5) ELSE DELTAT=TSUM+TAUEST ENDIF else DELTAT=0.d0 NSTART=1 NEND=1 QSUM2=ALLQS(NEND,1) QSUMVEC(1)=ALLQS(NEND,2) QSUMVEC(2)=ALLQS(NEND,3) QSUMVEC(3)=ALLQS(NEND,4) QSUMVEC(4)=ALLQS(NEND,5) IF(-ALLQS(NEND,1).GT.LOW)THEN OVERQ0=.TRUE. ELSE OVERQ0=.FALSE. ENDIF NEWMASS=P(L,5) endif return END *********************************************************************** *** function getnewmass *********************************************************************** DOUBLE PRECISION FUNCTION GETNEWMASS(L,Q2,QOLD2,MASS,IN,X, & ZDEC,QQBARDEC) IMPLICIT NONE C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--time common block COMMON/TIME/MV(23000,5) DOUBLE PRECISION MV C--variables for angular ordering COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) DOUBLE PRECISION ZA,ZD,THETAA LOGICAL QQBARD C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--local variables INTEGER L DOUBLE PRECISION Q2,QOLD2,R,PYR,PNOSPLIT1,PNOSPLIT2,Z,QA, &GETSUDAKOV,GETMASS,PKEEP,X,MASS,ZDEC,QTMP,ZOLD LOGICAL IN,QQBARDEC,QQBAROLD CHARACTER*2 TYP IF(x*P(L,4).LT.Q0)THEN GETNEWMASS=0.d0 ZDEC=0.d0 QQBARDEC=.FALSE. RETURN ENDIF IF (-Q2.LT.Q0**2)THEN GETNEWMASS=0.d0 RETURN ENDIF IF(K(L,2).EQ.21)THEN TYP='GC' ELSE TYP='QQ' ENDIF IF(SQRT(-QOLD2).LE.Q0)THEN IF(IN)THEN GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0, & X*P(L,4),TYP,X*P(L,4),IN,ZDEC,QQBARDEC) ELSE GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0,P(L,4),TYP, & SQRT(-Q2),IN,ZDEC,QQBARDEC) ENDIF GETNEWMASS=MIN(GETNEWMASS,X*P(L,4)) RETURN ENDIF Z=1.d0 QA=1.d0 IF(MAX(P(L,5),MASS).GT.0.d0)THEN IF(-Q2.GT.-QOLD2)THEN ZOLD=ZDEC QQBAROLD=QQBARDEC QTMP=GETMASS(0.d0,SQRT(-Q2),-1.d0,X*P(L,4),TYP, & SQRT(-Q2),IN,ZDEC,QQBARDEC) IF(QTMP.LT.SQRT(-QOLD2))THEN GETNEWMASS=MASS ZDEC=ZOLD QQBARDEC=QQBAROLD ELSE GETNEWMASS=QTMP ENDIF ELSE PNOSPLIT1=GETSUDAKOV(SQRT(-QOLD2),QA,Q0,Z,X*P(L,4), & TYP,MV(L,4),IN) PNOSPLIT2=GETSUDAKOV(SQRT(-Q2),QA,Q0,Z,X*P(L,4), & TYP,MV(L,4),IN) PKEEP=(1.-PNOSPLIT2)/(1.-PNOSPLIT1) IF(PYR(0).LT.PKEEP)THEN IF(P(L,5).LT.SQRT(-Q2))THEN GETNEWMASS=MASS ELSE 55 GETNEWMASS=GETMASS(Q0,SQRT(-Q2),-1.d0,X*P(L,4),TYP, & SQRT(-Q2),IN,ZDEC,QQBARDEC) IF((GETNEWMASS.EQ.0.d0).AND.(X*P(L,4).GT.Q0)) GOTO 55 ENDIF ELSE GETNEWMASS=0.d0 ZDEC=0.d0 QQBARDEC=.FALSE. ENDIF ENDIF ELSE IF(-Q2.GT.-QOLD2)THEN GETNEWMASS=GETMASS(0.d0,SQRT(-Q2),-1.d0, & X*P(L,4),TYP,X*P(L,4),IN,ZDEC,QQBARDEC) if(getnewmass.lt.SQRT(-QOLD2))then GETNEWMASS=0.d0 ZDEC=0.d0 QQBARDEC=.FALSE. endif ELSE GETNEWMASS=0.d0 ZDEC=0.d0 QQBARDEC=.FALSE. ENDIF ENDIF GETNEWMASS=MIN(GETNEWMASS,x*P(L,4)) END *********************************************************************** *** function getpnorad1 *********************************************************************** DOUBLE PRECISION FUNCTION GETPNORAD1(LINE,x,y,z,t) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--local variables INTEGER LINE DOUBLE PRECISION UP,LOW,CCOL,SIGMATOT,GETSSCAT,GETXSECINT, &SCATPRIMFUNC,MS1,MD1,shat,pcms2,avmom(5),x,y,z,t,getmd md1 = getmd(x,y,z,t) call avscatcen(x,y,z,t, &avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) ms1 = avmom(5) shat = avmom(5)**2 + p(line,5)**2 + 2.*(avmom(4)*p(line,4) & -avmom(1)*p(line,1)-avmom(2)*p(line,2)-avmom(3)*p(line,3)) pcms2 = (shat+p(line,5)**2-ms1**2)**2/(4.*shat)-p(line,5)**2 up = 4.*pcms2 LOW=Q0**2/SCALEFACM**2 IF((UP.LE.LOW).OR.(P(LINE,4).LT.Q0/SCALEFACM))THEN GETPNORAD1=1.d0 RETURN ENDIF IF(K(LINE,2).EQ.21)THEN CCOL=3./2. C--probability for no initial state radiation SIGMATOT=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3), & P(LINE,5),0.d0,'G','C',x,y,z,t,0) IF(SIGMATOT.EQ.0.d0)THEN GETPNORAD1=-1.d0 RETURN ENDIF GETPNORAD1=(CCOL*(SCATPRIMFUNC(LOW,MD1)- &SCATPRIMFUNC(0.d0,MD1)) & + GETXSECINT(UP,MD1,'GB'))/SIGMATOT ELSE CCOL=2./3. C--probability for no initial state radiation SIGMATOT=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3), & P(LINE,5),0.d0,'Q','C',x,y,z,t,0) IF(SIGMATOT.EQ.0.d0)THEN GETPNORAD1=1.d0 RETURN ENDIF GETPNORAD1=(CCOL*(SCATPRIMFUNC(LOW,MD1)- &SCATPRIMFUNC(0.d0,MD1)) & + GETXSECINT(UP,MD1,'QB'))/SIGMATOT ENDIF IF((GETPNORAD1.LT.-1.d-4).OR.(GETPNORAD1.GT.1.d0+1.d-4))THEN write(logfid,*)'error: P_norad=',GETPNORAD1, & P(LINE,4),P(LINE,5),LOW,UP,K(LINE,2),MD1 ENDIF END *********************************************************************** *** subroutine getqvec *********************************************************************** SUBROUTINE GETQVEC(L,J,DT,X) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--time common block COMMON/TIME/MV(23000,5) DOUBLE PRECISION MV C--variables for coherent scattering COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10), &QSUMVEC(4),QSUM2 INTEGER NSTART,NEND DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2 C--discard event flag COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD LOGICAL DISCARD INTEGER NDISC,NSTRANGE,NGOOD,errcount double precision wdisc C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--local variables INTEGER L,J,COUNTER,COUNTMAX,COUNT2,i DOUBLE PRECISION XSC,YSC,ZSC,TSC,GETMD,GETTEMP,DT,X,PYR,NEWMOM(4), &T,PT,MAXT,PHI2,BETA(3),PHI,THETA,GETT,PYP,PI,PT2,GETMS, &savemom(5),theta2,mb2,pz,kt2,phiq,maxt2,xi,md,shat,pcms2, &avmom(5) CHARACTER TYPS DATA PI/3.141592653589793d0/ DATA COUNTMAX/1000/ IF (J.GT.10000)THEN discard = .true. return ENDIF COUNTER=0 COUNT2=0 XSC=MV(L,1)+DT*P(L,1)/P(L,4) YSC=MV(L,2)+DT*P(L,2)/P(L,4) ZSC=MV(L,3)+DT*P(L,3)/P(L,4) TSC=MV(L,4)+DT md = GETMD(XSC,YSC,ZSC,TSC) call AVSCATCEN(xsc,ysc,zsc,tsc, &avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) do 210 i=1,5 savemom(i) = p(l,i) 210 continue xi = sqrt(max(x**2*p(l,4)**2,p(l,5)**2) - p(l,5)**2)/pyp(l,8) p(l,1) = xi*p(l,1) p(l,2) = xi*p(l,2) p(l,3) = xi*p(l,3) p(l,4) = max(x*p(l,4),p(l,5)) 444 CALL GETSCATTERER(XSC,YSC,ZSC,TSC, &K(1,2),P(1,1),P(1,2),P(1,3),P(1,4),P(1,5)) MV(1,1)=XSC MV(1,2)=YSC MV(1,3)=ZSC MV(1,4)=TSC TYPS='Q' IF(K(1,2).EQ.21)TYPS='G' shat = avmom(5)**2 + savemom(5)**2 + 2.*(avmom(4)*savemom(4) & -avmom(1)*savemom(1)-avmom(2)*savemom(2)-avmom(3)*savemom(3)) pcms2 = (shat+savemom(5)**2-avmom(5)**2)**2/(4.*shat) & -savemom(5)**2 maxt = 4.*pcms2 K(1,1)=13 SCATCENTRES(J,1)=K(1,2) SCATCENTRES(J,2)=P(1,1) SCATCENTRES(J,3)=P(1,2) SCATCENTRES(J,4)=P(1,3) SCATCENTRES(J,5)=P(1,4) SCATCENTRES(J,6)=P(1,5) SCATCENTRES(J,7)=MV(1,1) SCATCENTRES(J,8)=MV(1,2) SCATCENTRES(J,9)=MV(1,3) SCATCENTRES(J,10)=MV(1,4) C--transform to scattering centre's rest frame and rotate such that parton momentum is in z-direction BETA(1)=P(1,1)/P(1,4) BETA(2)=P(1,2)/P(1,4) BETA(3)=P(1,3)/P(1,4) CALL PYROBO(L,L,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) THETA=PYP(L,13) PHI=PYP(L,15) CALL PYROBO(L,L,0d0,-PHI,0d0,0d0,0d0) CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0) CALL PYROBO(L,L,-THETA,0d0,0d0,0d0,0d0) CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0) C--pick a t from differential scattering cross section 204 T=-GETT(0.d0,MAXT,md) 202 NEWMOM(4)=P(L,4)+T/(2.*p(1,5)) NEWMOM(3)=(T-2.*P(L,5)**2+2.*p(l,4)*NEWMOM(4))/(2.*P(L,3)) PT2=NEWMOM(4)**2-NEWMOM(3)**2-P(L,5)**2 IF(DABS(PT2).LT.1.d-10) PT2=0.d0 IF(T.EQ.0.d0) PT2=0.d0 IF(PT2.LT.0.d0)THEN T=0.d0 GOTO 202 ENDIF PT=SQRT(PT2) PHI2=PYR(0)*2*PI NEWMOM(1)=PT*COS(PHI2) NEWMOM(2)=PT*SIN(PHI2) P(1,1)=NEWMOM(1)-P(L,1) P(1,2)=NEWMOM(2)-P(L,2) P(1,3)=NEWMOM(3)-P(L,3) P(1,4)=NEWMOM(4)-P(L,4) P(1,5)=0.d0 C--transformation to lab CALL PYROBO(L,L,THETA,0d0,0d0,0d0,0d0) CALL PYROBO(1,1,THETA,0d0,0d0,0d0,0d0) CALL PYROBO(L,L,0d0,PHI,0d0,0d0,0d0) CALL PYROBO(1,1,0d0,PHI,0d0,0d0,0d0) CALL PYROBO(L,L,0d0,0d0,BETA(1),BETA(2),BETA(3)) CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3)) ALLQS(J,1)=T ALLQS(J,2)=P(1,1) ALLQS(J,3)=P(1,2) ALLQS(J,4)=P(1,3) ALLQS(J,5)=P(1,4) QSUMVEC(1)=QSUMVEC(1)+ALLQS(NEND,2) QSUMVEC(2)=QSUMVEC(2)+ALLQS(NEND,3) QSUMVEC(3)=QSUMVEC(3)+ALLQS(NEND,4) QSUMVEC(4)=QSUMVEC(4)+ALLQS(NEND,5) QSUM2=QSUMVEC(4)**2-QSUMVEC(1)**2-QSUMVEC(2)**2-QSUMVEC(3)**2 IF(QSUM2.GT.0.d0)THEN QSUMVEC(1)=QSUMVEC(1)-ALLQS(NEND,2) QSUMVEC(2)=QSUMVEC(2)-ALLQS(NEND,3) QSUMVEC(3)=QSUMVEC(3)-ALLQS(NEND,4) QSUMVEC(4)=QSUMVEC(4)-ALLQS(NEND,5) QSUM2=QSUMVEC(4)**2-QSUMVEC(1)**2-QSUMVEC(2)**2-QSUMVEC(3)**2 IF(COUNTER.GT.COUNTMAX)THEN write(logfid,*)'GETQVEC unable to find q vector' ALLQS(J,1)=0.d0 ALLQS(J,2)=0.d0 ALLQS(J,3)=0.d0 ALLQS(J,4)=0.d0 ALLQS(J,5)=0.d0 ELSE COUNTER=COUNTER+1 GOTO 444 ENDIF ENDIF do 211 i=1,5 p(l,i) = savemom(i) 211 continue END *********************************************************************** *** subroutine dokinematics *********************************************************************** SUBROUTINE DOKINEMATICS(L,lold,N1,N2,NEWM,RETRYSPLIT, & TIME,X,Z,QQBAR) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--time common block COMMON/TIME/MV(23000,5) DOUBLE PRECISION MV C--factor in front of formation times COMMON/FTIMEFAC/FTFAC DOUBLE PRECISION FTFAC C--colour index common block COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX INTEGER TRIP,ANTI,COLMAX C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--discard event flag COMMON/DISC/NDISC,NSTRANGE,NGOOD,errcount,wdisc,DISCARD LOGICAL DISCARD INTEGER NDISC,NSTRANGE,NGOOD,errcount double precision wdisc C--variables for angular ordering COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) DOUBLE PRECISION ZA,ZD,THETAA LOGICAL QQBARD C--variables for coherent scattering COMMON/COHERENT/NSTART,NEND,ALLQS(10000,6),SCATCENTRES(10000,10), &QSUMVEC(4),QSUM2 INTEGER NSTART,NEND DOUBLE PRECISION ALLQS,SCATCENTRES,QSUMVEC,QSUM2 C--number of scattering events COMMON/CHECK/NSCAT,NSCATEFF,NSPLIT DOUBLE PRECISION NSCAT,NSCATEFF,NSPLIT C--event weight COMMON/WEIGHT/EVWEIGHT,sumofweights double precision EVWEIGHT,sumofweights C--extra storage for scattering centres before interactions common/storescatcen/nscatcen,maxnscatcen,scatflav(23000), &scatcen(23000,5),writescatcen,writedummies integer nscatcen,maxnscatcen,scatflav double precision scatcen logical writescatcen,writedummies C--extra storage for dummy particles for subtraction common/storedummies/dummies(10000,5) double precision dummies C--local variables INTEGER L,LINE,N1,N2,J,DIR,lold,nold,colmaxold,statold,nscatcenold DOUBLE PRECISION PYR,PI,BETA(3),THETA,PHI,PYP,PHI2,MAXT,T, &NEWMASS,DELTAM,DM,TTOT,DMLEFT,LAMBDA,TIME,ENDTIME,X,tmp, &m32,newm2,shat,theta2,z,gettemp,E3new,E4new,p32,p42,p3old, &newm,mass2,enew,pt2,pt,pl,m12,firsttime,pcms2, &ys,p3boost,pboost,m42,localt,oldt,precoil,qmass2,pdummy,pproj double precision m4,z4,getmass,getms,getmd double precision thetasub,phisub,rapsub CHARACTER*2 TYP LOGICAL RETRYSPLIT,QQBAR,QQBARDEC,rejectt,redokin,reshuffle, &softrec,splitrec,isrecoil DATA PI/3.141592653589793d0/ data pdummy/1.d-6/ IF((N+2*(n2-n1+1)).GT.22990)THEN write(logfid,*)'event too long for event record' DISCARD=.TRUE. RETURN ENDIF if (k(l,1).eq.2) then isrecoil = .true. else isrecoil = .false. endif firsttime = mv(l,5) redokin = .false. newm2=newm nold=n nscatcenold=nscatcen colmaxold=colmax statold=k(l,1) 204 DELTAM=NEWM2-P(L,5) DMLEFT=DELTAM TTOT=0.d0 DO 220 J=N1,N2 TTOT=TTOT+ALLQS(J,1) 220 CONTINUE LINE=L DO 222 J=N1,N2 splitrec = .false. C--projectile type IF(K(LINE,2).EQ.21)THEN TYP='GC' IF(PYR(0).LT.0.5)THEN DIR=1 ELSE DIR=-1 ENDIF ELSE TYP='QQ' DIR=0 ENDIF K(1,1)=6 K(1,2)=SCATCENTRES(J,1) P(1,1)=SCATCENTRES(J,2) P(1,2)=SCATCENTRES(J,3) P(1,3)=SCATCENTRES(J,4) P(1,4)=SCATCENTRES(J,5) P(1,5)=SCATCENTRES(J,6) MV(1,1)=SCATCENTRES(J,7) MV(1,2)=SCATCENTRES(J,8) MV(1,3)=SCATCENTRES(J,9) MV(1,4)=SCATCENTRES(J,10) T=ALLQS(J,1) if (t.eq.0.d0) then rejectt = .true. else rejectt = .false. endif IF(TTOT.EQ.0.d0)THEN DM=0.d0 ELSE if (dmleft.lt.0.d0) then DM=max(DMLEFT*T/TTOT*1.5d0,dmleft) else DM=min(DMLEFT*T/TTOT*1.5d0,dmleft) endif ENDIF TTOT=TTOT-ALLQS(J,1) C--transform to c.m.s. and rotate such that parton momentum is in z-direction BETA(1)=(P(1,1)+p(line,1))/(P(1,4)+p(line,4)) BETA(2)=(P(1,2)+p(line,2))/(P(1,4)+p(line,4)) BETA(3)=(P(1,3)+p(line,3))/(P(1,4)+p(line,4)) IF ((BETA(1).GT.1.d0).OR.(BETA(2).GT.1.d0).OR.(BETA(3).GT.1.d0) & .or.(sqrt(beta(1)**2+beta(2)**2+beta(3)**2).gt.1.d0))THEN reshuffle = .false. else reshuffle = .true. endif 205 if (.not.reshuffle) then BETA(1)=P(1,1)/P(1,4) BETA(2)=P(1,2)/P(1,4) BETA(3)=P(1,3)/P(1,4) CALL PYROBO(LINE,LINE,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) THETA=PYP(LINE,13) PHI=PYP(LINE,15) CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0) CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0) CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0) CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0) if (kinmode.eq.0)then m42 = 0.d0 elseif (kinmode.eq.1)then m42 = p(1,5)**2 else if (scalefacm*sqrt(-t).gt.q0) then m4 = getmass(0.d0,scalefacm*sqrt(-t),-1.d0,p(1,4),typ, & p(1,4),.false.,z4,qqbardec) if (m4.gt.0.d0) splitrec = .true. m42 = m4**2 else m42 = p(1,5)**2 endif endif if (t.eq.0.d0) m42 = p(1,5)**2 maxt = -2.*p(1,5)*p(line,4) - p(1,5)**2 + m42 if (t.lt.maxt) then t=0.d0 rejectt = .true. dm = 0.d0 m42 = p(1,5)**2 endif m12 = -p(line,5)**2 203 newmass = p(line,5)+dm if (newmass.lt.0.d0) then m32 = -NEWMASS**2 else m32 = NEWMASS**2 endif if ((deltam.eq.0.d0).and.isrecoil.and.(kinmode.eq.3)) then localt = GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4)) oldt = GETTEMP(MV(l,1),MV(l,2),MV(l,3),MV(l,4)) if (localt.gt.0.d0) then m32 = (p(l,5)*localt/oldt)**2 newm2 = sqrt(m32) endif endif if (t.eq.0.d0) then enew = p(line,4) else enew = p(line,4)+(t+p(1,5)**2-m42)/(2.*p(1,5)) endif pl = (t+2.*p(line,4)*enew-m12-m32)/(2.*p(line,3)) pt2 = enew**2-pl**2-m32 if (t.eq.0.d0) pt2 = 0.d0 if (dabs(pt2).lt.1.d-8) pt2 = 0.d0 if (pt2.lt.0.d0) then if (splitrec) then m4 = getmass(0.d0,sqrt(m42),-1.d0,p(1,4),typ, & p(1,4),.false.,z4,qqbardec) if (m4.eq.0.d0) splitrec = .false. m42 = m4**2 goto 203 endif if (dm.ne.0.d0) then dm = 0.d0 goto 203 else write(logfid,*)' This should not have happened: pt^2<0!' write(logfid,*)t,enew,pl,pt2 t = 0.d0 m42 = p(1,5)**2 rejectt = .true. goto 203 endif endif pt = sqrt(pt2) phi2 = pyr(0)*2.*pi n=n+2 p(n,1)=pt*cos(phi2) p(n,2)=pt*sin(phi2) p(n,3)=pl p(n,4)=enew p(n,5)=sign(sqrt(abs(m32)),newmass) !--------------------------------- P(N-1,1)=P(1,1)+P(LINE,1)-P(N,1) P(N-1,2)=P(1,2)+P(LINE,2)-P(N,2) P(N-1,3)=P(1,3)+P(LINE,3)-P(N,3) P(N-1,4)=P(1,4)+P(LINE,4)-P(N,4) mass2 = P(N-1,4)**2-P(N-1,1)**2-P(N-1,2)**2-P(N-1,3)**2 if ((mass2.lt.0.d0).and.(mass2.gt.-1.-6)) mass2=0.d0 if (mass2.lt.0.d0) & write(logfid,*)'messed up scattering centres mass^2: ', & mass2,p(1,5)**2 P(N-1,5)=SQRT(mass2) if (abs(p(n-1,5)-sqrt(m42)).gt.1.d-6) & write(logfid,*)'messed up scattering centres mass (no rs): ', & p(n-1,5),p(1,5),p(l,5),sqrt(m42),rejectt call flush(logfid) !--------------------------------- ! P(N-1,1)=P(1,1) ! P(N-1,2)=P(1,2) ! P(N-1,3)=P(1,3) ! P(N-1,4)=P(1,4) ! P(N-1,5)=P(1,5) !--------------------------------- else CALL PYROBO(LINE,LINE,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) CALL PYROBO(1,1,0d0,0d0,-BETA(1),-BETA(2),-BETA(3)) if ((p(1,4).lt.0.d0).or.(p(line,4).lt.0.d0)) then CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3)) CALL PYROBO(LINE,LINE,0d0,0d0,BETA(1),BETA(2),BETA(3)) reshuffle = .false. goto 205 endif THETA=PYP(LINE,13) PHI=PYP(LINE,15) CALL PYROBO(LINE,LINE,0d0,-PHI,0d0,0d0,0d0) CALL PYROBO(1,1,0d0,-PHI,0d0,0d0,0d0) CALL PYROBO(LINE,LINE,-THETA,0d0,0d0,0d0,0d0) CALL PYROBO(1,1,-THETA,0d0,0d0,0d0,0d0) shat = (p(1,4)+p(line,4))**2 p3old = p(line,3) maxt = -4.*p(line,3)**2 if (t.lt.maxt) then t=0.d0 rejectt = .true. endif theta2 = acos(1.d0+t/(2.*p(line,3)**2)) phi2 = pyr(0)*2.*pi n=n+2 p(n,1)=p(line,3)*sin(theta2)*cos(phi2) p(n,2)=p(line,3)*sin(theta2)*sin(phi2) p(n,3)=p(line,3)*cos(theta2) p(n,4)=p(line,4) p(n,5)=p(line,5) !--------------------------------- P(N-1,1)=P(1,1)+P(LINE,1)-P(N,1) P(N-1,2)=P(1,2)+P(LINE,2)-P(N,2) P(N-1,3)=P(1,3)+P(LINE,3)-P(N,3) P(N-1,4)=P(1,4)+P(LINE,4)-P(N,4) mass2 = P(N-1,4)**2-P(N-1,1)**2-P(N-1,2)**2-P(N-1,3)**2 if ((mass2.lt.0.d0).and.(mass2.gt.-1.-6)) mass2=0.d0 if (mass2.lt.0.d0) & write(logfid,*)'messed up scattering centres mass^2: ', & mass2,p(1,5)**2 P(N-1,5)=SQRT(mass2) if (abs(p(n-1,5)-p(1,5)).gt.1.d-6) & write(logfid,*)'messed up scattering centres mass: ', & p(n-1,5),p(1,5),p(l,5) call flush(logfid) !--------------------------------- ! P(N-1,1)=P(1,1) ! P(N-1,2)=P(1,2) ! P(N-1,3)=P(1,3) ! P(N-1,4)=P(1,4) ! P(N-1,5)=P(1,5) !--------------------------------- endif C--outgoing projectile K(N,1)=K(LINE,1) if (isrecoil.and.(newm.gt.p(l,5)).and.(p(n,5).gt.q0) & .and.(j.eq.n2)) then k(n,1)=1 endif K(N,2)=K(LINE,2) ! K(N,3)=L K(N,3)=LINE K(N,4)=0 K(N,5)=0 ZA(N)=1.d0 THETAA(N)=-1.d0 if ((k(n,1).eq.2).and.(z.eq.0.d0)) then zd(n) = -1.d0 else ZD(N)=Z endif QQBARD(N)=QQBAR C--take care of incoming projectile IF(K(LINE,1).EQ.1)THEN K(LINE,1)=12 ELSE K(LINE,1)=14 ENDIF K(LINE,4)=N-1 K(LINE,5)=N C--temporary status code, will be overwritten later K(N-1,1)=3 K(N-1,2)=21 K(N-1,3)=0 K(N-1,4)=0 K(N-1,5)=0 if (reshuffle) then C--adjust mass and re-shuffle momenta if (kinmode.eq.0) then m42 = 0.d0 elseif (kinmode.eq.1) then m42 = p(1,5)**2 else if (scalefacm*sqrt(-t).gt.q0) then m4 = getmass(0.d0,scalefacm*sqrt(-t),-1.d0,p(1,4),typ, & p(1,4),.false.,z4,qqbardec) if (m4.gt.0.d0) splitrec = .true. m42 = m4**2 else m42 = p(1,5)**2 endif endif 206 newmass = p(n,5)+dm if (newmass.lt.0.d0) then m32 = -NEWMASS**2 else m32 = NEWMASS**2 endif if ((deltam.eq.0.d0).and.isrecoil.and.(kinmode.eq.3)) then localt = GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4)) oldt = GETTEMP(MV(l,1),MV(l,2),MV(l,3),MV(l,4)) if (localt.gt.0.d0) then m32 = (p(l,5)*localt/oldt)**2 newm2 = sqrt(m32) endif endif if (t.eq.0.d0) m42 = p(1,5)**2 E3new = (shat + m32 - m42)/(2.d0*sqrt(shat)) E4new = (shat - m32 + m42)/(2.d0*sqrt(shat)) p32 = E3new**2 - m32 p42 = E4new**2 - m42 if ((p32.lt.0.d0).or.(p42.lt.0.d0).or. & (E3new.lt.0.d0).or.(E4new.lt.0.d0)) then if (m42.eq.0.d0) then p42 = 1.d-4 else p42 = 0.d0 endif E4new = sqrt(p42 + m42) E3new = sqrt(shat) - E4new p32 = E4new**2 - m42 m32 = E3new**2 - E4new**2 + m42 if ((E3new.lt.0.d0).or.(E4new.lt.0.d0)) then if (splitrec) then m4 = getmass(0.d0,sqrt(m42),-1.d0,p(1,4),typ, & p(1,4),.false.,z4,qqbardec) if (m4.eq.0.d0) splitrec = .false. m42 = m4**2 goto 206 endif if (dm.ne.0.d0) then dm = 0.d0 goto 206 endif m42 = p(1,5)**2 E3new = p(n,4) E4new = p(n-1,4) p32 = p3old**2 p42 = p3old**2 if (p(n,5).lt.0.d0) then m32 = -p(n,5)**2 else m32 = p(n,5)**2 endif endif endif p(n,1) = sqrt(p32)*p(n,1)/p3old p(n,2) = sqrt(p32)*p(n,2)/p3old p(n,3) = sqrt(p32)*p(n,3)/p3old p(n,4) = E3new p(n,5) = sign(sqrt(abs(m32)),newmass) tmp = p(n,4)**2-p(n,1)**2-p(n,2)**2-p(n,3)**2-m32 if (abs(tmp).gt.1.d-6) & write(logfid,*) 'Oups, messed up projectiles mass (rs):', & tmp,m32,p(n,5),dm,m42,p32 !--------------------------------- p(n-1,1) = sqrt(p42)*p(n-1,1)/p3old p(n-1,2) = sqrt(p42)*p(n-1,2)/p3old p(n-1,3) = sqrt(p42)*p(n-1,3)/p3old p(n-1,4) = E4new p(n-1,5) = sqrt(m42) tmp = p(n-1,4)**2-p(n-1,1)**2-p(n-1,2)**2-p(n-1,3)**2 & -p(n-1,5)**2 if (abs(tmp).gt.1.d-6) & write(logfid,*) 'Oups, messed up scattering centres mass (rs):', & tmp,p3old,p(n-1,1),p(n-1,2),p(n-1,3),p(n-1,4),p(n-1,5) if ((abs(p(n,1)+p(n-1,1)).gt.1.d-6).or. & (abs(p(n,2)+p(n-1,2)).gt.1.d-6).or. & (abs(p(n,3)+p(n-1,3)).gt.1.d-6)) then write(logfid,*) 'Oups, momentum not conserved (rs)', & p(n,1)+p(n-1,1),p(n,2)+p(n-1,2),p(n,3)+p(n-1,3) write(logfid,*) m42,dm,E3new,E4new endif !--------------------------------- ! P(N-1,1)=P(1,1) ! P(N-1,2)=P(1,2) ! P(N-1,3)=P(1,3) ! P(N-1,4)=P(1,4) ! P(N-1,5)=P(1,5) !--------------------------------- endif C--transformation to lab CALL PYROBO(N-1,N,THETA,0d0,0d0,0d0,0d0) CALL PYROBO(LINE,LINE,THETA,0d0,0d0,0d0,0d0) CALL PYROBO(N-1,N,0d0,PHI,0d0,0d0,0d0) CALL PYROBO(LINE,LINE,0d0,PHI,0d0,0d0,0d0) CALL PYROBO(N-1,N,0d0,0d0,BETA(1),BETA(2),BETA(3)) CALL PYROBO(LINE,LINE,0d0,0d0,BETA(1),BETA(2),BETA(3)) CALL PYROBO(1,1,THETA,0d0,0d0,0d0,0d0) CALL PYROBO(1,1,0d0,PHI,0d0,0d0,0d0) CALL PYROBO(1,1,0d0,0d0,BETA(1),BETA(2),BETA(3)) if (.not.allhad) then k(n-1,1)=13 softrec=.false. else C--boost to fluid rest frame ys = 0.5*log((mv(1,4)+mv(1,3))/(mv(1,4)-mv(1,3))) p3boost = sinh(-ys)*p(n-1,4) + cosh(-ys)*p(n-1,3) pboost = sqrt(p3boost**2+p(n-1,1)**2+p(n-1,2)**2) localt = GETTEMP(MV(1,1),MV(1,2),MV(1,3),MV(1,4)) if (pboost.lt.(recsoftcut*3.*localt)) then softrec = .true. k(n-1,1)=13 else softrec = .false. if (scatrecoil.and.(pboost.GT.(rechardcut*3.*localt))) THEN K(N-1,1)=2 else K(N-1,1)=3 ENDIF endif endif if (rejectt) k(n-1,1)=11 C--outgoing projectile IF(ALLHAD.and.(.not.rejectt).and.(.not.softrec))THEN IF(K(N,2).EQ.21)THEN IF(DIR.EQ.1)THEN TRIP(N)=COLMAX+1 ANTI(N)=ANTI(LINE) ELSE TRIP(N)=TRIP(LINE) ANTI(N)=COLMAX+1 ENDIF ELSEIF(K(N,2).GT.0)THEN TRIP(N)=COLMAX+1 ANTI(N)=0 ELSE TRIP(N)=0 ANTI(N)=COLMAX+1 ENDIF COLMAX=COLMAX+1 ELSE TRIP(N)=TRIP(LINE) ANTI(N)=ANTI(LINE) ENDIF C--outgoing scattering centre IF(ALLHAD.and.(.not.rejectt).and.(.not.softrec))THEN IF((K(N,2).GT.0).AND.(DIR.GE.0))THEN TRIP(N-1)=TRIP(LINE) ANTI(N-1)=TRIP(N) ELSE TRIP(N-1)=ANTI(N) ANTI(N-1)=ANTI(LINE) ENDIF ELSE TRIP(N-1)=0 ANTI(N-1)=0 ENDIF C--outgoing scattering centre if (splitrec) then if (k(n-1,1).eq.2) k(n-1,1)=1 ZA(N-1)=1.d0 THETAA(N-1)=P(n-1,5)/(SQRT(Z4*(1.-Z4))*P(n-1,4)) ZD(N-1)=z4 QQBARD(N-1)=qqbardec else ZA(N-1)=1.d0 THETAA(N-1)=-1.d0 ZD(N-1)=-1.d0 QQBARD(N-1)=.false. endif MV(N,4)=MV(1,4) MV(N-1,4)=MV(1,4) C--set the production vertices: x_mother + (tprod - tprod_mother) * beta_mother MV(N-1,1)=MV(line,1) & +(MV(N-1,4)-MV(line,4))*P(line,1)/max(pyp(line,8),P(line,4)) MV(N-1,2)=MV(line,2) & +(MV(N-1,4)-MV(line,4))*P(line,2)/max(pyp(line,8),P(line,4)) MV(N-1,3)=MV(line,3) & +(MV(N-1,4)-MV(line,4))*P(line,3)/max(pyp(line,8),P(line,4)) MV(N, 1)=MV(line,1) & +(MV(N, 4)-MV(line,4))*P(line,1)/max(pyp(line,8),P(line,4)) MV(N, 2)=MV(line,2) & +(MV(N, 4)-MV(line,4))*P(line,2)/max(pyp(line,8),P(line,4)) MV(N, 3)=MV(line,3) & +(MV(N, 4)-MV(line,4))*P(line,3)/max(pyp(line,8),P(line,4)) IF(P(N-1,5).GT.P(1,5))THEN LAMBDA=1.d0/(FTFAC*0.2*P(N-1,4)/P(N-1,5)**2) MV(N-1,5)=MV(N-1,4)-LOG(1.d0-PYR(0))/LAMBDA ELSE MV(N-1,5)=0.d0 ENDIF IF(J.LT.N2)THEN MV(N,5)=SCATCENTRES(J+1,10) ELSE IF(P(N,5).GT.0.d0)THEN IF(DELTAM.EQ.0.d0)THEN ENDTIME=firsttime ELSE IF(X.LT.1.d0)THEN LAMBDA=1.d0/(FTFAC*P(N,4)*0.2/P(N,5)**2) ENDTIME=SCATCENTRES(J,10)-LOG(1.d0-PYR(0))/LAMBDA ELSE ENDTIME=TIME ENDIF ENDIF MV(N,5)=ENDTIME ELSE MV(N,5)=0.d0 ENDIF ENDIF MV(LINE,5)=ALLQS(J,6) if ((.not.redokin).and.(.not.rejectt)) NSCAT=NSCAT+EVWEIGHT C--store scattering centre before interaction in separate common block if (writescatcen.and.(.not.rejectt).and. & (nscatcen.lt.maxnscatcen)) then nscatcen = nscatcen+1 if (nscatcen.gt.maxnscatcen) then write(logfid,*) &'WARNING: no room left to store further scattering centres' goto 230 endif - if (recmode.eq.0) then - scatflav(nscatcen) = k(1,2) - scatcen(nscatcen,1) = p(1,1) - scatcen(nscatcen,2) = p(1,2) - scatcen(nscatcen,3) = p(1,3) - scatcen(nscatcen,4) = p(1,4) - scatcen(nscatcen,5) = p(1,5) - dummies(nscatcen,1) = scatcen(nscatcen,1)* + if (recmode.eq.0) then + if (.not.softrec) then + scatflav(nscatcen) = k(1,2) + scatcen(nscatcen,1) = p(1,1) + scatcen(nscatcen,2) = p(1,2) + scatcen(nscatcen,3) = p(1,3) + scatcen(nscatcen,4) = p(1,4) + scatcen(nscatcen,5) = p(1,5) + dummies(nscatcen,1) = scatcen(nscatcen,1)* & pdummy/scatcen(nscatcen,4) - dummies(nscatcen,2) = scatcen(nscatcen,2)* + dummies(nscatcen,2) = scatcen(nscatcen,2)* & pdummy/scatcen(nscatcen,4) - dummies(nscatcen,3) = scatcen(nscatcen,3)* + dummies(nscatcen,3) = scatcen(nscatcen,3)* & pdummy/scatcen(nscatcen,4) - dummies(nscatcen,4) = pdummy - dummies(nscatcen,5) = sqrt(dummies(nscatcen,4)**2 - + dummies(nscatcen,4) = pdummy + dummies(nscatcen,5) = sqrt(dummies(nscatcen,4)**2 - & dummies(nscatcen,1)**2 - dummies(nscatcen,2)**2 - & dummies(nscatcen,3)**2) C-------------------- + endif elseif (recmode.eq.1) then - scatflav(nscatcen) = k(1,2) - scatcen(nscatcen,1) = p(1,1) - scatcen(nscatcen,2) = p(1,2) - scatcen(nscatcen,3) = p(1,3) - scatcen(nscatcen,4) = p(1,4) - scatcen(nscatcen,5) = p(1,5) - dummies(nscatcen,1) = scatcen(nscatcen,1)* - & pdummy/scatcen(nscatcen,4) - dummies(nscatcen,2) = scatcen(nscatcen,2)* - & pdummy/scatcen(nscatcen,4) - dummies(nscatcen,3) = scatcen(nscatcen,3)* - & pdummy/scatcen(nscatcen,4) - dummies(nscatcen,4) = pdummy - dummies(nscatcen,5) = sqrt(dummies(nscatcen,4)**2 - - & dummies(nscatcen,1)**2 - dummies(nscatcen,2)**2 - - & dummies(nscatcen,3)**2) -C-------------------- + if (.not.softrec) then + scatflav(nscatcen) = k(1,2) + scatcen(nscatcen,1) = p(1,1) + scatcen(nscatcen,2) = p(1,2) + scatcen(nscatcen,3) = p(1,3) + scatcen(nscatcen,4) = p(1,4) + scatcen(nscatcen,5) = p(1,5) + dummies(nscatcen,1) = p(n-1,1)*pdummy/p(n-1,4) + dummies(nscatcen,2) = p(n-1,2)*pdummy/p(n-1,4) + dummies(nscatcen,3) = p(n-1,3)*pdummy/p(n-1,4) + dummies(nscatcen,4) = pdummy + dummies(nscatcen,5) = sqrt(dummies(nscatcen,4)**2 - + & dummies(nscatcen,1)**2 - dummies(nscatcen,2)**2 - + & dummies(nscatcen,3)**2) + endif elseif (recmode.eq.2) then scatflav(nscatcen) = k(1,2) scatcen(nscatcen,1) = p(n-1,1) - p(1,1) scatcen(nscatcen,2) = p(n-1,2) - p(1,2) scatcen(nscatcen,3) = p(n-1,3) - p(1,3) scatcen(nscatcen,4) = p(n-1,4) - p(1,4) qmass2 = scatcen(nscatcen,4)**2 - scatcen(nscatcen,1)**2 & - scatcen(nscatcen,2)**2 - scatcen(nscatcen,3)**2 scatcen(nscatcen,5) = sign(sqrt(abs(qmass2)),qmass2) dummies(nscatcen,1) = scatcen(nscatcen,1)* & pdummy/scatcen(nscatcen,4) dummies(nscatcen,2) = scatcen(nscatcen,2)* & pdummy/scatcen(nscatcen,4) dummies(nscatcen,3) = scatcen(nscatcen,3)* & pdummy/scatcen(nscatcen,4) dummies(nscatcen,4) = pdummy dummies(nscatcen,5) = - sqrt(dummies(nscatcen,1)**2 + & dummies(nscatcen,2)**2 + dummies(nscatcen,3)**2 - & dummies(nscatcen,4)**2) if (scatcen(nscatcen,4).lt.0.d0) then dummies(nscatcen,1) = -1.*dummies(nscatcen,1) dummies(nscatcen,2) = -1.*dummies(nscatcen,2) dummies(nscatcen,3) = -1.*dummies(nscatcen,3) endif elseif (recmode.eq.3) then if (softrec) then scatflav(nscatcen) = k(1,2) scatcen(nscatcen,1) = p(n-1,1) - p(1,1) scatcen(nscatcen,2) = p(n-1,2) - p(1,2) scatcen(nscatcen,3) = p(n-1,3) - p(1,3) scatcen(nscatcen,4) = p(n-1,4) - p(1,4) qmass2 = scatcen(nscatcen,4)**2 - scatcen(nscatcen,1)**2 & - scatcen(nscatcen,2)**2 - scatcen(nscatcen,3)**2 scatcen(nscatcen,5) = sign(sqrt(abs(qmass2)),qmass2) dummies(nscatcen,1) = scatcen(nscatcen,1)* & pdummy/scatcen(nscatcen,4) dummies(nscatcen,2) = scatcen(nscatcen,2)* & pdummy/scatcen(nscatcen,4) dummies(nscatcen,3) = scatcen(nscatcen,3)* & pdummy/scatcen(nscatcen,4) dummies(nscatcen,4) = pdummy dummies(nscatcen,5) = - sqrt(dummies(nscatcen,1)**2 + & dummies(nscatcen,2)**2 + dummies(nscatcen,3)**2 - & dummies(nscatcen,4)**2) if (scatcen(nscatcen,4).lt.0.d0) then dummies(nscatcen,1) = -1.*dummies(nscatcen,1) dummies(nscatcen,2) = -1.*dummies(nscatcen,2) dummies(nscatcen,3) = -1.*dummies(nscatcen,3) endif else scatflav(nscatcen) = k(1,2) scatcen(nscatcen,1) = p(1,1) scatcen(nscatcen,2) = p(1,2) scatcen(nscatcen,3) = p(1,3) scatcen(nscatcen,4) = p(1,4) scatcen(nscatcen,5) = p(1,5) dummies(nscatcen,1) = scatcen(nscatcen,1)* & pdummy/scatcen(nscatcen,4) dummies(nscatcen,2) = scatcen(nscatcen,2)* & pdummy/scatcen(nscatcen,4) dummies(nscatcen,3) = scatcen(nscatcen,3)* & pdummy/scatcen(nscatcen,4) dummies(nscatcen,4) = pdummy dummies(nscatcen,5) = sqrt(dummies(nscatcen,4)**2 - & dummies(nscatcen,1)**2 - dummies(nscatcen,2)**2 - & dummies(nscatcen,3)**2) C-------------------- endif - elseif (recmode.eq.4) then - pproj = (p(n-1,1)*p(1,1)+p(n-1,2)*p(1,2)+p(n-1,3)*p(1,3))/ - & pyp(n-1,8) - scatflav(nscatcen) = k(1,2) - scatcen(nscatcen,1) = pproj*p(n-1,1)/pyp(n-1,8) - scatcen(nscatcen,2) = pproj*p(n-1,2)/pyp(n-1,8) - scatcen(nscatcen,3) = pproj*p(n-1,3)/pyp(n-1,8) - scatcen(nscatcen,4) = pproj*p(n-1,4)/pyp(n-1,8) - scatcen(nscatcen,5) = 0.d0 - precoil = sqrt(scatcen(nscatcen,1)**2+scatcen(nscatcen,2)**2 - & +scatcen(nscatcen,3)**2) - dummies(nscatcen,1) = pdummy*scatcen(nscatcen,1)/precoil - dummies(nscatcen,2) = pdummy*scatcen(nscatcen,2)/precoil - dummies(nscatcen,3) = pdummy*scatcen(nscatcen,3)/precoil - dummies(nscatcen,4) = pdummy endif endif 230 continue DMLEFT=DMLEFT-(p(n,5)-P(LINE,5)) LINE=N tmp = abs(p(n,4)**2-p(n,1)**2-p(n,2)**2-p(n,3)**2)-p(n,5)**2 if (abs(tmp).ge.1.d-6) & write(logfid,*)'dokinematics 4-momentum test failed:', & tmp,j,p(l,5),p(line,5),p(n,5),reshuffle 222 CONTINUE if (p(n,5).lt.0.d0) then RETRYSPLIT=.TRUE. return endif if (p(n,5).ne.newm2) then RETRYSPLIT=.TRUE. redokin = .true. n=nold colmax=colmaxold nscatcen=nscatcenold k(l,1)=statold if (p(l,5).lt.0.d0) then newm2 = 0.d0 else if ((p(l,5).lt.q0).and.(k(l,1).ne.14)) then if ((newm2.eq.newm).and.(newm.ne.q0+1.d-6)) then newm2=q0+1.d-6 else newm2=0.d0 endif else newm2=p(l,5) if (k(l,1).eq.14) z = 0.d0 endif n2=n1 endif goto 204 endif if ((k(n,1).eq.1).and. & ((p(n,5).lt.0.d0).or.((p(n,5).gt.0.d0).and.(p(n,5).lt.q0)))) &write(logfid,*)'dokinematics did not reach sensible mass: ',l, &p(n,5),newm,p(l,5),newm2 NSCATEFF=NSCATEFF+EVWEIGHT END *********************************************************************** *** function getproba *********************************************************************** DOUBLE PRECISION FUNCTION GETPROBA(QI,QF,QAA,ZAA,EBB,TYPE, & T1,INS2) IMPLICIT NONE C--variables for Sudakov integration COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP DOUBLE PRECISION QA,ZA2,EB,T CHARACTER*2 TYP LOGICAL INSTATE C--local variables DOUBLE PRECISION QI,QF,QAA,ZAA,EBB,GETSUDAKOV,DERIV,T1 CHARACTER*2 TYPE LOGICAL INS2 QA=QAA ZA2=ZAA EB=EBB TYP=TYPE T=T1 INSTATE=INS2 GETPROBA=GETSUDAKOV(QI,QAA,QF,ZAA,EBB,TYPE,T1,INS2) & *DERIV(QF,1) END *********************************************************************** *** function getsudakov *********************************************************************** DOUBLE PRECISION FUNCTION GETSUDAKOV(QMAX1,QA1,QB1,ZA1,EB1, & TYPE3,T2,INS) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--variables for Sudakov integration COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP DOUBLE PRECISION QA,ZA2,EB,T CHARACTER*2 TYP LOGICAL INSTATE C--local variables DOUBLE PRECISION QMAX1,QA1,QB1,ZA1,EB1,TMAX,TB,YSTART,EPSI, &HFIRST,T2,GETINSUDAFAST,QB2 CHARACTER*2 TYPE3 LOGICAL INS DATA EPSI/1.d-4/ QB2=QB1 IF(INS)THEN IF(QB2.LT.Q0) write(logfid,*) 'error: Q < Q0',QB2,QMAX1 IF(QB2.LT.(Q0+1.d-10)) QB2=QB2+1.d-10 ELSE IF(QB2.LT.Q0) write(logfid,*) 'error: Q < min',QB2,QMAX1 IF(QB2.LT.(Q0+1.d-10)) QB2=QB2+1.d-10 ENDIF IF(QB2.GE.(QMAX1-1.d-10)) THEN GETSUDAKOV=1.d0 ELSE IF(INS)THEN GETSUDAKOV=GETINSUDAFAST(QB1,QMAX1,TYPE3) ELSE QA=QA1 ZA2=ZA1 EB=EB1 TYP=TYPE3 T=T2 INSTATE=.FALSE. HFIRST=0.01*(QMAX1-QB1) YSTART=0.d0 CALL ODEINT(YSTART,QB2,QMAX1,EPSI,HFIRST,0.d0,1) GETSUDAKOV=EXP(-YSTART) ENDIF ENDIF END *********************************************************************** *** function getinsudakov *********************************************************************** DOUBLE PRECISION FUNCTION GETINSUDAKOV(QB,QMAX1,TYPE3) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--variables for Sudakov integration COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP DOUBLE PRECISION QA,ZA2,EB,T CHARACTER*2 TYP LOGICAL INSTATE C--local variables DOUBLE PRECISION QMAX1,QB,QB1,ZA1,EA1,YSTART,EPSI, &HFIRST CHARACTER*2 TYPE3 DATA EPSI/1.d-4/ QB1=QB IF(QB1.LT.Q0) write(logfid,*) 'error: Q < Q0',QB1,QMAX1 IF(QB1.LT.(Q0+1.d-12)) QB1=QB1+1.d-12 IF(QB1.GE.(QMAX1-1.d-12)) THEN GETINSUDAKOV=1.d0 ELSE TYP=TYPE3 HFIRST=0.01*(QMAX1-QB1) YSTART=0.d0 CALL ODEINT(YSTART,QB1,QMAX1,EPSI,HFIRST,0.d0,6) GETINSUDAKOV=EXP(-YSTART) ENDIF END *********************************************************************** *** function deriv *********************************************************************** DOUBLE PRECISION FUNCTION DERIV(XVAL,W4) IMPLICIT NONE C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--variables for splitting function integration COMMON/INTSPLITF/QQUAD,FM DOUBLE PRECISION QQUAD,FM C--variables for Sudakov integration COMMON/SUDAINT/QA,ZA2,EB,T,INSTATE,TYP DOUBLE PRECISION QA,ZA2,EB,T CHARACTER*2 TYP LOGICAL INSTATE C--variables for pdf integration COMMON/PDFINTV/XMAX,Z DOUBLE PRECISION XMAX,Z C--variables for cross section integration COMMON/XSECV/QLOW,MDX DOUBLE PRECISION QLOW,MDX C--local variables INTEGER W4 DOUBLE PRECISION XVAL,GETSPLITI,PI,ALPHAS,GETINSPLITI, &GETINSUDAFAST,SCATPRIMFUNC,PQQ,PQG,PGG,PGQ, &MEDDERIV DATA PI/3.141592653589793d0/ IF(W4.EQ.1)THEN C--Sudakov integration IF(INSTATE)THEN DERIV=2.*GETINSPLITI(XVAL,TYP)/XVAL ELSE DERIV=2.*GETSPLITI(QA,XVAL,ZA2,EB,TYP)/XVAL ENDIF ELSEIF(W4.EQ.2)THEN C--P(q->qg) integration DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD/1.,LPS)* & PQQ(XVAL)/(2.*PI) ELSEIF(W4.EQ.3)THEN C--P(g->gg) integration DERIV=(1.+FM)*ALPHAS(XVAL*(1.-XVAL)*QQUAD/1.,LPS) & *PGG(XVAL)/(2.*PI) ELSEIF(W4.EQ.4)THEN C--P(g->qq) integration DERIV=(1.+FM)*ALPHAS(XVAL*(1-XVAL)*QQUAD/1.,LPS)* & PQG(XVAL)/(2.*PI) ELSEIF(W4.EQ.5)THEN DERIV=EXP(-XVAL)/XVAL ELSEIF(W4.EQ.6)THEN DERIV=2.*GETINSPLITI(XVAL,TYP)/XVAL ELSEIF(W4.EQ.7)THEN DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ') & *ALPHAS((1.-Z)*XVAL**2/1.,LPS) & *PQQ(Z)/(2.*PI*XVAL) ELSEIF(W4.EQ.8)THEN DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC') & *ALPHAS((1.-Z)*XVAL**2/1.,LPS) & *PGQ(Z)/(2.*PI*XVAL) ELSEIF(W4.EQ.9)THEN DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ') & *ALPHAS((1.-Z)*XVAL**2/1.,LPS) & *PQG(Z)/(2.*PI*XVAL) ELSEIF(W4.EQ.10)THEN DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC') & *ALPHAS((1.-Z)*XVAL**2/1.,LPS)* & *2.*PGG(Z)/(2.*PI*XVAL) ELSEIF(W4.EQ.11)THEN DERIV=3.*GETINSPLITI(SCALEFACM*SQRT(XVAL),'GQ') & *SCATPRIMFUNC(XVAL,MDX)/(2.*XVAL) ELSEIF(W4.EQ.12)THEN DERIV=2.*GETINSPLITI(SCALEFACM*SQRT(XVAL),'QG') & *SCATPRIMFUNC(XVAL,MDX)/(3.*XVAL) ELSEIF(W4.EQ.13)THEN DERIV=GETINSUDAFAST(QLOW,SCALEFACM*SQRT(XVAL),'GC') & *3.*2.*PI*ALPHAS(XVAL+MDX**2,LQCD)**2/(2.*(XVAL+MDX**2)**2) ELSEIF(W4.EQ.14)THEN DERIV=GETINSUDAFAST(QLOW,SCALEFACM*SQRT(XVAL),'QQ') & *2.*2.*PI*ALPHAS(XVAL+MDX**2,LQCD)**2/(3.*(XVAL+MDX**2)**2) ELSEIF(W4.EQ.21)THEN DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')*GETINSPLITI(XVAL,'QQ') & /XVAL ELSEIF(W4.EQ.22)THEN DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')*GETINSPLITI(XVAL,'GQ') & /XVAL ELSEIF(W4.EQ.23)THEN DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'QQ')*GETINSPLITI(XVAL,'QG') & /XVAL ELSEIF(W4.EQ.24)THEN DERIV=2.*GETINSUDAFAST(XVAL,XMAX,'GC')*2. & *GETINSPLITI(XVAL,'GG')/XVAL ELSE DERIV=MEDDERIV(XVAL,W4-100) ENDIF END *********************************************************************** *** function getspliti *********************************************************************** DOUBLE PRECISION FUNCTION GETSPLITI(QA,QB,ZETA,EB,TYPE1) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--splitting integral COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000), &SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT INTEGER NPOINT DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV, &QVAL,ZMVAL,QMAX,ZMMIN C--variables for splitting function integration COMMON/INTSPLITF/QQUAD,FM DOUBLE PRECISION QQUAD,FM C--number of extrapolations in tables common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf, &ntotxsec,noverxsec,ntotsuda,noversuda integer ntotspliti,noverspliti,ntotpdf,noverpdf, &ntotxsec,noverxsec,ntotsuda,noversuda C--local variables INTEGER I,J,LT,QLMAX,ZLMAX,QLINE,ZLINE DOUBLE PRECISION QA,QB,ZETA,EB,LOW,X1A(2),X2A(2),YA(2,2),Y, &SPLITINTGG,SPLITINTQG,A,B,YB(2) CHARACTER*2 TYPE1 ntotspliti=ntotspliti+1 if (qb.gt.qmax) then noverspliti=noverspliti+1 if (noverspliti.le.25) & write(logfid,*)'WARNING in getspliti: need to extrapolate: ', & qb,qmax endif C--find boundaries for z integration IF(ANGORD.AND.(ZETA.NE.1.d0))THEN LOW=MAX(0.5-0.5*SQRT(1.-Q0**2/QB**2) & *SQRT(1.-QB**2/EB**2), & 0.5-0.5*SQRT(1.-4.*QB**2*(1.-ZETA)/(ZETA*QA**2))) ELSE LOW=0.5-0.5*SQRT(1.-Q0**2/QB**2) & *SQRT(1.-QB**2/EB**2) ENDIF C--find values in array QLMAX=INT((QB-QVAL(1))*NPOINT/(QVAL(1000)-QVAL(1))+1) QLINE=MAX(QLMAX,1) QLINE=MIN(QLINE,NPOINT) ZLMAX=INT((LOG(LOW)-LOG(ZMVAL(1)))*NPOINT/ & (LOG(ZMVAL(1000))-LOG(ZMVAL(1)))+1) ZLINE=MAX(ZLMAX,1) ZLINE=MIN(ZLINE,NPOINT) IF((QLINE.GT.999).OR.(ZLINE.GT.999).OR. & (QLINE.LT.1).OR.(ZLINE.LT.1))THEN write(logfid,*)'ERROR in GETSPLITI: line number out of bound', & QLINE,ZLINE ENDIF IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN DO 17 I=1,2 X1A(I)=QVAL(QLINE-1+I) X2A(I)=ZMVAL(ZLINE-1+I) DO 16 J=1,2 YA(I,J)=SPLITIGGV(QLINE-1+I,ZLINE-1+J) 16 CONTINUE 17 CONTINUE DO 30 I=1,2 A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1)) B=YA(I,1)-A*X2A(1) YB(I)=A*LOW+B 30 CONTINUE IF(X1A(1).EQ.X1A(2))THEN Y=(YB(1)+YB(2))/2. ELSE A=(YB(2)-YB(1))/(X1A(2)-X1A(1)) B=YB(1)-A*X1A(1) Y=A*QB+B ENDIF IF(TYPE1.EQ.'GG')THEN GETSPLITI=MIN(Y,10.d0) ELSE SPLITINTGG=MIN(Y,10.d0) ENDIF ENDIF IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN DO 19 I=1,2 X1A(I)=QVAL(QLINE-1+I) X2A(I)=ZMVAL(ZLINE-1+I) DO 18 J=1,2 YA(I,J)=SPLITIQGV(QLINE-1+I,ZLINE-1+J) 18 CONTINUE 19 CONTINUE DO 31 I=1,2 A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1)) B=YA(I,1)-A*X2A(1) YB(I)=A*LOW+B 31 CONTINUE IF(X1A(1).EQ.X1A(2))THEN Y=(YB(1)+YB(2))/2. ELSE A=(YB(2)-YB(1))/(X1A(2)-X1A(1)) B=YB(1)-A*X1A(1) Y=A*QB+B ENDIF IF(TYPE1.EQ.'QG')THEN GETSPLITI=NF*MIN(Y,10.d0) ELSE SPLITINTQG=NF*MIN(Y,10.d0) ENDIF ENDIF IF(TYPE1.EQ.'QQ')THEN DO 21 I=1,2 X1A(I)=QVAL(QLINE-1+I) X2A(I)=ZMVAL(ZLINE-1+I) DO 20 J=1,2 YA(I,J)=SPLITIQQV(QLINE-1+I,ZLINE-1+J) 20 CONTINUE 21 CONTINUE DO 32 I=1,2 A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1)) B=YA(I,1)-A*X2A(1) YB(I)=A*LOW+B 32 CONTINUE IF(X1A(1).EQ.X1A(2))THEN Y=(YB(1)+YB(2))/2. ELSE A=(YB(2)-YB(1))/(X1A(2)-X1A(1)) B=YB(1)-A*X1A(1) Y=A*QB+B ENDIF GETSPLITI=MIN(Y,10.d0) ENDIF IF(TYPE1.EQ.'GC') GETSPLITI=SPLITINTGG+SPLITINTQG END *********************************************************************** *** function getinspliti *********************************************************************** DOUBLE PRECISION FUNCTION GETINSPLITI(QB,TYPE1) IMPLICIT NONE C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--local variables DOUBLE PRECISION QB,LOW,PI,Y,SPLITINTGG,SPLITINTQG,UP,EI CHARACTER*2 TYPE1 DATA PI/3.141592653589793d0/ C--find boundaries for z integration UP = 1. - Q0**2/(4.*QB**2) IF((TYPE1.EQ.'GG').OR.(TYPE1.EQ.'GC'))THEN LOW=1.d0-UP IF (UP.LE.LOW) THEN GETINSPLITI=0.d0 RETURN ENDIF Y = 2.* ( LOG(LOG((1.-LOW)*QB**2/LPS**2)) & - LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2 & + LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4 & - LPS**6*EI(3.*LOG((1.-LOW)*QB**2/LPS**2))/QB**6 & - LOG(LOG((1.-UP)*QB**2/LPS**2)) & + LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2 & - LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4 & + LPS**6*EI(3.*LOG((1.-UP)*QB**2/LPS**2))/QB**6 & + LOW - LOG(LOW) - UP + LOG(UP) ) & *3.*12.*PI/(2.*PI*(33.-2.*NF)) IF(TYPE1.EQ.'GG')THEN GETINSPLITI=Y ELSE SPLITINTGG=Y ENDIF ENDIF IF((TYPE1.EQ.'QG').OR.(TYPE1.EQ.'GC'))THEN LOW=0.d0 IF (UP.LE.LOW) THEN GETINSPLITI=0.d0 RETURN ENDIF Y = ( 2.*LPS**6*EI(3.*LOG((1.-LOW)*QB**2/LPS**2))/QB**6 & - 2.*LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4 & + 2.*LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2 & - 2.*LPS**6*EI(3.*LOG((1.-UP)*QB**2/LPS**2))/QB**6 & + 2.*LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4 & - 2.*LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2 ) & *12.*PI/(2.*2.*PI*(33.-2.*NF)) IF(TYPE1.EQ.'QG')THEN GETINSPLITI=NF*Y ELSE SPLITINTQG=NF*Y ENDIF ENDIF IF(TYPE1.EQ.'QQ')THEN LOW=0.d0 IF (UP.LE.LOW) THEN GETINSPLITI=0.d0 RETURN ENDIF Y = ( 2.*LOG(LOG((1.-LOW)*QB**2/LPS**2)) & - 2.*LPS**2*EI(LOG((1.-LOW)*QB**2/LPS**2))/QB**2 & + LPS**4*EI(2.*LOG((1.-LOW)*QB**2/LPS**2))/QB**4 & - 2.*LOG(LOG((1.-UP)*QB**2/LPS**2)) & + 2.*LPS**2*EI(LOG((1.-UP)*QB**2/LPS**2))/QB**2 & - LPS**4*EI(2.*LOG((1.-UP)*QB**2/LPS**2))/QB**4 ) & *4.*12.*PI/(3.*2.*PI*(33.-2.*NF)) GETINSPLITI=Y ENDIF IF(TYPE1.EQ.'GQ')THEN LOW=1.d0-UP IF (UP.LE.LOW) THEN GETINSPLITI=0.d0 RETURN ENDIF Y = (UP**2/2.-2.*UP+2.*LOG(UP)-LOW**2/2.+2.*LOW- 2.*LOG(LOW)) & *4.*12.*PI/(3.*2.*PI*(33.-2.*NF)*LOG(QB**2/LPS**2)) GETINSPLITI=Y ENDIF IF(TYPE1.EQ.'GC') GETINSPLITI=SPLITINTGG+SPLITINTQG END *********************************************************************** *** function getpdf *********************************************************************** DOUBLE PRECISION FUNCTION GETPDF(X,Q,TYP) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--pdf common block COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000), &GINGX(2,1000) DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--variables for pdf integration COMMON/PDFINTV/XMAX,Z DOUBLE PRECISION XMAX,Z C--local variables DOUBLE PRECISION X,Q,QLOW,QHIGH,YSTART,EPSI,HFIRST CHARACTER*2 TYP DATA EPSI/1.d-4/ IF((X.LT.0.d0).OR.(X.GT.1.d0).OR.(Q.LT.Q0))THEN write(logfid,*)'error in GETPDF: parameter out of bound',X,Q GETPDF=0.d0 RETURN ENDIF IF(TYP.EQ.'QQ')THEN Z=X XMAX=Q C--f_q^q QLOW=MAX(Q0,Q0/(2.*SQRT(1.-X))) QHIGH=Q IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN YSTART=0.d0 ELSE HFIRST=0.01*(QHIGH-QLOW) YSTART=0.d0 CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,7) ENDIF GETPDF=YSTART ELSEIF(TYP.EQ.'GQ')THEN Z=X XMAX=Q C--f_q^g QLOW=MAX(Q0,MAX(Q0/(2.*SQRT(X)),Q0/(2.*SQRT(1.-X)))) QHIGH=Q IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.LT.0.d0+1.d-10) & .OR.(X.GT.1.d0-1.d-10))THEN YSTART=0.d0 ELSE HFIRST=0.01*(QHIGH-QLOW) YSTART=0.d0 CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,8) ENDIF GETPDF=YSTART ELSEIF(TYP.EQ.'QG')THEN Z=X XMAX=Q C--f_q^g QLOW=MAX(Q0,Q0/(2.*SQRT(1.-X))) QHIGH=Q IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.GT.1.d0-1.d-10))THEN YSTART=0.d0 ELSE HFIRST=0.01*(QHIGH-QLOW) YSTART=0.d0 CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,9) ENDIF GETPDF=YSTART ELSEIF(TYP.EQ.'GG')THEN Z=X XMAX=Q C--f_q^q QLOW=MAX(Q0,MAX(Q0/(2.*SQRT(X)),Q0/(2.*SQRT(1.-X)))) QHIGH=Q IF((QLOW.GE.QHIGH*(1.d0-1.d-10)).OR.(X.LT.0.d0+1.d-10) & .OR.(X.GT.1.d0-1d-10))THEN YSTART=0.d0 ELSE HFIRST=0.01*(QHIGH-QLOW) YSTART=0.d0 CALL ODEINT(YSTART,QLOW,QHIGH,EPSI,HFIRST,0.d0,10) ENDIF GETPDF=YSTART ELSE write(logfid,*)'error: pdf-type ',TYP,' does not exist' GETPDF=0.d0 ENDIF END *********************************************************************** *** function getpdfxint *********************************************************************** DOUBLE PRECISION FUNCTION GETPDFXINT(Q,TYP) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--pdf common block COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000), &GINGX(2,1000) DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX C--number of extrapolations in tables common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf, &ntotxsec,noverxsec,ntotsuda,noversuda integer ntotspliti,noverspliti,ntotpdf,noverpdf, &ntotxsec,noverxsec,ntotsuda,noversuda C--local variables INTEGER J,Q2CLOSE,Q2LINE DOUBLE PRECISION Q,XA(2),YA(2),Y,A,B CHARACTER*2 TYP ntotpdf=ntotpdf+1 if (q**2.gt.QINQX(1,1000)) then noverpdf=noverpdf+1 if (noverpdf.le.25) & write(logfid,*)'WARNING in getpdfxint: need to extrapolate: ', & q**2,QINQX(1,1000) endif Q2CLOSE=INT((LOG(Q**2)-LOG(QINQX(1,1)))*999.d0/ & (LOG(QINQX(1,1000))-LOG(QINQX(1,1)))+1) Q2LINE=MAX(Q2CLOSE,1) Q2LINE=MIN(Q2LINE,999) IF((Q2LINE.GT.999).OR.(Q2LINE.LT.1))THEN write(logfid,*)'ERROR in GETPDFXINT: line number out of bound', & Q2LINE ENDIF IF(TYP.EQ.'QQ')THEN DO 11 J=1,2 XA(J)=QINQX(1,Q2LINE-1+J) YA(J)=QINQX(2,Q2LINE-1+J) 11 CONTINUE ELSEIF(TYP.EQ.'GQ')THEN DO 13 J=1,2 XA(J)=GINQX(1,Q2LINE-1+J) YA(J)=GINQX(2,Q2LINE-1+J) 13 CONTINUE ELSEIF(TYP.EQ.'QG')THEN DO 15 J=1,2 XA(J)=QINGX(1,Q2LINE-1+J) YA(J)=QINGX(2,Q2LINE-1+J) 15 CONTINUE ELSEIF(TYP.EQ.'GG')THEN DO 17 J=1,2 XA(J)=GINGX(1,Q2LINE-1+J) YA(J)=GINGX(2,Q2LINE-1+J) 17 CONTINUE ELSE write(logfid,*)'error in GETPDFXINT: unknown integral type ',TYP ENDIF A=(YA(2)-YA(1))/(XA(2)-XA(1)) B=YA(1)-A*XA(1) Y=A*Q**2+B GETPDFXINT=Y END *********************************************************************** *** subroutine getpdfxintexact *********************************************************************** DOUBLE PRECISION FUNCTION GETPDFXINTEXACT(Q,TYP) IMPLICIT NONE C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--variables for pdf integration COMMON/PDFINTV/XMAX,Z DOUBLE PRECISION XMAX,Z C--local variables DOUBLE PRECISION Q,EPSI,YSTART,HFIRST CHARACTER*2 TYP DATA EPSI/1.d-4/ HFIRST=0.01d0 YSTART=0.d0 XMAX=Q Z=0.d0 IF(TYP.EQ.'QQ')THEN CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,21) ELSEIF(TYP.EQ.'QG')THEN CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,23) ELSEIF(TYP.EQ.'GQ')THEN CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,22) ELSEIF(TYP.EQ.'GG')THEN CALL ODEINT(YSTART,Q0,Q,EPSI,HFIRST,0.d0,24) ENDIF GETPDFXINTEXACT=YSTART END *********************************************************************** *** function getxsecint *********************************************************************** DOUBLE PRECISION FUNCTION GETXSECINT(TM,MD,TYP2) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--cross secttion common block COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101), &INTG1(1001,101),INTG2(1001,101) DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2 C--variables for cross section integration COMMON/XSECV/QLOW,MDX DOUBLE PRECISION QLOW,MDX C--number of extrapolations in tables common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf, &ntotxsec,noverxsec,ntotsuda,noversuda integer ntotspliti,noverspliti,ntotpdf,noverpdf, &ntotxsec,noverxsec,ntotsuda,noversuda C--local variables INTEGER TLINE,TCLOSE,MDCLOSE,MDLINE,I,J DOUBLE PRECISION TM,X1A(2),X2A(2),YA(2,2),Y,MD,YB(2),A,B CHARACTER*2 TYP2 ntotxsec=ntotxsec+1 if (tm.gt.intq1(1000,101)) then noverxsec=noverxsec+1 if (noverpdf.le.25) & write(logfid,*)'WARNING in getxsecint: need to extrapolate: ', & tm,intq1(1000,101) endif TCLOSE=INT((LOG(TM)-LOG(INTQ1(1,101)))*999.d0/ & (LOG(INTQ1(1000,101))-LOG(INTQ1(1,101)))+1) TLINE=MAX(TCLOSE,1) TLINE=MIN(TLINE,999) MDCLOSE=INT((MD-INTQ1(1001,1))*99.d0/ &(INTQ1(1001,100)-INTQ1(1001,1))+1) MDLINE=MAX(MDCLOSE,1) MDLINE=MIN(MDLINE,99) IF((TLINE.GT.999).OR.(MDLINE.GT.99) & .OR.(TLINE.LT.1).OR.(MDLINE.LT.1)) THEN write(logfid,*)'ERROR in GETXSECINT: line number out of bound', & TLINE,MDLINE ENDIF IF(TYP2.EQ.'QA')THEN C--first quark integral DO 12 I=1,2 X1A(I)=INTQ1(1001,MDLINE-1+I) X2A(I)=INTQ1(TLINE-1+I,101) DO 11 J=1,2 YA(I,J)=INTQ1(TLINE-1+J,MDLINE-1+I) 11 CONTINUE 12 CONTINUE ELSEIF(TYP2.EQ.'QB')THEN C--second quark integral DO 18 I=1,2 X1A(I)=INTQ2(1001,MDLINE-1+I) X2A(I)=INTQ2(TLINE-1+I,101) DO 17 J=1,2 YA(I,J)=INTQ2(TLINE-1+J,MDLINE-1+I) 17 CONTINUE 18 CONTINUE ELSEIF(TYP2.EQ.'GA')THEN C--first gluon integral DO 14 I=1,2 X1A(I)=INTG1(1001,MDLINE-1+I) X2A(I)=INTG1(TLINE-1+I,101) DO 13 J=1,2 YA(I,J)=INTG1(TLINE-1+J,MDLINE-1+I) 13 CONTINUE 14 CONTINUE ELSEIF(TYP2.EQ.'GB')THEN C--second gluon integral DO 16 I=1,2 X1A(I)=INTG2(1001,MDLINE-1+I) X2A(I)=INTG2(TLINE-1+I,101) DO 15 J=1,2 YA(I,J)=INTG2(TLINE-1+J,MDLINE-1+I) 15 CONTINUE 16 CONTINUE ELSE write(logfid,*)'error in GETXSECINT: unknown integral type ', & TYP2 ENDIF DO 19 I=1,2 A=(YA(I,2)-YA(I,1))/(X2A(2)-X2A(1)) B=YA(I,1)-A*X2A(1) YB(I)=A*TM+B 19 CONTINUE IF(X1A(1).EQ.X1A(2))THEN Y=YB(1) ELSE A=(YB(2)-YB(1))/(X1A(2)-X1A(1)) B=YB(1)-A*X1A(1) Y=A*MD+B ENDIF GETXSECINT=Y END *********************************************************************** *** function getinsudafast *********************************************************************** DOUBLE PRECISION FUNCTION GETINSUDAFAST(Q1,Q2,TYP) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--local variables DOUBLE PRECISION Q1,Q2,GETINSUDARED CHARACTER*2 TYP IF(Q2.LE.Q1)THEN GETINSUDAFAST=1.d0 ELSEIF(Q1.LE.Q0)THEN GETINSUDAFAST=GETINSUDARED(Q2,TYP) ELSE GETINSUDAFAST=GETINSUDARED(Q2,TYP)/GETINSUDARED(Q1,TYP) ENDIF IF(GETINSUDAFAST.GT.1.d0) GETINSUDAFAST=1.d0 IF(GETINSUDAFAST.LT.(-1.d-10))THEN write(logfid,*)'ERROR: GETINSUDAFAST < 0:', & GETINSUDAFAST,' for',Q1,' ',Q2,' ',TYP ENDIF if (getinsudafast.lt.0.d0) getinsudafast = 0.d0 END *********************************************************************** *** function getinsudared *********************************************************************** DOUBLE PRECISION FUNCTION GETINSUDARED(Q,TYP2) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--Sudakov common block COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2), &SUDAGC(1000,2) DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC C--number of extrapolations in tables common/extrapolations/ntotspliti,noverspliti,ntotpdf,noverpdf, &ntotxsec,noverxsec,ntotsuda,noversuda integer ntotspliti,noverspliti,ntotpdf,noverpdf, &ntotxsec,noverxsec,ntotsuda,noversuda C--local variables INTEGER QCLOSE,QBIN,I DOUBLE PRECISION Q,XA(2),YA(2),Y,A,B CHARACTER*2 TYP2 ntotsuda=ntotsuda+1 if (q.gt.sudaqq(1000,1)) then noversuda=noversuda+1 if (noversuda.le.25) & write(logfid,*)'WARNING in getinsudared: need to extrapolate: ', & q,sudaqq(1000,1) endif QCLOSE=INT((LOG(Q)-LOG(SUDAQQ(1,1)))*999.d0 & /(LOG(SUDAQQ(1000,1))-LOG(SUDAQQ(1,1)))+1) QBIN=MAX(QCLOSE,1) QBIN=MIN(QBIN,999) IF((QBIN.GT.999).OR.(QBIN.LT.1)) THEN write(logfid,*) & 'ERROR in GETINSUDARED: line number out of bound',QBIN ENDIF IF(TYP2.EQ.'QQ')THEN DO 16 I=1,2 XA(I)=SUDAQQ(QBIN-1+I,1) YA(I)=SUDAQQ(QBIN-1+I,2) 16 CONTINUE ELSEIF(TYP2.EQ.'QG')THEN DO 17 I=1,2 XA(I)=SUDAQG(QBIN-1+I,1) YA(I)=SUDAQG(QBIN-1+I,2) 17 CONTINUE ELSEIF(TYP2.EQ.'GG')THEN DO 18 I=1,2 XA(I)=SUDAGG(QBIN-1+I,1) YA(I)=SUDAGG(QBIN-1+I,2) 18 CONTINUE ELSEIF(TYP2.EQ.'GC')THEN DO 19 I=1,2 XA(I)=SUDAGC(QBIN-1+I,1) YA(I)=SUDAGC(QBIN-1+I,2) 19 CONTINUE ELSE write(logfid,*)'error in GETINSUDARED: unknown type ',TYP2 ENDIF A=(YA(2)-YA(1))/(XA(2)-XA(1)) B=YA(1)-A*XA(1) Y=A*Q+B GETINSUDARED=Y IF(GETINSUDARED.LT.(-1.d-10))THEN write(logfid,*) 'ERROR: GETINSUDARED < 0:',GETINSUDARED,Q,TYP2 ENDIF if (getinsudared.lt.0.d0) getinsudared = 0.d0 END *********************************************************************** *** function getsscat *********************************************************************** DOUBLE PRECISION FUNCTION GETSSCAT(EN,px,py,PZ,MP,LW,TYPE1,TYPE2, & x,y,z,t,mode) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--variables for cross section integration COMMON/XSECV/QLOW,MDX DOUBLE PRECISION QLOW,MDX C--local variables integer mode DOUBLE PRECISION UP,EN,LW,SCATPRIMFUNC,CCOL,MP, &LOW,GETPDFXINT,GETXSECINT,MDEB,pz,pcms2,shat,gettemp, &x,y,z,t,getmd,avmom(5),px,py,getmdmin,getmdmax,pproj,psct CHARACTER TYPE1,TYPE2 IF(TYPE1.EQ.'Q')THEN CCOL=2./3. ELSE CCOL=3./2. ENDIF if (mode.eq.0) then mdeb = getmd(x,y,z,t) call avscatcen(x,y,z,t, & avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) shat = avmom(5)**2 + mp**2 + & 2.*(avmom(4)*en - avmom(1)*px - avmom(2)*py - avmom(3)*pz) pcms2 = (shat+mp**2-avmom(5)**2)**2/(4.*shat)-mp**2 up = 4.*pcms2 else if (mode.eq.1) then mdeb = getmdmin() else mdeb = getmdmax() endif call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) psct = sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2) pproj = sqrt(px**2+py**2+pz**2) shat = avmom(5)**2 + mp**2 + 2.*(en*avmom(4) + pproj*psct) pcms2 = (shat+mp**2-avmom(5)**2)**2/(4.*shat)-mp**2 up = 4.*pcms2 endif LOW=LW**2 IF(LOW.GT.UP)THEN GETSSCAT=0.d0 RETURN ENDIF IF((TYPE2.EQ.'C').OR. & ((TYPE1.EQ.'Q').AND.(TYPE2.EQ.'Q')).OR. & ((TYPE1.EQ.'G').AND.(TYPE2.EQ.'G')))THEN GETSSCAT=CCOL*(SCATPRIMFUNC(UP,MDEB)-SCATPRIMFUNC(LOW,MDEB)) ELSE GETSSCAT=0.d0 ENDIF LOW=Q0**2/SCALEFACM**2 IF(UP.GT.LOW)THEN IF(TYPE1.EQ.'Q')THEN IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN GETSSCAT=GETSSCAT+GETPDFXINT(SCALEFACM*SQRT(UP),'GQ') & *3.*SCATPRIMFUNC(UP,MDEB)/2. GETSSCAT=GETSSCAT-GETXSECINT(UP,MDEB,'QA') ENDIF ELSE IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'G'))THEN GETSSCAT=GETSSCAT+CCOL*(SCATPRIMFUNC(UP,MDEB)- & SCATPRIMFUNC(LOW,MDEB)) & - GETXSECINT(UP,MDEB,'GB') ENDIF IF((TYPE2.EQ.'C').OR.(TYPE2.EQ.'Q'))THEN GETSSCAT=GETSSCAT+2.*GETPDFXINT(SCALEFACM*SQRT(UP),'QG') & *2.*SCATPRIMFUNC(UP,MDEB)/3. GETSSCAT=GETSSCAT-2.*GETXSECINT(UP,MDEB,'GA') ENDIF ENDIF ENDIF IF(GETSSCAT.LT.-1.d-4) then write(logfid,*) 'error: cross section < 0',GETSSCAT,'for', & EN,mp,LW,TYPE1,TYPE2,LW**2,UP,mode endif GETSSCAT=MAX(GETSSCAT,0.d0) END *********************************************************************** *** function getmass *********************************************************************** DOUBLE PRECISION FUNCTION GETMASS(QBMIN,QBMAX,THETA,EP,TYPE, & MAX2,INS,ZDEC,QQBARDEC) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--Common block of Pythia COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200) INTEGER MSTU,MSTJ DOUBLE PRECISION PARU,PARJ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5) INTEGER MDCY,MDME,KFDP DOUBLE PRECISION BRAT C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--time common block COMMON/TIME/MV(23000,5) DOUBLE PRECISION MV C--factor in front of alphas argument COMMON/ALPHASFAC/PTFAC DOUBLE PRECISION PTFAC C--local variables DOUBLE PRECISION qbmin,qbmax,theta,ep,max2,zdec, &q2min,alphmax,alphas,log14,pref,q2max,sudaover,gmin, &gmax,arg,cand,eps,trueeps,trueval,oest,weight,getinspliti, &r,pyr,z,rz,thetanew,r2,pi,pqq,pgg,pqg,rmin CHARACTER*2 TYPE LOGICAL INS,QQBARDEC DATA PI/3.141592653589793d0/ q2min = q0**2 alphmax = alphas(3.*ptfac*q2min/16.,lps) log14 = log(0.25) IF(TYPE.EQ.'QQ')THEN pref=4.*alphmax/(3.*2.*PI) ELSE pref=29.*alphmax/(8.*2.*PI) ENDIF C--check if phase space available, return 0.d0 otherwise IF((qbmax.LE.QBMIN).OR.(EP.LT.QBMIN)) THEN getmass=0.d0 ZDEC=0.d0 QQBARDEC=.FALSE. RETURN ENDIF q2max = qbmax**2 -! 21 sudaover = exp(-pref*(log(q2min/(4.*q2max))**2 - log14**2)) -! IF(pyr(0).LE.sudaover)THEN 21 if (q2max-qbmin**2.lt.1e-4)then getmass=qbmin zdec=0.5 IF(TYPE.EQ.'QQ')THEN QQBARDEC=.FALSE. ELSE IF(PYR(0).LT.PQG(0.5d0)/(PQG(0.5d0)+PGG(0.5d0)))THEN QQBARDEC=.TRUE. ELSE QQBARDEC=.FALSE. ENDIF endif return endif gmax = pref*log(q2min/(4.*q2max))**2 if (qbmin.gt.0.d0) then rmin = exp(pref*log(q2min/(4.*qbmin**2))**2-gmax) else rmin = 0.d0 endif r=pyr(0)*(1.d0-rmin)+rmin arg=gmax+log(r) if(arg.lt.0.d0)then getmass=0.d0 ZDEC=0.d0 QQBARDEC=.FALSE. RETURN endif -! r=pyr(0) -! gmin = pref*log14**2 -! gmax = pref*log(q2min/(4.*q2max))**2 -! arg = log(r*exp(gmax)+(1.-r)*exp(gmin)) cand = q2min*exp(sqrt(arg/pref))/4. eps = q2min/(4.*cand) if ((cand.lt.q2min).or.(cand.lt.qbmin**2)) then getmass=0.d0 ZDEC=0.d0 QQBARDEC=.FALSE. RETURN endif IF((CAND.GT.MAX2**2).OR.(CAND.GT.EP**2))THEN q2max=cand goto 21 ENDIF if (ins) then trueval=getinspliti(sqrt(cand),type) oest = -2.*pref*log(eps) weight = trueval/oest else C--find true z interval TRUEEPS=0.5-0.5*SQRT(1.-q2min/cand) & *SQRT(1.-cand/EP**2) IF(TRUEEPS.LT.EPS) & WRITE(logfid,*)'error in getmass: true eps < eps',TRUEEPS,EPS RZ=PYR(0) z = 1.-eps**rz if ((z.lt.trueeps).or.(z.gt.(1.-trueeps))) then weight = 0. else if (type.eq.'QQ')then -! if (ins) then -! trueval = alphas(ptfac*(1.-z)*cand,lps)*pqq(z)/(2.*pi) -! else trueval = alphas(ptfac*z*(1.-z)*cand,lps)*pqq(z)/(2.*pi) -! endif oest = 2.*pref/(1.-z) weight = trueval/oest else if (pyr(0).lt.(17./29.)) z = 1.-z -! if (ins)then -! trueval = alphas(ptfac*(1.-z)*cand,lps) -! & *(pgg(z)+pqg(z))/(2.*pi) -! else trueval = alphas(ptfac*z*(1.-z)*cand,lps) & *(pgg(z)+pqg(z))/(2.*pi) -! endif oest = alphmax*(17./(4.*z)+3./(1.-z))/(2.*pi) weight = trueval/oest endif thetanew = sqrt(cand/(z*(1.-z)))/ep if (angord.and.(theta.gt.0.).and.(thetanew.gt.theta)) & weight = 0.d0 endif endif IF (WEIGHT.GT.1.d0) WRITE(logfid,*) & 'problem in getmass: weight> 1', & WEIGHT,TYPE,EPS,TRUEEPS,Z,CAND R2=PYR(0) IF(R2.GT.WEIGHT)THEN q2max=cand GOTO 21 ELSE getmass=sqrt(cand) if (.not.ins) then ZDEC=Z IF(TYPE.EQ.'QQ')THEN QQBARDEC=.FALSE. ELSE IF(PYR(0).LT.PQG(Z)/(PQG(Z)+PGG(Z)))THEN QQBARDEC=.TRUE. ELSE QQBARDEC=.FALSE. ENDIF ENDIF endif ENDIF END *********************************************************************** *** function generatez *********************************************************************** DOUBLE PRECISION FUNCTION GENERATEZ(TI,EA,EPSI,TYPE) IMPLICIT NONE C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--local variables DOUBLE PRECISION TI,EA,EPS,PYR,X,R,HELP,R1,EPSI CHARACTER*2 TYPE IF(TI.EQ.0.d0)THEN EPS=EPSI ELSE EPS=MAX(0.5-0.5*SQRT(1.-Q0**2/TI) & *SQRT(1.-TI/EA**2),EPSI) ENDIF IF(EPS.GT.0.5)THEN GENERATEZ=0.5 GOTO 61 ENDIF 60 R=PYR(0) IF(TYPE.EQ.'QQ')THEN X=1.-(1.-EPS)*(EPS/(1.-EPS))**R R=PYR(0) IF(R.LT.((1.+X**2)/2.))THEN GENERATEZ=X ELSE GOTO 60 ENDIF ELSEIF(TYPE.EQ.'GG')THEN X=1./(1.+((1.-EPS)/EPS)**(1.-2.*R)) R=PYR(0) HELP=((1.-X)/X+X/(1.-X)+X*(1.-X))/(1./(1.-X)+1./X) IF(R.LT.HELP)THEN GENERATEZ=X ELSE GOTO 60 ENDIF ELSE R=PYR(0)*(1.-2.*EPS)+EPS R1=PYR(0)/2. HELP=0.5*(R**2+(1.-R)**2) IF(R1.LT.HELP)THEN GENERATEZ=R ELSE GOTO 60 ENDIF ENDIF 61 END *********************************************************************** *** function scatprimfunc *********************************************************************** DOUBLE PRECISION FUNCTION SCATPRIMFUNC(T,MDEB) IMPLICIT NONE C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--local variables DOUBLE PRECISION T,PI,S,EI,ALPHAS,T1,MDEB DATA PI/3.141592653589793d0/ SCATPRIMFUNC = 2.*PI*(12.*PI)**2*( & - EI(-LOG((T+MDEB**2)/LQCD**2))/LQCD**2 & - 1./((T+MDEB**2)*LOG((T+MDEB**2)/LQCD**2)))/(33.-2.*NF)**2 END *********************************************************************** *** function intpqq *********************************************************************** DOUBLE PRECISION FUNCTION INTPQQ(Z,Q) IMPLICIT NONE C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--local variables DOUBLE PRECISION Z,Q INTPQQ=6.*4.*(-2.*LOG(LOG(Q**2/LPS**2) & +LOG(1.-Z)))/((33.-2.*NF)*3.) END *********************************************************************** *** function intpgglow *********************************************************************** DOUBLE PRECISION FUNCTION INTPGGLOW(Z,Q) IMPLICIT NONE C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--local variables DOUBLE PRECISION Z,Q INTPGGLOW=6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(Z)))/(33.-2.*NF) END *********************************************************************** *** function intpgghigh *********************************************************************** DOUBLE PRECISION FUNCTION INTPGGHIGH(Z,Q) IMPLICIT NONE C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--local variables DOUBLE PRECISION Z,Q INTPGGHIGH=-6.*3.*(LOG(LOG(Q**2/LPS**2)+LOG(1.-Z)))/(33.-2.*NF) END *********************************************************************** *** function intpqglow *********************************************************************** DOUBLE PRECISION FUNCTION INTPQGLOW(Z,Q) IMPLICIT NONE C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--local variables DOUBLE PRECISION Z,Q,EI INTPQGLOW=6.*(LPS**2*EI(LOG(Q**2/LPS**2)+LOG(Z))/Q**2 & - 2.*LPS**4*EI(2.*(LOG(Q**2/LPS**2)+LOG(Z)))/Q**4 & + 2.*LPS**6*EI(3.*(LOG(Q**2/LPS**2)+LOG(Z)))/Q**6)/ &((33.-2.*NF)*2.) END *********************************************************************** *** function intpqghigh *********************************************************************** DOUBLE PRECISION FUNCTION INTPQGHIGH(Z,Q) IMPLICIT NONE C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--local variables DOUBLE PRECISION Z,Q,EI INTPQGHIGH=-6.*(LPS**2*EI(LOG(Q**2/LPS**2)+LOG(1.-Z))/Q**2 & - 2.*LPS**4*EI(2.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/Q**4 & + 2.*LPS**6*EI(3.*(LOG(Q**2/LPS**2)+LOG(1.-Z)))/Q**6)/ &((33.-2.*NF)*2.) END *********************************************************************** *** function gett *********************************************************************** DOUBLE PRECISION FUNCTION GETT(MINT,MAXT,MDEB) IMPLICIT NONE C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--local variables DOUBLE PRECISION TMIN,TMAX,MAXI,PYR,R1,R2,ALPHAS,PI,Y,MAXT, &MDEB,MINT,T DATA PI/3.141592653589793d0/ TMAX=MAXT+MDEB**2 TMIN=MINT+MDEB**2 IF(TMIN.GT.TMAX) THEN GETT=0.d0 RETURN ENDIF 20 R1=PYR(0) T=TMAX*TMIN/(TMAX+R1*(TMIN-TMAX)) R2=PYR(0) IF(R2.LT.ALPHAS(T,LQCD)**2/ALPHAS(TMIN,LQCD)**2)THEN GETT=T-MDEB**2 ELSE GOTO 20 ENDIF END *********************************************************************** *** function ei *********************************************************************** DOUBLE PRECISION FUNCTION EI(X) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--exponential integral for negative arguments COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL INTEGER NVAL DOUBLE PRECISION EIXS,VALMAX C--local variables INTEGER K,LINE,LMAX DOUBLE PRECISION X,R,GA,XA(2),YA(2),Y,DY,A,B DOUBLE PRECISION YSTART,EPSI,HFIRST DATA EPSI/1.e-5/ IF(DABS(X).GT.VALMAX) & write(logfid,*)'warning: value out of array in Ei(x)',X,VALMAX IF(X.GE.0.d0)THEN LMAX=INT(X*NVAL/VALMAX) LINE=MAX(LMAX,1) LINE=MIN(LINE,999) IF((LINE.GT.999).OR.(LINE.LT.1)) THEN write(logfid,*)'ERROR in EI: line number out of bound',LINE ENDIF DO 26 K=1,2 XA(K)=EIXS(1,LINE-1+K) YA(K)=EIXS(3,LINE-1+K) 26 CONTINUE A=(YA(2)-YA(1))/(XA(2)-XA(1)) B=YA(1)-A*XA(1) Y=A*X+B ELSE LMAX=INT(-X*NVAL/VALMAX) LINE=MAX(LMAX,1) LINE=MIN(LINE,999) IF((LINE.GT.999).OR.(LINE.LT.1)) THEN write(logfid,*)'ERROR in EI: line number out of bound',LINE ENDIF DO 27 K=1,2 XA(K)=EIXS(1,LINE-1+K) YA(K)=EIXS(2,LINE-1+K) 27 CONTINUE A=(YA(2)-YA(1))/(XA(2)-XA(1)) B=YA(1)-A*XA(1) Y=-A*X+B ENDIF EI=Y END *********************************************************************** *** function pqq *********************************************************************** DOUBLE PRECISION FUNCTION PQQ(Z) IMPLICIT NONE DOUBLE PRECISION Z PQQ=4.*(1.+Z**2)/(3.*(1.-Z)) END *********************************************************************** *** function pgq *********************************************************************** DOUBLE PRECISION FUNCTION PGQ(Z) IMPLICIT NONE DOUBLE PRECISION Z PGQ=4.*(1.+(1.-Z)**2)/(3.*Z) END *********************************************************************** *** function pgg *********************************************************************** DOUBLE PRECISION FUNCTION PGG(Z) IMPLICIT NONE DOUBLE PRECISION Z PGG=3.*((1.-Z)/Z + Z/(1.-Z) + Z*(1.-Z)) END *********************************************************************** *** function pqg *********************************************************************** DOUBLE PRECISION FUNCTION PQG(Z) IMPLICIT NONE DOUBLE PRECISION Z PQG=0.5*(Z**2 + (1.-Z)**2) END *********************************************************************** *** function alphas *********************************************************************** DOUBLE PRECISION FUNCTION ALPHAS(T,LAMBDA) IMPLICIT NONE C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--local variables DOUBLE PRECISION T,L0,PI,LAMBDA DATA PI/3.141592653589793d0/ ALPHAS=4.*PI/((11.-2.*NF/3.)*LOG(T/LAMBDA**2)) END *********************************************************************** *** subroutine splitfncint *********************************************************************** SUBROUTINE SPLITFNCINT(EMAX) IMPLICIT NONE C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--splitting integral COMMON/SPLITINT/SPLITIGGV(1000,1000),SPLITIQQV(1000,1000), &SPLITIQGV(1000,1000),QVAL(1000),ZMVAL(1000),QMAX,ZMMIN,NPOINT INTEGER NPOINT DOUBLE PRECISION SPLITIGGV,SPLITIQQV,SPLITIQGV, &QVAL,ZMVAL,QMAX,ZMMIN C--variables for splitting function integration COMMON/INTSPLITF/QQUAD,FM DOUBLE PRECISION QQUAD,FM C--max rapidity common/rapmax/etamax double precision etamax C--local variables INTEGER NSTEP,I,J DOUBLE PRECISION EMAX,ZMMAX,EPSI,HFIRST,YSTART,LNZMMIN, &LNZMMAX,ZM,ZM2,Q,GETMSMAX,avmom(5),shat,pcms2 DATA ZMMAX/0.5/ DATA NSTEP/999/ DATA EPSI/1.d-5/ call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) shat = avmom(5)**2 + & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2)) pcms2 = (shat-avmom(5)**2)**2/(4.*shat) qmax = sqrt(scalefacm*4.*pcms2) ZMMIN=Q0/EMAX LNZMMIN=LOG(ZMMIN) LNZMMAX=LOG(ZMMAX) NPOINT=NSTEP DO 100 I=1,NSTEP+1 Q=(I-1)*(QMAX-Q0)/NSTEP+Q0 QVAL(I)=Q QQUAD=Q**2 DO 110 J=1,NSTEP+1 ZM=EXP((J-1)*(LNZMMAX-LNZMMIN)/NSTEP+LNZMMIN) ZMVAL(J)=ZM IF(Q**2.LT.Q0**2)THEN ZM2=0.5 ELSE ZM2=0.5-0.5*SQRT(1.-Q0**2/Q**2) ENDIF ZM=MAX(ZM,ZM2) IF(ZM.EQ.0.5)THEN SPLITIQQV(I,J)=0.d0 SPLITIGGV(I,J)=0.d0 SPLITIQGV(I,J)=0.d0 ELSE YSTART=0d0 HFIRST=0.01 FM=0.d0 CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,2) SPLITIQQV(I,J)=YSTART YSTART=0d0 HFIRST=0.01 FM=0.d0 CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,3) SPLITIGGV(I,J)=YSTART YSTART=0d0 HFIRST=0.01 FM=0.d0 CALL ODEINT(YSTART,ZM,1.-ZM,EPSI,HFIRST,0d0,4) SPLITIQGV(I,J)=YSTART ENDIF 110 CONTINUE 100 CONTINUE END *********************************************************************** *** subroutine pdfint *********************************************************************** SUBROUTINE PDFINT(EMAX) IMPLICIT NONE C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--pdf common block COMMON/PDFS/QINQX(2,1000),GINQX(2,1000),QINGX(2,1000), &GINGX(2,1000) DOUBLE PRECISION QINQX,GINQX,QINGX,GINGX C--variables for pdf integration COMMON/PDFINTV/XMAX,Z DOUBLE PRECISION XMAX,Z C--max rapidity common/rapmax/etamax double precision etamax C--local variables INTEGER I,J DOUBLE PRECISION EMAX,Q2,GETPDFXINTEXACT,YSTART,HFIRST,EPSI, &Q2MAX,DELTAQ2,avmom(5),shat,pcms2 DATA EPSI/1.d-4/ call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) shat = avmom(5)**2 + & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2)) pcms2 = (shat-avmom(5)**2)**2/(4.*shat) q2max = scalefacm*4.*pcms2 DELTAQ2=LOG(Q2MAX)-LOG(Q0**2) QINQX(1,1)=Q0**2 GINQX(1,1)=Q0**2 QINGX(1,1)=Q0**2 GINGX(1,1)=Q0**2 QINQX(2,1)=0.d0 GINQX(2,1)=0.d0 QINGX(2,1)=0.d0 GINGX(2,1)=0.d0 DO 12 J=2,1000 Q2 = EXP((J-1)*DELTAQ2/999.d0 + LOG(Q0**2)) QINQX(1,J)=Q2 GINQX(1,J)=Q2 QINGX(1,J)=Q2 GINGX(1,J)=Q2 QINQX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'QQ') GINQX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'GQ') QINGX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'QG') GINGX(2,J)=GETPDFXINTEXACT(SQRT(Q2),'GG') 12 CONTINUE END *********************************************************************** *** subroutine xsecint *********************************************************************** SUBROUTINE XSECINT(EMAX) IMPLICIT NONE C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--cross secttion common block COMMON/XSECS/INTQ1(1001,101),INTQ2(1001,101), &INTG1(1001,101),INTG2(1001,101) DOUBLE PRECISION INTQ1,INTQ2,INTG1,INTG2 C--variables for cross section integration COMMON/XSECV/QLOW,MDX DOUBLE PRECISION QLOW,MDX C--max rapidity common/rapmax/etamax double precision etamax C--local variables INTEGER J,K DOUBLE PRECISION EMAX,TMAX,TMAXMAX,DELTATMAX,YSTART,HFIRST,EPSI, &GETMSMAX,GETMDMAX,MDMIN,MDMAX,DELTAMD,GETMDMIN,avmom(5),shat,pcms2 DATA EPSI/1.d-4/ call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) shat = avmom(5)**2 + & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2)) pcms2 = (shat-avmom(5)**2)**2/(4.*shat) tmaxmax = scalefacm*4.*pcms2 DELTATMAX=(LOG(TMAXMAX)- & LOG(Q0**2*(1.d0+1.d-6)/SCALEFACM**2))/999.d0 MDMIN=GETMDMIN() MDMAX=MAX(MDMIN,GETMDMAX()) DELTAMD=(MDMAX-MDMIN)/99.d0 DO 12 J=1,1000 TMAX = EXP((J-1)*DELTATMAX & + LOG(Q0**2*(1.d0+1.d-6)/SCALEFACM**2)) INTQ1(J,101)=TMAX INTQ2(J,101)=TMAX INTG1(J,101)=TMAX INTG2(J,101)=TMAX DO 13 K=1,100 MDX=MDMIN+(K-1)*DELTAMD INTQ1(1001,K)=MDX INTQ2(1001,K)=MDX INTG1(1001,K)=MDX INTG2(1001,K)=MDX IF(TMAX.LT.Q0**2/SCALEFACM**2)THEN INTQ1(J,K)=0.d0 INTQ2(J,K)=0.d0 INTG1(J,K)=0.d0 INTG2(J,K)=0.d0 ELSE C--first quark integral QLOW=Q0 HFIRST=0.01*(TMAX-Q0**2/SCALEFACM**2) YSTART=0.d0 CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST & ,0.d0,11) INTQ1(J,K)=YSTART C--second quark integral QLOW=Q0 HFIRST=0.01*(TMAX-Q0**2/SCALEFACM**2) YSTART=0.d0 CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST & ,0.d0,14) INTQ2(J,K)=YSTART C--first gluon integral QLOW=Q0 YSTART=0.d0 CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST & ,0.d0,12) INTG1(J,K)=YSTART C--second gluon integral QLOW=Q0 YSTART=0.d0 CALL ODEINT(YSTART,Q0**2/SCALEFACM**2,TMAX,EPSI,HFIRST & ,0.d0,13) INTG2(J,K)=YSTART ENDIF 13 CONTINUE 12 CONTINUE END *********************************************************************** *** function insudaint *********************************************************************** SUBROUTINE INSUDAINT(EMAX) IMPLICIT NONE C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--Sudakov common block COMMON/INSUDA/SUDAQQ(1000,2),SUDAQG(1000,2),SUDAGG(1000,2), &SUDAGC(1000,2) DOUBLE PRECISION SUDAQQ,SUDAQG,SUDAGG,SUDAGC C--max rapidity common/rapmax/etamax double precision etamax C--local variables INTEGER I DOUBLE PRECISION QMAX,Q,GETINSUDAKOV,DELTA,EMAX,avmom(5), &shat,pcms2 call maxscatcen(avmom(1),avmom(2),avmom(3),avmom(4),avmom(5)) shat = avmom(5)**2 + & 2.*emax*(avmom(4)+sqrt(avmom(1)**2+avmom(2)**2+avmom(3)**2)) pcms2 = (shat-avmom(5)**2)**2/(4.*shat) qmax = sqrt(scalefacm*4.*pcms2) DELTA=(LOG(3.*QMAX)-LOG(Q0**2*(1.d0+1.d-6)))/999.d0 DO 22 I=1,1000 Q = EXP((I-1)*DELTA + LOG(Q0**2*(1.d0+1.d-6))) SUDAQQ(I,1)=Q SUDAQG(I,1)=Q SUDAGG(I,1)=Q SUDAGC(I,1)=Q SUDAQQ(I,2)=GETINSUDAKOV(Q0,Q,'QQ') SUDAQG(I,2)=GETINSUDAKOV(Q0,Q,'QG') SUDAGG(I,2)=GETINSUDAKOV(Q0,Q,'GG') SUDAGC(I,2)=GETINSUDAKOV(Q0,Q,'GC') 22 CONTINUE END *********************************************************************** *** function eixint *********************************************************************** SUBROUTINE EIXINT IMPLICIT NONE C--exponential integral for negative arguments COMMON/EXPINT/EIXS(3,1000),VALMAX,NVAL INTEGER NVAL DOUBLE PRECISION EIXS,VALMAX C-local variables INTEGER I,K DOUBLE PRECISION X,EPSI,HFIRST,YSTART,EI,GA,R DATA EPSI/1.d-6/ NVAL=1000 VALMAX=55. DO 10 I=1,NVAL X=I*VALMAX/(NVAL*1.d0) EIXS(1,I)=X C--do negative arguments first YSTART=0d0 HFIRST=0.01 CALL ODEINT(YSTART,X,1000.d0,EPSI,HFIRST,0.d0,5) EIXS(2,I)=-YSTART C--now do the positive arguments call eix(x,ei) EIXS(3,I)=EI 10 CONTINUE END *********************************************************************** *** function odeint *********************************************************************** subroutine odeint(ystart,a,b,eps,h1,hmin,w1) implicit none C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--local variables integer nmax,nstep,w1 double precision ystart,a,b,eps,h1,hmin,x,h,y,dydx, &deriv,yscale,hdid,hnew data nmax/100000/ x = a y = ystart h = sign(h1,b-a) do 20 nstep=1,nmax dydx = deriv(x,w1) yscale = abs(y) + abs(h*dydx) + 1.e-25 if (((x + h - b)*h).gt.0.) h = b-x call rkstepper(x,y,dydx,h,hdid,hnew,yscale,eps,w1) if ((x - b)*h.ge.0) then ystart = y return endif h = hnew if (abs(h).lt.abs(hmin)) then write(logfid,*)'Error in odeint: stepsize too small',w1 & ,ystart,a,b,h1 return endif 20 continue write(logfid,*)'Error in odeint: too many steps',w1 & ,ystart,a,b,h1 end *********************************************************************** *** function rkstepper *********************************************************************** subroutine rkstepper(x,y,dydx,htest,hdid,hnew,yscale,eps,w1) implicit none C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--local variables integer w1 double precision x,y,dydx,htest,hdid,hnew,yscale,eps, &yhalf,y1,y2,rk4step,dydxhalf,xnew,delta,err,h,safety, powerdown, &powerup,maxup,maxdown,deriv,fac logical reject data powerdown/0.25/ data powerup/0.2/ data safety/0.9/ data maxdown/10./ data maxup/5./ reject = .false. h = htest 10 xnew = x + h if (x.eq.xnew) then write(logfid,*)'Error in rkstepper: step size not significant' return endif yhalf = rk4step(x,y,dydx,h/2.,w1) dydxhalf = deriv(x+h/2.,w1) y2 = rk4step(x+h/2.,yhalf,dydxhalf,h/2.,w1) y1 = rk4step(x,y,dydx,h,w1) delta = y2-y1 err = abs(delta)/(yscale*eps) if (err.gt.1.) then reject = .true. fac = max(1./maxdown,safety/err**powerdown) h = h*fac goto 10 else if (reject) then hnew = h else fac = min(maxup,safety/err**powerup) hnew = fac*h endif x = xnew y = y2 + delta/15. hdid = h endif end *********************************************************************** *** function rk4step *********************************************************************** double precision function rk4step(x,y,dydx,h,w1) implicit none integer w1 double precision x,y,dydx,h,k1,k2,k4,yout,deriv k1 = h*dydx k2 = h*deriv(x+h/2.,w1) k4 = h*deriv(x+h,w1) yout = y+k1/6.+2.*k2/3.+k4/6. rk4step = yout end *********************************************************************** *** function getdeltat *********************************************************************** LOGICAL FUNCTION GETDELTAT(LINE,TSTART,DTMAX1,DELTAT) IMPLICIT NONE C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--pythia common block COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--time common block COMMON/TIME/MV(23000,5) DOUBLE PRECISION MV C--max rapidity common/rapmax/etamax double precision etamax C--memory for error message from getdeltat common/errline/errl integer errl C--local variables INTEGER LINE,I,NNULL DOUBLE PRECISION DTMAX,SIGMAMAX,NEFFMAX,LINVMAX,PYR, &R,TOFF,XS,YS,ZS,TS,GETSSCAT,GETMSMAX,GETMDMIN,MSMAX,MDMIN, &XSTART,YSTART,ZSTART,WEIGHT,MS,MD,NEFF,SIGMA,GETNEFF, &GETNEFFMAX,GETMS,GETMD,TAU,MDMAX,GETMDMAX,GETNATMDMIN, &SIGMAMIN,NEFFMIN,TSTART,DTMAX1,DELTAT CHARACTER PTYPE LOGICAL STOPNOW C--initialization GETDELTAT=.FALSE. DELTAT=0.D0 DTMAX=DTMAX1 IF(K(LINE,2).EQ.21)THEN PTYPE='G' ELSE PTYPE='Q' ENDIF NNULL=0 STOPNOW=.FALSE. C--check for upper bound from plasma lifetime IF((TSTART+DTMAX).GE.LTIME)DTMAX=LTIME-TSTART IF(DTMAX.LT.0.D0) RETURN C--calculate time relative to production of the considered parton TOFF=TSTART-MV(LINE,4) XSTART=MV(LINE,1)+TOFF*P(LINE,1)/P(LINE,4) YSTART=MV(LINE,2)+TOFF*P(LINE,2)/P(LINE,4) ZSTART=MV(LINE,3)+TOFF*P(LINE,3)/P(LINE,4) C--calculate upper limit for density*cross section SIGMAMAX=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3), ! & xstart,ystart,-sign(abs(zstart),p(line,3)),zstart+1.d-6) & P(LINE,5),0.d0,PTYPE,'C',xstart,ystart,zstart,tstart,1) SIGMAMIN=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3), ! & xstart,ystart,-sign(abs(zstart),p(line,3)),zstart+1.d-6) & P(LINE,5),0.d0,PTYPE,'C',xstart,ystart,zstart,tstart,2) NEFFMAX=GETNEFFMAX() NEFFMIN=GETNATMDMIN() LINVMAX=5.d0*MAX(NEFFMIN*SIGMAMAX,NEFFMAX*SIGMAMIN) if(linvmax.eq.0.d0) return DO 333 I=1,1000000 DELTAT=DELTAT-LOG(PYR(0))/LINVMAX XS=XSTART+DELTAT*P(LINE,1)/P(LINE,4) YS=YSTART+DELTAT*P(LINE,2)/P(LINE,4) ZS=ZSTART+DELTAT*P(LINE,3)/P(LINE,4) TS=TSTART+DELTAT IF(TS.LT.ZS)THEN TAU=-1.d0 ELSE TAU=SQRT(TS**2-ZS**2) ENDIF NEFF=GETNEFF(XS,YS,ZS,TS) IF((TAU.GT.1.d0).AND.(NEFF.EQ.0.d0))THEN IF(NNULL.GT.4)THEN STOPNOW=.TRUE. ELSE NNULL=NNULL+1 ENDIF ELSE NNULL=0 ENDIF IF((DELTAT.GT.DTMAX).OR.STOPNOW) THEN DELTAT=DTMAX RETURN ENDIF IF(NEFF.GT.0.d0)THEN SIGMA=GETSSCAT(P(LINE,4),p(line,1),p(line,2),p(line,3), & P(LINE,5),0.d0,PTYPE,'C',xs,ys,zs,ts,0) ELSE SIGMA=0.d0 ENDIF WEIGHT=5.d0*NEFF*SIGMA/LINVMAX IF(WEIGHT.GT.1.d0+1d-6) then if (line.ne.errl) then write(logfid,*)'error in GETDELTAT: weight > 1',WEIGHT, & NEFF*SIGMA/(NEFFMAX*SIGMAMIN),NEFF*SIGMA/(NEFFMIN*SIGMAMAX), & p(line,4) errl=line endif endif R=PYR(0) IF(R.LT.WEIGHT)THEN GETDELTAT=.TRUE. RETURN ENDIF 333 CONTINUE END integer function poissonian(lambda) implicit none integer n double precision lambda,disc,p,pyr,u,v,pi data pi/3.141592653589793d0/ if (lambda.gt.745.d0) then u = pyr(0); v = pyr(0); poissonian = & int(sqrt(lambda)*sqrt(-2.*log(u))*cos(2.*pi*v)+lambda) else disc=exp(-lambda) p=1.d0 n=0 800 p = p*pyr(0) if (p.gt.disc) then n = n+1 goto 800 endif poissonian=n endif end *********************************************************************** *** function ishadron *********************************************************************** LOGICAL FUNCTION ISHADRON(ID) IMPLICIT NONE C--local variables INTEGER ID IF(ABS(ID).LT.100) THEN ISHADRON=.FALSE. ELSE IF(MOD(INT(ABS(ID)/10.),10).EQ.0) THEN ISHADRON = .FALSE. ELSE ISHADRON = .TRUE. ENDIF ENDIF END *********************************************************************** *** function isdiquark *********************************************************************** LOGICAL FUNCTION ISDIQUARK(ID) IMPLICIT NONE C--local variables INTEGER ID IF(ABS(ID).LT.1000) THEN ISDIQUARK=.FALSE. ELSE IF(MOD(INT(ID/10),10).EQ.0) THEN ISDIQUARK = .TRUE. ELSE ISDIQUARK = .FALSE. ENDIF ENDIF END *********************************************************************** *** function islepton *********************************************************************** LOGICAL FUNCTION ISLEPTON(ID) IMPLICIT NONE C-- local variables INTEGER ID IF((ABS(ID).EQ.11).OR.(ABS(ID).EQ.13).OR.(ABS(ID).EQ.15)) THEN ISLEPTON=.TRUE. ELSE ISLEPTON=.FALSE. ENDIF END *********************************************************************** *** function isparton *********************************************************************** LOGICAL FUNCTION ISPARTON(ID) IMPLICIT NONE C--local variables INTEGER ID LOGICAL ISDIQUARK IF((ABS(ID).LT.6).OR.(ID.EQ.21).OR.ISDIQUARK(ID)) THEN ISPARTON=.TRUE. ELSE ISPARTON=.FALSE. ENDIF END *********************************************************************** *** function isprimstring *********************************************************************** logical function isprimstring(l) implicit none COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--local variables integer l logical isparton if ((K(l,2).ne.91).and.(K(l,2).ne.92)) then isprimstring=.false. return endif if ((K(K(l,3),3).eq.0).or.(isparton(K(K(K(l,3),3),2)))) then isprimstring=.true. else isprimstring=.false. endif end *********************************************************************** *** function issecstring *********************************************************************** logical function issecstring(l) implicit none COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--local variables integer l logical isparton,isprimstring if ((K(l,2).ne.91).and.(K(l,2).ne.92)) then issecstring = .false. return endif if (isprimstring(l)) then issecstring = .false. return endif if (isparton(K(K(K(l,3),3),2))) then issecstring = .false. else issecstring = .true. endif end *********************************************************************** *** function isprimhadron *********************************************************************** logical function isprimhadron(l) implicit none COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--local variables integer l logical isprimstring,isparton if (((K(K(l,3),2).EQ.91).OR.(K(K(l,3),2).EQ.92)) & .and.isprimstring(K(l,3)) & .and.(.not.isparton(K(l,2)))) then isprimhadron=.true. else isprimhadron=.false. endif if (k(l,1).eq.17) isprimhadron=.true. end *********************************************************************** *** function compressevent *********************************************************************** logical function compressevent(l1) implicit none C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--variables for angular ordering COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) DOUBLE PRECISION ZA,ZD,THETAA LOGICAL QQBARD C--time common block COMMON/TIME/MV(23000,5) DOUBLE PRECISION MV C--colour index common block COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX INTEGER TRIP,ANTI,COLMAX C--local variables integer l1,i,j,nold,nnew,nstart nold = n do 777 i=2,nold if (((k(i,1).eq.11).or.(k(i,1).eq.12).or.(k(i,1).eq.13) & .or.(k(i,1).eq.14)).and.(i.ne.l1)) then nnew = i goto 778 endif 777 continue compressevent = .false. return 778 continue nstart = nnew do 779 i=nstart,nold if (((k(i,1).ne.11).and.(k(i,1).ne.12).and.(k(i,1).ne.13) & .and.(k(i,1).ne.14)).or.(i.eq.l1)) then do 780 j=1,5 p(nnew,j)=p(i,j) v(nnew,j)=v(i,j) mv(nnew,j)=mv(i,j) 780 continue trip(nnew)=trip(i) anti(nnew)=anti(i) za(nnew)=za(i) zd(nnew)=zd(i) thetaa(nnew)=thetaa(i) qqbard(nnew)=qqbard(i) k(nnew,1)=k(i,1) k(nnew,2)=k(i,2) k(nnew,3)=0 k(nnew,4)=0 k(nnew,5)=0 if (l1.eq.i) l1=nnew nnew=nnew+1 endif 779 continue n=nnew-1 if ((nold-n).le.10) then compressevent = .false. else compressevent = .true. endif do 781 i=nnew,nold do 782 j=1,5 k(i,j)=0 p(i,j)=0.d0 v(i,j)=0.d0 mv(i,j)=0.d0 782 continue trip(i)=0 anti(i)=0 za(i)=0.d0 zd(i)=0.d0 thetaa(i)=0.d0 qqbard(i)=.false. 781 continue if (n.gt.23000) write(logfid,*)'Error in compressevent: n = ',n if (l1.gt.n) write(logfid,*)'Error in compressevent: l1 = ',l1 call flush(logfid) return end *********************************************************************** *** subroutine pevrec *********************************************************************** SUBROUTINE PEVREC(NUM,COL) C--identifier of file for hepmc output and logfile implicit none common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V C--variables for angular ordering COMMON/ANGOR/ZA(23000),ZD(23000),THETAA(23000),QQBARD(23000) DOUBLE PRECISION ZA,ZD,THETAA LOGICAL QQBARD C--time common block COMMON/TIME/MV(23000,5) DOUBLE PRECISION MV C--colour index common block COMMON/COLOUR/TRIP(23000),ANTI(23000),COLMAX INTEGER TRIP,ANTI,COLMAX INTEGER NUM,i LOGICAL COL DO 202 I=1,N V(I,1)=MV(I,1) V(I,2)=MV(I,2) V(I,3)=MV(I,3) V(I,4)=MV(I,4) V(I,5)=MV(I,5) IF(COL) write(logfid,*)I,' (',TRIP(I),',',ANTI(I),') [', &K(I,3),K(I,4),K(I,5),' ] {',K(I,2),K(I,1),' } ', &ZD(I),THETAA(I) 202 CONTINUE CALL PYLIST(NUM) END *********************************************************************** *** subroutine converttohepmc *********************************************************************** SUBROUTINE CONVERTTOHEPMC(J,EVNUM,PID,beam1,beam2) IMPLICIT NONE COMMON/PYJETS/N,NPAD,K(23000,5),P(23000,5),V(23000,5) INTEGER N,NPAD,K DOUBLE PRECISION P,V COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200) INTEGER MSTP,MSTI DOUBLE PRECISION PARP,PARI C--Parameter common block COMMON/PARAM/Q0,LPS,LQCD,LTIME,SCALEFACM, &RECSOFTCUT,RECHARDCUT, &ANGORD,SCATRECOIL,ALLHAD,compress, &NF,KINMODE,recmode INTEGER NF,KINMODE,recmode DOUBLE PRECISION Q0,LQCD,LTIME,LPS,SCALEFACM, &RECSOFTCUT,RECHARDCUT LOGICAL ANGORD,SCATRECOIL,ALLHAD,compress C--organisation of event record common/evrecord/nsim,npart,offset,hadrotype,sqrts,collider,hadro, &shorthepmc,channel,isochannel integer nsim,npart,offset,hadrotype double precision sqrts character*4 collider,channel character*2 isochannel logical hadro,shorthepmc C--extra storage for scattering centres before interactions common/storescatcen/nscatcen,maxnscatcen,scatflav(23000), &scatcen(23000,5),writescatcen,writedummies integer nscatcen,maxnscatcen,scatflav double precision scatcen logical writescatcen,writedummies C--extra storage for dummy particles for subtraction common/storedummies/dummies(10000,5) double precision dummies C--local variables INTEGER EVNUM,PBARCODE,VBARCODE,CODELIST(25000),I,PID,NSTART, &NFIRST,NVERTEX,NTOT,J,CODEFIRST DOUBLE PRECISION mproton,mneutron,pdummy,pscatcen LOGICAL ISHADRON,ISDIQUARK,ISPARTON,isprimhadron,isprimstring, &issecstring character*2 beam1,beam2 data mproton/0.9383/ data mneutron/0.9396/ 5000 FORMAT(A2,I10,I3,3E14.6,2I2,I6,4I2,E14.6) 5100 FORMAT(A2,2E14.6) 5200 FORMAT(A2,6I7,2I2,1I7,4E14.6) 5300 FORMAT(A2,2I2,5E14.6,2I2) ! 5400 FORMAT(A2,I6,6I2,I6,I2) 5400 FORMAT(A2,2I6,5I2,I6,I2) 5500 FORMAT(A2,I6,I6,5E14.6,3I2,I6,I2) PBARCODE=0 VBARCODE=0 if (shorthepmc) then C--short output IF(COLLIDER.EQ.'EEJJ')THEN NVERTEX=3 PBARCODE=5 ELSE NVERTEX=1 PBARCODE=2 ENDIF nfirst = 0 do 131 i=1,N if (((k(i,1).lt.6).or.(k(i,1).eq.17))) & nfirst = nfirst+1 131 continue if(writescatcen) NFIRST=NFIRST+nscatcen if(writedummies) NFIRST=NFIRST+nscatcen WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX,1,2,0,1, &PARI(10) WRITE(J,'(A2,I2,A5)')'N ',1,'"0"' WRITE(J,'(A)')'U GEV MM' WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0 WRITE(J,5200)'H ',0,0,0,0,0,0,0,0,0,0.d0,0.d0,0.d0,0.d0 WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0 C--write out vertex line IF(COLLIDER.EQ.'EEJJ')THEN WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0 WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2., & 0.00051,2,0,0,-1,0 WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2., & 0.00051,2,0,0,-1,0 WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts, & 91.2,2,0,0,-2,0 WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0 WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2., & 0.000,2,0,0,-3,0 WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2., & 0.000,2,0,0,-3,0 WRITE(J,5400)'V ',-3,0,0,0,0,0,0,NFIRST,0 ELSE WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0 if (beam1.eq.'p+') then WRITE(J,5500)'P ',1,2212,0.d0,0.d0, & sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0 else WRITE(J,5500)'P ',1,2112,0.d0,0.d0, & sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0 endif if (beam2.eq.'p+') then WRITE(J,5500)'P ',2,2212,0.d0,0.d0, & -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0 else WRITE(J,5500)'P ',2,2112,0.d0,0.d0, & -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0 endif ENDIF C--write out scattering centres if(writescatcen) then do 133 i=1,nscatcen pbarcode=pbarcode+1 WRITE(J,5500)'P ',pbarcode,scatflav(i),scatcen(I,1), & scatcen(I,2),scatcen(I,3),scatcen(I,4),scatcen(I,5), & 3,0,0,0,0 133 continue endif C--write out dummy particles if(writedummies) then do 137 i=1,nscatcen pbarcode=pbarcode+1 WRITE(J,5500)'P ',pbarcode,111,dummies(i,1),dummies(i,2), & dummies(i,3),dummies(i,4),0.d0,1,0,0,0,0 137 continue endif C--write out particle lines do 132 i=1,N if(((k(i,1).lt.6).or.(k(i,1).eq.17))) then pbarcode=pbarcode+1 if((k(i,1).eq.3).or.(k(i,1).eq.5)) then WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), & P(I,4),P(I,5),4,0,0,0,0 else WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), & P(I,4),P(I,5),1,0,0,0,0 endif endif 132 continue else C--long output if (hadro) then C--hadronised events NFIRST=0 IF(COLLIDER.EQ.'EEJJ')THEN NVERTEX=3 ELSE NVERTEX=1 ENDIF DO 123 I=1,N IF(K(i,3).ne.0)THEN NSTART=I GOTO 124 ENDIF 123 CONTINUE 124 CONTINUE nstart=0 DO 126 I=NSTART+1,N IF(isprimhadron(i)) NFIRST=NFIRST+1 IF((ISHADRON(K(I,2)).OR.(ABS(K(I,2)).EQ.15)) & .AND.(K(I,4).NE.0)) NVERTEX=NVERTEX+1 126 CONTINUE 127 CONTINUE if(writescatcen) NFIRST=NFIRST+nscatcen if(writedummies) NFIRST=NFIRST+nscatcen WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX, &1,2,0,1,PARI(10) WRITE(J,'(A2,I2,A5)')'N ',1,'"0"' WRITE(J,'(A)')'U GEV MM' WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0 WRITE(J,5200)'H ',0,0,0,0,0,0,0,0,0,0.d0,0.d0,0.d0,0.d0 WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0 C--write out vertex line IF(COLLIDER.EQ.'EEJJ')THEN VBARCODE=-3 PBARCODE=5 ELSE VBARCODE=-1 PBARCODE=2 ENDIF IF(COLLIDER.EQ.'EEJJ')THEN WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0 WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2., & 0.00051,2,0,0,-1,0 WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2., & 0.00051,2,0,0,-1,0 WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts, & 91.2,2,0,0,-2,0 WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0 WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2., & 0.000,2,0,0,-3,0 WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2., & 0.000,2,0,0,-3,0 WRITE(J,5400)'V ',VBARCODE,0,0,0,0,0,0,NFIRST,0 ELSE WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0 if (beam1.eq.'p+') then WRITE(J,5500)'P ',1,2212,0.d0,0.d0, & sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0 else WRITE(J,5500)'P ',1,2112,0.d0,0.d0, & sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0 endif if (beam2.eq.'p+') then WRITE(J,5500)'P ',2,2212,0.d0,0.d0, & -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0 else WRITE(J,5500)'P ',2,2112,0.d0,0.d0, & -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0 endif ENDIF CODEFIRST=NFIRST+PBARCODE C--write out scattering centres if(writescatcen) then do 134 i=1,nscatcen pbarcode=pbarcode+1 WRITE(J,5500)'P ',PBARCODE,scatflav(I),scatcen(I,1), & scatcen(I,2),scatcen(I,3),scatcen(I,4),scatcen(I,5), & 3,0,0,0,0 134 continue endif C--write out dummy particles if(writedummies) then do 138 i=1,nscatcen pbarcode=pbarcode+1 WRITE(J,5500)'P ',pbarcode,111,dummies(i,1),dummies(i,2), & dummies(i,3),dummies(i,4),0.d0,1,0,0,0,0 138 continue endif C--first write out all particles coming directly from string or cluster decays DO 125 I=NSTART+1,N IF(.not.isprimhadron(i))THEN GOTO 125 ELSE IF (PBARCODE.EQ.CODEFIRST) GOTO 130 PBARCODE=PBARCODE+1 C--write out particle line IF(K(I,4).GT.0)THEN VBARCODE=VBARCODE-1 CODELIST(I)=VBARCODE WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), & P(I,4),P(I,5),2,0,0,VBARCODE,0 ELSE WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), & P(I,4),P(I,5),1,0,0,0,0 ENDIF ENDIF 125 CONTINUE 130 CONTINUE C--now write out all other particles and vertices DO 129 I=NSTART+1,N if (isprimhadron(i).or.isprimstring(i)) goto 129 if (isparton(K(i,2))) then if (ishadron(K(K(i,3),2))) codelist(i)=codelist(K(i,3)) goto 129 endif if (issecstring(i)) then codelist(i)=codelist(K(i,3)) goto 129 endif PBARCODE=PBARCODE+1 IF((K(I,3).NE.K(I-1,3)))THEN C--write out vertex line WRITE(J,5400)'V ',CODELIST(K(I,3)),0,0,0,0,0,0, & K(K(I,3),5)-K(K(I,3),4)+1,0 ENDIF C--write out particle line IF(K(I,4).GT.0)THEN VBARCODE=VBARCODE-1 CODELIST(I)=VBARCODE WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), & P(I,4),P(I,5),2,0,0,VBARCODE,0 ELSE WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), & P(I,4),P(I,5),1,0,0,0,0 ENDIF 129 CONTINUE else C--------------------------------------------------------------------------------------- C--partonic events ! call pevrec(2,.false.) C--hadronised events NFIRST=0 IF(COLLIDER.EQ.'EEJJ')THEN NVERTEX=3 ELSE NVERTEX=1 ENDIF DO 150 I=9,N IF((k(i,3).eq.1).or.(k(i,3).eq.2).or. & (k(i,3).eq.7).or.(k(i,3).eq.8)) NFIRST=NFIRST+1 IF(K(I,4).NE.0) NVERTEX=NVERTEX+1 150 CONTINUE nstart = 9+nfirst if(writescatcen) NFIRST=NFIRST+nscatcen if(writedummies) NFIRST=NFIRST+nscatcen WRITE(J,5000)'E ',EVNUM,-1,0.d0,0.d0,0.d0,0,0,NVERTEX, &1,2,0,1,PARI(10) WRITE(J,'(A2,I2,A5)')'N ',1,'"0"' WRITE(J,'(A)')'U GEV MM' WRITE(J,5100)'C ',PARI(1)*1.d9,0.d0 WRITE(J,5200)'H ',0,0,0,0,0,0,0,0,0,0.d0,0.d0,0.d0,0.d0 WRITE(J,5300)'F ',0,0,-1.d0,-1.d0,-1.d0,-1.d0,-1.d0,0,0 C--write out vertex line IF(COLLIDER.EQ.'EEJJ')THEN VBARCODE=-3 PBARCODE=5 ELSE VBARCODE=-1 PBARCODE=2 ENDIF IF(COLLIDER.EQ.'EEJJ')THEN WRITE(J,5400)'V ',-1,0,0,0,0,0,2,1,0 WRITE(J,5500)'P ',1,-11,0.d0,0.d0,sqrts/2.,sqrts/2., & 0.00051,2,0,0,-1,0 WRITE(J,5500)'P ',2,11,0.d0,0.d0,-sqrts/2.,sqrts/2., & 0.00051,2,0,0,-1,0 WRITE(J,5500)'P ',3,23,0.d0,0.d0,0.d0,sqrts, & 91.2,2,0,0,-2,0 WRITE(J,5400)'V ',-2,0,0,0,0,0,0,2,0 WRITE(J,5500)'P ',4,PID,sqrts/2.,0.d0,0.d0,sqrts/2., & 0.000,2,0,0,-3,0 WRITE(J,5500)'P ',5,-PID,-sqrts/2.,0.d0,0.d0,sqrts/2., & 0.000,2,0,0,-3,0 WRITE(J,5400)'V ',VBARCODE,0,0,0,0,0,0,NFIRST,0 ELSE WRITE(J,5400)'V ',-1,0,0,0,0,0,2,NFIRST,0 if (beam1.eq.'p+') then WRITE(J,5500)'P ',1,2212,0.d0,0.d0, & sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0 else WRITE(J,5500)'P ',1,2212,0.d0,0.d0, & sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0 endif if (beam2.eq.'p+') then WRITE(J,5500)'P ',2,2212,0.d0,0.d0, & -sqrt(sqrts**2/4.-mproton**2),sqrts/2.,mproton,2,0,0,-1,0 else WRITE(J,5500)'P ',2,2212,0.d0,0.d0, & -sqrt(sqrts**2/4.-mneutron**2),sqrts/2.,mneutron,2,0,0,-1,0 endif ENDIF C--write out scattering centres if(writescatcen) then do 151 i=1,nscatcen pbarcode=pbarcode+1 WRITE(J,5500)'P ',PBARCODE,scatflav(I),scatcen(I,1), & scatcen(I,2),scatcen(I,3),scatcen(I,4),scatcen(I,5), & 3,0,0,0,0 151 continue endif C--write out dummy particles if(writedummies) then do 152 i=1,nscatcen pbarcode=pbarcode+1 WRITE(J,5500)'P ',pbarcode,111,dummies(i,1),dummies(i,2), & dummies(i,3),dummies(i,4),0.d0,1,0,0,0,0 152 continue endif C--write out outgoing particles of first vertex do 154 i=9,nstart-1 PBARCODE=PBARCODE+1 C--write out particle line IF(K(I,4).GT.0)THEN VBARCODE=VBARCODE-1 CODELIST(I)=VBARCODE WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), & P(I,4),P(I,5),2,0,0,VBARCODE,0 ELSE WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), & P(I,4),P(I,5),1,0,0,0,0 endif 154 continue C--now write out all other particles and vertices DO 153 I=NSTART,N PBARCODE=PBARCODE+1 if (k(i,3).eq.0) then C--write out vertex line - scattering WRITE(J,5400)'V ',CODELIST(K(I+1,3)),k(k(i+1,3),1),0,0, & 0,0,0,K(K(I+1,3),5)-K(K(I+1,3),4)+1,0 elseif ((k(i,3).ne.k(i-1,3)).and.(k(i-1,3).ne.0)) then C--write out vertex line - splitting WRITE(J,5400)'V ',CODELIST(K(I,3)),k(k(i,3),1),0,0,0,0,0, & K(K(I,3),5)-K(K(I,3),4)+1,0 endif C--write out particle line IF(K(I,4).GT.0)THEN VBARCODE=VBARCODE-1 CODELIST(I)=VBARCODE WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), & P(I,4),P(I,5),2,0,0,VBARCODE,0 ELSE if((k(i,1).eq.3).or.(k(i,1).eq.5)) then WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), & P(I,4),P(I,5),4,0,0,0,0 elseif ((k(i,1).eq.11).and.(k(i,3).eq.0)) then WRITE(J,5500)'P ',PBARCODE,0,0.d0,0.d0,0.d0, & 0.d0,0.d0,0,0,0,0,0 else WRITE(J,5500)'P ',PBARCODE,K(I,2),P(I,1),P(I,2),P(I,3), & P(I,4),P(I,5),1,0,0,0,0 endif ENDIF 153 CONTINUE endif endif call flush(j) END *********************************************************************** *** subroutine printlogo *********************************************************************** subroutine printlogo(fid) implicit none integer fid write(fid,*) write(fid,*)' _______________'// &'__________________________ ' write(fid,*)' | '// &' | ' write(fid,*)' | JJJJJ EEEEE '// &' W W EEEEE L | ' write(fid,*)' | J E '// &' W W E L | ' write(fid,*)' _________________| J EEE '// &' W W W EEE L |_________________ ' write(fid,*)'| | J J E '// &' W W W W E L | |' write(fid,*)'| | JJJ EEEEE '// &' W W EEEEE LLLLL | |' write(fid,*)'| |_______________'// &'__________________________| |' write(fid,*)'| '// &' |' write(fid,*)'| '// &'this is JEWEL 2.3.0 |' write(fid,*)'| '// &' |' write(fid,*)'| Copyright Korinna C. Zapp (2021)'// &' [Korinna.Zapp@thep.lu.se] |' write(fid,*)'| '// &' |' write(fid,*)'| The JEWEL homepage is jewel.hepforge.org '// &' |' write(fid,*)'| '// &' |' write(fid,*)'| The medium model was partly '// &'implemented by Jochen Klein |' write(fid,*)'| [Jochen.Klein@cern.ch]. Raghav '// &'Kunnawalkam Elayavalli helped with the |' write(fid,*)'| implementation of the V+jet processes '// &'[raghav.k.e@cern.ch]. |' write(fid,*)'| '// &' |' write(fid,*)'| Please cite JHEP 1303 (2013) '// &'080 [arXiv:1212.1599] for physics and |' write(fid,*)'| EPJC 74 (2014) no.2, 2762 [arXiv:1311.0048] '// &' for the code. |' write(fid,*)'| The reference for '// &'V+jet processes is EPJC 76 (2016) no.12 695 |' write(fid,*)'| [arXiv:1608.03099] and for recoil effects'// &' it is JHEP 07 (2017) 141 |' write(fid,*)'| [arXiv:1707.01539]. '// &' |' write(fid,*)'| '// &' |' write(fid,*)'| JEWEL relies heavily on PYTHIA 6'// &' for the event generation. The modified |' write(fid,*)'| version of PYTHIA 6.4.25 that is'// &' shipped with JEWEL is, however, not an |' write(fid,*)'| official PYTHIA release and must'// &' not be used for anything else. Please |' write(fid,*)'| refer to results as "JEWEL+PYTHIA".'// &' |' write(fid,*)'| '// &' |' write(fid,*)'| JEWEL also uses code provided by'// &'S. Zhang and J. M. Jing |' write(fid,*)'| (Computation of Special Functions, '// &'John Wiley & Sons, New York, 1996 and |' write(fid,*)'| http://jin.ece.illinois.edu) for '// &'computing the exponential integral Ei(x). |' write(fid,*)'| '// &' |' write(fid,*)'|_________________________________'// &'____________________________________________|' write(fid,*) write(fid,*) end *********************************************************************** *** subroutine printtime *********************************************************************** subroutine printtime implicit none C--identifier of file for hepmc output and logfile common/hepmcid/hpmcfid,logfid integer hpmcfid,logfid C--local variables integer*4 date(3),time(3) 1000 format (i2.2, '.', i2.2, '.', i4.4, ', ', & i2.2, ':', i2.2, ':', i2.2 ) call idate(date) call itime(time) write(logfid,1000)date,time end Index: branches/rel-2.3.0/medium.params.dat =================================================================== --- branches/rel-2.3.0/medium.params.dat (revision 483) +++ branches/rel-2.3.0/medium.params.dat (revision 484) @@ -1,6 +1,6 @@ # This is the parameter file for the medium model. # Let's change the initial temperature: -TI 0.40 +TI 0.55 # and the centrality CENTRMIN 60. CENTRMAX 80. Index: branches/rel-2.3.0/medium-simple.f =================================================================== --- branches/rel-2.3.0/medium-simple.f (revision 483) +++ branches/rel-2.3.0/medium-simple.f (revision 484) @@ -1,818 +1,820 @@ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C++ Copyright (C) 2021 Korinna C. Zapp [Korinna.Zapp@thep.lu.ch] ++ C++ ++ C++ This file is part of JEWEL 2.3.0 ++ C++ ++ C++ The JEWEL homepage is jewel.hepforge.org ++ C++ ++ C++ The medium model was partly implemented by Jochen Klein. ++ C++ Raghav Kunnawalkam Elayavalli helped with the implementation ++ C++ of the V+jet processes. ++ C++ ++ C++ Please follow the MCnet GUIDELINES and cite Eur.Phys.J. C74 ++ C++ (2014) no.2, 2762 [arXiv:1311.0048] for the code and ++ C++ JHEP 1303 (2013) 080 [arXiv:1212.1599] and ++ C++ optionally EPJC 60 (2009) 617 [arXiv:0804.3568] for the ++ C++ physics. The reference for V+jet processes is EPJC 76 (2016) ++ C++ no.12 695 [arXiv:1608.03099] and for recoil effects it is ++ C++ JHEP 07 (2017) 141 [arXiv:1707.01539]. ++ C++ ++ C++ JEWEL relies heavily on PYTHIA 6 for the event generation. The ++ C++ modified version of PYTHIA 6.4.25 that is distributed with ++ C++ JEWEL is, however, not an official PYTHIA release and must not ++ C++ be used for anything else. Please refer to results as ++ C++ "JEWEL+PYTHIA". ++ C++ ++ C++ JEWEL also uses code provided by S. Zhang and J. M. Jing ++ C++ (Computation of Special Functions, John Wiley & Sons, New York, ++ C++ 1996 and http://jin.ece.illinois.edu) for computing the ++ C++ exponential integral Ei(x). ++ C++ ++ C++ ++ C++ JEWEL is free software; you can redistribute it and/or ++ C++ modify it under the terms of the GNU General Public License ++ C++ as published by the Free Software Foundation; either version 2 ++ C++ of the License, or (at your option) any later version. ++ C++ ++ C++ JEWEL is distributed in the hope that it will be useful, ++ C++ but WITHOUT ANY WARRANTY; without even the implied warranty of ++ C++ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ++ C++ GNU General Public License for more details. ++ C++ ++ C++ You should have received a copy of the GNU General Public ++ C++ License along with this program; if not, write to the Free ++ C++ Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, ++ C++ MA 02110-1301 USA ++ C++ ++ C++ Linking JEWEL statically or dynamically with other modules is ++ C++ making a combined work based on JEWEL. Thus, the terms and ++ C++ conditions of the GNU General Public License cover the whole ++ C++ combination. ++ C++ ++ C++ In addition, as a special exception, I give you permission to ++ C++ combine JEWEL with the code for the computation of special ++ C++ functions provided by S. Zhang and J. M. Jing. You may copy and ++ C++ distribute such a system following the terms of the GNU GPL for ++ C++ JEWEL and the licenses of the other code concerned, provided ++ C++ that you include the source code of that other code when and as ++ C++ the GNU GPL requires distribution of source code. ++ C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ SUBROUTINE MEDINIT(FILE,id,etam,mass) IMPLICIT NONE C--medium parameters COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF INTEGER NF DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, &N0,SIGMANN,A,WOODSSAXON DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, &SIGMANN INTEGER A LOGICAL WOODSSAXON C--max rapidity common/rapmax2/etamax2 double precision etamax2 C--longitudinal boost of momentum distribution common/boostmed/boost logical boost C--factor to vary Debye mass COMMON/MDFAC/MDFACTOR,MDSCALEFAC DOUBLE PRECISION MDFACTOR,MDSCALEFAC C--nuclear thickness function COMMON /THICKFNC/ RMAX,TA(100,2) DOUBLE PRECISION RMAX,TA C--geometrical cross section COMMON /CROSSSEC/ IMPMAX,CROSS(200,3) DOUBLE PRECISION IMPMAX,CROSS C--identifier of log file common/logfile/logfid integer logfid DATA RAU/10./ DATA D3/0.9d0/ DATA ZETA3/1.2d0/ C--local variables INTEGER I,LUN,POS,IOS,id,mass double precision etam CHARACTER*100 BUFFER,LABEL,tempbuf CHARACTER*80 FILE character firstchar logical fileexist etamax2 = etam logfid = id IOS=0 LUN=77 C--default settings TAUI=0.6d0 TI=0.36d0 TC=0.17d0 WOODSSAXON=.TRUE. CENTRMIN=0.d0 CENTRMAX=10.d0 NF=3 A=mass N0=0.17d0 D=0.54d0 SIGMANN=6.2 MDFACTOR=0.45d0 MDSCALEFAC=0.9d0 boost = .true. C--read settings from file write(logfid,*) inquire(file=FILE,exist=fileexist) if(fileexist)then write(logfid,*)'Reading medium parameters from ',FILE OPEN(unit=LUN,file=FILE,status='old',err=10) do 20 i=1,1000 READ(LUN, '(A)', iostat=ios) BUFFER if (ios.ne.0) goto 30 firstchar = buffer(1:1) if (firstchar.eq.'#') goto 20 POS=SCAN(BUFFER,' ') LABEL=BUFFER(1:POS) BUFFER=BUFFER(POS+1:) IF (LABEL=="TAUI")THEN READ(BUFFER,*,IOSTAT=IOS) TAUI ELSE IF (LABEL=="TI") THEN READ(BUFFER,*,IOSTAT=IOS) TI ELSE IF (LABEL=="TC") THEN READ(BUFFER,*,IOSTAT=IOS) TC ELSE IF (LABEL=="WOODSSAXON") THEN READ(BUFFER,*,IOSTAT=IOS) WOODSSAXON ELSE IF (LABEL=="CENTRMIN") THEN READ(BUFFER,*,IOSTAT=IOS) CENTRMIN ELSE IF (LABEL=="CENTRMAX") THEN READ(BUFFER,*,IOSTAT=IOS) CENTRMAX ELSE IF (LABEL=="NF") THEN READ(BUFFER,*,IOSTAT=IOS) NF ELSE IF (LABEL=="N0") THEN READ(BUFFER,*,IOSTAT=IOS) N0 ELSE IF (LABEL=="D") THEN READ(BUFFER,*,IOSTAT=IOS) D ELSE IF (LABEL=="SIGMANN") THEN READ(BUFFER,*,IOSTAT=IOS) SIGMANN ELSE IF (LABEL=="MDFACTOR") THEN READ(BUFFER,*,IOSTAT=IOS) MDFACTOR ELSE IF (LABEL=="MDSCALEFAC") THEN READ(BUFFER,*,IOSTAT=IOS) MDSCALEFAC else write(logfid,*)'unknown label ',label endif 20 continue 30 close(LUN,status='keep') write(logfid,*)'...done' goto 40 10 write(logfid,*)'Could not open medium parameter file, '// & 'will run with default settings.' else write(logfid,*)'No medium parameter file found, '// & 'will run with default settings.' endif 40 write(logfid,*)'using parameters:' write(logfid,*)'TAUI =',TAUI write(logfid,*)'TI =',TI write(logfid,*)'TC =',TC write(logfid,*)'WOODSSAXON =',WOODSSAXON write(logfid,*)'CENTRMIN =',CENTRMIN write(logfid,*)'CENTRMAX =',CENTRMAX write(logfid,*)'NF =',NF write(logfid,*)'A =',A write(logfid,*)'N0 =',N0 write(logfid,*)'D =',D write(logfid,*)'SIGMANN =',SIGMANN write(logfid,*)'MDFACTOR =',MDFACTOR write(logfid,*)'MDSCALEFAC =',MDSCALEFAC write(logfid,*) write(logfid,*) write(logfid,*) C--calculate T_A(x,y) CALL CALCTA C--calculate geometrical cross section CALL CALCXSECTION END SUBROUTINE MEDNEXTEVT IMPLICIT NONE C--medium parameters COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF INTEGER NF DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, &N0,SIGMANN,A,WOODSSAXON DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, &SIGMANN INTEGER A LOGICAL WOODSSAXON C--geometrical cross section COMMON /CROSSSEC/ IMPMAX,CROSS(200,3) DOUBLE PRECISION IMPMAX,CROSS C--local variables integer i,j DOUBLE PRECISION PYR,R,b1,b2,gettemp C--pick an impact parameter r=(pyr(0)*(centrmax-centrmin)+centrmin)/100. i=0 do 130 j=1,200 if ((r-cross(j,3)/cross(200,3)).ge.0.) then i=i+1 else goto 132 endif 130 continue 132 continue b1 = (i-1)*0.1d0 b2 = i*0.1d0 breal = (b2*(cross(i,3)/cross(200,3)-r) & +b1*(r-cross(i+1,3)/cross(200,3)))/ & (cross(i,3)/cross(200,3)-cross(i+1,3)/cross(200,3)) centr = r; END double precision function getcentrality() implicit none COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF INTEGER NF DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU getcentrality=centr end SUBROUTINE PICKVTX(X,Y) IMPLICIT NONE DOUBLE PRECISION X,Y C--medium parameters COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF INTEGER NF DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU C--local variables DOUBLE PRECISION X1,X2,Y1,Y2,Z,XVAL,YVAL,ZVAL,NTHICK,PYR X1=BREAL/2.-RAU X2=RAU-BREAL/2. Y1=-SQRT(4*RAU**2-BREAL**2)/2. Y2=SQRT(4*RAU**2-BREAL**2)/2. 131 XVAL=PYR(0)*(X2-X1)+X1 YVAL=PYR(0)*(Y2-Y1)+Y1 IF((NTHICK(XVAL-BREAL/2.,YVAL).EQ.0.d0).OR. & NTHICK(XVAL+BREAL/2.,YVAL).EQ.0.d0) GOTO 131 ZVAL=PYR(0)*NTHICK(-BREAL/2.,0d0)*NTHICK(BREAL/2.,0d0) Z=NTHICK(XVAL-BREAL/2.,YVAL)*NTHICK(XVAL+BREAL/2.,YVAL) IF(ZVAL.GT.Z) GOTO 131 X=XVAL Y=YVAL END SUBROUTINE SETB(BVAL) IMPLICIT NONE C--medium parameters COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF INTEGER NF DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU DOUBLE PRECISION BVAL BREAL=BVAL END SUBROUTINE GETSCATTERER(X,Y,Z,T,TYPE,PX,PY,PZ,E,MS) IMPLICIT NONE C--medium parameters COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF INTEGER NF DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU C--internal medium parameters COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, &N0,SIGMANN,A,WOODSSAXON DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, &SIGMANN INTEGER A LOGICAL WOODSSAXON C--longitudinal boost of momentum distribution common/boostmed/boost logical boost C--function calls DOUBLE PRECISION GETTEMP,GETMD,GETMOM,GETMS C--identifier of log file common/logfile/logfid integer logfid C--local variables DOUBLE PRECISION X,Y,Z,T,MS,PX,PY,PZ,E,MD,TEMP INTEGER TYPE DOUBLE PRECISION R,PYR,pmax,wt,tau,theta,phi,pi,p,ys,pz2,e2 DATA PI/3.141592653589793d0/ R=PYR(0) IF(R.LT.(2.*12.*NF*D3/3.)/(2.*12.*NF*D3/3.+3.*16.*ZETA3/2.))THEN TYPE=2 MS=GETMS(X,Y,Z,T) ELSE TYPE=21 MS=GETMD(X,Y,Z,T) ENDIF TEMP=GETTEMP(X,Y,Z,T) tau=sqrt(t**2-z**2) if (boost) then ys = 0.5*log((t+z)/(t-z)) else ys = 0.d0 endif pmax = 10.*temp IF(TEMP.LT.1.D-2)THEN write(logfid,*)'asking for a scattering centre without medium:' write(logfid,*)'at (x,y,z,t)=',X,Y,Z,T write(logfid,*)'making one up to continue but '// & 'something is wrong!' TYPE=21 PX=0.d0 PY=0.d0 PZ=0.d0 MS=GETMS(0.d0,0.d0,0.d0,0.d0) MD=GETMD(0.d0,0.d0,0.d0,0.d0) E=SQRT(PX**2+PY**2+PZ**2+MS**2) RETURN ENDIF 10 p = pyr(0)**0.3333333*pmax E2 = sqrt(p**2+ms**2) if (type.eq.2) then wt = (exp(ms/temp)-1.)/(exp(E2/temp)-1.) else wt = (exp(ms/temp)+1.)/(exp(E2/temp)+1.) endif if (wt.gt.1.) write(logfid,*)'Error in getscatterer: weight = ',wt if (wt.lt.0.) write(logfid,*)'Error in getscatterer: weight = ',wt if (pyr(0).gt.wt) goto 10 phi = pyr(0)*2.*pi theta = -acos(2.*pyr(0)-1.)+pi px = p*sin(theta)*cos(phi) py = p*sin(theta)*sin(phi) pz2 = p*cos(theta) E = cosh(ys)*E2 + sinh(ys)*pz2 pz = sinh(ys)*E2 + cosh(ys)*pz2 END SUBROUTINE AVSCATCEN(X,Y,Z,T,PX,PY,PZ,E,m) IMPLICIT NONE C--longitudinal boost of momentum distribution common/boostmed/boost logical boost C--max rapidity common/rapmax2/etamax2 double precision etamax2 C--local variables double precision x,y,z,t,px,py,pz,e,getms,m,ys if (boost) then ys = 0.5*log((t+z)/(t-z)) if ((z.eq.0.d0).and.(t.eq.0.d0)) ys =0.d0 if (ys.gt.etamax2) ys=etamax2 if (ys.lt.-etamax2) ys=-etamax2 else ys = 0.d0 endif m = getms(x,y,z,t) e = m*cosh(ys) px = 0.d0 py = 0.d0 pz = m*sinh(ys) end SUBROUTINE maxscatcen(PX,PY,PZ,E,m) IMPLICIT NONE C--longitudinal boost of momentum distribution common/boostmed/boost logical boost C--max rapidity common/rapmax2/etamax2 double precision etamax2 C--local variables double precision px,py,pz,e,getmsmax,m,ys if (boost) then ys = etamax2 else ys = 0.d0 endif m = getmsmax() e = m*cosh(ys) px = 0.d0 py = 0.d0 pz = m*sinh(ys) end DOUBLE PRECISION FUNCTION GETMD(X1,Y1,Z1,T1) IMPLICIT NONE C--factor to vary Debye mass COMMON/MDFAC/MDFACTOR,MDSCALEFAC DOUBLE PRECISION MDFACTOR,MDSCALEFAC DOUBLE PRECISION X1,Y1,Z1,T1,GETTEMP GETMD=MDSCALEFAC*3.*GETTEMP(X1,Y1,Z1,T1) GETMD=MAX(GETMD,MDFACTOR) END DOUBLE PRECISION FUNCTION GETMS(X2,Y2,Z2,T2) IMPLICIT NONE DOUBLE PRECISION X2,Y2,Z2,T2,GETMD GETMS=GETMD(X2,Y2,Z2,T2)/SQRT(2.) END DOUBLE PRECISION FUNCTION GETNEFF(X3,Y3,Z3,T3) IMPLICIT NONE COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF INTEGER NF DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, &N0,SIGMANN,A,WOODSSAXON DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, &SIGMANN INTEGER A LOGICAL WOODSSAXON C-- local variables DOUBLE PRECISION X3,Y3,Z3,T3,PI,GETTEMP,tau,cosheta DATA PI/3.141592653589793d0/ tau = sqrt(t3**2-z3**2) cosheta = t3/tau GETNEFF=(2.*6.*NF*D3*2./3. + 16.*ZETA3*3./2.) & *GETTEMP(X3,Y3,Z3,T3)**3/PI**2 getneff = getneff/cosheta END DOUBLE PRECISION FUNCTION GETTEMP(X4,Y4,Z4,T4) IMPLICIT NONE C--medium parameters COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF INTEGER NF DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, &N0,SIGMANN,A,WOODSSAXON DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, &SIGMANN INTEGER A LOGICAL WOODSSAXON C--max rapidity common/rapmax2/etamax2 double precision etamax2 C--local variables DOUBLE PRECISION X4,Y4,Z4,T4,TAU,NPART,EPS0,EPSIN,TEMPIN,PI, &NTHICK,ys DATA PI/3.141592653589793d0/ GETTEMP=0.D0 IF(ABS(Z4).GT.T4)RETURN TAU=SQRT(T4**2-Z4**2) C--check for overlap region IF((NTHICK(X4-BREAL/2.,Y4).EQ.0.d0).OR. &NTHICK(X4+BREAL/2.,Y4).EQ.0.d0) RETURN ys = 0.5*log((t4+z4)/(t4-z4)) if (abs(ys).gt.etamax2) return C--determine initial temperature at transverse position IF(WOODSSAXON)THEN EPS0=(16.*8.+7.*2.*6.*NF)*PI**2*TI**4/240. - EPSIN=EPS0*NPART(X4-BREAL/2.,Y4,X4+BREAL/2.,Y4) - & *PI*RAU**2/(2.*A) +! EPSIN=EPS0*NPART(X4-BREAL/2.,Y4,X4+BREAL/2.,Y4) +! & *PI*RAU**2/(2.*A) + EPSIN=EPS0*NPART(X4-BREAL/2.,Y4,X4+BREAL/2.,Y4)/ + & NPART(0.d0,0.d0,0.d0,0.d0) TEMPIN=(EPSIN*240./(PI**2*(16.*8.+7.*2.*6.*NF)))**0.25 ELSE TEMPIN=TI ENDIF C--calculate temperature if before initial time IF(TAU.LE.TAUI)THEN GETTEMP=TEMPIN*TAU/TAUI ELSE C--evolve temperature GETTEMP=TEMPIN*(TAUI/TAU)**0.3333 ENDIF IF(GETTEMP.LT.TC) GETTEMP=0.d0 END DOUBLE PRECISION FUNCTION GETTEMPMAX() IMPLICIT NONE C--medium parameters COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF INTEGER NF DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, &N0,SIGMANN,A,WOODSSAXON DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, &SIGMANN INTEGER A LOGICAL WOODSSAXON C--function call DOUBLE PRECISION GETTEMP GETTEMPMAX=GETTEMP(0.D0,0.D0,0.D0,TAUI) END DOUBLE PRECISION FUNCTION GETMDMAX() IMPLICIT NONE C--factor to vary Debye mass COMMON/MDFAC/MDFACTOR,MDSCALEFAC DOUBLE PRECISION MDFACTOR,MDSCALEFAC DOUBLE PRECISION GETTEMPMAX GETMDMAX=MDSCALEFAC*3.*GETTEMPMAX() GETMDMAX=MAX(GETMDMAX,MDFACTOR) END DOUBLE PRECISION FUNCTION GETMDMIN() IMPLICIT NONE C--medium parameters COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF INTEGER NF DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, &N0,SIGMANN,A,WOODSSAXON DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, &SIGMANN INTEGER A LOGICAL WOODSSAXON C--factor to vary Debye mass COMMON/MDFAC/MDFACTOR,MDSCALEFAC DOUBLE PRECISION MDFACTOR,MDSCALEFAC DOUBLE PRECISION GETTEMPMAX GETMDMIN=MDSCALEFAC*3.*TC GETMDMIN=MAX(GETMDMIN,MDFACTOR) END DOUBLE PRECISION FUNCTION GETMSMAX() IMPLICIT NONE DOUBLE PRECISION GETMDMAX,SQRT GETMSMAX=GETMDMAX()/SQRT(2.D0) END DOUBLE PRECISION FUNCTION GETNATMDMIN() IMPLICIT NONE C--medium parameters COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF INTEGER NF DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, &N0,SIGMANN,A,WOODSSAXON DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, &SIGMANN INTEGER A LOGICAL WOODSSAXON C--max rapidity common/rapmax2/etamax2 double precision etamax2 C--factor to vary Debye mass COMMON/MDFAC/MDFACTOR,MDSCALEFAC DOUBLE PRECISION MDFACTOR,MDSCALEFAC,PI DATA PI/3.141592653589793d0/ C--local variables DOUBLE PRECISION T,GETMDMIN T=GETMDMIN()/(MDSCALEFAC*3.) GETNATMDMIN=(2.*6.*NF*D3*2./3. + 16.*ZETA3*3./2.) & *T**3/PI**2 END DOUBLE PRECISION FUNCTION GETLTIMEMAX() IMPLICIT NONE C--medium parameters COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF INTEGER NF DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, &N0,SIGMANN,A,WOODSSAXON DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, &SIGMANN INTEGER A LOGICAL WOODSSAXON C--max rapidity common/rapmax2/etamax2 double precision etamax2 C--function call DOUBLE PRECISION GETTEMPMAX GETLTIMEMAX=TAUI*(GETTEMPMAX()/TC)**3*cosh(etamax2) END DOUBLE PRECISION FUNCTION GETNEFFMAX() IMPLICIT NONE COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF INTEGER NF DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, &N0,SIGMANN,A,WOODSSAXON DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, &SIGMANN INTEGER A LOGICAL WOODSSAXON C--max rapidity common/rapmax2/etamax2 double precision etamax2 C-- local variables DOUBLE PRECISION PI,GETTEMPMAX DATA PI/3.141592653589793d0/ GETNEFFMAX=(2.*6.*NF*D3*2./3. + 16.*ZETA3*3./2.) & *GETTEMPMAX()**3/PI**2 END DOUBLE PRECISION FUNCTION NPART(XX1,YY1,XX2,YY2) IMPLICIT NONE COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, &N0,SIGMANN,A,WOODSSAXON DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, &SIGMANN INTEGER A LOGICAL WOODSSAXON C--local variables DOUBLE PRECISION XX1,YY1,XX2,YY2,NTHICK NPART = NTHICK(XX1,YY1)*(1.-EXP(-SIGMANN*NTHICK(XX2,YY2))) + & NTHICK(XX2,YY2)*(1.-EXP(-SIGMANN*NTHICK(XX1,YY1))) END DOUBLE PRECISION FUNCTION NTHICK(X1,Y1) IMPLICIT NONE C--medium parameters COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF INTEGER NF DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, &N0,SIGMANN,A,WOODSSAXON DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, &SIGMANN INTEGER A LOGICAL WOODSSAXON C--identifier of log file common/logfile/logfid integer logfid C--nuclear thickness function COMMON /THICKFNC/ RMAX,TA(100,2) DOUBLE PRECISION RMAX,TA INTEGER LINE,LMIN,LMAX,I DOUBLE PRECISION X1,Y1,XA(4),YA(4),Y,DY,R,C,B,DELTA R=SQRT(X1**2+Y1**2) IF(R.GT.TA(100,1))THEN NTHICK=0. ELSE LINE=INT(R*99.d0/TA(100,1)+1) LMIN=MAX(LINE,1) LMIN=MIN(LMIN,99) IF((R.LT.TA(LMIN,1)).OR.(R.GT.TA(LMIN+1,1))) & write(logfid,*)LINE,LMIN,R,TA(LMIN,1),TA(LMIN+1,1) XA(1)=TA(LMIN,1) XA(2)=TA(LMIN+1,1) YA(1)=TA(LMIN,2) YA(2)=TA(LMIN+1,2) C=(YA(2)-YA(1))/(XA(2)-XA(1)) B=YA(1)-C*XA(1) NTHICK=C*R+B ENDIF END SUBROUTINE CALCTA() IMPLICIT NONE C--medium parameters COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF INTEGER NF DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, &N0,SIGMANN,A,WOODSSAXON DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, &SIGMANN INTEGER A LOGICAL WOODSSAXON C-- nuclear thickness function COMMON /THICKFNC/ RMAX,TA(100,2) DOUBLE PRECISION RMAX,TA C--variables for integration COMMON/INTEG/B,R DOUBLE PRECISION B,R C--local variables INTEGER NSTEPS,I DOUBLE PRECISION EPS,HFIRST,Y NSTEPS=100 EPS=1.E-4 HFIRST=0.1D0 R=1.12*A**(0.33333)-0.86*A**(-0.33333) RMAX=2.*R DO 10 I=1,NSTEPS C--set transverse position B=(I-1)*2.D0*R/NSTEPS Y=0.D0 C--integrate along longitudinal line CALL ODEINT(Y,-2*R,2*R,EPS,HFIRST,0.d0,101) TA(I,1)=B TA(I,2)=Y 10 CONTINUE END SUBROUTINE CALCXSECTION() IMPLICIT NONE C--medium parameters COMMON/MEDPARAM/CENTRMIN,CENTRMAX,BREAL,CENTR,RAU,NF INTEGER NF DOUBLE PRECISION CENTRMIN,CENTRMAX,BREAL,CENTR,RAU COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, &N0,SIGMANN,A,WOODSSAXON DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, &SIGMANN INTEGER A LOGICAL WOODSSAXON C-- geometrical cross section COMMON /CROSSSEC/ IMPMAX,CROSS(200,3) DOUBLE PRECISION IMPMAX,CROSS C--local variables INTEGER IX,IY,IB DOUBLE PRECISION B,P,PROD,X,Y,NTHICK,NPART,pprev pprev=0. DO 30 IB=1,200 B=0.1d0*IB PROD=1.d0 DO 10 IX=1,100 DO 20 IY=1,100 X=-20.d0+IX*0.4d0 Y=-20.d0+IY*0.4d0 PROD=PROD* &EXP(-NTHICK(X+B/2.D0,Y)*SIGMANN)**(0.16d0*NTHICK(X-B/2.D0,Y)) 20 CONTINUE 10 CONTINUE P=(1.D0-PROD)*8.8D0/14.D0*B CROSS(IB,1)=B CROSS(IB,2)=P if (ib.eq.1) then cross(ib,3)=0. else cross(ib,3)=cross(ib-1,3)+(p+pprev)/2.*0.1 endif pprev=p 30 CONTINUE IMPMAX=19.95 END DOUBLE PRECISION FUNCTION MEDDERIV(XVAL,W) IMPLICIT NONE DOUBLE PRECISION XVAL INTEGER W C--medium parameters COMMON/MEDPARAMINT/TAUI,TI,TC,D3,ZETA3,D, &N0,SIGMANN,A,WOODSSAXON DOUBLE PRECISION TAUI,TI,TC,ALPHA,BETA,GAMMA,D3,ZETA3,D,N0, &SIGMANN INTEGER A LOGICAL WOODSSAXON C--variables for integration COMMON/INTEG/B,R DOUBLE PRECISION B,R IF (W.EQ.1) THEN C--XVAL corresponds to z-coordinate MEDDERIV=N0/(1+EXP((SQRT(B**2+XVAL**2)-R)/D)) ELSE MEDDERIV=0.D0 ENDIF END Index: branches/rel-2.3.0/Makefile =================================================================== --- branches/rel-2.3.0/Makefile (revision 483) +++ branches/rel-2.3.0/Makefile (revision 484) @@ -1,21 +1,21 @@ all: jewel-2.3.0-vac jewel-2.3.0-simple # path to LHAPDF library -LHAPDF_PATH := /home/lhapdf/install/lib/ +LHAPDF_PATH := /home/lhapdf6/install/lib/ FC := gfortran -FFLAGS := -g -static +FFLAGS := -O2 -jewel-2.3.0-vac: jewel-2.3.0.o medium-vac.o pythia6425mod.o meix.o - $(FC) -o $@ -L$(LHAPDF_PATH) $^ -lLHAPDF +jewel-2.3.0-vac: jewel-2.3.0.o medium-vac.o pythia6425mod-lhapdf6.o meix.o + $(FC) -o $@ -L$(LHAPDF_PATH) $^ -lLHAPDF -lstdc++ -jewel-2.3.0-simple: jewel-2.3.0.o medium-simple.o pythia6425mod.o meix.o - $(FC) -o $@ -L$(LHAPDF_PATH) $^ -lLHAPDF +jewel-2.3.0-simple: jewel-2.3.0.o medium-simple.o pythia6425mod-lhapdf6.o meix.o + $(FC) -o $@ -L$(LHAPDF_PATH) $^ -lLHAPDF -lstdc++ clean: rm -f medium-*.o rm -f jewel*.o - rm -f pythia6425mod.o meix.o + rm -f pythia6425mod-lhapdf6.o meix.o rm -f *~ .PHONY: all